[armedbear-cvs] r12742 - trunk/abcl/src/org/armedbear/lisp
Alessio Stalla
astalla at common-lisp.net
Mon Jun 7 18:30:40 UTC 2010
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);
+ 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);
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
, at decls (block ,block-name , at 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 , at 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))))|#
(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)
More information about the armedbear-cvs
mailing list