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

[Erik Huelsmann]

Author: ehuelsmann
Date: Tue Sep 29 15:08:59 2009
New Revision: 12165

Log:
Removal of duplication of TAGBODY processing code in DO*/DO and TAGBODY.

Modified:
   trunk/abcl/src/org/armedbear/lisp/Do.java
   trunk/abcl/src/org/armedbear/lisp/Lisp.java
   trunk/abcl/src/org/armedbear/lisp/Primitives.java

Modified: trunk/abcl/src/org/armedbear/lisp/Do.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Do.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Do.java	Tue Sep 29 15:08:59 2009
@@ -120,62 +120,21 @@
         list = list.cdr();
       }
     // Look for tags.
-    LispObject remaining = body;
-    while (remaining != NIL)
-      {
-        LispObject current = remaining.car();
-        remaining = remaining.cdr();
-        if (current instanceof Cons)
-          continue;
-        // It's a tag.
-        ext.addTagBinding(current, remaining);
-      }
+    LispObject localTags = preprocessTagBody(body, ext);
+    LispObject blockId = new LispObject();
     try
       {
         // Implicit block.
-        ext.addBlock(NIL, new LispObject());
+        ext.addBlock(NIL, blockId);
         while (true)
           {
             // Execute body.
             // Test for termination.
             if (eval(end_test_form, ext, thread) != NIL)
               break;
-            remaining = body;
-            while (remaining != NIL)
-              {
-                LispObject current = remaining.car();
-                if (current instanceof Cons)
-                  {
-                    try
-                      {
-                        // Handle GO inline if possible.
-                        if (current.car() == Symbol.GO)
-                          {
-                            LispObject tag = current.cadr();
-                            Binding binding = ext.getTagBinding(tag);
-                            if (binding != null && binding.value != null)
-                              {
-                                remaining = binding.value;
-                                continue;
-                              }
-                            throw new Go(tag);
-                          }
-                        eval(current, ext, thread);
-                      }
-                    catch (Go go)
-                      {
-                        LispObject tag = go.getTag();
-                        Binding binding = ext.getTagBinding(tag);
-                        if (binding != null && binding.value != null)
-                          {
-                            remaining = binding.value;
-                            continue;
-                          }
-                        throw go;
-                      }
-                  }
-                remaining = remaining.cdr();
-              }
+
+            processTagBody(body, localTags, ext);
+
             // Update variables.
             if (sequential)
               {
@@ -230,7 +189,7 @@
       }
     catch (Return ret)
       {
-        if (ret.getTag() == NIL)
+        if (ret.getBlock() == blockId)
           {
             return ret.getResult();
           }

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	Tue Sep 29 15:08:59 2009
@@ -626,6 +626,81 @@
     return result;
   }
 
+  public static final LispObject preprocessTagBody(LispObject body,
+                                                   Environment env)
+    throws ConditionThrowable
+  {
+    LispObject localTags = NIL; // Tags that are local to this TAGBODY.
+    while (body != NIL)
+      {
+        LispObject current = body.car();
+        body = ((Cons)body).cdr;
+        if (current instanceof Cons)
+          continue;
+        // It's a tag.
+        env.addTagBinding(current, body);
+        localTags = new Cons(current, localTags);
+      }
+    return localTags;
+  }
+
+  public static final LispObject processTagBody(LispObject body,
+                                                LispObject localTags,
+                                                Environment env)
+    throws ConditionThrowable
+  {
+    LispObject remaining = body;
+    LispThread thread = LispThread.currentThread();
+    while (remaining != NIL)
+      {
+        LispObject current = remaining.car();
+        if (current instanceof Cons)
+          {
+            try {
+              // Handle GO inline if possible.
+              if (((Cons)current).car == Symbol.GO)
+                {
+                  if (interrupted)
+                    handleInterrupt();
+                  LispObject tag = current.cadr();
+                  Binding binding = env.getTagBinding(tag);
+                  if (binding == null)
+                    return error(new ControlError("No tag named " +
+                                                  tag.writeToString() +
+                                                  " is currently visible."));
+                  else if (memql(tag, localTags))
+                    {
+                      if (binding.value != null)
+                        {
+                          remaining = binding.value;
+                          continue;
+                        }
+                    }
+                  throw new Go(tag);
+                }
+              eval(current, env, thread);
+            }
+            catch (Go go)
+              {
+                LispObject tag = go.getTag();
+                if (memql(tag, localTags))
+                  {
+                    Binding binding = env.getTagBinding(tag);
+                    if (binding != null && binding.value != null)
+                      {
+                        remaining = binding.value;
+                        continue;
+                      }
+                  }
+                throw go;
+              }
+          }
+        remaining = ((Cons)remaining).cdr;
+      }
+    thread._values = null;
+    return NIL;
+  }
+
   // Environment wrappers.
   private static final boolean isSpecial(Symbol sym, LispObject ownSpecials,
                                          Environment env)

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	Tue Sep 29 15:08:59 2009
@@ -3496,65 +3496,7 @@
         throws ConditionThrowable
       {
         Environment ext = new Environment(env);
-        LispObject localTags = NIL; // Tags that are local to this TAGBODY.
-        LispObject body = args;
-        while (body != NIL)
-          {
-            LispObject current = body.car();
-            body = ((Cons)body).cdr;
-            if (current instanceof Cons)
-              continue;
-            // It's a tag.
-            ext.addTagBinding(current, body);
-            localTags = new Cons(current, localTags);
-          }
-        final LispThread thread = LispThread.currentThread();
-        LispObject remaining = args;
-        while (remaining != NIL)
-          {
-            LispObject current = remaining.car();
-            if (current instanceof Cons)
-              {
-                try
-                  {
-                    // Handle GO inline if possible.
-                    if (((Cons)current).car == Symbol.GO)
-                      {
-                        if (interrupted)
-                          handleInterrupt();
-                        LispObject tag = current.cadr();
-                        if (memql(tag, localTags))
-                          {
-                            Binding binding = ext.getTagBinding(tag);
-                            if (binding != null && binding.value != null)
-                              {
-                                remaining = binding.value;
-                                continue;
-                              }
-                          }
-                        throw new Go(tag);
-                      }
-                    eval(current, ext, thread);
-                  }
-                catch (Go go)
-                  {
-                    LispObject tag = go.getTag();
-                    if (memql(tag, localTags))
-                      {
-                        Binding binding = ext.getTagBinding(tag);
-                        if (binding != null && binding.value != null)
-                          {
-                            remaining = binding.value;
-                            continue;
-                          }
-                      }
-                    throw go;
-                  }
-              }
-            remaining = ((Cons)remaining).cdr;
-          }
-        thread._values = null;
-        return NIL;
+        return processTagBody(args, preprocessTagBody(args, ext), ext);
       }
     };