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

[Erik Huelsmann]

Author: ehuelsmann
Date: Sat Aug  8 15:18:31 2009
New Revision: 12088

Log:
Register blocks with their compiland;
create a field in the variable-info structure to allow registration
of the block they belong to.

Modified:
   trunk/abcl/src/org/armedbear/lisp/jvm.lisp

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	Sat Aug  8 15:18:31 2009
@@ -162,6 +162,7 @@
   parent            ; the parent for compilands which defined within another
   (children 0       ; Number of local functions
             :type fixnum) ; defined with with FLET, LABELS or LAMBDA
+  blocks            ; TAGBODY, PROGV, BLOCK, etc. blocks
   argument-register
   closure-register
   environment-register
@@ -271,7 +272,8 @@
   (references-allowed-p t) ; NIL if this is a symbol macro in the enclosing
                            ; lexical environment
   used-non-locally-p
-  (compiland *current-compiland*))
+  (compiland *current-compiland*)
+  block)
 
 (defstruct (var-ref (:constructor make-var-ref (variable)))
   ;; The variable this reference refers to. Will be NIL if the VAR-REF has been
@@ -369,7 +371,7 @@
 ;; BLOCKs per se.
 (defstruct (block-node (:conc-name block-)
                        (:include node)
-                       (:constructor make-block-node (name)))
+                       (:constructor %make-block-node (name)))
   (exit (gensym))
   target
   catch-tag
@@ -394,6 +396,12 @@
 
 (defvar *blocks* ())
 
+(defknown make-block-node (t) t)
+(defun make-block-node (name)
+  (let ((block (%make-block-node name)))
+    (push block (compiland-blocks *current-compiland*))
+    block))
+
 (defun find-block (name)
   (dolist (block *blocks*)
     (when (eq name (block-name block))