Hi Alessio, Nice work!

On Mon, Jun 7, 2010 at 8:30 PM, Alessio Stalla astalla@common-lisp.net wrote:

Author: astalla Date: Mon Jun  7 14:30:36 2010 New Revision: 12742

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

Added:   trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java      - copied, changed from r12739, /branches/less-reflection/abcl/src/org/armedbear/lisp/FaslClassLoader.java Modified:   trunk/abcl/src/org/armedbear/lisp/Autoload.java   trunk/abcl/src/org/armedbear/lisp/Function.java   trunk/abcl/src/org/armedbear/lisp/Lisp.java   trunk/abcl/src/org/armedbear/lisp/Load.java   trunk/abcl/src/org/armedbear/lisp/compile-file.lisp   trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp   trunk/abcl/src/org/armedbear/lisp/disassemble.lisp   trunk/abcl/src/org/armedbear/lisp/gui.lisp   trunk/abcl/src/org/armedbear/lisp/load.lisp   trunk/abcl/src/org/armedbear/lisp/precompiler.lisp   trunk/abcl/src/org/armedbear/lisp/proclaim.lisp

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

--- trunk/abcl/src/org/armedbear/lisp/Autoload.java     (original) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java     Mon Jun  7 14:30:36 2010 @@ -97,7 +97,7 @@             symbol.setSymbolFunction(new Autoload(symbol, null,                                                   "org.armedbear.lisp.".concat(className)));     }

public void load()     {         if (className != null) { @@ -684,6 +684,9 @@

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");

Copied: trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java (from r12739, /branches/less-reflection/abcl/src/org/armedbear/lisp/FaslClassLoader.java)

--- /branches/less-reflection/abcl/src/org/armedbear/lisp/FaslClassLoader.java  (original) +++ trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java      Mon Jun  7 14:30:36 2010 @@ -70,7 +70,15 @@

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);

Maybe a code comment why this needs commenting out? Or maybe it was an unintended leftover?

• thread.bindSpecial(Symbol.LOAD_TRUENAME, NIL);
• return readFunctionBytes(pathname);
• } finally {
• thread.resetSpecialBindings(mark);
• }

}

public byte[] getFunctionClassBytes(Class<?> functionClass) {

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

--- trunk/abcl/src/org/armedbear/lisp/Function.java     (original) +++ trunk/abcl/src/org/armedbear/lisp/Function.java     Mon Jun  7 14:30:36 2010 @@ -175,23 +175,51 @@                             new JavaObject(bytes));     }

• 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));

}

@Override     public LispObject execute(LispObject arg)     {

• return error(new WrongNumberOfArgumentsException(this));

• return error(new WrongNumberOfArgumentsException(this, 1));

}

@Override     public LispObject execute(LispObject first, LispObject second)

{

• return error(new WrongNumberOfArgumentsException(this));

• return error(new WrongNumberOfArgumentsException(this, 2));

}

@Override @@ -199,7 +227,7 @@                               LispObject third)

{

• return error(new WrongNumberOfArgumentsException(this));

• return error(new WrongNumberOfArgumentsException(this, 3));

}

@Override @@ -207,7 +235,7 @@                               LispObject third, LispObject fourth)

{

• return error(new WrongNumberOfArgumentsException(this));

• return error(new WrongNumberOfArgumentsException(this, 4));

}

@Override @@ -216,7 +244,7 @@                               LispObject fifth)

{

• return error(new WrongNumberOfArgumentsException(this));

• return error(new WrongNumberOfArgumentsException(this, 5));

}

@Override @@ -225,7 +253,7 @@                               LispObject fifth, LispObject sixth)

{

• return error(new WrongNumberOfArgumentsException(this));

• return error(new WrongNumberOfArgumentsException(this, 6));

}

@Override @@ -235,7 +263,7 @@                               LispObject seventh)

{

• return error(new WrongNumberOfArgumentsException(this));

• return error(new WrongNumberOfArgumentsException(this, 7));

}

@Override @@ -245,7 +273,7 @@                               LispObject seventh, LispObject eighth)

{

• return error(new WrongNumberOfArgumentsException(this));

• return error(new WrongNumberOfArgumentsException(this, 8));

}

@Override

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 Jun  7 14:30:36 2010 @@ -43,8 +43,6 @@  import java.net.URL;  import java.net.URLDecoder;  import java.util.Hashtable; -import java.util.zip.ZipEntry; -import java.util.zip.ZipFile;

