Changeset 12742

Timestamp:

06/07/10 18:30:36 (13 years ago)

Author:

astalla

Message:

less-reflection branch merged with trunk. verify-load temporarily disabled.

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• Autoload.java (modified) (2 diffs)
• FaslClassLoader.java (copied) (copied from branches/less-reflection/abcl/src/org/armedbear/lisp/FaslClassLoader.java) (1 diff)
• Function.java (modified) (9 diffs)
• Lisp.java (modified) (4 diffs)
• Load.java (modified) (4 diffs)
• compile-file.lisp (modified) (15 diffs)
• compiler-pass1.lisp (modified) (2 diffs)
• compiler-pass2.lisp (modified) (7 diffs)
• disassemble.lisp (modified) (1 diff)
• gui.lisp (modified) (1 diff)
• load.lisp (modified) (2 diffs)
• precompiler.lisp (modified) (5 diffs)
• proclaim.lisp (modified) (3 diffs)

trunk/abcl/src/org/armedbear/lisp/Autoload.java

@@ -98 +98 @@
                                                   "org.armedbear.lisp.".concat(className)));
     }
-
+    
     public void load()
     {
@@ -685 +685 @@
         autoload(Symbol.COPY_LIST, "copy_list");
 
+  autoload(PACKAGE_SYS, "make-fasl-class-loader", "FaslClassLoader", false);
+  autoload(PACKAGE_SYS, "get-fasl-function", "FaslClassLoader", false);
+
         autoload(Symbol.SET_CHAR, "StringFunctions");
         autoload(Symbol.SET_SCHAR, "StringFunctions");

trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java

@@ -71 +71 @@
     public byte[] getFunctionClassBytes(String name) {
   Pathname pathname = new Pathname(name.substring("org/armedbear/lisp/".length()) + ".cls");
-  return readFunctionBytes(pathname);
+  final LispThread thread = LispThread.currentThread();
+  SpecialBindingsMark mark = thread.markSpecialBindings();
+  try {
+      //thread.bindSpecial(Symbol.LOAD_TRUENAME_FASL, NIL);
+      thread.bindSpecial(Symbol.LOAD_TRUENAME, NIL);
+      return readFunctionBytes(pathname);
+  } finally {
+      thread.resetSpecialBindings(mark);
+  }
     }
     

trunk/abcl/src/org/armedbear/lisp/Function.java

@@ -176 +176 @@
     }
 
+    public final LispObject getClassBytes() {
+  LispObject o = getf(propertyList, Symbol.CLASS_BYTES, NIL);
+  if(o != NIL) {
+      return o;
+  } else {
+      ClassLoader c = getClass().getClassLoader();
+      if(c instanceof FaslClassLoader) {
+    return new JavaObject(((FaslClassLoader) c).getFunctionClassBytes(this));
+      } else {
+    return NIL;
+      }
+  }
+    }
+
+    public static final Primitive FUNCTION_CLASS_BYTES = new pf_function_class_bytes();
+    public static final class pf_function_class_bytes extends Primitive {
+  public pf_function_class_bytes() {
+      super("function-class-bytes", PACKAGE_SYS, false, "function");
+        }
+        @Override
+        public LispObject execute(LispObject arg) {
+            if (arg instanceof Function) {
+                return ((Function) arg).getClassBytes();
+      }
+            return type_error(arg, Symbol.FUNCTION);
+        }
+    }
+
     @Override
     public LispObject execute()
     {
-        return error(new WrongNumberOfArgumentsException(this));
+        return error(new WrongNumberOfArgumentsException(this, 0));
     }
 
@@ -185 +213 @@
     public LispObject execute(LispObject arg)
     {
-        return error(new WrongNumberOfArgumentsException(this));
+        return error(new WrongNumberOfArgumentsException(this, 1));
     }
 
@@ -192 +220 @@
 
     {
-        return error(new WrongNumberOfArgumentsException(this));
+        return error(new WrongNumberOfArgumentsException(this, 2));
     }
 
