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

[Erik Huelsmann]

Author: ehuelsmann
Date: Sun Aug 23 17:50:04 2009
New Revision: 12115

Log:
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.


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	Sun Aug 23 17:50:04 2009
@@ -640,15 +640,15 @@
 	 (push local-function local-functions)))
       ((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)))))
 

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	Sun Aug 23 17:50:04 2009
@@ -4954,7 +4954,7 @@
 
 (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*)
          (local-functions (cadr form))
@@ -4963,9 +4963,10 @@
       (p2-flet-process-compiland local-function))
     (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)
 (defun p2-labels-node (block target representation)
@@ -7913,10 +7914,14 @@
                  (cond
                    ((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)
          (cond
@@ -7929,6 +7934,8 @@
            ((m-v-b-node-p form)
             (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))
            ((catch-node-p form)