[armedbear-devel] Ticket 240: Support 3-arg FIND-CLASS and (SETF FIND-CLASS) - armedbear-devel - mailman3.common-lisp.net

8 Apr 2015

Hi Rudi,
Some time ago, I promissed I'd look at implementing the three argument
version of FIND-CLASS. I can't really test it, but I've finally managed to
hack up my proposed solution. Find the patch included below and attached to
the ticket.
Also, I'm not sure the compiler sets up a global compilation environment. I
think that if it doesn't, you want to bind a new environment somewhere in
the COMPILE-FROM-STREAM to *compile-file-environment*.
HTH,
-- 
Bye,

Erik.

http://efficito.com -- Hosted accounting and ERP.
Robust and Flexible. No vendor lock-in.


The patch:


Index: Environment.java
===================================================================

--- Environment.java (revision 14552)
+++ Environment.java (working copy)
@@ -42,6 +42,7 @@
   private Binding blocks;
   private Binding tags;
   public boolean inactive; //default value: false == active
+  private static final ConcurrentHashMap<Symbol, LispObject> classMap;

   public Environment() {}

@@ -53,7 +54,11 @@
         lastFunctionBinding = parent.lastFunctionBinding;
         blocks = parent.blocks;
         tags = parent.tags;
+        classMap = parent.classMap;
       }
+    else
+      classMap = new ConcurrentHashMap<Symbol, LispObject>();
+
   }

   // Construct a new Environment extending parent with the specified
symbol-
@@ -217,6 +222,36 @@
     return null;
   }

+  final public LispObject addClass(LispObject name, LispObject c)
+  {
+    classMap.put(checkSymbol(name), c);
+    return c;
+  }
+
+  final public LispObject findClass(LispObject name, boolean errorp)
+  {
+    final Symbol symbol = checkSymbol(name);
+    final LispObject c = classMap.get(symbol);
+
+    if (c != null)
+      return c;
+
+    if (errorp)
+    {
+      StringBuilder sb =
+        new StringBuilder("There is no class named ");
+      sb.append(name.princToString());
+      sb.append('.');
+      return error(new LispError(sb.toString()));
+    }
+    return NIL;
+  }
+
+  final public void removeClass(LispObject name)
+  {
+    classMap.remove(checkSymbol(name));
+  }
+
   // Returns body with declarations removed.
   public LispObject processDeclarations(LispObject body)

Index: LispClass.java
===================================================================
--- LispClass.java (revision 14552)
+++ LispClass.java (working copy)
@@ -328,8 +328,7 @@
                                 LispObject third)

       {
-        // FIXME Use environment!
-        return findClass(first, second != NIL);
+        return checkEnvironment(third).findClass(first, second != NIL);
       }
     };

@@ -339,7 +338,6 @@
     {
       @Override
       public LispObject execute(LispObject first, LispObject second)
-
       {
         final Symbol name = checkSymbol(first);
         if (second == NIL)
@@ -350,6 +348,18 @@
         addClass(name, second);
         return second;
       }
+
+      @Override
+      public LispObject execute(LispObject first, LispObject second,
+                                  LispObject third, LispObject fourth)
+      {
+        if (second == NIL)
+        {
+          checkEnvironment.removeClass(first);
+          return second;
+        }
+
+        return checkEnvironment(fourth).addCleass(first, second);
     };

   // ### subclassp



    