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

[Erik Huelsmann]

Author: ehuelsmann
Date: Mon Dec 28 08:00:31 2009
New Revision: 12310

Log:
Implement note 1 from r12306: function preloading for macros.

Modified:
   trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java
   trunk/abcl/src/org/armedbear/lisp/Lisp.java
   trunk/abcl/src/org/armedbear/lisp/compile-file.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java	Mon Dec 28 08:00:31 2009
@@ -41,27 +41,31 @@
 
 public class AutoloadedFunctionProxy extends Function {
 
+    public enum FunctionType
+    {
+        NORMAL, SETF, MACRO
+    };
+
     final private Symbol symbol;
     final private String name;
     final private LispObject cache;
     final private LispObject pack;
     final private LispObject anonymousPackage;
-    final private boolean isSetfFunction;
+    final private FunctionType fType;
     Function fun = null;
 
     public AutoloadedFunctionProxy(Symbol symbol, LispObject name,
                                    LispObject cache, LispObject pack,
                                    LispObject anonymousPackage,
-                                   boolean setfFunction) {
+                                   FunctionType ft) {
         super();
         this.symbol = symbol;
         this.name = name.getStringValue();
         this.cache = cache;
         this.pack = pack;
-        //        Debug.trace("proxying ... " + name.getStringValue());
         Debug.assertTrue(! (cache instanceof Nil));
         this.anonymousPackage = anonymousPackage;
-        this.isSetfFunction = setfFunction;
+        this.fType = ft;
     }
 
     final private synchronized Function load() {
@@ -86,16 +90,27 @@
             thread.resetSpecialBindings(mark);
         }
 
-        if (symbol != null) {
-            if (isSetfFunction)
-                put(symbol, Symbol.SETF_FUNCTION, fun);
-            else
-                symbol.setSymbolFunction(fun);
-        }
+        if (symbol != null)
+            installFunction(fType, symbol, fun);
 
         return fun;
     }
 
+    final static private void installFunction(FunctionType fType,
+                                              Symbol sym, Function fun) {
+
+        if (fType == FunctionType.SETF)
+            put(sym, Symbol.SETF_FUNCTION, fun);
+        else if (fType == FunctionType.MACRO) {
+            if (sym.getSymbolFunction() instanceof SpecialOperator)
+                put(sym, Symbol.MACROEXPAND_MACRO,
+                    new MacroObject(sym, fun));
+            else
+                sym.setSymbolFunction(new MacroObject(sym, fun));
+        } else
+            sym.setSymbolFunction(fun);
+    }
+
     @Override
     public LispObject execute()
     {
@@ -214,14 +229,17 @@
       final public LispObject execute(LispObject symbol, LispObject name) {
         LispThread thread = LispThread.currentThread();
         Symbol sym;
-        LispObject fun;
-        boolean setfFun = false;
+        Function fun;
+        FunctionType fType = FunctionType.NORMAL;
 
         if (symbol instanceof Symbol)
             sym = (Symbol)symbol;
         else if (isValidSetfFunctionName(symbol)) {
             sym = (Symbol)symbol.cadr();
-            setfFun = true;
+            fType = FunctionType.SETF;
+        } else if (isValidMacroFunctionName(symbol)) {
+            sym = (Symbol)symbol.cadr();
+            fType = FunctionType.MACRO;
         } else {
             checkSymbol(symbol); // generate an error
             return null; // not reached
@@ -235,11 +253,9 @@
         else {
             fun = new AutoloadedFunctionProxy(sym, name, cache, pack,
                                               Load._FASL_ANONYMOUS_PACKAGE_.symbolValue(thread),
-                                              setfFun);
-            if (setfFun)
-                put(sym, Symbol.SETF_FUNCTION, fun);
-            else
-                sym.setSymbolFunction(fun);
+                                              fType);
+
+            installFunction(fType, sym, fun);
         }
 
         return fun;

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	Mon Dec 28 08:00:31 2009
@@ -1478,6 +1478,21 @@
     return false;
   }
 
+  public static final boolean isValidMacroFunctionName(LispObject obj)
+  {
+    if (obj instanceof Cons)
+      {
+        Cons cons = (Cons) obj;
+        if (cons.car == Symbol.MACRO_FUNCTION && cons.cdr instanceof Cons)
+          {
+            Cons cdr = (Cons) cons.cdr;
+            return (cdr.car instanceof Symbol && cdr.cdr == NIL);
+          }
+      }
+    return false;
+  }
+
+
   public static final LispObject FUNCTION_NAME =
     list(Symbol.OR,
           Symbol.SYMBOL,

Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp	Mon Dec 28 08:00:31 2009
@@ -224,11 +224,13 @@
                          (if (special-operator-p name)
                              `(put ',name 'macroexpand-macro
                                    (make-macro ',name
-                                               (load-compiled-function
+                                               (proxy-preloaded-function
+                                                '(macro-function ,name)
                                                 ,(file-namestring classfile))))
                              `(fset ',name
                                     (make-macro ',name
-                                                (load-compiled-function
+                                                (proxy-preloaded-function
+                                                 '(macro-function ,name)
                                                  ,(file-namestring classfile)))
                                     ,*source-position*
                                     ',(third form)))))))))