public final class Lisp  { @@ -1266,6 +1264,7 @@               url = Lisp.class.getResource(name.getNamestring());               input = url.openStream();           } catch (IOException e) {

• System.err.println("Failed to read class bytes from boot class " + url);

I understand this from a debugging point of view, but maybe we want to make sure ABCL doesn't crash hard if its unable to write to err, for whatever reason? (Like being in a Swing app without console stream bindings.)

error(new LispError("Failed to read class bytes from boot class " + url));           }       } @@ -2385,6 +2384,10 @@   public static final Symbol _LOAD_STREAM_ =     internSpecial("*LOAD-STREAM*", PACKAGE_SYS, NIL);

• // ### *fasl-loader*
• public static final Symbol _FASL_LOADER_ =
• exportSpecial("*FASL-LOADER*", PACKAGE_SYS, NIL);

// ### *source*   // internal symbol   public static final Symbol _SOURCE_ = @@ -2758,4 +2761,16 @@     Symbol.DEBUG_IO.initializeSpecial(new TwoWayStream(stdin, stdout, true));   }

• 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."));
• }
• }

}

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

--- trunk/abcl/src/org/armedbear/lisp/Load.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Load.java Mon Jun  7 14:30:36 2010 @@ -242,6 +242,7 @@         }     }

• private static final Symbol FASL_LOADER = PACKAGE_SYS.intern("*FASL-LOADER*");

static final LispObject COMPILE_FILE_INIT_FASL_TYPE = new SimpleString("_");

public static final LispObject loadSystemFile(final String filename, @@ -268,7 +269,7 @@             String path = pathname.asEntryPath();             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");                 } @@ -322,6 +323,7 @@             final LispThread thread = LispThread.currentThread();             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);                 return loadFileFromStream(pathname, truename, stream, @@ -567,7 +569,7 @@                                          thread, Stream.currentReadtable);                 if (obj == EOF)                     break;

• result = eval(obj, env, thread);

• result = eval(obj, env, thread);

if (print) {                     Stream out =                         checkCharacterOutputStream(Symbol.STANDARD_OUTPUT.symbolValue(thread));

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 Jun  7 14:30:36 2010 @@ -40,17 +40,33 @@

(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                                             *output-file-pathname*))   "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))  (defun next-classfile-name ()   (compute-classfile-name (incf *class-number*))) @@ -69,12 +85,14 @@

(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))  (defun process-defconstant (form) @@ -144,6 +162,7 @@                    (parse-body body)                  (let* ((expr `(lambda ,lambda-list                                  ,@decls (block ,block-name ,@body)))

• (saved-class-number *class-number*)

(classfile (next-classfile-name))                         (internal-compiler-errors nil)                         (result (with-open-file @@ -168,7 +187,8 @@                            compiled-function)                       (setf form                             `(fset ',name

• (proxy-preloaded-function ',name ,(file-namestring classfile))

• (sys::get-fasl-function *fasl-loader*
• ,saved-class-number)

,*source-position*                                    ',lambda-list                                    ,doc)) @@ -225,6 +245,7 @@            (let ((name (second form)))              (eval form)              (let* ((expr (function-lambda-expression (macro-function name)))

• (saved-class-number *class-number*)

(classfile (next-classfile-name)))               (with-open-file                   (f classfile @@ -241,14 +262,10 @@                          (if (special-operator-p name)                              `(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)))))))))           (DEFTYPE @@ -348,8 +365,12 @@   ;; to load the compiled functions. Note that this trickery   ;; 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))))

(declaim (ftype (function (t) t) convert-ensure-method)) @@ -366,7 +387,8 @@                (eq (%car function-form) 'FUNCTION))       (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                      (f classfile @@ -379,7 +401,8 @@            (declare (ignore result))             (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...                    (format *error-output* "; Unable to compile method~%"))))))))) @@ -412,6 +435,7 @@     (return-from convert-toplevel-form       (precompiler:precompile-form form nil *compile-file-environment*)))   (let* ((expr `(lambda () ,form))

• (saved-class-number *class-number*)

(classfile (next-classfile-name))          (result          (with-open-file @@ -425,7 +449,7 @@     (declare (ignore result))     (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*)))))

@@ -572,25 +596,22 @@               (write (list 'setq '*source* *compile-file-truename*)                      :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))

@@ -609,7 +630,11 @@                  (zipfile (namestring                            (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))))                 (when (probe-file pathname) @@ -632,6 +657,55 @@                   (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                                &allow-other-keys)   (setf input-file (truename input-file))

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

--- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp       (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp       Mon Jun  7 14:30:36 2010 @@ -1298,7 +1298,7 @@                      (format t ";   inlining call to local function ~S~%" op)))                  (return-from p1-function-call                   (let ((*inline-declarations*

• (remove op *inline-declarations* :key #'car)))

• (remove op *inline-declarations* :key #'car :test #'equal)))

(p1 expansion))))))

;; FIXME @@ -1432,7 +1432,8 @@                   (TRULY-THE            p1-truly-the)                   (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))))

(initialize-p1-handlers)

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       Mon Jun  7 14:30:36 2010 @@ -198,6 +198,8 @@   (u2 (if (< n 0) (1+ (logxor (- n) #xFFFF))           n)))

+(defconstant +fasl-loader-class+

• "org/armedbear/lisp/FaslClassLoader")

(defconstant +java-string+ "Ljava/lang/String;")  (defconstant +java-object+ "Ljava/lang/Object;")  (defconstant +lisp-class+ "org/armedbear/lisp/Lisp") @@ -2267,12 +2269,22 @@    local-function *declared-functions* ht g    (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*)      (setf (gethash local-function ht) g)))) @@ -5094,7 +5106,8 @@                            (local-function-function local-function)))))                (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+)           (emit-move-from-stack target)) @@ -7544,6 +7557,32 @@       ;; delay resolving the method to run-time; it's unavailable now       (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))))|#

