Changeset 12115 for trunk/abcl/src/org

Timestamp:

08/23/09 21:50:04 (14 years ago)

Author:

ehuelsmann

Message:

Convert FLET BLOCK-NODEs to flet-nodes.

Note: This commit also fixes the failure of some ANSI

tests introduced in r12086 by special casing SETF function
handling. This special casing is temporary.

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• compiler-pass1.lisp (modified) (1 diff)
• compiler-pass2.lisp (modified) (4 diffs)

trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp

@@ -641 +641 @@
       ((with-saved-compiler-policy
      (process-optimization-declarations (cddr form))
-         (let* ((block (make-block-node '(FLET)))
+         (let* ((block (make-flet-node))
                 (*blocks* (cons block *blocks*))
                 (body (cddr form))
                 (*visible-variables* *visible-variables*))
-           (setf (block-free-specials block)
+           (setf (flet-free-specials block)
                  (process-declarations-for-vars body nil block))
-           (dolist (special (block-free-specials block))
+           (dolist (special (flet-free-specials block))
              (push special *visible-variables*))
-           (setf (block-form block)
+           (setf (flet-form block)
                  (list* (car form) local-functions (p1-body (cddr form))))
            block)))))

trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

@@ -4955 +4955 @@
 (defknown p2-flet-node (t t t) t)
 (defun p2-flet-node (block target representation)
-  (let* ((form (block-form block))
+  (let* ((form (flet-form block))
          (*local-functions* *local-functions*)
          (*visible-variables* *visible-variables*)
@@ -4964 +4964 @@
     (dolist (local-function local-functions)
       (push local-function *local-functions*))
-    (dolist (special (block-free-specials block))
+    (dolist (special (flet-free-specials block))
       (push special *visible-variables*))
-    (compile-progn-body body target representation)))
+    (let ((*blocks* (cons block *blocks*)))
+      (compile-progn-body body target representation))))
 
 (defknown p2-labels-node (t t t) t)
@@ -7914 +7915 @@
                    ((eq name 'LET)
                     (p2-let/let*-node form target representation))
-                   ((eq name 'FLET)
-                    (p2-flet-node form target representation))
                    ((eq name 'LABELS)
                     (p2-labels-node form target representation))
+                   ((eq name 'SETF) ;; SETF functions create
+                    ;; consp block names, if we're unlucky
+                    (p2-block-node form target representation))
+                   (t
+                    (print name)
+                    (aver (not "Can't happen.")))
                    )))))
         ((node-p form)
@@ -7930 +7935 @@
             (p2-m-v-b-node form target)
             (fix-boxing representation nil))
+           ((flet-node-p form)
+            (p2-flet-node form target representation))
            ((locally-node-p form)
             (p2-locally-node form target representation))