[armedbear-cvs] r12094 - trunk/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Tue Aug 11 15:41:43 UTC 2009
Author: ehuelsmann
Date: Tue Aug 11 11:41:40 2009
New Revision: 12094
Log:
Convert TAGBODY block-nodes to TAGBODY-NODEs.
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 Tue Aug 11 11:41:40 2009
@@ -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 #'block-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-block-node '(TAGBODY)))
+ (let* ((block (make-tagbody-node :name '(TAGBODY)))
(*blocks* (cons block *blocks*))
(*visible-tags* *visible-tags*)
(local-tags '())
@@ -402,7 +402,7 @@
(cond ((or (symbolp subform) (integerp subform))
(push subform new-body)
(push (find subform local-tags :key #'tag-name :test #'eql)
- (block-tags block))
+ (tagbody-tags block))
(setf live t))
((not live)
;; Nothing to do.
@@ -414,7 +414,7 @@
;; tag.
(setf live nil))
(push (p1 subform) new-body))))
- (setf (block-form block) (list* 'TAGBODY (nreverse new-body))))
+ (setf (tagbody-form block) (list* 'TAGBODY (nreverse new-body))))
block))
(defknown p1-go (t) t)
@@ -428,14 +428,14 @@
(cond ((eq (tag-compiland tag) *current-compiland*)
;; Does the GO leave an enclosing UNWIND-PROTECT or CATCH?
(if (enclosed-by-protected-block-p tag-block)
- (setf (block-non-local-go-p tag-block) t)
+ (setf (tagbody-non-local-go-p tag-block) t)
;; non-local GO's ensure environment restoration
;; find out about this local GO
- (when (null (block-needs-environment-restoration tag-block))
- (setf (block-needs-environment-restoration tag-block)
+ (when (null (tagbody-needs-environment-restoration tag-block))
+ (setf (tagbody-needs-environment-restoration tag-block)
(enclosed-by-environment-setting-block-p tag-block)))))
(t
- (setf (block-non-local-go-p tag-block) t)))))
+ (setf (tagbody-non-local-go-p tag-block) t)))))
form)
(defun validate-function-name (name)
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 Tue Aug 11 11:41:40 2009
@@ -836,8 +836,8 @@
(defknown single-valued-p (t) t)
(defun single-valued-p (form)
- (cond ((block-node-p form)
- (if (equal (block-name form) '(TAGBODY))
+ (cond ((node-p form)
+ (if (equal (node-name form) '(TAGBODY))
(not (unsafe-p (node-form form)))
(single-valued-p (node-form form))))
((var-ref-p form)
@@ -4451,14 +4451,14 @@
(let* ((*blocks* (cons block *blocks*))
(*visible-tags* *visible-tags*)
(*register* *register*)
- (form (block-form block))
+ (form (tagbody-form block))
(body (cdr form))
(BEGIN-BLOCK (gensym))
(END-BLOCK (gensym))
(EXIT (gensym))
(must-clear-values nil))
;; Scan for tags.
- (dolist (tag (block-tags block))
+ (dolist (tag (tagbody-tags block))
(push tag *visible-tags*))
(label BEGIN-BLOCK)
@@ -4466,7 +4466,7 @@
(subform (car rest) (car rest)))
((null rest))
(cond ((or (symbolp subform) (integerp subform))
- (let ((tag (find subform (block-tags block) :key #'tag-name
+ (let ((tag (find subform (tagbody-tags block) :key #'tag-name
:test #'eql)))
(unless tag
(error "COMPILE-TAGBODY: tag not found: ~S~%" subform))
@@ -4481,7 +4481,7 @@
(setf must-clear-values t))))))
(label END-BLOCK)
(emit 'goto EXIT)
- (when (block-non-local-go-p block)
+ (when (tagbody-non-local-go-p block)
; We need a handler to catch non-local GOs.
(let* ((HANDLER (gensym))
(*register* *register*)
@@ -4497,7 +4497,7 @@
(astore tag-register)
;; Don't actually generate comparisons for tags
;; to which there is no GO instruction
- (dolist (tag (remove-if-not #'tag-used (block-tags block)))
+ (dolist (tag (remove-if-not #'tag-used (tagbody-tags block)))
(let ((NEXT (gensym)))
(aload tag-register)
(emit 'getstatic *this-class*
@@ -4539,7 +4539,7 @@
(not (enclosed-by-protected-block-p tag-block)))
;; Local case with local transfer of control
;; Note: Local case with non-local transfer of control handled below
- (when (and (block-needs-environment-restoration tag-block)
+ (when (and (tagbody-needs-environment-restoration tag-block)
(enclosed-by-environment-setting-block-p tag-block))
;; If there's a dynamic environment to restore, do it.
(restore-dynamic-environment (environment-register-to-restore tag-block)))
@@ -6408,11 +6408,11 @@
(if variable
(derive-type variable)
t)))))
- ((block-node-p form)
+ ((node-p form)
(let ((result t))
- (cond ((equal (block-name form) '(LET))
+ (cond ((equal (node-name form) '(LET))
;; (format t "derive-type LET/LET* node case~%")
- (let* ((forms (cddr (block-form form)))
+ (let* ((forms (cddr (node-form form)))
(last-form (car (last forms)))
(derived-type (derive-compiler-type last-form)))
;; (unless (eq derived-type t)
@@ -6421,7 +6421,7 @@
;; (format t "derived-type = ~S~%" derived-type)
;; )
(setf result derived-type)))
- ((symbolp (block-name form))
+ ((symbolp (node-name form))
(unless (block-return-p form)
(let* ((forms (cddr (block-form form)))
(last-form (car (last forms)))
@@ -7907,31 +7907,45 @@
(if (not (consp name))
(p2-block-node form target representation)
(let ((name (car name)))
- (cond ((eq name 'TAGBODY)
- (p2-tagbody-node form target)
- (fix-boxing representation nil))
- ((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 'MULTIPLE-VALUE-BIND)
- (p2-m-v-b-node form target)
- (fix-boxing representation nil))
- ((eq name 'UNWIND-PROTECT)
- (p2-unwind-protect-node form target)
- (fix-boxing representation nil))
- ((eq name 'CATCH)
- (p2-catch-node form target)
- (fix-boxing representation nil))
- ((eq name 'PROGV)
- (p2-progv-node form target representation))
- ((eq name 'LOCALLY)
- (p2-locally-node form target representation))
- ((eq name 'THREADS:SYNCHRONIZED-ON)
- (p2-threads-synchronized-on form target)
- (fix-boxing representation nil)))))))
+ (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 'MULTIPLE-VALUE-BIND)
+ (p2-m-v-b-node form target)
+ (fix-boxing representation nil))
+ ((eq name 'UNWIND-PROTECT)
+ (p2-unwind-protect-node form target)
+ (fix-boxing representation nil))
+ ((eq name 'CATCH)
+ (p2-catch-node form target)
+ (fix-boxing representation nil))
+ ((eq name 'PROGV)
+ (p2-progv-node form target representation))
+ ((eq name 'LOCALLY)
+ (p2-locally-node form target representation))
+ ((eq name 'THREADS:SYNCHRONIZED-ON)
+ (p2-threads-synchronized-on form target)
+ (fix-boxing representation nil)))))))
+ ((node-p form)
+ (cond
+ ((tagbody-node-p form)
+ (p2-tagbody-node form target)
+ (fix-boxing representation nil))
+ ((unwind-protect-node-p form)
+ (p2-unwind-protect-node form target)
+ (fix-boxing representation nil))
+ ((locally-node-p form)
+ (p2-locally-node form target representation))
+ ((catch-node-p form)
+ (p2-catch-node form target)
+ (fix-boxing representation nil))
+ ((progv-node-p form)
+ (p2-progv-node form target representation))
+))
((constantp form)
(compile-constant form target representation))
(t
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 Tue Aug 11 11:41:40 2009
@@ -446,8 +446,6 @@
;; Only used in LET/LET*/M-V-B nodes.
vars
free-specials
- ;; Only used in TAGBODY
- tags
)
(defvar *blocks* ())
@@ -465,7 +463,7 @@
(defknown node-constant-p (t) boolean)
(defun node-constant-p (object)
- (cond ((block-node-p object)
+ (cond ((node-p object)
nil)
((var-ref-p object)
nil)
@@ -505,7 +503,10 @@
(dolist (enclosing-block *blocks*)
(when (eq enclosing-block outermost-block)
(return nil))
- (when (and (block-environment-register enclosing-block))
+ (when (or (and (binding-node-p enclosing-block)
+ (binding-node-environment-register enclosing-block))
+ (and (block-node-p enclosing-block)
+ (block-environment-register enclosing-block)))
(return t))))
(defknown environment-register-to-restore (&optional t) t)
@@ -517,7 +518,10 @@
(flet ((outermost-register (last-register block)
(when (eq block outermost-block)
(return-from environment-register-to-restore last-register))
- (or (block-environment-register block)
+ (or (and (binding-node-p block)
+ (binding-node-environment-register block))
+ (and (block-node-p block)
+ (block-environment-register block))
last-register)))
(reduce #'outermost-register *blocks*
:initial-value nil)))
More information about the armedbear-cvs
mailing list