[armedbear-cvs] r12104 - trunk/abcl/src/org/armedbear/lisp

[Erik Huelsmann]

Author: ehuelsmann
Date: Fri Aug 14 17:08:05 2009
New Revision: 12104

Log:
Switch MULTIPLE-VALUE-BIND block-nodes to M-V-B-NODEs.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp	Fri Aug 14 17:08:05 2009
@@ -255,14 +255,13 @@
     (let ((new-form `(let* ((,(caadr form) ,(caddr form))) ,@(cdddr form))))
       (return-from p1-m-v-b (p1-let/let* new-form))))
   (let* ((*visible-variables* *visible-variables*)
-         (block (make-block-node '(MULTIPLE-VALUE-BIND)))
-         (*blocks* (cons block *blocks*))
+         (block (make-m-v-b-node))
          (varlist (cadr form))
-         (values-form (caddr form))
+         ;; Process the values-form first. ("The scopes of the name binding and
+         ;; declarations do not include the values-form.")
+         (values-form (p1 (caddr form)))
+         (*blocks* (cons block *blocks*))
          (body (cdddr form)))
-    ;; Process the values-form first. ("The scopes of the name binding and
-    ;; declarations do not include the values-form.")
-    (setf values-form (p1 values-form))
     (let ((vars ()))
       (dolist (symbol varlist)
         (let ((var (make-variable :name symbol :block block)))
@@ -273,14 +272,14 @@
       (dolist (variable vars)
         (when (special-variable-p (variable-name variable))
           (setf (variable-special-p variable) t
-                (block-environment-register block) t)))
-      (setf (block-free-specials block)
+                (m-v-b-environment-register block) t)))
+      (setf (m-v-b-free-specials block)
             (process-declarations-for-vars body vars block))
-      (dolist (special (block-free-specials block))
+      (dolist (special (m-v-b-free-specials block))
         (push special *visible-variables*))
-      (setf (block-vars block) (nreverse vars)))
+      (setf (m-v-b-vars block) (nreverse vars)))
     (setf body (p1-body body))
-    (setf (block-form block)
+    (setf (m-v-b-form block)
           (list* 'MULTIPLE-VALUE-BIND varlist values-form body))
     block))
 

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Fri Aug 14 17:08:05 2009
@@ -3987,13 +3987,12 @@
 			:catch-type 0) *handlers*)))
 
 (defun p2-m-v-b-node (block target)
-  (let* ((*blocks* (cons block *blocks*))
-         (*register* *register*)
-         (form (block-form block))
+  (let* ((*register* *register*)
+         (form (m-v-b-form block))
          (*visible-variables* *visible-variables*)
          (vars (second form))
          (bind-special-p nil)
-         (variables (block-vars block))
+         (variables (m-v-b-vars block))
          (label-START (gensym)))
     (dolist (variable variables)
       (let ((special-p (variable-special-p variable)))
@@ -4006,8 +4005,8 @@
     (when bind-special-p
       (dformat t "p2-m-v-b-node lastSpecialBinding~%")
       ;; Save current dynamic environment.
-      (setf (block-environment-register block) (allocate-register))
-      (save-dynamic-environment (block-environment-register block))
+      (setf (m-v-b-environment-register block) (allocate-register))
+      (save-dynamic-environment (m-v-b-environment-register block))
       (label label-START))
     ;; Make sure there are no leftover values from previous calls.
     (emit-clear-values)
@@ -4062,10 +4061,11 @@
     ;; Make the variables visible for the body forms.
     (dolist (variable variables)
       (push variable *visible-variables*))
-    (dolist (variable (block-free-specials block))
+    (dolist (variable (m-v-b-free-specials block))
       (push variable *visible-variables*))
     ;; Body.
-    (compile-progn-body (cdddr form) target)
+    (let ((*blocks* (cons block *blocks*)))
+      (compile-progn-body (cdddr form) target))
     (when bind-special-p
       (restore-environment-and-make-handler (block-environment-register block)
 					    label-START))))
@@ -7917,9 +7917,6 @@
                     (p2-flet-node form target representation))
                    ((eq name 'LABELS)
                     (p2-labels-node form target representation))
-                   ((eq name 'MULTIPLE-VALUE-BIND)
-                    (p2-m-v-b-node form target)
-                    (fix-boxing representation nil))
                    )))))
         ((node-p form)
          (cond
@@ -7929,6 +7926,9 @@
            ((unwind-protect-node-p form)
             (p2-unwind-protect-node form target)
             (fix-boxing representation nil))
+           ((m-v-b-node-p form)
+            (p2-m-v-b-node form target)
+            (fix-boxing representation nil))
            ((locally-node-p form)
             (p2-locally-node form target representation))
            ((catch-node-p form)
@@ -7939,6 +7939,8 @@
            ((synchronized-node-p form)
             (p2-threads-synchronized-on form target)
             (fix-boxing representation nil))
+           (t
+            (aver (not "Can't happen")))
 ))
         ((constantp form)
          (compile-constant form target representation))