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

[Erik Huelsmann]

Author: ehuelsmann
Date: Thu Aug 13 16:18:59 2009
New Revision: 12100

Log:
Move the NAME field from the NODE to the BLOCK-NODE;
with the other node types, it's no longer required to
distinguish nodes by the content of their NAME field.

BLOCKs have NAMEs; CATCHes have TAGs. So, in the end,
the NAME field belongs in the BLOCK-NODE.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   trunk/abcl/src/org/armedbear/lisp/jvm.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	Thu Aug 13 16:18:59 2009
@@ -340,7 +340,7 @@
       ;;
       ;; However, p1 transforms the forms being processed, so, we
       ;; need to copy the forms to create a second copy.
-      (let* ((block (make-unwind-protect-node :name '(UNWIND-PROTECT)))
+      (let* ((block (make-unwind-protect-node))
              ;; a bit of jumping through hoops...
              (unwinding-forms (p1-body (copy-tree (cddr form))))
              (unprotected-forms (p1-body (cddr form)))
@@ -368,7 +368,7 @@
            ;; which is inside the block we're returning from, we'll do a non-
            ;; local return anyway so that UNWIND-PROTECT can catch it and run
            ;; its cleanup forms.
-           (dformat t "*blocks* = ~S~%" (mapcar #'node-name *blocks*))
+           ;;(dformat t "*blocks* = ~S~%" (mapcar #'node-name *blocks*))
            (let ((protected (enclosed-by-protected-block-p block)))
              (dformat t "p1-return-from protected = ~S~%" protected)
              (if protected
@@ -385,7 +385,7 @@
   (list* 'RETURN-FROM (cadr form) (mapcar #'p1 (cddr form))))
 
 (defun p1-tagbody (form)
-  (let* ((block (make-tagbody-node :name '(TAGBODY)))
+  (let* ((block (make-tagbody-node))
          (*blocks* (cons block *blocks*))
          (*visible-tags* *visible-tags*)
          (local-tags '())

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	Thu Aug 13 16:18:59 2009
@@ -837,7 +837,7 @@
 (defknown single-valued-p (t) t)
 (defun single-valued-p (form)
   (cond ((node-p form)
-         (if (equal (node-name form) '(TAGBODY))
+         (if (tagbody-node-p form)
              (not (unsafe-p (node-form form)))
              (single-valued-p (node-form form))))
         ((var-ref-p form)
@@ -6410,7 +6410,8 @@
                       t)))))
         ((node-p form)
          (let ((result t))
-           (cond ((equal (node-name form) '(LET))
+           (cond ((and (block-node-p form)
+                       (equal (block-name form) '(LET)))
                   ;;              (format t "derive-type LET/LET* node case~%")
                   (let* ((forms (cddr (node-form form)))
                          (last-form (car (last forms)))
@@ -6421,7 +6422,8 @@
                     ;;                  (format t "derived-type = ~S~%" derived-type)
                     ;;                  )
                     (setf result derived-type)))
-                 ((symbolp (node-name form))
+                 ((and (block-node-p form)
+                       (symbolp (block-name form)))
                   (unless (block-return-p form)
                     (let* ((forms (cddr (block-form form)))
                            (last-form (car (last forms)))

Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/jvm.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp	Thu Aug 13 16:18:59 2009
@@ -362,8 +362,6 @@
 (defvar *hairy-arglist-p* nil)
 
 (defstruct node
-  ;; Block name or (TAGBODY) or (LET) or (MULTIPLE-VALUE-BIND).
-  name
   form
   (compiland *current-compiland*))
 
@@ -432,6 +430,8 @@
 (defstruct (block-node (:conc-name block-)
                        (:include control-transferring-node)
                        (:constructor %make-block-node (name)))
+  ;; Block name or (TAGBODY) or (LET) or (MULTIPLE-VALUE-BIND).
+  name
   (exit (gensym))
   target
   catch-tag
@@ -456,7 +456,8 @@
 
 (defun find-block (name)
   (dolist (block *blocks*)
-    (when (eq name (node-name block))
+    (when (and (block-node-p block)
+               (eq name (block-name block)))
       (return block))))
 
 (defknown node-constant-p (t) boolean)
@@ -478,10 +479,10 @@
 Non-local exits are required by blocks which do more in their cleanup
 than just restore the lastSpecialBinding (= dynamic environment).
 "
-  (let ((name (node-name object)))
-    (or (equal name '(CATCH))
-        (equal name '(UNWIND-PROTECT))
-        (equal name '(THREADS:SYNCHRONIZED-ON)))))
+  (or (unwind-protect-node-p object)
+      (catch-node-p object)
+      (and (block-node-p object)
+           (equal (block-name object) '(THREADS:SYNCHRONIZED-ON)))))
 
 
 (defknown enclosed-by-protected-block-p (&optional t) boolean)