@@ -200 +228 @@
 
     {
-        return error(new WrongNumberOfArgumentsException(this));
+        return error(new WrongNumberOfArgumentsException(this, 3));
     }
 
@@ -208 +236 @@
 
     {
-        return error(new WrongNumberOfArgumentsException(this));
+        return error(new WrongNumberOfArgumentsException(this, 4));
     }
 
@@ -217 +245 @@
 
     {
-        return error(new WrongNumberOfArgumentsException(this));
+        return error(new WrongNumberOfArgumentsException(this, 5));
     }
 
@@ -226 +254 @@
 
     {
-        return error(new WrongNumberOfArgumentsException(this));
+        return error(new WrongNumberOfArgumentsException(this, 6));
     }
 
@@ -236 +264 @@
 
     {
-        return error(new WrongNumberOfArgumentsException(this));
+        return error(new WrongNumberOfArgumentsException(this, 7));
     }
 
@@ -246 +274 @@
 
     {
-        return error(new WrongNumberOfArgumentsException(this));
+        return error(new WrongNumberOfArgumentsException(this, 8));
     }
 

trunk/abcl/src/org/armedbear/lisp/Lisp.java

@@ -44 +44 @@
 import java.net.URLDecoder;
 import java.util.Hashtable;
-import java.util.zip.ZipEntry;
-import java.util.zip.ZipFile;
 
 public final class Lisp
@@ -1267 +1265 @@
               input = url.openStream();
           } catch (IOException e) {
+        System.err.println("Failed to read class bytes from boot class " + url);
               error(new LispError("Failed to read class bytes from boot class " + url));
           }
@@ -2386 +2385 @@
     internSpecial("*LOAD-STREAM*", PACKAGE_SYS, NIL);
 
+    // ### *fasl-loader*
+    public static final Symbol _FASL_LOADER_ =
+  exportSpecial("*FASL-LOADER*", PACKAGE_SYS, NIL);
+
   // ### *source*
   // internal symbol
@@ -2759 +2762 @@
   }
 
+  private static final SpecialOperator WITH_INLINE_CODE = new with_inline_code();
+  private static class with_inline_code extends SpecialOperator {
+    with_inline_code() {
+      super("with-inline-code", PACKAGE_JVM, true, "(&optional target repr) &body body");
+    }
+    @Override
+    public LispObject execute(LispObject args, Environment env)
+    {
+  return error(new SimpleError("This is a placeholder. It should only be called in compiled code, and tranformed by the compiler using special form handlers."));
+    }
+  }
+
 }

trunk/abcl/src/org/armedbear/lisp/Load.java

@@ -243 +243 @@
     }
 
+    private static final Symbol FASL_LOADER = PACKAGE_SYS.intern("*FASL-LOADER*");
     static final LispObject COMPILE_FILE_INIT_FASL_TYPE = new SimpleString("_");
 
