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

[Erik Huelsmann]

Author: ehuelsmann
Date: Fri Oct  1 04:24:41 2010
New Revision: 12932

Log:
Fix #88: "We need SYS:COMPILED-LISP-FUNCTION-P" to distinguish
Java-defined and Lisp-defined functions (for SLIME).

Modified:
   trunk/abcl/src/org/armedbear/lisp/Primitives.java
   trunk/abcl/src/org/armedbear/lisp/Symbol.java
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp

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	Fri Oct  1 04:24:41 2010
@@ -199,6 +199,21 @@
         }
     };
 
+    // ### compiled-lisp-function-p
+    private static final Primitive COMPILED_LISP_FUNCTION_P =
+        new pf_compiled_lisp_function_p();
+    private static final class pf_compiled_lisp_function_p extends Primitive {
+        pf_compiled_lisp_function_p() {
+            super(Symbol.COMPILED_LISP_FUNCTION_P, "object");
+        }
+
+        @Override
+        public LispObject execute(LispObject arg) {
+            return (arg instanceof CompiledClosure
+                    || arg instanceof CompiledPrimitive) ? T : NIL;
+        }
+    }
+
     // ### consp
     private static final Primitive CONSP = new pf_consp();
     private static final class pf_consp extends Primitive {

Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Symbol.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Symbol.java	Fri Oct  1 04:24:41 2010
@@ -2986,6 +2986,8 @@
     PACKAGE_SYS.addExternalSymbol("CLASS-BYTES");
   public static final Symbol _CLASS_SLOTS =
     PACKAGE_SYS.addExternalSymbol("%CLASS-SLOTS");
+  public static final Symbol COMPILED_LISP_FUNCTION_P =
+    PACKAGE_SYS.addExternalSymbol("COMPILED-LISP-FUNCTION-P");
   public static final Symbol LAYOUT =
     PACKAGE_SYS.addExternalSymbol("LAYOUT");
   public static final Symbol NAMED_LAMBDA =

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	Fri Oct  1 04:24:41 2010
@@ -808,7 +808,7 @@
          (*code* ())
          (*current-code-attribute* code))
     (setf (code-max-locals code) 1)
-    (unless (eq super +lisp-primitive+)
+    (unless (eq super +lisp-compiled-primitive+)
       (multiple-value-bind
             (req opt key key-p rest
                  allow-other-keys-p)
@@ -876,7 +876,7 @@
                                       (list +lisp-symbol+ +lisp-symbol+
                                             +lisp-object+ +lisp-object+))))))
     (aload 0) ;; this
-    (cond ((eq super +lisp-primitive+)
+    (cond ((eq super +lisp-compiled-primitive+)
            (emit-constructor-lambda-name lambda-name)
            (emit-constructor-lambda-list args)
            (emit-invokespecial-init super (lisp-object-arg-types 2)))
@@ -7050,7 +7050,7 @@
           (if (or *hairy-arglist-p*
 		  (and *child-p* *closure-variables*))
 	      +lisp-compiled-closure+
-	    +lisp-primitive+))
+	    +lisp-compiled-primitive+))
 
     (setf (abcl-class-file-lambda-list class-file) args)
     (setf (code-max-locals code) *registers-allocated*)

Modified: trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp	Fri Oct  1 04:24:41 2010
@@ -167,6 +167,8 @@
 (define-class-name +lisp-return+ "org.armedbear.lisp.Return")
 (define-class-name +lisp-go+ "org.armedbear.lisp.Go")
 (define-class-name +lisp-primitive+ "org.armedbear.lisp.Primitive")
+(define-class-name +lisp-compiled-primitive+
+    "org.armedbear.lisp.CompiledPrimitive")
 (define-class-name +lisp-eql-hash-table+ "org.armedbear.lisp.EqlHashTable")
 (define-class-name +lisp-hash-table+ "org.armedbear.lisp.HashTable")
 (define-class-name +lisp-package+ "org.armedbear.lisp.Package")