Maybe this can use a comment on why it's commented out? Is this not a good idea? Does it depend on premises which are not (yet) met?

(defknown p2-char= (t t t) t)  (defun p2-char= (form target representation) @@ -8220,6 +8259,13 @@     (setf (method-handlers execute-method) (nreverse *handlers*)))   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)         (*closure-variables* nil) @@ -8512,6 +8558,7 @@   (install-p2-handler 'java:jclass         'p2-java-jclass)   (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)   (install-p2-handler 'coerce-to-function  'p2-coerce-to-function) @@ -8596,6 +8643,7 @@   (install-p2-handler 'vector-push-extend  'p2-vector-push-extend)   (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)

(initialize-p2-handlers)

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

--- trunk/abcl/src/org/armedbear/lisp/disassemble.lisp  (original) +++ trunk/abcl/src/org/armedbear/lisp/disassemble.lisp  Mon Jun  7 14:30:36 2010 @@ -47,14 +47,15 @@     (when (functionp function)       (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.~%"))))

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

--- trunk/abcl/src/org/armedbear/lisp/gui.lisp  (original) +++ trunk/abcl/src/org/armedbear/lisp/gui.lisp  Mon Jun  7 14:30:36 2010 @@ -1,5 +1,7 @@  (in-package :extensions)

+(require :java)

(defvar *gui-backend* :swing)

(defun init-gui ()

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

--- trunk/abcl/src/org/armedbear/lisp/load.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/load.lisp Mon Jun  7 14:30:36 2010 @@ -38,10 +38,11 @@              (if-does-not-exist t)              (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              &key @@ -50,7 +51,8 @@              (if-does-not-exist t)              (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))

\ No newline at end of file

• (let (*fasl-loader*)
• (%load-returning-last-result (if (streamp filespec)
• filespec
• (merge-pathnames (pathname filespec)))
• verbose print if-does-not-exist)))

\ No newline at end of file

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

--- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp  (original) +++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp  Mon Jun  7 14:30:36 2010 @@ -32,13 +32,10 @@  (in-package "SYSTEM")

-(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))  (defun process-optimization-declarations (forms)   (dolist (form forms) @@ -86,7 +83,7 @@  (declaim (ftype (function (t) t) inline-p))  (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)         (and (symbolp name) (eq (get name '%inline) 'INLINE))))) @@ -94,7 +91,7 @@  (declaim (ftype (function (t) t) notinline-p))  (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)         (and (symbolp name) (eq (get name '%inline) 'NOTINLINE))))) @@ -961,7 +958,8 @@                                                 (symbol-name symbol))                                   '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)))

(defun install-handlers () @@ -1024,7 +1022,9 @@                   (TRULY-THE            precompile-truly-the)

(THREADS:SYNCHRONIZED-ON

• precompile-threads-synchronized-on)))

• precompile-threads-synchronized-on)
• (JVM::WITH-INLINE-CODE precompile-identity)))

(install-handler (first pair) (second pair))))

(install-handlers)

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

--- trunk/abcl/src/org/armedbear/lisp/proclaim.lisp     (original) +++ trunk/abcl/src/org/armedbear/lisp/proclaim.lisp     Mon Jun  7 14:30:36 2010 @@ -31,7 +31,7 @@

(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)  `(eval-when (:compile-toplevel :load-toplevel :execute) @@ -43,6 +43,7 @@          :format-control "The symbol ~S cannot be both the name of a type and the name of a declaration."          :format-arguments (list name)))

+(defvar *inline-declarations* nil)  (defvar *declaration-types* (make-hash-table :test 'eq))

;; "A symbol cannot be both the name of a type and the name of a declaration. @@ -91,8 +92,9 @@      (apply 'proclaim-type (cdr declaration-specifier)))     ((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))        (when (or (get name 'deftype-definition)

Thanks again! I hope this helps us getting a common base for things happening in the FASL (such as constants and other stuff that we want to create/instantiate only once; not every function class by itself).

Bye,

Erik.