diff --git a/src/cmp/cmpc-wt.lsp b/src/cmp/cmpc-wt.lsp index 918215567..6e9f346bb 100644 --- a/src/cmp/cmpc-wt.lsp +++ b/src/cmp/cmpc-wt.lsp @@ -85,9 +85,9 @@ (defun wt-nl-close-brace () (if (plusp *opened-c-braces*) (progn + (decf *opened-c-braces*) (wt-nl-indent) - (wt1 #\}) - (decf *opened-c-braces*)) + (wt1 #\})) (baboon :format-control "Mismatch in C blocks"))) ;;; diff --git a/src/cmp/cmpeval.lsp b/src/cmp/cmpeval.lsp index 409940df1..6c65a2917 100644 --- a/src/cmp/cmpeval.lsp +++ b/src/cmp/cmpeval.lsp @@ -165,14 +165,13 @@ (apply dispatch form args)))) (defun c2expr* (form) - (let* ((*exit* (next-label)) - (*unwind-exit* (cons *exit* *unwind-exit*)) - ;;(*lex* *lex*) - (*lcl* *lcl*) - (*temp* *temp*)) - (c2expr form) - (wt-label *exit*)) - ) + (with-exit-label (label) + (let* ((*exit* label) + (*unwind-exit* (cons *exit* *unwind-exit*)) + ;;(*lex* *lex*) + (*lcl* *lcl*) + (*temp* *temp*)) + (c2expr form)))) (defun c1with-backend (forms) (c1progn (loop for tag = (pop forms) diff --git a/src/cmp/cmpexit.lsp b/src/cmp/cmpexit.lsp index 4c6b13edd..397b97a54 100644 --- a/src/cmp/cmpexit.lsp +++ b/src/cmp/cmpexit.lsp @@ -16,20 +16,31 @@ (defun unwind-bds (bds-lcl bds-bind stack-frame ihs-p) (declare (fixnum bds-bind)) - (when stack-frame - (if (stringp stack-frame) - (wt-nl "ecl_stack_frame_close(" stack-frame ");") - (wt-nl "ECL_STACK_SET_INDEX(cl_env_copy," stack-frame ");"))) - (when bds-lcl - (wt-nl "ecl_bds_unwind(cl_env_copy," bds-lcl ");")) - (if (< bds-bind 4) - (dotimes (n bds-bind) - (declare (fixnum n)) - (wt-nl "ecl_bds_unwind1(cl_env_copy);")) - (wt-nl "ecl_bds_unwind_n(cl_env_copy," bds-bind ");")) - (case ihs-p - (IHS (wt-nl "ecl_ihs_pop(cl_env_copy);")) - (IHS-ENV (wt-nl "ihs.lex_env = _ecl_debug_env;")))) + (let ((some nil)) + (when stack-frame + (setf some t) + (if (stringp stack-frame) + (wt-nl "ecl_stack_frame_close(" stack-frame ");") + (wt-nl "ECL_STACK_SET_INDEX(cl_env_copy," stack-frame ");"))) + (when bds-lcl + (setf some t) + (wt-nl "ecl_bds_unwind(cl_env_copy," bds-lcl ");")) + (cond ((< bds-bind 4) + (dotimes (n bds-bind) + (declare (fixnum n)) + (setf some t) + (wt-nl "ecl_bds_unwind1(cl_env_copy);"))) + (t + (setf some t) + (wt-nl "ecl_bds_unwind_n(cl_env_copy," bds-bind ");"))) + (case ihs-p + (IHS + (setf some t) + (wt-nl "ecl_ihs_pop(cl_env_copy);")) + (IHS-ENV + (setf some t) + (wt-nl "ihs.lex_env = _ecl_debug_env;"))) + some)) (defun unwind-exit (loc &optional (jump-p nil) &aux (bds-lcl nil) (bds-bind 0) (stack-frame nil) (ihs-p nil)) (declare (fixnum bds-bind)) @@ -144,25 +155,25 @@ (cond ((consp ue) (cond ((eq ue exit) - (unwind-bds bds-lcl bds-bind stack-frame ihs-p) - (return)) + (return (unwind-bds bds-lcl bds-bind stack-frame ihs-p))) ((eq (first ue) 'STACK) (setf stack-frame (second ue))))) - ((numberp ue) (setq bds-lcl ue bds-bind 0)) - ((eq ue 'BDS-BIND) (incf bds-bind)) + ((numberp ue) + (setq bds-lcl ue bds-bind 0)) + ((eq ue 'BDS-BIND) + (incf bds-bind)) ((member ue '(RETURN RETURN-OBJECT RETURN-FIXNUM RETURN-CHARACTER RETURN-DOUBLE-FLOAT RETURN-SINGLE-FLOAT)) (if (eq exit ue) - (progn (unwind-bds bds-lcl bds-bind stack-frame ihs-p) - (return)) + (return (unwind-bds bds-lcl bds-bind stack-frame ihs-p)) (baboon-unwind-exit ue)) ;;; Never reached ) - ((eq ue 'FRAME) (wt-nl "ecl_frs_pop(cl_env_copy);")) + ((eq ue 'FRAME) + (wt-nl "ecl_frs_pop(cl_env_copy);")) ((eq ue 'TAIL-RECURSION-MARK) (if (eq exit 'TAIL-RECURSION-MARK) - (progn (unwind-bds bds-lcl bds-bind stack-frame ihs-p) - (return)) + (return (unwind-bds bds-lcl bds-bind stack-frame ihs-p)) (baboon-unwind-exit ue)) ;;; Never reached ) diff --git a/src/cmp/cmpif.lsp b/src/cmp/cmpif.lsp index 7c83d89a3..fc90d856d 100644 --- a/src/cmp/cmpif.lsp +++ b/src/cmp/cmpif.lsp @@ -74,13 +74,6 @@ :args butlast last) last)))) -(eval-when (:compile-toplevel :execute) -(defmacro with-exit-label ((label) &body body) - `(let* ((,label (next-label)) - (*unwind-exit* (cons ,label *unwind-exit*))) - ,@body - (wt-label ,label)))) - (defun c2if (c1form fmla form1 form2) (declare (ignore c1form)) ;; FIXME! Optimize when FORM1 or FORM2 are constants @@ -170,14 +163,17 @@ (loc-immediate-value-p loc) (cond ((not constantp) (cond ((eq (loc-representation-type loc) :bool) - (wt-nl "if(" loc "){")) + (wt-nl "if (" loc ") {")) (t - (wt-nl "if((") + (wt-nl "if ((") (wt-coerce-loc :object loc) - (wt ")!=ECL_NIL){"))) - (unwind-no-exit label) - (wt-nl) (wt-go label) - (wt "}")) + (wt ")!=ECL_NIL) {"))) + (cond ((unwind-no-exit label) + (incf *opened-c-braces*) + (wt-nl) (wt-go label) + (wt-nl-close-brace)) + (t + (wt " ") (wt-go label) (wt " }")))) ((null value)) (t (unwind-no-exit label) @@ -188,14 +184,17 @@ (loc-immediate-value-p loc) (cond ((not constantp) (cond ((eq (loc-representation-type loc) :bool) - (wt-nl "if(!(" loc ")){")) + (wt-nl "if (!(" loc ")) {")) (t - (wt-nl "if((") + (wt-nl "if (Null(") (wt-coerce-loc :object loc) - (wt ")==ECL_NIL){"))) - (unwind-no-exit label) - (wt-nl) (wt-go label) - (wt "}")) + (wt ")) {"))) + (cond ((unwind-no-exit label) + (incf *opened-c-braces*) + (wt-nl) (wt-go label) + (wt-nl-close-brace)) + (t + (wt " ") (wt-go label) (wt " }")))) (value) (t (unwind-no-exit label) diff --git a/src/cmp/cmplam.lsp b/src/cmp/cmplam.lsp index 7d67f5f51..623274a76 100644 --- a/src/cmp/cmplam.lsp +++ b/src/cmp/cmplam.lsp @@ -505,12 +505,14 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." ;; with initform (setf (second KEYVARS[i]) (+ nkey i)) (wt-nl "if (") (wt-loc KEYVARS[i]) (wt "==ECL_NIL) {") - (let ((*unwind-exit* *unwind-exit*)) + (let ((*unwind-exit* *unwind-exit*) + (*opened-c-braces* (1+ *opened-c-braces*))) (bind-init init var)) (wt-nl "} else {") - (setf (second KEYVARS[i]) i) - (bind KEYVARS[i] var) - (wt "}"))) + (let ((*opened-c-braces* (1+ *opened-c-braces*))) + (setf (second KEYVARS[i]) i) + (bind KEYVARS[i] var)) + (wt-nl "}"))) (when flag (setf (second KEYVARS[i]) (+ nkey i)) (bind KEYVARS[i] flag)))) diff --git a/src/cmp/cmpmac.lsp b/src/cmp/cmpmac.lsp index 8ebd40f66..7484a77e1 100644 --- a/src/cmp/cmpmac.lsp +++ b/src/cmp/cmpmac.lsp @@ -61,9 +61,32 @@ (defmacro next-cmacro () '(incf *next-cmacro*)) ;;; from cmplabel.lsp -(defmacro next-label () `(cons (incf *last-label*) nil)) +(defun next-label () + (cons (incf *last-label*) nil)) -(defmacro next-label* () `(cons (incf *last-label*) t)) +(defun next-label* () + (cons (incf *last-label*) t)) + +(defun maybe-next-label () + (let ((l (next-label))) + (if (and (consp *exit*) (numberp (car *exit*))) + *exit* + l))) + +(defun maybe-wt-label (label) + (unless (eq label *exit*) + (wt-label label))) + +(defmacro with-exit-label ((label) &body body) + `(let* ((,label (next-label)) + (*unwind-exit* (cons ,label *unwind-exit*))) + ,@body + (wt-label ,label))) + +(defmacro with-optional-label ((label-name) &body body) + `(let ((,label-name (maybe-next-label))) + ,@body + (maybe-wt-label ,label-name))) (defun next-lcl () (list 'LCL (incf *lcl*)))