[armedbear-cvs] r12168 - trunk/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Wed Sep 30 19:10:54 UTC 2009
Author: ehuelsmann
Date: Wed Sep 30 15:10:51 2009
New Revision: 12168
Log:
Correct identification of the lexical context of a GO in relation to its TAGBODY.
The change applies to both compiled and interpreted code, both of which didn't
identify the correct TAGBODY to which the GO belonged.
Modified:
trunk/abcl/src/org/armedbear/lisp/Binding.java
trunk/abcl/src/org/armedbear/lisp/Environment.java
trunk/abcl/src/org/armedbear/lisp/Go.java
trunk/abcl/src/org/armedbear/lisp/Lisp.java
trunk/abcl/src/org/armedbear/lisp/Primitives.java
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/Binding.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Binding.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Binding.java Wed Sep 30 15:10:51 2009
@@ -37,6 +37,7 @@
final class Binding
{
final LispObject symbol;
+ LispObject tagbody = null;
LispObject value;
boolean specialp;
final Binding next;
@@ -47,4 +48,11 @@
this.value = value;
this.next = next;
}
+
+ Binding(LispObject symbol, LispObject tagbody,
+ LispObject value, Binding next)
+ {
+ this(symbol, value, next);
+ this.tagbody = tagbody;
+ }
}
Modified: trunk/abcl/src/org/armedbear/lisp/Environment.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Environment.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Environment.java Wed Sep 30 15:10:51 2009
@@ -182,9 +182,9 @@
return null;
}
- public void addTagBinding(LispObject tag, LispObject code)
+ public void addTagBinding(LispObject tag, LispObject tagbody, LispObject code)
{
- tags = new Binding(tag, code, tags);
+ tags = new Binding(tag, tagbody, code, tags);
}
public Binding getTagBinding(LispObject tag)
Modified: trunk/abcl/src/org/armedbear/lisp/Go.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Go.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Go.java Wed Sep 30 15:10:51 2009
@@ -35,13 +35,20 @@
public final class Go extends ConditionThrowable
{
+ public final LispObject tagbody;
public final LispObject tag;
- public Go(LispObject tag)
+ public Go(LispObject tagbody, LispObject tag)
{
+ this.tagbody = tagbody;
this.tag = tag;
}
+ public LispObject getTagBody()
+ {
+ return tagbody;
+ }
+
public LispObject getTag()
{
return tag;
Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Lisp.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Wed Sep 30 15:10:51 2009
@@ -638,7 +638,7 @@
if (current instanceof Cons)
continue;
// It's a tag.
- env.addTagBinding(current, body);
+ env.addTagBinding(current, env, body);
localTags = new Cons(current, localTags);
}
return localTags;
@@ -676,14 +676,15 @@
continue;
}
}
- throw new Go(tag);
+ throw new Go(binding.tagbody, tag);
}
eval(current, env, thread);
}
catch (Go go)
{
- LispObject tag = go.getTag();
- if (memql(tag, localTags))
+ LispObject tag;
+ if (go.getTagBody() == env
+ && memql(tag = go.getTag(), localTags))
{
Binding binding = env.getTagBinding(tag);
if (binding != null && binding.value != null)
Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Primitives.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Wed Sep 30 15:10:51 2009
@@ -3515,7 +3515,7 @@
return error(new ControlError("No tag named " +
args.car().writeToString() +
" is currently visible."));
- throw new Go(args.car());
+ throw new Go(binding.tagbody, args.car());
}
};
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 Wed Sep 30 15:10:51 2009
@@ -420,6 +420,12 @@
(setf live nil))
(push (p1 subform) new-body))))
(setf (tagbody-form block) (list* 'TAGBODY (nreverse new-body))))
+ (when (some #'tag-used-non-locally (tagbody-tags block))
+ (push (setf (tagbody-id-variable block)
+ (make-variable :name (gensym)
+ :block block
+ :used-non-locally-p t))
+ *all-variables*))
block))
(defknown p1-go (t) t)
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 Wed Sep 30 15:10:51 2009
@@ -4469,12 +4469,20 @@
(body (cdr form))
(BEGIN-BLOCK (gensym))
(END-BLOCK (gensym))
+ (RETHROW (gensym))
(EXIT (gensym))
(must-clear-values nil))
;; Scan for tags.
(dolist (tag (tagbody-tags block))
(push tag *visible-tags*))
+ (when (tagbody-id-variable block)
+ ;; we have a block variable; that should be a closure variable
+ (assert (not (null (variable-closure-index (tagbody-id-variable block)))))
+ (emit 'new +lisp-object-class+)
+ (emit 'dup)
+ (emit-invokespecial-init +lisp-object-class+ '())
+ (emit-new-closure-binding (tagbody-id-variable block)))
(label BEGIN-BLOCK)
(do* ((rest body (cdr rest))
(subform (car rest) (car rest)))
@@ -4506,7 +4514,10 @@
(emit 'dup)
(astore go-register)
;; Get the tag.
- (emit 'checkcast +lisp-go-class+)
+ (emit 'getfield +lisp-go-class+ "tagbody" +lisp-object+) ; Stack depth is still 1.
+ (emit-push-variable (tagbody-id-variable block))
+ (emit 'if_acmpne RETHROW) ;; Not this TAGBODY
+ (aload go-register)
(emit 'getfield +lisp-go-class+ "tag" +lisp-object+) ; Stack depth is still 1.
(astore tag-register)
;; Don't actually generate comparisons for tags
@@ -4525,6 +4536,7 @@
(emit 'goto (tag-label tag))
(label NEXT)))
;; Not found. Re-throw Go.
+ (label RETHROW)
(aload go-register)
(emit 'athrow)
;; Finally...
@@ -4564,8 +4576,9 @@
;; Non-local GO.
(emit 'new +lisp-go-class+)
(emit 'dup)
+ (emit-push-variable (tagbody-id-variable (tag-block tag)))
(compile-form `',(tag-label tag) 'stack nil) ; Tag.
- (emit-invokespecial-init +lisp-go-class+ (lisp-object-arg-types 1))
+ (emit-invokespecial-init +lisp-go-class+ (lisp-object-arg-types 2))
(emit 'athrow)
;; Following code will not be reached, but is needed for JVM stack
;; consistency.
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 Wed Sep 30 15:10:51 2009
@@ -383,7 +383,11 @@
(:constructor %make-tagbody-node ()))
;; True if a tag in this tagbody is the target of a non-local GO.
non-local-go-p
- tags)
+ ;; Tags in the tagbody form; a list of tag structures
+ tags
+ ;; Contains a variable whose value uniquely identifies the
+ ;; lexical scope from this block, to be used by GO
+ id-variable)
(defknown make-tagbody-node () t)
(defun make-tagbody-node ()
(let ((block (%make-tagbody-node)))
More information about the armedbear-cvs
mailing list