Last uses of braces outside IF and some in IFs updated to the new model

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")))
 
 ;;;

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)

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
         )

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)

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))))

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*)))