@@ -269 +270 @@
             url = Lisp.class.getResource(path);
             if (url == null || url.toString().endsWith("/")) {
-                url = Lisp.class.getResource(path + ".abcl");
+                url = Lisp.class.getResource(path.replace('-', '_') + ".abcl");
                 if (url == null) {
                     url = Lisp.class.getResource(path + ".lisp");
@@ -323 +324 @@
             final SpecialBindingsMark mark = thread.markSpecialBindings();
             thread.bindSpecial(_WARN_ON_REDEFINITION_, NIL);
+      thread.bindSpecial(FASL_LOADER, NIL);
             try {
                 Stream stream = new Stream(Symbol.SYSTEM_STREAM, in, Symbol.CHARACTER);
@@ -568 +570 @@
                 if (obj == EOF)
                     break;
-                result = eval(obj, env, thread);
+    result = eval(obj, env, thread);
                 if (print) {
                     Stream out =

trunk/abcl/src/org/armedbear/lisp/compile-file.lisp

@@ -41 +41 @@
 (defvar *output-file-pathname*)
 
+(defun base-classname (&optional (output-file-pathname *output-file-pathname*))
+  (sanitize-class-name (pathname-name output-file-pathname)))
+
+(defun fasl-loader-classname (&optional (output-file-pathname *output-file-pathname*))
+  (%format nil "~A_0" (base-classname output-file-pathname)))
+
 (declaim (ftype (function (t) t) compute-classfile-name))
 (defun compute-classfile-name (n &optional (output-file-pathname
@@ -46 +52 @@
   "Computes the name of the class file associated with number `n'."
   (let ((name
-         (%format nil "~A-~D"
-                  (substitute #\_ #\.
-                              (pathname-name output-file-pathname)) n)))
+         (sanitize-class-name
+    (%format nil "~A_~D" (pathname-name output-file-pathname) n))))
     (namestring (merge-pathnames (make-pathname :name name :type "cls")
                                  output-file-pathname))))
+
+(defun sanitize-class-name (name)
+  (let ((name (copy-seq name)))
+    (dotimes (i (length name))
+      (declare (type fixnum i))
+      (when (or (char= (char name i) #\-)
+    (char= (char name i) #\.)
+    (char= (char name i) #\Space))
+        (setf (char name i) #\_)))
+    name))
+  
 
 (declaim (ftype (function () t) next-classfile-name))
@@ -70 +86 @@
 (declaim (ftype (function (t) t) verify-load))
 (defun verify-load (classfile)
-  (if (> *safety* 0)
-    (and classfile
+  #|(if (> *safety* 0) 
+      (and classfile
          (let ((*load-truename* *output-file-pathname*))
            (report-error
             (load-compiled-function classfile))))
-    t))
+    t)|#
+  (declare (ignore classfile))
+  t)
 
 (declaim (ftype (function (t) t) process-defconstant))
@@ -145 +163 @@
                  (let* ((expr `(lambda ,lambda-list
                                  ,@decls (block ,block-name ,@body)))
+      (saved-class-number *class-number*)
                         (classfile (next-classfile-name))
                         (internal-compiler-errors nil)
@@ -169 +188 @@
                       (setf form
                             `(fset ',name
-                                   (proxy-preloaded-function ',name ,(file-namestring classfile))
+           (sys::get-fasl-function *fasl-loader*
+                 ,saved-class-number)
                                    ,*source-position*
                                    ',lambda-list
@@ -226 +246 @@
              (eval form)
              (let* ((expr (function-lambda-expression (macro-function name)))
+        (saved-class-number *class-number*)
                     (classfile (next-classfile-name)))
          (with-open-file
@@ -242 +263 @@
                              `(put ',name 'macroexpand-macro
                                    (make-macro ',name
-                                               (proxy-preloaded-function
-                                                '(macro-function ,name)
-                                                ,(file-namestring classfile))))
+                 (sys::get-fasl-function *fasl-loader* ,saved-class-number)))
                              `(fset ',name
                                     (make-macro ',name
-                                                (proxy-preloaded-function
-                                                 '(macro-function ,name)
-                                                 ,(file-namestring classfile)))
+            (sys::get-fasl-function *fasl-loader* ,saved-class-number))
                                     ,*source-position*
                                     ',(third form)))))))))
@@ -349 +366 @@
   ;; was already used in verify-load before I used it,
   ;; however, binding *load-truename* isn't fully compliant, I think.
-  (let ((*load-truename* *output-file-pathname*))
-    (when compile-time-too
+  (when compile-time-too
+    (let ((*load-truename* *output-file-pathname*)
+    (*fasl-loader* (make-fasl-class-loader
+        *class-number*
+        (concatenate 'string "org.armedbear.lisp." (base-classname))
+        nil)))
       (eval form))))
 
@@ -367 +388 @@
       (let ((lambda-expression (cadr function-form)))
         (jvm::with-saved-compiler-policy
-          (let* ((classfile (next-classfile-name))
+          (let* ((saved-class-number *class-number*)
+     (classfile (next-classfile-name))
                  (result
       (with-open-file
@@ -380 +402 @@
             (cond (compiled-function
                    (setf (getf tail key)
-                         `(load-compiled-function ,(file-namestring classfile))))
+       `(sys::get-fasl-function *fasl-loader* ,saved-class-number)))
+;;                         `(load-compiled-function ,(file-namestring classfile))))
                   (t
                    ;; FIXME This should be a warning or error of some sort...
@@ -413 +436 @@
       (precompiler:precompile-form form nil *compile-file-environment*)))
   (let* ((expr `(lambda () ,form))
+   (saved-class-number *class-number*)
          (classfile (next-classfile-name))
          (result
@@ -426 +450 @@
     (setf form
           (if compiled-function
-              `(funcall (load-compiled-function ,(file-namestring classfile)))
+              `(funcall (sys::get-fasl-function *fasl-loader* ,saved-class-number))
               (precompiler:precompile-form form nil *compile-file-environment*)))))
 
@@ -573 +597 @@
                      :stream out)
               (%stream-terpri out)
-              ;; Note: Beyond this point, you can't use DUMP-FORM,
-              ;; because the list of uninterned symbols has been fixed now.
-              (when *fasl-uninterned-symbols*
-                (write (list 'setq '*fasl-uninterned-symbols*
-                             (coerce (mapcar #'car
-                                             (nreverse *fasl-uninterned-symbols*))
-                                     'vector))
-                       :stream out))
-              (%stream-terpri out)
-              ;; we work with a fixed variable name here to work around the
-              ;; lack of availability of the circle reader in the fasl reader
-              ;; but it's a toplevel form anyway
-              (write `(dotimes (i ,*class-number*)
-                        (function-preload
-                         (%format nil "~A-~D.cls"
-                                  ,(substitute #\_ #\. (pathname-name output-file))
-                                  (1+ i))))
-                     :stream out
-                     :circle t)
+        ;; Note: Beyond this point, you can't use DUMP-FORM,
+        ;; because the list of uninterned symbols has been fixed now.
+        (when *fasl-uninterned-symbols*
+    (write (list 'setq '*fasl-uninterned-symbols*
+           (coerce (mapcar #'car
+               (nreverse *fasl-uninterned-symbols*))
+             'vector))
+           :stream out))
+        (%stream-terpri out)
+
+        (when (> *class-number* 0)
+    (generate-loader-function)
+    (write (list 'setq '*fasl-loader*
+           `(sys::make-fasl-class-loader
+             ,*class-number*
+             ,(concatenate 'string "org.armedbear.lisp." (base-classname)))) :stream out))
               (%stream-terpri out))
 
@@ -610 +631 @@
                            (merge-pathnames (make-pathname :type type)
                                             output-file)))
-                 (pathnames ()))
+                 (pathnames nil)
+     (fasl-loader (namestring (merge-pathnames (make-pathname :name (fasl-loader-classname) :type "cls")
+                 output-file))))
+      (when (probe-file fasl-loader)
+        (push fasl-loader pathnames))
             (dotimes (i *class-number*)
               (let* ((pathname (compute-classfile-name (1+ i))))
@@ -632 +657 @@
                   (namestring output-file) elapsed))))
     (values (truename output-file) warnings-p failure-p)))
+
+(defmacro ncase (expr min max &rest clauses)
+  "A CASE where all test clauses are numbers ranging from a minimum to a maximum."
+  ;;Expr is subject to multiple evaluation, but since we only use ncase for
+  ;;fn-index below, let's ignore it.
+  (let* ((half (floor (/ (- max min) 2)))
+   (middle (+ min half)))
+    (if (> (- max min) 10)
+  `(if (< ,expr ,middle)
+       (ncase ,expr ,min ,middle ,@(subseq clauses 0 half))
+       (ncase ,expr ,middle ,max ,@(subseq clauses half)))
+  `(case ,expr ,@clauses))))
+
+(defun generate-loader-function ()
+  (let* ((basename (base-classname))
+   (expr `(lambda (fasl-loader fn-index)
+      (identity fasl-loader) ;;to avoid unused arg
+      (ncase fn-index 0 ,(1- *class-number*)
+        ,@(loop
+       :for i :from 1 :to *class-number*
+       :collect
+       (let ((class (%format nil "org/armedbear/lisp/~A_~A" basename i)))
+         `(,(1- i)
+            (jvm::with-inline-code ()
+        (jvm::emit 'jvm::aload 1)
+        (jvm::emit-invokevirtual jvm::+lisp-object-class+ "javaInstance"
+               nil jvm::+java-object+)
+        (jvm::emit 'jvm::checkcast "org/armedbear/lisp/FaslClassLoader")
+        (jvm::emit 'jvm::dup)
+        (jvm::emit-push-constant-int ,(1- i))
+        (jvm::emit 'jvm::new ,class)
+        (jvm::emit 'jvm::dup)
+        (jvm::emit-invokespecial-init ,class '())
+        (jvm::emit-invokevirtual "org/armedbear/lisp/FaslClassLoader" "putFunction"
+               (list "I" jvm::+lisp-object+) jvm::+lisp-object+)
+        (jvm::emit 'jvm::pop))
+            t))))))
+   (classname (fasl-loader-classname))
+   (classfile (namestring (merge-pathnames (make-pathname :name classname :type "cls")
+             *output-file-pathname*))))
+    (jvm::with-saved-compiler-policy
+  (jvm::with-file-compilation
+      (with-open-file
+    (f classfile
+       :direction :output
+       :element-type '(unsigned-byte 8)
+       :if-exists :supersede)
+        (jvm:compile-defun nil expr nil
+         classfile f nil))))))
 
 (defun compile-file-if-needed (input-file &rest allargs &key force-compile

trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp

@@ -1299 +1299 @@
                  (return-from p1-function-call
        (let ((*inline-declarations*
-        (remove op *inline-declarations* :key #'car)))
+        (remove op *inline-declarations* :key #'car :test #'equal)))
          (p1 expansion))))))
 
@@ -1433 +1433 @@
                   (UNWIND-PROTECT       p1-unwind-protect)
                   (THREADS:SYNCHRONIZED-ON
-                                        p1-threads-synchronized-on)))
+                                        p1-threads-synchronized-on)
+      (JVM::WITH-INLINE-CODE identity)))
     (install-p1-handler (%car pair) (%cadr pair))))
 

trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

@@ -199 +199 @@
           n)))
 
+(defconstant +fasl-loader-class+
+  "org/armedbear/lisp/FaslClassLoader")
 (defconstant +java-string+ "Ljava/lang/String;")
 (defconstant +java-object+ "Ljava/lang/Object;")
@@ -2268 +2270 @@
    (setf g (symbol-name (gensym "LFUN")))
    (let* ((pathname (abcl-class-file-pathname (local-function-class-file local-function)))
+    (class-name (concatenate 'string "org/armedbear/lisp/" (pathname-name pathname)))
     (*code* *static-code*))
      ;; fixme *declare-inline*
-     (declare-field g +lisp-object+ +field-access-default+)
-     (emit 'ldc (pool-string (file-namestring pathname)))
-     (emit-invokestatic +lisp-function-proxy-class+ "loadPreloadedFunction"
-      (list +java-string+) +lisp-object+)
+     (declare-field g +lisp-object+ +field-access-private+)
+     (emit 'new class-name)
+     (emit 'dup)
+     (emit-invokespecial-init class-name '())
+
+     ;(emit 'ldc (pool-string (pathname-name pathname)))
+     ;(emit-invokestatic +fasl-loader-class+ "faslLoadFunction"
+     ;(list +java-string+) +lisp-object+)
+
+;     (emit 'ldc (pool-string (file-namestring pathname)))
+     
+;     (emit-invokestatic +lisp-function-proxy-class+ "loadPreloadedFunction"
+;     (list +java-string+) +lisp-object+)
      (emit 'putstatic *this-class* g +lisp-object+)
      (setf *static-code* *code*)
@@ -5095 +5107 @@
                (emit 'getstatic *this-class*
                      g +lisp-object+))))) ; Stack: template-function
-         ((member name *functions-defined-in-current-file* :test #'equal)
+         ((and (member name *functions-defined-in-current-file* :test #'equal)
+         (not (notinline-p name)))
           (emit 'getstatic *this-class*
                 (declare-setf-function name) +lisp-object+)
@@ -7545 +7558 @@
       (compile-function-call form target representation))))
 
+#|(defknown p2-java-jcall (t t t) t)
+(define-inlined-function p2-java-jcall (form target representation)
+  ((and (> *speed* *safety*)
+  (< 1 (length form))
+  (eq 'jmethod (car (cadr form)))
+  (every #'stringp (cdr (cadr form)))))
+  (let ((m (ignore-errors (eval (cadr form)))))
+    (if m 
+  (let ((must-clear-values nil)
+        (arg-types (raw-arg-types (jmethod-params m))))
+    (declare (type boolean must-clear-values))
+    (dolist (arg (cddr form))
+      (compile-form arg 'stack nil)
+      (unless must-clear-values
+        (unless (single-valued-p arg)
+    (setf must-clear-values t))))
+    (when must-clear-values
+      (emit-clear-values))
+    (dotimes (i (jarray-length raw-arg-types))
+      (push (jarray-ref raw-arg-types i) arg-types))
+    (emit-invokevirtual (jclass-name (jmethod-declaring-class m))
+            (jmethod-name m)
+            (nreverse arg-types)
+            (jmethod-return-type m)))
+      ;; delay resolving the method to run-time; it's unavailable now
+      (compile-function-call form target representation))))|#
 
 (defknown p2-char= (t t t) t)
@@ -8221 +8260 @@
   t)
 
+(defun p2-with-inline-code (form target representation)
+  ;;form = (with-inline-code (&optional target-var repr-var) ...body...)
+  (destructuring-bind (&optional target-var repr-var) (cadr form)
+    (eval `(let (,@(when target-var `((,target-var ,target)))
+     ,@(when repr-var `((,repr-var ,representation))))
+       ,@(cddr form)))))
+
 (defun compile-1 (compiland stream)
   (let ((*all-variables* nil)
@@ -8513 +8559 @@
   (install-p2-handler 'java:jconstructor   'p2-java-jconstructor)
   (install-p2-handler 'java:jmethod        'p2-java-jmethod)
+;  (install-p2-handler 'java:jcall          'p2-java-jcall)
   (install-p2-handler 'char=               'p2-char=)
   (install-p2-handler 'characterp          'p2-characterp)
@@ -8597 +8644 @@
   (install-p2-handler 'write-8-bits        'p2-write-8-bits)
   (install-p2-handler 'zerop               'p2-zerop)
+  (install-p2-handler 'with-inline-code    'p2-with-inline-code)
   t)
 

trunk/abcl/src/org/armedbear/lisp/disassemble.lisp

@@ -48 +48 @@
       (unless (compiled-function-p function)
         (setf function (compile nil function)))
-      (when (getf (function-plist function) 'class-bytes)
-        (with-input-from-string
-          (stream (disassemble-class-bytes (getf (function-plist function) 'class-bytes)))
-          (loop
-            (let ((line (read-line stream nil)))
-              (unless line (return))
-              (write-string "; ")
-              (write-string line)
-              (terpri))))
-        (return-from disassemble)))
-    (%format t "; Disassembly is not available.~%")))
+      (let ((class-bytes (function-class-bytes function)))
+  (when class-bytes
+    (with-input-from-string
+        (stream (disassemble-class-bytes class-bytes))
+      (loop
+         (let ((line (read-line stream nil)))
+     (unless line (return))
+     (write-string "; ")
+     (write-string line)
+     (terpri))))
+    (return-from disassemble)))
+      (%format t "; Disassembly is not available.~%"))))

trunk/abcl/src/org/armedbear/lisp/gui.lisp

@@ -1 +1 @@
 (in-package :extensions)
+
+(require :java)
 
 (defvar *gui-backend* :swing)

trunk/abcl/src/org/armedbear/lisp/load.lisp

@@ -39 +39 @@
              (external-format :default))
   (declare (ignore external-format)) ; FIXME
-  (%load (if (streamp filespec)
-             filespec
-             (merge-pathnames (pathname filespec)))
-         verbose print if-does-not-exist))
+  (let (*fasl-loader*)
+    (%load (if (streamp filespec)
+         filespec
+         (merge-pathnames (pathname filespec)))
+     verbose print if-does-not-exist)))
 
 (defun load-returning-last-result (filespec
@@ -51 +52 @@
              (external-format :default))
   (declare (ignore external-format)) ; FIXME
-  (%load-returning-last-result (if (streamp filespec)
-             filespec
-             (merge-pathnames (pathname filespec)))
-         verbose print if-does-not-exist))
+  (let (*fasl-loader*)
+    (%load-returning-last-result (if (streamp filespec)
+             filespec
+             (merge-pathnames (pathname filespec)))
+         verbose print if-does-not-exist)))

trunk/abcl/src/org/armedbear/lisp/precompiler.lisp

@@ -33 +33 @@
 
 
-(export '(*inline-declarations*
-          process-optimization-declarations
+(export '(process-optimization-declarations
           inline-p notinline-p inline-expansion expand-inline
           *defined-functions* *undefined-functions* note-name-defined))
-
-(defvar *inline-declarations* nil)
 
 (declaim (ftype (function (t) t) process-optimization-declarations))
@@ -87 +84 @@
 (defun inline-p (name)
   (declare (optimize speed))
-  (let ((entry (assoc name *inline-declarations*)))
+  (let ((entry (assoc name *inline-declarations* :test #'equal)))
     (if entry
         (eq (cdr entry) 'INLINE)
@@ -95 +92 @@
 (defun notinline-p (name)
   (declare (optimize speed))
-  (let ((entry (assoc name *inline-declarations*)))
+  (let ((entry (assoc name *inline-declarations* :test #'equal)))
     (if entry
         (eq (cdr entry) 'NOTINLINE)
@@ -962 +959 @@
                                   'precompiler))))
     (unless (and handler (fboundp handler))
-      (error "No handler for ~S." symbol))
+      (error "No handler for ~S." (let ((*package* (find-package :keyword)))
+            (format nil "~S" symbol))))
     (setf (get symbol 'precompile-handler) handler)))
 
@@ -1025 +1023 @@
 
                   (THREADS:SYNCHRONIZED-ON
-                                        precompile-threads-synchronized-on)))
+                                        precompile-threads-synchronized-on)
+      
+      (JVM::WITH-INLINE-CODE precompile-identity)))
     (install-handler (first pair) (second pair))))
 

trunk/abcl/src/org/armedbear/lisp/proclaim.lisp

@@ -32 +32 @@
 (in-package #:system)
 
-(export '(check-declaration-type proclaimed-type proclaimed-ftype ftype-result-type))
+(export '(check-declaration-type proclaimed-type proclaimed-ftype ftype-result-type *inline-declarations*))
 
 (defmacro declaim (&rest decls)
@@ -44 +44 @@
          :format-arguments (list name)))
 
+(defvar *inline-declarations* nil)
 (defvar *declaration-types* (make-hash-table :test 'eq))
 
@@ -92 +93 @@
     ((INLINE NOTINLINE)
      (dolist (name (cdr declaration-specifier))
-       (when (symbolp name) ; FIXME Need to support non-symbol function names.
-         (setf (get name '%inline) (car declaration-specifier)))))
+       (if (symbolp name)
+         (setf (get name '%inline) (car declaration-specifier))
+   (push (cons name (car declaration-specifier)) *inline-declarations*))))
     (DECLARATION
      (dolist (name (cdr declaration-specifier))