From ehuelsmann at common-lisp.net Thu Sep 9 20:56:24 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 09 Sep 2010 16:56:24 -0400 Subject: [armedbear-cvs] r12910 - in tags: 0.00.10 0.00.11 0.00.3 0.00.4 0.00.5 0.00.5.1 0.00.6 0.00.7 0.00.8 0.00.9 0.00.9.1 abcl-0-0-10 abcl-0-0-11 abcl-0-0-4 abcl-0-0-5 abcl-0-0-5-1 abcl-0-0-6 abcl-0-0-7 abcl-0-0-8 abcl-0-0-9 abcl-0-0-9-1 abl-0-0-3 Message-ID: Author: ehuelsmann Date: Thu Sep 9 16:56:21 2010 New Revision: 12910 Log: Rename old CVS tags to our new naming scheme in Subversion. Added: tags/0.00.10/ - copied from r12909, /tags/abcl-0-0-10/ tags/0.00.11/ - copied from r12909, /tags/abcl-0-0-11/ tags/0.00.3/ - copied from r12909, /tags/abl-0-0-3/ tags/0.00.4/ - copied from r12909, /tags/abcl-0-0-4/ tags/0.00.5/ - copied from r12909, /tags/abcl-0-0-5/ tags/0.00.5.1/ - copied from r12909, /tags/abcl-0-0-5-1/ tags/0.00.6/ - copied from r12909, /tags/abcl-0-0-6/ tags/0.00.7/ - copied from r12909, /tags/abcl-0-0-7/ tags/0.00.8/ - copied from r12909, /tags/abcl-0-0-8/ tags/0.00.9/ - copied from r12909, /tags/abcl-0-0-9/ tags/0.00.9.1/ - copied from r12909, /tags/abcl-0-0-9-1/ Removed: tags/abcl-0-0-10/ tags/abcl-0-0-11/ tags/abcl-0-0-4/ tags/abcl-0-0-5/ tags/abcl-0-0-5-1/ tags/abcl-0-0-6/ tags/abcl-0-0-7/ tags/abcl-0-0-8/ tags/abcl-0-0-9/ tags/abcl-0-0-9-1/ tags/abl-0-0-3/ From ehuelsmann at common-lisp.net Thu Sep 9 20:57:35 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 09 Sep 2010 16:57:35 -0400 Subject: [armedbear-cvs] r12911 - in tags: j-0-17-1 j-0-17-2 j-0-18-0 j-0-18-1 j-0-19-0 j-0-20-0 j-0-20-1 j-0-20-2 j-0-21-0 j-0-21-0-4 j-0-21-0-5 start Message-ID: Author: ehuelsmann Date: Thu Sep 9 16:57:34 2010 New Revision: 12911 Log: Delete non-ABCL tags (J and CVS import ones). Removed: tags/j-0-17-1/ tags/j-0-17-2/ tags/j-0-18-0/ tags/j-0-18-1/ tags/j-0-19-0/ tags/j-0-20-0/ tags/j-0-20-1/ tags/j-0-20-2/ tags/j-0-21-0/ tags/j-0-21-0-4/ tags/j-0-21-0-5/ tags/start/ From ehuelsmann at common-lisp.net Fri Sep 24 07:15:54 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 24 Sep 2010 03:15:54 -0400 Subject: [armedbear-cvs] r12912 - trunk/abcl Message-ID: Author: ehuelsmann Date: Fri Sep 24 03:15:51 2010 New Revision: 12912 Log: Update CHANGES for the upcoming release. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Fri Sep 24 03:15:51 2010 @@ -1,13 +1,25 @@ Version 0.22 ============ unreleased -(??, 2010) +(September 24, 2010) Fixes ----- * [svn r12902] Fix reading data with scandinavian latin1 characters +* [svn r12906] Respect the CLASSPATH environment variable in the + abcl wrapper scripts + +* [ticket #103] DOCUMENTATION not autoloaded + +Other +----- + +* [svn r12819] Until-0.22-compatibility hacks (in threads support) removed + + + Version 0.21 ============ svn://common-lisp.net/project/armedbear/svn/tags/0.21.0/abcl @@ -19,15 +31,19 @@ * [svn r12818] Update to ASDF 2.004 -* [svn r12738-805] Support for custom CLOS slot definitions and custom class options. +* [svn r12738-805] Support for custom CLOS slot definitions and + custom class options. * [svn r12756] slot-* functions work on structures too. -* [svn r12774] Improved Java integration: jmake-proxy can implement more than one interface. +* [svn r12774] Improved Java integration: jmake-proxy can implement + more than one interface. -* [svn r12773] Improved Java integration: functions to dynamically manipulate the classpath. +* [svn r12773] Improved Java integration: functions to dynamically + manipulate the classpath. -* [svn r12755] Improved Java integration: CL:STRING can convert Java strings to Lisp strings. +* [svn r12755] Improved Java integration: CL:STRING can convert Java + strings to Lisp strings. Fixes ----- @@ -36,16 +52,20 @@ * [svn 12804] Fixed elimination of unused local functions shadowed by macrolet. -* [svn r12798-803] Fixed pathname serialization across OSes. On Windows pathnames are always printed with forward slashes, but can still be read with backslashes. +* [svn r12798-803] Fixed pathname serialization across OSes. + On Windows pathnames are always printed with forward slashes, + but can still be read with backslashes. * [svn r12740] Make JSR-223 classes compilable with Java 1.5 Other ----- -* [svn r12754] Changed class file generation and FASL loading to minimize reflection. +* [svn r12754] Changed class file generation and FASL loading + to minimize reflection. -* [svn r12734] A minimal Swing GUI Console with a REPL is now included with ABCL. +* [svn r12734] A minimal Swing GUI Console with a REPL + is now included with ABCL. Version 0.20 ============ From ehuelsmann at common-lisp.net Fri Sep 24 07:16:44 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 24 Sep 2010 03:16:44 -0400 Subject: [armedbear-cvs] r12913 - trunk/abcl Message-ID: Author: ehuelsmann Date: Fri Sep 24 03:16:43 2010 New Revision: 12913 Log: Add the URL to be used. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Fri Sep 24 03:16:43 2010 @@ -1,6 +1,6 @@ Version 0.22 ============ -unreleased +svn://common-lisp.net/project/armedbear/svn/tags/0.22.0/abcl (September 24, 2010) Fixes From ehuelsmann at common-lisp.net Fri Sep 24 07:18:00 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 24 Sep 2010 03:18:00 -0400 Subject: [armedbear-cvs] r12914 - branches/0.22.x Message-ID: Author: ehuelsmann Date: Fri Sep 24 03:17:59 2010 New Revision: 12914 Log: Create 0.22 maintenance branch. Added: branches/0.22.x/ - copied from r12913, /trunk/ From ehuelsmann at common-lisp.net Fri Sep 24 07:19:14 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 24 Sep 2010 03:19:14 -0400 Subject: [armedbear-cvs] r12915 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Sep 24 03:19:13 2010 New Revision: 12915 Log: With 0.22 branched, update the version number of trunk. Modified: trunk/abcl/src/org/armedbear/lisp/Version.java Modified: trunk/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Version.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Version.java Fri Sep 24 03:19:13 2010 @@ -41,7 +41,7 @@ public static String getVersion() { - return "0.22.0-dev"; + return "0.23.0-dev"; } public static void main(String args[]) { From ehuelsmann at common-lisp.net Fri Sep 24 07:29:58 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 24 Sep 2010 03:29:58 -0400 Subject: [armedbear-cvs] r12916 - in tags/0.22.0: . abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Sep 24 03:29:57 2010 New Revision: 12916 Log: Tag 0.22. Added: tags/0.22.0/ - copied from r12915, /branches/0.22.x/ Modified: tags/0.22.0/abcl/src/org/armedbear/lisp/Version.java Modified: tags/0.22.0/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- /branches/0.22.x/abcl/src/org/armedbear/lisp/Version.java (original) +++ tags/0.22.0/abcl/src/org/armedbear/lisp/Version.java Fri Sep 24 03:29:57 2010 @@ -41,7 +41,7 @@ public static String getVersion() { - return "0.22.0-dev"; + return "0.22.0"; } public static void main(String args[]) { From ehuelsmann at common-lisp.net Fri Sep 24 07:51:44 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 24 Sep 2010 03:51:44 -0400 Subject: [armedbear-cvs] r12917 - public_html Message-ID: Author: ehuelsmann Date: Fri Sep 24 03:51:42 2010 New Revision: 12917 Log: Properties fix-up. Modified: public_html/release-notes-0.17.shtml (contents, props changed) public_html/release-notes-0.18.shtml (contents, props changed) public_html/release-notes-0.19.shtml (contents, props changed) public_html/release-notes-0.20.shtml (contents, props changed) public_html/release-notes-0.21.shtml (contents, props changed) Modified: public_html/release-notes-0.17.shtml ============================================================================== --- public_html/release-notes-0.17.shtml (original) +++ public_html/release-notes-0.17.shtml Fri Sep 24 03:51:42 2010 @@ -62,7 +62,7 @@
Valid XHTML 1.0 Strict
-
$Id: release-notes-0.16.shtml 12246 2009-11-04 22:00:47Z ehuelsmann $
+
$Id$
Modified: public_html/release-notes-0.18.shtml ============================================================================== --- public_html/release-notes-0.18.shtml (original) +++ public_html/release-notes-0.18.shtml Fri Sep 24 03:51:42 2010 @@ -64,7 +64,7 @@
Valid XHTML 1.0 Strict
-
$Id: release-notes-0.16.shtml 12246 2009-11-04 22:00:47Z ehuelsmann $
+
$Id$
Modified: public_html/release-notes-0.19.shtml ============================================================================== --- public_html/release-notes-0.19.shtml (original) +++ public_html/release-notes-0.19.shtml Fri Sep 24 03:51:42 2010 @@ -51,7 +51,7 @@
Valid XHTML 1.0 Strict
-
$Id: release-notes-0.16.shtml 12246 2009-11-04 22:00:47Z ehuelsmann $
+
$Id$
Modified: public_html/release-notes-0.20.shtml ============================================================================== --- public_html/release-notes-0.20.shtml (original) +++ public_html/release-notes-0.20.shtml Fri Sep 24 03:51:42 2010 @@ -46,7 +46,7 @@
Valid XHTML 1.0 Strict
-
$Id: release-notes-0.16.shtml 12246 2009-11-04 22:00:47Z ehuelsmann $
+
$Id$
Modified: public_html/release-notes-0.21.shtml ============================================================================== --- public_html/release-notes-0.21.shtml (original) +++ public_html/release-notes-0.21.shtml Fri Sep 24 03:51:42 2010 @@ -45,7 +45,7 @@
Valid XHTML 1.0 Strict
-
$Id: release-notes-0.16.shtml 12246 2009-11-04 22:00:47Z ehuelsmann $
+
$Id$
From astalla at common-lisp.net Fri Sep 24 22:35:06 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Fri, 24 Sep 2010 18:35:06 -0400 Subject: [armedbear-cvs] r12918 - in trunk/abcl: . src/org/armedbear/lisp test/lisp/abcl test/lisp/ansi Message-ID: Author: astalla Date: Fri Sep 24 18:35:02 2010 New Revision: 12918 Log: generic-class-file branch merged. Added: trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp - copied unchanged from r12917, /branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-class-file.lisp trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp - copied unchanged from r12917, /branches/generic-class-file/abcl/src/org/armedbear/lisp/jvm-instructions.lisp trunk/abcl/test/lisp/abcl/class-file.lisp - copied unchanged from r12917, /branches/generic-class-file/abcl/test/lisp/abcl/class-file.lisp Removed: trunk/abcl/src/org/armedbear/lisp/opcodes.lisp Modified: trunk/abcl/abcl.asd trunk/abcl/src/org/armedbear/lisp/compile-file.lisp trunk/abcl/src/org/armedbear/lisp/compile-system.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp trunk/abcl/src/org/armedbear/lisp/known-symbols.lisp trunk/abcl/test/lisp/ansi/parse-ansi-errors.lisp Modified: trunk/abcl/abcl.asd ============================================================================== --- trunk/abcl/abcl.asd (original) +++ trunk/abcl/abcl.asd Fri Sep 24 18:35:02 2010 @@ -32,6 +32,7 @@ :pathname "test/lisp/abcl/" :components ((:file "compiler-tests") (:file "condition-tests") + (:file "class-file") (:file "metaclass") #+abcl (:file "mop-tests-setup") 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 Fri Sep 24 18:35:02 2010 @@ -672,6 +672,9 @@ (ncase ,expr ,middle ,max ,@(subseq clauses half))) `(case ,expr , at clauses)))) +(defconstant +fasl-classloader+ + (jvm::make-class-name "org.armedbear.lisp.FaslClassLoader")) + (defun generate-loader-function () (let* ((basename (base-classname)) (expr `(lambda (fasl-loader fn-index) @@ -680,20 +683,23 @@ ,@(loop :for i :from 1 :to *class-number* :collect - (let ((class (%format nil "org/armedbear/lisp/~A_~A" basename i))) + (let* ((class (%format nil "org/armedbear/lisp/~A_~A" + basename i)) + (class-name (jvm::make-class-name class))) `(,(1- i) (jvm::with-inline-code () (jvm::emit 'jvm::aload 1) - (jvm::emit-invokevirtual jvm::+lisp-object-class+ "javaInstance" + (jvm::emit-invokevirtual jvm::+lisp-object+ "javaInstance" nil jvm::+java-object+) - (jvm::emit 'jvm::checkcast "org/armedbear/lisp/FaslClassLoader") + (jvm::emit-checkcast +fasl-classloader+) (jvm::emit 'jvm::dup) (jvm::emit-push-constant-int ,(1- i)) - (jvm::emit 'jvm::new ,class) + (jvm::emit-new ,class-name) (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-invokespecial-init ,class-name '()) + (jvm::emit-invokevirtual +fasl-classloader+ + "putFunction" + (list :int jvm::+lisp-object+) jvm::+lisp-object+) (jvm::emit 'jvm::pop)) t)))))) (classname (fasl-loader-classname)) Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-system.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Fri Sep 24 18:35:02 2010 @@ -97,10 +97,11 @@ (load (do-compile "precompiler.lisp")) (load (do-compile "compiler-pass1.lisp")) (load (do-compile "compiler-pass2.lisp")) + (load (do-compile "jvm-class-file.lisp")) (load (do-compile "jvm.lisp")) (load (do-compile "source-transform.lisp")) (load (do-compile "compiler-macro.lisp")) - (load (do-compile "opcodes.lisp")) + (load (do-compile "jvm-instructions.lisp")) (load (do-compile "setf.lisp")) (load (do-compile "extensible-sequences-base.lisp")) (load (do-compile "require.lisp")) 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 Sep 24 18:35:02 2010 @@ -41,318 +41,64 @@ (require "KNOWN-FUNCTIONS") (require "KNOWN-SYMBOLS") (require "DUMP-FORM") - (require "OPCODES") + (require "JVM-INSTRUCTIONS") (require "JAVA")) -(defun dump-pool () - (let ((pool (reverse *pool*)) - entry type) - (dotimes (index (1- *pool-count*)) - (setq entry (car pool)) - (setq type (case (car entry) - (7 'class) - (9 'field) - (10 'method) - (11 'interface) - (8 'string) - (3 'integer) - (4 'float) - (5 'long) - (6 'double) - (12 'name-and-type) - (1 'utf8))) - (format t "~D: ~A ~S~%" (1+ index) type entry) - (setq pool (cdr pool)))) - t) - -(defknown pool-get (t) (integer 1 65535)) -(defun pool-get (entry) - (declare (optimize speed (safety 0))) - (let* ((ht *pool-entries*) - (index (gethash1 entry ht))) - (declare (type hash-table ht)) - (unless index - (setf index *pool-count*) - (push entry *pool*) - (setf (gethash entry ht) index) - (setf *pool-count* (1+ index))) - index)) +(declaim (inline pool-name pool-string pool-name-and-type + pool-class pool-field pool-method pool-int + pool-float pool-long pool-double)) -(declaim (ftype (function (string) fixnum) pool-name)) -(declaim (inline pool-name)) (defun pool-name (name) - (declare (optimize speed)) - (pool-get (list 1 (length name) name))) + (pool-add-utf8 *pool* name)) -(declaim (ftype (function (string string) fixnum) pool-name-and-type)) -(declaim (inline pool-name-and-type)) (defun pool-name-and-type (name type) - (declare (optimize speed)) - (pool-get (list 12 - (pool-name name) - (pool-name type)))) - -;; Assumes CLASS-NAME is already in the correct form ("org/armedbear/lisp/Lisp" -;; as opposed to "org.armedbear.lisp.Lisp"). -(declaim (ftype (function (string) fixnum) pool-class)) -(declaim (inline pool-class)) -(defun pool-class (class-name) - (declare (optimize speed)) - (pool-get (list 7 (pool-name class-name)))) + (pool-add-name/type *pool* name type)) -;; (tag class-index name-and-type-index) -(declaim (ftype (function (string string string) fixnum) pool-field)) -(declaim (inline pool-field)) -(defun pool-field (class-name field-name type-name) - (declare (optimize speed)) - (pool-get (list 9 - (pool-class class-name) - (pool-name-and-type field-name type-name)))) - -;; (tag class-index name-and-type-index) -(declaim (ftype (function (string string string) fixnum) pool-method)) -(declaim (inline pool-method)) -(defun pool-method (class-name method-name type-name) - (declare (optimize speed)) - (pool-get (list 10 - (pool-class class-name) - (pool-name-and-type method-name type-name)))) +(defun pool-class (name) + (pool-add-class *pool* name)) -(declaim (ftype (function (string) fixnum) pool-string)) (defun pool-string (string) - (declare (optimize speed)) - (pool-get (list 8 (pool-name string)))) - -(defknown pool-int (fixnum) (integer 1 65535)) -(defun pool-int (n) - (declare (optimize speed)) - (pool-get (list 3 n))) - -(defknown pool-float (single-float) (integer 1 65535)) -(defun pool-float (n) - (declare (optimize speed)) - (pool-get (list 4 (%float-bits n)))) - -(defun pool-long/double (entry) - (let* ((ht *pool-entries*) - (index (gethash1 entry ht))) - (declare (type hash-table ht)) - (unless index - (setf index *pool-count*) - (push entry *pool*) - (setf (gethash entry ht) index) - ;; The Java Virtual Machine Specification, Section 4.4.5: "All 8-byte - ;; constants take up two entries in the constant_pool table of the class - ;; file. If a CONSTANT_Long_info or CONSTANT_Double_info structure is the - ;; item in the constant_pool table at index n, then the next usable item in - ;; the pool is located at index n+2. The constant_pool index n+1 must be - ;; valid but is considered unusable." So: - (setf *pool-count* (+ index 2))) - index)) + (pool-add-string *pool* string)) -(defknown pool-long (integer) (integer 1 65535)) -(defun pool-long (n) - (declare (optimize speed)) - (declare (type java-long n)) - (let* ((entry (list 5 - (logand (ash n -32) #xffffffff) - (logand n #xffffffff)))) - (pool-long/double entry))) +(defun pool-field (class-name field-name type-name) + (pool-add-field-ref *pool* class-name field-name type-name)) -(defknown pool-double (double-float) (integer 1 65535)) -(defun pool-double (n) - (declare (optimize speed)) - (let* ((n (%float-bits n)) - (entry (list 6 - (logand (ash n -32) #xffffffff) - (logand n #xffffffff)))) - (pool-long/double entry))) +(defun pool-method (class-name method-name type-name) + (pool-add-method-ref *pool* class-name method-name type-name)) -(defknown u2 (fixnum) cons) -(defun u2 (n) - (declare (optimize speed)) - (declare (type (unsigned-byte 16) n)) - (when (not (<= 0 n 65535)) - (error "u2 argument ~A out of 65k range." n)) - (list (logand (ash n -8) #xff) - (logand n #xff))) +(defun pool-int (int) + (pool-add-int *pool* int)) -(defknown s1 (fixnum) fixnum) -(defun s1 (n) - (declare (optimize speed)) - (declare (type (signed-byte 8) n)) - (when (not (<= -128 n 127)) - (error "s2 argument ~A out of 16-bit signed range." n)) - (if (< n 0) - (1+ (logxor (- n) #xFF)) - n)) +(defun pool-float (float) + (pool-add-float *pool* float)) +(defun pool-long (long) + (pool-add-long *pool* long)) -(defknown s2 (fixnum) cons) -(defun s2 (n) - (declare (optimize speed)) - (declare (type (signed-byte 16) n)) - (when (not (<= -32768 n 32767)) - (error "s2 argument ~A out of 16-bit signed range." n)) - (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") -(defconstant +lisp-nil-class+ "org/armedbear/lisp/Nil") -(defconstant +lisp-class-class+ "org/armedbear/lisp/LispClass") -(defconstant +lisp-object-class+ "org/armedbear/lisp/LispObject") -(defconstant +lisp-object+ "Lorg/armedbear/lisp/LispObject;") -(defconstant +lisp-object-array+ "[Lorg/armedbear/lisp/LispObject;") -(defconstant +closure-binding-array+ "[Lorg/armedbear/lisp/ClosureBinding;") -(defconstant +closure-binding-class+ "org/armedbear/lisp/ClosureBinding") -(defconstant +lisp-symbol-class+ "org/armedbear/lisp/Symbol") -(defconstant +lisp-symbol+ "Lorg/armedbear/lisp/Symbol;") -(defconstant +lisp-structure-object-class+ "org/armedbear/lisp/StructureObject") -(defconstant +lisp-thread-class+ "org/armedbear/lisp/LispThread") -(defconstant +lisp-thread+ "Lorg/armedbear/lisp/LispThread;") -(defconstant +lisp-load-class+ "org/armedbear/lisp/Load") -(defconstant +lisp-cons-class+ "org/armedbear/lisp/Cons") -(defconstant +lisp-cons+ "Lorg/armedbear/lisp/Cons;") -(defconstant +lisp-integer-class+ "org/armedbear/lisp/LispInteger") -(defconstant +lisp-integer+ "Lorg/armedbear/lisp/LispInteger;") -(defconstant +lisp-fixnum-class+ "org/armedbear/lisp/Fixnum") -(defconstant +lisp-fixnum+ "Lorg/armedbear/lisp/Fixnum;") -(defconstant +lisp-fixnum-array+ "[Lorg/armedbear/lisp/Fixnum;") -(defconstant +lisp-function-proxy-class+ - "org/armedbear/lisp/AutoloadedFunctionProxy") -(defconstant +lisp-bignum-class+ "org/armedbear/lisp/Bignum") -(defconstant +lisp-bignum+ "Lorg/armedbear/lisp/Bignum;") -(defconstant +lisp-single-float-class+ "org/armedbear/lisp/SingleFloat") -(defconstant +lisp-single-float+ "Lorg/armedbear/lisp/SingleFloat;") -(defconstant +lisp-double-float-class+ "org/armedbear/lisp/DoubleFloat") -(defconstant +lisp-double-float+ "Lorg/armedbear/lisp/DoubleFloat;") -(defconstant +lisp-character-class+ "org/armedbear/lisp/LispCharacter") -(defconstant +lisp-character+ "Lorg/armedbear/lisp/LispCharacter;") -(defconstant +lisp-character-array+ "[Lorg/armedbear/lisp/LispCharacter;") -(defconstant +lisp-abstract-bit-vector-class+ "org/armedbear/lisp/AbstractBitVector") -(defconstant +lisp-abstract-vector-class+ "org/armedbear/lisp/AbstractVector") -(defconstant +lisp-abstract-string-class+ "org/armedbear/lisp/AbstractString") -(defconstant +lisp-abstract-string+ "Lorg/armedbear/lisp/AbstractString;") -(defconstant +lisp-simple-vector-class+ "org/armedbear/lisp/SimpleVector") -(defconstant +lisp-simple-string-class+ "org/armedbear/lisp/SimpleString") -(defconstant +lisp-simple-string+ "Lorg/armedbear/lisp/SimpleString;") -(defconstant +lisp-environment+ "Lorg/armedbear/lisp/Environment;") -(defconstant +lisp-environment-class+ "org/armedbear/lisp/Environment") -(defconstant +lisp-special-binding+ "Lorg/armedbear/lisp/SpecialBinding;") -(defconstant +lisp-special-binding-class+ "org/armedbear/lisp/SpecialBinding") -(defconstant +lisp-special-bindings-mark+ "Lorg/armedbear/lisp/SpecialBindingsMark;") -(defconstant +lisp-special-bindings-mark-class+ "org/armedbear/lisp/SpecialBindingsMark") -(defconstant +lisp-throw-class+ "org/armedbear/lisp/Throw") -(defconstant +lisp-return-class+ "org/armedbear/lisp/Return") -(defconstant +lisp-go-class+ "org/armedbear/lisp/Go") -(defconstant +lisp-compiled-closure-class+ "org/armedbear/lisp/CompiledClosure") -(defconstant +lisp-primitive-class+ "org/armedbear/lisp/Primitive") -(defconstant +lisp-hash-table-class+ "org/armedbear/lisp/HashTable") -(defconstant +lisp-eql-hash-table-class+ "org/armedbear/lisp/EqlHashTable") -(defconstant +lisp-package-class+ "org/armedbear/lisp/Package") -(defconstant +lisp-readtable-class+ "org/armedbear/lisp/Readtable") -(defconstant +lisp-stream-class+ "org/armedbear/lisp/Stream") -(defconstant +lisp-closure-class+ "org/armedbear/lisp/Closure") -(defconstant +lisp-closure-parameter-class+ "org/armedbear/lisp/Closure$Parameter") -(defconstant +lisp-closure-parameter-array+ "[Lorg/armedbear/lisp/Closure$Parameter;") - -(defstruct (instruction (:constructor %make-instruction (opcode args))) - (opcode 0 :type (integer 0 255)) - args - stack - depth - wide) - -(defun make-instruction (opcode args) - (let ((inst (apply #'%make-instruction - (list opcode - (remove :wide-prefix args))))) - (when (memq :wide-prefix args) - (setf (inst-wide inst) t)) - inst)) - -(defun print-instruction (instruction) - (sys::%format nil "~A ~A stack = ~S depth = ~S" - (opcode-name (instruction-opcode instruction)) - (instruction-args instruction) - (instruction-stack instruction) - (instruction-depth instruction))) +(defun pool-double (double) + (pool-add-double *pool* double)) -(defknown inst * t) -(defun inst (instr &optional args) - (declare (optimize speed)) - (let ((opcode (if (fixnump instr) - instr - (opcode-number instr)))) - (unless (listp args) - (setf args (list args))) - (make-instruction opcode args))) +(defun add-exception-handler (start end handler type) + (code-add-exception-handler *current-code-attribute* + start end handler type)) -(defknown %%emit * t) -(defun %%emit (instr &rest args) - (declare (optimize speed)) - (let ((instruction (make-instruction instr args))) - (push instruction *code*) - instruction)) -(defknown %emit * t) -(defun %emit (instr &rest args) - (declare (optimize speed)) - (let ((instruction (inst instr args))) - (push instruction *code*) - instruction)) - -(defmacro emit (instr &rest args) - (when (and (consp instr) (eq (car instr) 'QUOTE) (symbolp (cadr instr))) - (setf instr (opcode-number (cadr instr)))) - (if (fixnump instr) - `(%%emit ,instr , at args) - `(%emit ,instr , at args))) - -(defknown label (symbol) t) -(defun label (symbol) - (declare (type symbol symbol)) - (declare (optimize speed)) - (emit 'label symbol) - (setf (symbol-value symbol) nil)) - -(defknown aload (fixnum) t) -(defun aload (index) - (case index - (0 (emit 'aload_0)) - (1 (emit 'aload_1)) - (2 (emit 'aload_2)) - (3 (emit 'aload_3)) - (t (emit 'aload index)))) - -(defknown astore (fixnum) t) -(defun astore (index) - (case index - (0 (emit 'astore_0)) - (1 (emit 'astore_1)) - (2 (emit 'astore_2)) - (3 (emit 'astore_3)) - (t (emit 'astore index)))) (defknown emit-push-nil () t) (declaim (inline emit-push-nil)) (defun emit-push-nil () - (emit-getstatic +lisp-class+ "NIL" +lisp-object+)) + (emit-getstatic +lisp+ "NIL" +lisp-object+)) (defknown emit-push-nil-symbol () t) (declaim (inline emit-push-nil-symbol)) (defun emit-push-nil-symbol () - (emit-getstatic +lisp-nil-class+ "NIL" +lisp-symbol+)) + (emit-getstatic +lisp-nil+ "NIL" +lisp-symbol+)) (defknown emit-push-t () t) (declaim (inline emit-push-t)) (defun emit-push-t () - (emit-getstatic +lisp-class+ "T" +lisp-symbol+)) + (emit-getstatic +lisp+ "T" +lisp-symbol+)) (defknown emit-push-false (t) t) (defun emit-push-false (representation) @@ -455,46 +201,11 @@ (emit 'dup2_x2) (emit 'pop2))))) -(declaim (ftype (function (t t) cons) make-descriptor-info)) -(defun make-descriptor-info (arg-types return-type) - (let ((descriptor (with-standard-io-syntax - (with-output-to-string (s) - (princ #\( s) - (dolist (type arg-types) - (princ type s)) - (princ #\) s) - (princ (or return-type "V") s)))) - (stack-effect (let ((result (cond ((null return-type) 0) - ((or (equal return-type "J") - (equal return-type "D")) 2) - (t 1)))) - (dolist (type arg-types result) - (decf result (if (or (equal type "J") - (equal type "D")) - 2 1)))))) - (cons descriptor stack-effect))) - -(defparameter *descriptors* (make-hash-table :test #'equal)) - -(declaim (ftype (function (t t) cons) get-descriptor-info)) -(defun get-descriptor-info (arg-types return-type) - (let* ((key (list arg-types return-type)) - (ht *descriptors*) - (descriptor-info (gethash1 key ht))) - (declare (type hash-table ht)) - (or descriptor-info - (setf (gethash key ht) (make-descriptor-info arg-types return-type))))) - -(declaim (inline get-descriptor)) -(defun get-descriptor (arg-types return-type) - (car (get-descriptor-info arg-types return-type))) - (declaim (ftype (function * t) emit-invokestatic)) (defun emit-invokestatic (class-name method-name arg-types return-type) - (let* ((info (get-descriptor-info arg-types return-type)) - (descriptor (car info)) - (stack-effect (cdr info)) - (index (pool-method class-name method-name descriptor)) + (let* ((stack-effect (apply #'descriptor-stack-effect return-type arg-types)) + (index (pool-add-method-ref *pool* class-name + method-name (cons return-type arg-types))) (instruction (apply #'%emit 'invokestatic (u2 index)))) (setf (instruction-stack instruction) stack-effect))) @@ -502,21 +213,20 @@ (declaim (ftype (function t string) pretty-java-class)) (defun pretty-java-class (class) - (cond ((equal class +lisp-object-class+) + (cond ((equal class +lisp-object+) "LispObject") ((equal class +lisp-symbol+) "Symbol") - ((equal class +lisp-thread-class+) + ((equal class +lisp-thread+) "LispThread") (t class))) (defknown emit-invokevirtual (t t t t) t) (defun emit-invokevirtual (class-name method-name arg-types return-type) - (let* ((info (get-descriptor-info arg-types return-type)) - (descriptor (car info)) - (stack-effect (cdr info)) - (index (pool-method class-name method-name descriptor)) + (let* ((stack-effect (apply #'descriptor-stack-effect return-type arg-types)) + (index (pool-add-method-ref *pool* class-name + method-name (cons return-type arg-types))) (instruction (apply #'%emit 'invokevirtual (u2 index)))) (declare (type (signed-byte 8) stack-effect)) (let ((explain *explain*)) @@ -531,10 +241,9 @@ (defknown emit-invokespecial-init (string list) t) (defun emit-invokespecial-init (class-name arg-types) - (let* ((info (get-descriptor-info arg-types nil)) - (descriptor (car info)) - (stack-effect (cdr info)) - (index (pool-method class-name "" descriptor)) + (let* ((stack-effect (apply #'descriptor-stack-effect :void arg-types)) + (index (pool-add-method-ref *pool* class-name + "" (cons nil arg-types))) (instruction (apply #'%emit 'invokespecial (u2 index)))) (declare (type (signed-byte 8) stack-effect)) (setf (instruction-stack instruction) (1- stack-effect)))) @@ -556,13 +265,14 @@ "Symbol") ((equal type +lisp-thread+) "LispThread") - ((equal type "C") + ((equal type :char) "char") - ((equal type "I") + ((equal type :int) "int") - ((equal type "Z") + ((equal type :boolean) "boolean") - ((null type) + ((or (null type) + (eq type :void)) "void") (t type))) @@ -573,14 +283,44 @@ (declaim (inline emit-getstatic emit-putstatic)) (defknown emit-getstatic (t t t) t) (defun emit-getstatic (class-name field-name type) - (let ((index (pool-field class-name field-name type))) + (let ((index (pool-add-field-ref *pool* class-name field-name type))) (apply #'%emit 'getstatic (u2 index)))) (defknown emit-putstatic (t t t) t) (defun emit-putstatic (class-name field-name type) - (let ((index (pool-field class-name field-name type))) + (let ((index (pool-add-field-ref *pool* class-name field-name type))) (apply #'%emit 'putstatic (u2 index)))) +(declaim (inline emit-getfield emit-putfield)) +(defknown emit-getfield (t t t) t) +(defun emit-getfield (class-name field-name type) + (let* ((index (pool-add-field-ref *pool* class-name field-name type))) + (apply #'%emit 'getfield (u2 index)))) + +(defknown emit-putfield (t t t) t) +(defun emit-putfield (class-name field-name type) + (let* ((index (pool-add-field-ref *pool* class-name field-name type))) + (apply #'%emit 'putfield (u2 index)))) + + +(defknown emit-new (t) t) +(declaim (inline emit-new emit-anewarray emit-checkcast emit-instanceof)) +(defun emit-new (class-name) + (apply #'%emit 'new (u2 (pool-class class-name)))) + +(defknown emit-anewarray (t) t) +(defun emit-anewarray (class-name) + (apply #'%emit 'anewarray (u2 (pool-class class-name)))) + +(defknown emit-checkcast (t) t) +(defun emit-checkcast (class-name) + (apply #'%emit 'checkcast (u2 (pool-class class-name)))) + +(defknown emit-instanceof (t) t) +(defun emit-instanceof (class-name) + (apply #'%emit 'instanceof (u2 (pool-class class-name)))) + + (defvar type-representations '((:int fixnum) (:long (integer #.most-negative-java-long #.most-positive-java-long)) @@ -613,18 +353,18 @@ (defknown emit-unbox-boolean () t) (defun emit-unbox-boolean () - (emit 'instanceof +lisp-nil-class+) + (emit-instanceof +lisp-nil+) (emit 'iconst_1) (emit 'ixor)) ;; 1 -> 0 && 0 -> 1: in other words, negate the low bit (defknown emit-unbox-character () t) (defun emit-unbox-character () (cond ((> *safety* 0) - (emit-invokestatic +lisp-character-class+ "getValue" - (lisp-object-arg-types 1) "C")) + (emit-invokestatic +lisp-character+ "getValue" + (lisp-object-arg-types 1) :char)) (t - (emit 'checkcast +lisp-character-class+) - (emit 'getfield +lisp-character-class+ "value" "C")))) + (emit-checkcast +lisp-character+) + (emit-getfield +lisp-character+ "value" :char)))) ;; source type / ;; targets :boolean :char :int :long :float :double @@ -642,24 +382,15 @@ internal representation conversion.") (defvar rep-classes - '((:boolean #.+lisp-object-class+ #.+lisp-object+) - (:char #.+lisp-character-class+ #.+lisp-character+) - (:int #.+lisp-integer-class+ #.+lisp-integer+) - (:long #.+lisp-integer-class+ #.+lisp-integer+) - (:float #.+lisp-single-float-class+ #.+lisp-single-float+) - (:double #.+lisp-double-float-class+ #.+lisp-double-float+)) + `((:boolean . ,+lisp-object+) + (:char . ,+lisp-character+) + (:int . ,+lisp-integer+) + (:long . ,+lisp-integer+) + (:float . ,+lisp-single-float+) + (:double . ,+lisp-double-float+)) "Lists the class on which to call the `getInstance' method on, when converting the internal representation to a LispObject.") -(defvar rep-arg-chars - '((:boolean . "Z") - (:char . "C") - (:int . "I") - (:long . "J") - (:float . "F") - (:double . "D")) - "Lists the argument type identifiers for each -of the internal representations.") (defun convert-representation (in out) "Converts the value on the stack in the `in' representation @@ -670,10 +401,8 @@ (when (null out) ;; Convert back to a lisp object (when in - (let ((class (cdr (assoc in rep-classes))) - (arg-spec (cdr (assoc in rep-arg-chars)))) - (emit-invokestatic (first class) "getInstance" (list arg-spec) - (second class)))) + (let ((class (cdr (assoc in rep-classes)))) + (emit-invokestatic class "getInstance" (list in) class))) (return-from convert-representation)) (let* ((in-map (cdr (assoc in rep-conversion))) (op-num (position out '(:boolean :char :int :long :float :double))) @@ -687,8 +416,7 @@ ((functionp op) (funcall op)) ((stringp op) - (emit-invokevirtual +lisp-object-class+ op nil - (cdr (assoc out rep-arg-chars)))) + (emit-invokevirtual +lisp-object+ op nil out)) (t (emit op)))))) @@ -721,7 +449,7 @@ (defun maybe-initialize-thread-var () (when *initialize-thread-var* - (emit-invokestatic +lisp-thread-class+ "currentThread" nil +lisp-thread+) + (emit-invokestatic +lisp-thread+ "currentThread" nil +lisp-thread+) (astore *thread*) (setf *initialize-thread-var* nil))) @@ -736,7 +464,7 @@ (ensure-thread-var-initialized) (aload *thread*)) -(defun local-variable-p (variable) +(defun variable-local-p (variable) "Return non-NIL if `variable' is a local variable. Special variables are not considered local." @@ -745,7 +473,7 @@ (defun emit-load-local-variable (variable) "Loads a local variable in the top stack position." - (aver (local-variable-p variable)) + (aver (variable-local-p variable)) (if (variable-register variable) (aload (variable-register variable)) (progn @@ -763,31 +491,31 @@ The stack pointer is returned to the position from before the emitted code: the code is 'stack-neutral'." (declare (type symbol expected-type)) - (unless (local-variable-p variable) + (unless (variable-local-p variable) (return-from generate-instanceof-type-check-for-variable)) (let ((instanceof-class (ecase expected-type - (SYMBOL +lisp-symbol-class+) - (CHARACTER +lisp-character-class+) - (CONS +lisp-cons-class+) - (HASH-TABLE +lisp-hash-table-class+) - (FIXNUM +lisp-fixnum-class+) - (STREAM +lisp-stream-class+) - (STRING +lisp-abstract-string-class+) - (VECTOR +lisp-abstract-vector-class+))) + (SYMBOL +lisp-symbol+) + (CHARACTER +lisp-character+) + (CONS +lisp-cons+) + (HASH-TABLE +lisp-hash-table+) + (FIXNUM +lisp-fixnum+) + (STREAM +lisp-stream+) + (STRING +lisp-abstract-string+) + (VECTOR +lisp-abstract-vector+))) (expected-type-java-symbol-name (case expected-type (HASH-TABLE "HASH_TABLE") (t (symbol-name expected-type)))) (LABEL1 (gensym))) (emit-load-local-variable variable) - (emit 'instanceof instanceof-class) + (emit-instanceof instanceof-class) (emit 'ifne LABEL1) (emit-load-local-variable variable) - (emit-getstatic +lisp-symbol-class+ expected-type-java-symbol-name + (emit-getstatic +lisp-symbol+ expected-type-java-symbol-name +lisp-symbol+) - (emit-invokestatic +lisp-class+ "type_error" + (emit-invokestatic +lisp+ "type_error" (lisp-object-arg-types 2) +lisp-object+) - (emit 'pop) ; Needed for JVM stack consistency. + (emit 'areturn) ; Needed for JVM stack consistency. (label LABEL1)) t) @@ -843,9 +571,9 @@ (defun maybe-generate-interrupt-check () (unless (> *speed* *safety*) (let ((label1 (gensym))) - (emit-getstatic +lisp-class+ "interrupted" "Z") + (emit-getstatic +lisp+ "interrupted" :boolean) (emit 'ifeq label1) - (emit-invokestatic +lisp-class+ "handleInterrupt" nil nil) + (emit-invokestatic +lisp+ "handleInterrupt" nil nil) (label label1)))) (defknown single-valued-p (t) t) @@ -899,7 +627,7 @@ (defun emit-clear-values () (declare (optimize speed (safety 0))) (ensure-thread-var-initialized) - (emit 'clear-values)) + (emit 'clear-values *thread*)) (defknown maybe-emit-clear-values (&rest t) t) (defun maybe-emit-clear-values (&rest forms) @@ -907,7 +635,7 @@ (dolist (form forms) (unless (single-valued-p form) (ensure-thread-var-initialized) - (emit 'clear-values) + (emit 'clear-values *thread*) (return)))) (defun compile-forms-and-maybe-emit-clear-values (&rest forms-and-compile-args) @@ -921,36 +649,36 @@ (defun emit-unbox-fixnum () (declare (optimize speed)) (cond ((= *safety* 3) - (emit-invokestatic +lisp-fixnum-class+ "getValue" - (lisp-object-arg-types 1) "I")) + (emit-invokestatic +lisp-fixnum+ "getValue" + (lisp-object-arg-types 1) :int)) (t - (emit 'checkcast +lisp-fixnum-class+) - (emit 'getfield +lisp-fixnum-class+ "value" "I")))) + (emit-checkcast +lisp-fixnum+) + (emit-getfield +lisp-fixnum+ "value" :int)))) (defknown emit-unbox-long () t) (defun emit-unbox-long () - (emit-invokestatic +lisp-bignum-class+ "longValue" - (lisp-object-arg-types 1) "J")) + (emit-invokestatic +lisp-bignum+ "longValue" + (lisp-object-arg-types 1) :long)) (defknown emit-unbox-float () t) (defun emit-unbox-float () (declare (optimize speed)) (cond ((= *safety* 3) - (emit-invokestatic +lisp-single-float-class+ "getValue" - (lisp-object-arg-types 1) "F")) + (emit-invokestatic +lisp-single-float+ "getValue" + (lisp-object-arg-types 1) :float)) (t - (emit 'checkcast +lisp-single-float-class+) - (emit 'getfield +lisp-single-float-class+ "value" "F")))) + (emit-checkcast +lisp-single-float+) + (emit-getfield +lisp-single-float+ "value" :float)))) (defknown emit-unbox-double () t) (defun emit-unbox-double () (declare (optimize speed)) (cond ((= *safety* 3) - (emit-invokestatic +lisp-double-float-class+ "getValue" - (lisp-object-arg-types 1) "D")) + (emit-invokestatic +lisp-double-float+ "getValue" + (lisp-object-arg-types 1) :double)) (t - (emit 'checkcast +lisp-double-float-class+) - (emit 'getfield +lisp-double-float-class+ "value" "D")))) + (emit-checkcast +lisp-double-float+) + (emit-getfield +lisp-double-float+ "value" :double)))) (defknown fix-boxing (t t) t) (defun fix-boxing (required-representation derived-type) @@ -960,20 +688,20 @@ ((eq required-representation :int) (cond ((and (fixnum-type-p derived-type) (< *safety* 3)) - (emit 'checkcast +lisp-fixnum-class+) - (emit 'getfield +lisp-fixnum-class+ "value" "I")) + (emit-checkcast +lisp-fixnum+) + (emit-getfield +lisp-fixnum+ "value" :int)) (t - (emit-invokevirtual +lisp-object-class+ "intValue" nil "I")))) + (emit-invokevirtual +lisp-object+ "intValue" nil :int)))) ((eq required-representation :char) (emit-unbox-character)) ((eq required-representation :boolean) (emit-unbox-boolean)) ((eq required-representation :long) - (emit-invokevirtual +lisp-object-class+ "longValue" nil "J")) + (emit-invokevirtual +lisp-object+ "longValue" nil :long)) ((eq required-representation :float) - (emit-invokevirtual +lisp-object-class+ "floatValue" nil "F")) + (emit-invokevirtual +lisp-object+ "floatValue" nil :float)) ((eq required-representation :double) - (emit-invokevirtual +lisp-object-class+ "doubleValue" nil "D")) + (emit-invokevirtual +lisp-object+ "doubleValue" nil :double)) (t (assert nil)))) (defknown emit-move-from-stack (t &optional t) t) @@ -1003,7 +731,7 @@ ;; Expects value on stack. (defknown emit-invoke-method (t t t) t) (defun emit-invoke-method (method-name target representation) - (emit-invokevirtual +lisp-object-class+ method-name nil +lisp-object+) + (emit-invokevirtual +lisp-object+ method-name nil +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation)) @@ -1039,741 +767,15 @@ (defun check-min-args (form n) (check-number-of-args form n t)) -(defun unsupported-opcode (instruction) - (error "Unsupported opcode ~D." (instruction-opcode instruction))) - -(declaim (type hash-table +resolvers+)) -(defconst +resolvers+ (make-hash-table)) - -(defun initialize-resolvers () - (let ((ht +resolvers+)) - (dotimes (n (1+ *last-opcode*)) - (setf (gethash n ht) #'unsupported-opcode)) - ;; The following opcodes resolve to themselves. - (dolist (n '(0 ; nop - 1 ; aconst_null - 2 ; iconst_m1 - 3 ; iconst_0 - 4 ; iconst_1 - 5 ; iconst_2 - 6 ; iconst_3 - 7 ; iconst_4 - 8 ; iconst_5 - 9 ; lconst_0 - 10 ; lconst_1 - 11 ; fconst_0 - 12 ; fconst_1 - 13 ; fconst_2 - 14 ; dconst_0 - 15 ; dconst_1 - 42 ; aload_0 - 43 ; aload_1 - 44 ; aload_2 - 45 ; aload_3 - 46 ; iaload - 47 ; laload - 48 ; faload - 49 ; daload - 50 ; aaload - 75 ; astore_0 - 76 ; astore_1 - 77 ; astore_2 - 78 ; astore_3 - 79 ; iastore - 80 ; lastore - 81 ; fastore - 82 ; dastore - 83 ; aastore - 87 ; pop - 88 ; pop2 - 89 ; dup - 90 ; dup_x1 - 91 ; dup_x2 - 92 ; dup2 - 93 ; dup2_x1 - 94 ; dup2_x2 - 95 ; swap - 96 ; iadd - 97 ; ladd - 98 ; fadd - 99 ; dadd - 100 ; isub - 101 ; lsub - 102 ; fsub - 103 ; dsub - 104 ; imul - 105 ; lmul - 106 ; fmul - 107 ; dmul - 116 ; ineg - 117 ; lneg - 118 ; fneg - 119 ; dneg - 120 ; ishl - 121 ; lshl - 122 ; ishr - 123 ; lshr - 126 ; iand - 127 ; land - 128 ; ior - 129 ; lor - 130 ; ixor - 131 ; lxor - 133 ; i2l - 134 ; i2f - 135 ; i2d - 136 ; l2i - 137 ; l2f - 138 ; l2d - 141 ; f2d - 144 ; d2f - 148 ; lcmp - 149 ; fcmpd - 150 ; fcmpg - 151 ; dcmpd - 152 ; dcmpg - 153 ; ifeq - 154 ; ifne - 155 ; ifge - 156 ; ifgt - 157 ; ifgt - 158 ; ifle - 159 ; if_icmpeq - 160 ; if_icmpne - 161 ; if_icmplt - 162 ; if_icmpge - 163 ; if_icmpgt - 164 ; if_icmple - 165 ; if_acmpeq - 166 ; if_acmpne - 167 ; goto - 176 ; areturn - 177 ; return - 190 ; arraylength - 191 ; athrow - 194 ; monitorenter - 195 ; monitorexit - 198 ; ifnull - 202 ; label - )) - (setf (gethash n ht) nil)))) -(initialize-resolvers) - -(defmacro define-resolver (opcodes args &body body) - (let ((name (gensym))) - `(progn - (defun ,name ,args , at body) - (eval-when (:load-toplevel :execute) - ,(if (listp opcodes) - `(dolist (op ',opcodes) - (setf (gethash op +resolvers+) (symbol-function ',name))) - `(setf (gethash ,opcodes +resolvers+) (symbol-function ',name))))))) - -(defun load/store-resolver (instruction inst-index inst-index2 error-text) - (let* ((args (instruction-args instruction)) - (index (car args))) - (declare (type (unsigned-byte 16) index)) - (cond ((<= 0 index 3) - (inst (+ index inst-index))) - ((<= 0 index 255) - (inst inst-index2 index)) - (t - (error error-text))))) - -;; aload -(define-resolver 25 (instruction) - (load/store-resolver instruction 42 25 "ALOAD unsupported case")) - -;; astore -(define-resolver 58 (instruction) - (load/store-resolver instruction 75 58 "ASTORE unsupported case")) - -;; iload -(define-resolver 21 (instruction) - (load/store-resolver instruction 26 21 "ILOAD unsupported case")) - -;; istore -(define-resolver 54 (instruction) - (load/store-resolver instruction 59 54 "ISTORE unsupported case")) - -;; lload -(define-resolver 22 (instruction) - (load/store-resolver instruction 30 22 "LLOAD unsupported case")) - -;; lstore -(define-resolver 55 (instruction) - (load/store-resolver instruction 63 55 "LSTORE unsupported case")) - -;; getstatic, putstatic -(define-resolver (178 179) (instruction) - ;; we used to create the pool-field here; that moved to the emit-* layer - instruction) - -;; bipush, sipush -(define-resolver (16 17) (instruction) - (let* ((args (instruction-args instruction)) - (n (first args))) - (declare (type fixnum n)) - (cond ((<= 0 n 5) - (inst (+ n 3))) - ((<= -128 n 127) - (inst 16 (logand n #xff))) ; BIPUSH - (t ; SIPUSH - (inst 17 (s2 n)))))) - -;; invokevirtual, invokespecial, invokestatic class-name method-name descriptor -(define-resolver (182 183 184) (instruction) - ;; we used to create the pool-method here; that moved to the emit-* layer - instruction) - -;; ldc -(define-resolver 18 (instruction) - (let* ((args (instruction-args instruction))) - (unless (= (length args) 1) - (error "Wrong number of args for LDC.")) - (if (> (car args) 255) - (inst 19 (u2 (car args))) ; LDC_W - (inst 18 args)))) - -;; ldc2_w -(define-resolver 20 (instruction) - (let* ((args (instruction-args instruction))) - (unless (= (length args) 1) - (error "Wrong number of args for LDC2_W.")) - (inst 20 (u2 (car args))))) - -;; getfield, putfield class-name field-name type-name -(define-resolver (180 181) (instruction) - (let* ((args (instruction-args instruction)) - (index (pool-field (first args) (second args) (third args)))) - (inst (instruction-opcode instruction) (u2 index)))) - -;; new, anewarray, checkcast, instanceof class-name -(define-resolver (187 189 192 193) (instruction) - (let* ((args (instruction-args instruction)) - (index (pool-class (first args)))) - (inst (instruction-opcode instruction) (u2 index)))) - -;; iinc -(define-resolver 132 (instruction) - (let* ((args (instruction-args instruction)) - (register (first args)) - (n (second args))) - (when (not (<= -128 n 127)) - (error "IINC argument ~A out of bounds." n)) - (inst 132 (list register (s1 n))))) - -(defknown resolve-instruction (t) t) -(defun resolve-instruction (instruction) - (declare (optimize speed)) - (let ((resolver (gethash1 (instruction-opcode instruction) +resolvers+))) - (if resolver - (funcall resolver instruction) - instruction))) - -(defun resolve-instructions (code) - (let ((vector (make-array 512 :fill-pointer 0 :adjustable t))) - (dotimes (index (length code) vector) - (declare (type (unsigned-byte 16) index)) - (let ((instruction (svref code index))) - (case (instruction-opcode instruction) - (205 ; CLEAR-VALUES - (let ((instructions - (list - (inst 'aload *thread*) - (inst 'aconst_null) - (inst 'putfield (list +lisp-thread-class+ "_values" - +lisp-object-array+))))) - (dolist (instruction instructions) - (vector-push-extend (resolve-instruction instruction) vector)))) - (t - (vector-push-extend (resolve-instruction instruction) vector))))))) - -(declaim (ftype (function (t) t) branch-opcode-p)) -(declaim (inline branch-opcode-p)) -(defun branch-opcode-p (opcode) - (declare (optimize speed)) - (declare (type '(integer 0 255) opcode)) - (or (<= 153 opcode 168) - (= opcode 198))) - -(declaim (ftype (function (t t t) t) walk-code)) -(defun walk-code (code start-index depth) - (declare (optimize speed)) - (declare (type fixnum start-index depth)) - (do* ((i start-index (1+ i)) - (limit (length code))) - ((>= i limit)) - (declare (type fixnum i limit)) - (let* ((instruction (aref code i)) - (instruction-depth (instruction-depth instruction)) - (instruction-stack (instruction-stack instruction))) - (declare (type fixnum instruction-stack)) - (when instruction-depth - (unless (= (the fixnum instruction-depth) (the fixnum (+ depth instruction-stack))) - (internal-compiler-error - "Stack inconsistency detected in ~A at index ~D: found ~S, expected ~S." - (compiland-name *current-compiland*) - i instruction-depth (+ depth instruction-stack))) - (return-from walk-code)) - (let ((opcode (instruction-opcode instruction))) - (setf depth (+ depth instruction-stack)) - (setf (instruction-depth instruction) depth) - (when (branch-opcode-p opcode) - (let ((label (car (instruction-args instruction)))) - (declare (type symbol label)) - (walk-code code (symbol-value label) depth))) - (when (member opcode '(167 176 191)) ; GOTO ARETURN ATHROW - ;; Current path ends. - (return-from walk-code)))))) - -(declaim (ftype (function () t) analyze-stack)) -(defun analyze-stack () - (declare (optimize speed)) - (let* ((code *code*) - (code-length (length code))) - (declare (type vector code)) - (dotimes (i code-length) - (declare (type (unsigned-byte 16) i)) - (let* ((instruction (aref code i)) - (opcode (instruction-opcode instruction))) - (when (eql opcode 202) ; LABEL - (let ((label (car (instruction-args instruction)))) - (set label i))) - (if (instruction-stack instruction) - (when (opcode-stack-effect opcode) - (unless (eql (instruction-stack instruction) (opcode-stack-effect opcode)) - (sys::%format t "instruction-stack = ~S opcode-stack-effect = ~S~%" - (instruction-stack instruction) - (opcode-stack-effect opcode)) - (sys::%format t "index = ~D instruction = ~A~%" i (print-instruction instruction)))) - (setf (instruction-stack instruction) (opcode-stack-effect opcode))) - (unless (instruction-stack instruction) - (sys::%format t "no stack information for instruction ~D~%" (instruction-opcode instruction)) - (aver nil)))) - (walk-code code 0 0) - (dolist (handler *handlers*) - ;; Stack depth is always 1 when handler is called. - (walk-code code (symbol-value (handler-code handler)) 1)) - (let ((max-stack 0)) - (declare (type fixnum max-stack)) - (dotimes (i code-length) - (declare (type (unsigned-byte 16) i)) - (let* ((instruction (aref code i)) - (instruction-depth (instruction-depth instruction))) - (when instruction-depth - (setf max-stack (max max-stack (the fixnum instruction-depth)))))) - max-stack))) - - -(defun finalize-code () - (setf *code* (nreverse (coerce *code* 'vector)))) - -(defun print-code () - (dotimes (i (length *code*)) - (let ((instruction (elt *code* i))) - (sys::%format t "~D ~A ~S ~S ~S~%" - i - (opcode-name (instruction-opcode instruction)) - (instruction-args instruction) - (instruction-stack instruction) - (instruction-depth instruction))))) - -(defun print-code2 (code) - (dotimes (i (length code)) - (let ((instruction (elt code i))) - (case (instruction-opcode instruction) - (202 ; LABEL - (format t "~A:~%" (car (instruction-args instruction)))) - (t - (format t "~8D: ~A ~S~%" - i - (opcode-name (instruction-opcode instruction)) - (instruction-args instruction))))))) - -(declaim (ftype (function (t) boolean) label-p)) -(defun label-p (instruction) - (and instruction - (= (the fixnum (instruction-opcode (the instruction instruction))) 202))) - -(declaim (ftype (function (t) t) instruction-label)) -(defun instruction-label (instruction) - (and instruction - (= (instruction-opcode (the instruction instruction)) 202) - (car (instruction-args instruction)))) - -;; Remove unused labels. -(defun optimize-1 () - (let ((code (coerce *code* 'vector)) - (changed nil) - (marker (gensym))) - ;; Mark the labels that are actually branched to. - (dotimes (i (length code)) - (declare (type (unsigned-byte 16) i)) - (let ((instruction (aref code i))) - (when (branch-opcode-p (instruction-opcode instruction)) - (let ((label (car (instruction-args instruction)))) - (set label marker))))) - ;; Add labels used for exception handlers. - (dolist (handler *handlers*) - (set (handler-from handler) marker) - (set (handler-to handler) marker) - (set (handler-code handler) marker)) - ;; Remove labels that are not used as branch targets. - (dotimes (i (length code)) - (declare (type (unsigned-byte 16) i)) - (let ((instruction (aref code i))) - (when (= (instruction-opcode instruction) 202) ; LABEL - (let ((label (car (instruction-args instruction)))) - (declare (type symbol label)) - (unless (eq (symbol-value label) marker) - (setf (aref code i) nil) - (setf changed t)))))) - (when changed - (setf *code* (delete nil code)) - t))) - -(defun optimize-2 () - (let* ((code (coerce *code* 'vector)) - (length (length code)) - (changed nil)) - (declare (type (unsigned-byte 16) length)) - ;; Since we're looking at this instruction and the next one, we can stop - ;; one before the end. - (dotimes (i (1- length)) - (declare (type (unsigned-byte 16) i)) - (let ((instruction (aref code i))) - (when (and instruction (= (instruction-opcode instruction) 167)) ; GOTO - (do* ((j (1+ i) (1+ j)) - (next-instruction (aref code j) (aref code j))) - ((>= j length)) - (declare (type (unsigned-byte 16) j)) - (when next-instruction - (cond ((= (instruction-opcode next-instruction) 167) ; GOTO - (cond ((= j (1+ i)) - ;; Two GOTOs in a row: the second instruction is - ;; unreachable. - (setf (aref code j) nil) - (setf changed t)) - ((eq (car (instruction-args next-instruction)) - (car (instruction-args instruction))) - ;; We've reached another GOTO to the same destination. - ;; We don't need the first GOTO; we can just fall - ;; through to the second one. - (setf (aref code i) nil) - (setf changed t))) - (return)) - ((= (instruction-opcode next-instruction) 202) ; LABEL - (when (eq (car (instruction-args instruction)) - (car (instruction-args next-instruction))) - ;; GOTO next instruction; we don't need this one. - (setf (aref code i) nil) - (setf changed t) - (return))) - (t - ;; Not a GOTO or a label. - (return)))))))) - (when changed - (setf *code* (delete nil code)) - t))) - -(declaim (ftype (function (t) hash-table) hash-labels)) -(defun hash-labels (code) - (let ((ht (make-hash-table :test 'eq)) - (code (coerce code 'vector)) - (pending-labels '())) - (dotimes (i (length code)) - (declare (type (unsigned-byte 16) i)) - (let ((instruction (aref code i))) - (cond ((label-p instruction) - (push (instruction-label instruction) pending-labels)) - (t - ;; Not a label. - (when pending-labels - (dolist (label pending-labels) - (setf (gethash label ht) instruction)) - (setf pending-labels nil)))))) - ht)) - -(defun optimize-2b () - (let* ((code (coerce *code* 'vector)) - (ht (hash-labels code)) - (changed nil)) - (dotimes (i (length code)) - (declare (type (unsigned-byte 16) i)) - (let ((instruction (aref code i))) - (when (and instruction (= (instruction-opcode instruction) 167)) ; GOTO - (let* ((target-label (car (instruction-args instruction))) - (next-instruction (gethash1 target-label ht))) - (when next-instruction - (case (instruction-opcode next-instruction) - (167 ; GOTO - (setf (instruction-args instruction) - (instruction-args next-instruction) - changed t)) - (176 ; ARETURN - (setf (instruction-opcode instruction) 176 - (instruction-args instruction) nil - changed t)))))))) - (when changed - (setf *code* code) - t))) - -;; CLEAR-VALUES CLEAR-VALUES => CLEAR-VALUES -;; GETSTATIC POP => nothing -(defun optimize-3 () - (let* ((code (coerce *code* 'vector)) - (changed nil)) - (dotimes (i (1- (length code))) - (declare (type (unsigned-byte 16) i)) - (let* ((this-instruction (aref code i)) - (this-opcode (and this-instruction (instruction-opcode this-instruction))) - (next-instruction (aref code (1+ i))) - (next-opcode (and next-instruction (instruction-opcode next-instruction)))) - (case this-opcode - (205 ; CLEAR-VALUES - (when (eql next-opcode 205) ; CLEAR-VALUES - (setf (aref code i) nil) - (setf changed t))) - (178 ; GETSTATIC - (when (eql next-opcode 87) ; POP - (setf (aref code i) nil) - (setf (aref code (1+ i)) nil) - (setf changed t)))))) - (when changed - (setf *code* (delete nil code)) - t))) - -(defun delete-unreachable-code () - ;; Look for unreachable code after GOTO. - (let* ((code (coerce *code* 'vector)) - (changed nil) - (after-goto/areturn nil)) - (dotimes (i (length code)) - (declare (type (unsigned-byte 16) i)) - (let* ((instruction (aref code i)) - (opcode (instruction-opcode instruction))) - (cond (after-goto/areturn - (if (= opcode 202) ; LABEL - (setf after-goto/areturn nil) - ;; Unreachable. - (progn - (setf (aref code i) nil) - (setf changed t)))) - ((= opcode 176) ; ARETURN - (setf after-goto/areturn t)) - ((= opcode 167) ; GOTO - (setf after-goto/areturn t))))) - (when changed - (setf *code* (delete nil code)) - t))) - -(defvar *enable-optimization* t) - -(defknown optimize-code () t) -(defun optimize-code () - (unless *enable-optimization* - (format t "optimizations are disabled~%")) - (when *enable-optimization* - (when *compiler-debug* - (format t "----- before optimization -----~%") - (print-code)) - (loop - (let ((changed-p nil)) - (setf changed-p (or (optimize-1) changed-p)) - (setf changed-p (or (optimize-2) changed-p)) - (setf changed-p (or (optimize-2b) changed-p)) - (setf changed-p (or (optimize-3) changed-p)) - (setf changed-p (or (delete-unreachable-code) changed-p)) - (unless changed-p - (return)))) - (unless (vectorp *code*) - (setf *code* (coerce *code* 'vector))) - (when *compiler-debug* - (sys::%format t "----- after optimization -----~%") - (print-code))) - t) - -(defun code-bytes (code) - (let ((length 0)) - (declare (type (unsigned-byte 16) length)) - ;; Pass 1: calculate label offsets and overall length. - (dotimes (i (length code)) - (declare (type (unsigned-byte 16) i)) - (let* ((instruction (aref code i)) - (opcode (instruction-opcode instruction))) - (if (= opcode 202) ; LABEL - (let ((label (car (instruction-args instruction)))) - (set label length)) - (incf length (opcode-size opcode))))) - ;; Pass 2: replace labels with calculated offsets. - (let ((index 0)) - (declare (type (unsigned-byte 16) index)) - (dotimes (i (length code)) - (declare (type (unsigned-byte 16) i)) - (let ((instruction (aref code i))) - (when (branch-opcode-p (instruction-opcode instruction)) - (let* ((label (car (instruction-args instruction))) - (offset (- (the (unsigned-byte 16) (symbol-value (the symbol label))) index))) - (setf (instruction-args instruction) (s2 offset)))) - (unless (= (instruction-opcode instruction) 202) ; LABEL - (incf index (opcode-size (instruction-opcode instruction))))))) - ;; Expand instructions into bytes, skipping LABEL pseudo-instructions. - (let ((bytes (make-array length)) - (index 0)) - (declare (type (unsigned-byte 16) index)) - (dotimes (i (length code)) - (declare (type (unsigned-byte 16) i)) - (let ((instruction (aref code i))) - (unless (= (instruction-opcode instruction) 202) ; LABEL - (setf (svref bytes index) (instruction-opcode instruction)) - (incf index) - (dolist (byte (instruction-args instruction)) - (setf (svref bytes index) byte) - (incf index))))) - bytes))) - -(declaim (inline write-u1)) -(defun write-u1 (n stream) - (declare (optimize speed)) - (declare (type (unsigned-byte 8) n)) - (declare (type stream stream)) - (write-8-bits n stream)) - -(defknown write-u2 (t t) t) -(defun write-u2 (n stream) - (declare (optimize speed)) - (declare (type (unsigned-byte 16) n)) - (declare (type stream stream)) - (write-8-bits (logand (ash n -8) #xFF) stream) - (write-8-bits (logand n #xFF) stream)) - -(defknown write-u4 (integer stream) t) -(defun write-u4 (n stream) - (declare (optimize speed)) - (declare (type (unsigned-byte 32) n)) - (write-u2 (logand (ash n -16) #xFFFF) stream) - (write-u2 (logand n #xFFFF) stream)) - -(declaim (ftype (function (t t) t) write-s4)) -(defun write-s4 (n stream) - (declare (optimize speed)) - (cond ((minusp n) - (write-u4 (1+ (logxor (- n) #xFFFFFFFF)) stream)) - (t - (write-u4 n stream)))) - -(declaim (ftype (function (t t t) t) write-ascii)) -(defun write-ascii (string length stream) - (declare (type string string)) - (declare (type (unsigned-byte 16) length)) - (declare (type stream stream)) - (write-u2 length stream) - (dotimes (i length) - (declare (type (unsigned-byte 16) i)) - (write-8-bits (char-code (char string i)) stream))) - -(declaim (ftype (function (t t) t) write-utf8)) -(defun write-utf8 (string stream) - (declare (optimize speed)) - (declare (type string string)) - (declare (type stream stream)) - (let ((length (length string)) - (must-convert nil)) - (declare (type fixnum length)) - (dotimes (i length) - (declare (type fixnum i)) - (unless (< 0 (char-code (char string i)) #x80) - (setf must-convert t) - (return))) - (if must-convert - (let ((octets (make-array (* length 2) - :element-type '(unsigned-byte 8) - :adjustable t - :fill-pointer 0))) - (declare (type (vector (unsigned-byte 8)) octets)) - (dotimes (i length) - (declare (type fixnum i)) - (let* ((c (char string i)) - (n (char-code c))) - (cond ((zerop n) - (vector-push-extend #xC0 octets) - (vector-push-extend #x80 octets)) - ((< 0 n #x80) - (vector-push-extend n octets)) - (t - (let ((char-octets (char-to-utf8 c))) - (dotimes (j (length char-octets)) - (declare (type fixnum j)) - (vector-push-extend (svref char-octets j) octets))))))) - (write-u2 (length octets) stream) - (dotimes (i (length octets)) - (declare (type fixnum i)) - (write-8-bits (aref octets i) stream))) - (write-ascii string length stream)))) - -(defknown write-constant-pool-entry (t t) t) -(defun write-constant-pool-entry (entry stream) - (declare (optimize speed)) - (declare (type stream stream)) - (let ((tag (first entry))) - (declare (type (integer 1 12) tag)) - (write-u1 tag stream) - (case tag - (1 ; UTF8 - (write-utf8 (third entry) stream)) - ((3 4) ; int - (write-u4 (second entry) stream)) - ((5 6) ; long double - (write-u4 (second entry) stream) - (write-u4 (third entry) stream)) - ((9 10 11 12) ; fieldref methodref InterfaceMethodref nameAndType - (write-u2 (second entry) stream) - (write-u2 (third entry) stream)) - ((7 8) ; class string - (write-u2 (second entry) stream)) - (t - (error "write-constant-pool-entry unhandled tag ~D~%" tag))))) - -(defun write-constant-pool (stream) - (declare (optimize speed)) - (write-u2 *pool-count* stream) - (dolist (entry (reverse *pool*)) - (write-constant-pool-entry entry stream))) - -(defstruct (field (:constructor make-field (name descriptor))) - access-flags - name - descriptor - name-index - descriptor-index) - -(defstruct (java-method (:conc-name method-) (:constructor %make-method)) - access-flags - name - descriptor - name-index - descriptor-index - max-stack - max-locals - code - handlers) - -(defun make-method (&rest args &key descriptor name - descriptor-index name-index - &allow-other-keys) - (apply #'%make-method - (list* :descriptor-index (or descriptor-index (pool-name descriptor)) - :name-index (or name-index (pool-name name)) - args))) (defun emit-constructor-lambda-name (lambda-name) (cond ((and lambda-name (symbolp lambda-name) (symbol-package (truly-the symbol lambda-name))) (emit 'ldc (pool-string (symbol-name (truly-the symbol lambda-name)))) (emit 'ldc (pool-string (package-name (symbol-package (truly-the symbol lambda-name))))) - (emit-invokestatic +lisp-class+ "internInPackage" - (list +java-string+ +java-string+) +lisp-symbol+)) + (emit-invokestatic +lisp+ "internInPackage" + (list +java-string+ +java-string+) + +lisp-symbol+)) (t ;; No name. (emit-push-nil)))) @@ -1784,7 +786,7 @@ (*print-length* nil) (s (sys::%format nil "~S" lambda-list))) (emit 'ldc (pool-string s)) - (emit-invokestatic +lisp-class+ "readObjectFromString" + (emit-invokestatic +lisp+ "readObjectFromString" (list +java-string+) +lisp-object+)) (emit-push-nil))) @@ -1794,8 +796,9 @@ (defun make-constructor (super lambda-name args) (let* ((*compiler-debug* nil) ;; We don't normally need to see debugging output for constructors. - (constructor (make-method :name "" - :descriptor "()V")) + (method (make-method :constructor :void nil + :flags '(:public))) + (code (method-add-code method)) req-params-register opt-params-register key-params-register @@ -1803,9 +806,9 @@ keys-p more-keys-p (*code* ()) - (*handlers* nil)) - (setf (method-max-locals constructor) 1) - (unless (equal super +lisp-primitive-class+) + (*current-code-attribute* code)) + (setf (code-max-locals code) 1) + (unless (eq super +lisp-primitive+) (multiple-value-bind (req opt key key-p rest allow-other-keys-p) @@ -1818,9 +821,9 @@ (let ((count-sym (gensym))) `(progn (emit-push-constant-int (length ,params)) - (emit 'anewarray +lisp-closure-parameter-class+) - (astore (setf ,register (method-max-locals constructor))) - (incf (method-max-locals constructor)) + (emit-anewarray +lisp-closure-parameter+) + (astore (setf ,register (code-max-locals code))) + (incf (code-max-locals code)) (do* ((,count-sym 0 (1+ ,count-sym)) (,params ,params (cdr ,params)) (,param (car ,params) (car ,params))) @@ -1828,14 +831,14 @@ (declare (ignorable ,param)) (aload ,register) (emit-push-constant-int ,count-sym) - (emit 'new +lisp-closure-parameter-class+) + (emit-new +lisp-closure-parameter+) (emit 'dup) , at body (emit 'aastore)))))) ;; process required args (parameters-to-array (ignore req req-params-register) (emit-push-t) ;; we don't need the actual symbol - (emit-invokespecial-init +lisp-closure-parameter-class+ + (emit-invokespecial-init +lisp-closure-parameter+ (list +lisp-symbol+))) (parameters-to-array (param opt opt-params-register) @@ -1844,24 +847,24 @@ (if (null (third param)) ;; supplied-p (emit-push-nil) (emit-push-t)) ;; we don't need the actual supplied-p symbol - (emit-getstatic +lisp-closure-class+ "OPTIONAL" "I") - (emit-invokespecial-init +lisp-closure-parameter-class+ + (emit-getstatic +lisp-closure+ "OPTIONAL" :int) + (emit-invokespecial-init +lisp-closure-parameter+ (list +lisp-symbol+ +lisp-object+ - +lisp-object+ "I"))) + +lisp-object+ :int))) (parameters-to-array (param key key-params-register) (let ((keyword (fourth param))) (if (keywordp keyword) (progn (emit 'ldc (pool-string (symbol-name keyword))) - (emit-invokestatic +lisp-class+ "internKeyword" + (emit-invokestatic +lisp+ "internKeyword" (list +java-string+) +lisp-symbol+)) ;; symbol is not really a keyword; yes, that's allowed! (progn (emit 'ldc (pool-string (symbol-name keyword))) (emit 'ldc (pool-string (package-name (symbol-package keyword)))) - (emit-invokestatic +lisp-class+ "internInPackage" + (emit-invokestatic +lisp+ "internInPackage" (list +java-string+ +java-string+) +lisp-symbol+)))) (emit-push-t) ;; we don't need the actual variable-symbol @@ -1869,15 +872,15 @@ (if (null (third param)) (emit-push-nil) (emit-push-t)) ;; we don't need the actual supplied-p symbol - (emit-invokespecial-init +lisp-closure-parameter-class+ + (emit-invokespecial-init +lisp-closure-parameter+ (list +lisp-symbol+ +lisp-symbol+ +lisp-object+ +lisp-object+)))))) (aload 0) ;; this - (cond ((equal super +lisp-primitive-class+) + (cond ((eq super +lisp-primitive+) (emit-constructor-lambda-name lambda-name) (emit-constructor-lambda-list args) (emit-invokespecial-init super (lisp-object-arg-types 2))) - ((equal super +lisp-compiled-closure-class+) + ((equal super +lisp-compiled-closure+) ;;### only needs EQ when SUPER is guaranteed to be CLASS-NAME (aload req-params-register) (aload opt-params-register) (aload key-params-register) @@ -1900,102 +903,30 @@ (aver nil))) (setf *code* (append *static-code* *code*)) (emit 'return) - (finalize-code) - (setf *code* (resolve-instructions *code*)) - (setf (method-max-stack constructor) (analyze-stack)) - (setf (method-code constructor) (code-bytes *code*)) - (setf (method-handlers constructor) (nreverse *handlers*)) - constructor)) - -(defun write-exception-table (method stream) - (let ((handlers (method-handlers method))) - (write-u2 (length handlers) stream) ; number of entries - (dolist (handler handlers) - (write-u2 (symbol-value (handler-from handler)) stream) - (write-u2 (symbol-value (handler-to handler)) stream) - (write-u2 (symbol-value (handler-code handler)) stream) - (write-u2 (handler-catch-type handler) stream)))) - -(defun write-source-file-attr (source-file stream) - (let* ((name-index (pool-name "SourceFile")) - (source-file-index (pool-name source-file))) - (write-u2 name-index stream) - ;; "The value of the attribute_length item of a SourceFile_attribute - ;; structure must be 2." - (write-u4 2 stream) - (write-u2 source-file-index stream))) + (setf (code-code code) *code*) + method)) + (defvar *source-line-number* nil) -(defun write-line-number-table (stream) - (let* ((name-index (pool-name "LineNumberTable"))) - (write-u2 name-index stream) - (write-u4 6 stream) ; "the length of the attribute, excluding the initial six bytes" - (write-u2 1 stream) ; number of entries - (write-u2 0 stream) ; start_pc - (write-u2 *source-line-number* stream))) -(defun write-code-attr (method stream) - (declare (optimize speed)) - (declare (type stream stream)) - (let* ((name-index (pool-name "Code")) - (code (method-code method)) - (code-length (length code)) - (line-number-available-p (and (fixnump *source-line-number*) - (plusp *source-line-number*))) - (length (+ code-length 12 - (* (length (method-handlers method)) 8) - (if line-number-available-p 12 0))) - (max-stack (or (method-max-stack method) 20)) - (max-locals (or (method-max-locals method) 1))) - (write-u2 name-index stream) - (write-u4 length stream) - (write-u2 max-stack stream) - (write-u2 max-locals stream) - (write-u4 code-length stream) - (dotimes (i code-length) - (declare (type index i)) - (write-u1 (the (unsigned-byte 8) (svref code i)) stream)) - (write-exception-table method stream) - (cond (line-number-available-p - ; attributes count - (write-u2 1 stream) - (write-line-number-table stream)) - (t - ; attributes count - (write-u2 0 stream))))) +(defun finish-class (class stream) + "Finalizes the `class' and writes the result to `stream'. -(defun write-method (method stream) - (declare (optimize speed)) - (write-u2 (or (method-access-flags method) #x1) stream) ; access flags - (write-u2 (method-name-index method) stream) - (write-u2 (method-descriptor-index method) stream) - (write-u2 1 stream) ; attributes count - (write-code-attr method stream)) +The compiler calls this function to indicate it doesn't want to +extend the class any further." + (class-add-method class (make-constructor (class-file-superclass class) + (abcl-class-file-lambda-name class) + (abcl-class-file-lambda-list class))) + (finalize-class-file class) + (write-class-file class stream)) -(defun write-field (field stream) - (declare (optimize speed)) - (write-u2 (or (field-access-flags field) #x1) stream) ; access flags - (write-u2 (field-name-index field) stream) - (write-u2 (field-descriptor-index field) stream) - (write-u2 0 stream)) ; attributes count - -(defconst +field-flag-final+ #x10) ;; final field -(defconst +field-flag-static+ #x08) ;; static field -(defconst +field-access-protected+ #x04) ;; subclass accessible -(defconst +field-access-private+ #x02) ;; class-only accessible -(defconst +field-access-public+ #x01) ;; generally accessible -(defconst +field-access-default+ #x00) ;; package accessible, used for LABELS (defknown declare-field (t t t) t) -(defun declare-field (name descriptor access-flags) - (let ((field (make-field name descriptor))) - ;; final static - (setf (field-access-flags field) - (logior +field-flag-final+ +field-flag-static+ access-flags)) - (setf (field-name-index field) (pool-name (field-name field))) - (setf (field-descriptor-index field) (pool-name (field-descriptor field))) - (push field *fields*))) +(defun declare-field (name descriptor) + (let ((field (make-field name descriptor + :flags '(:final :static :private)))) + (class-add-field *class-file* field))) (defknown sanitize (symbol) string) (defun sanitize (symbol) @@ -2042,57 +973,57 @@ (defun serialize-integer (n) "Generates code to restore a serialized integer." (cond((<= 0 n 255) - (emit-getstatic +lisp-fixnum-class+ "constants" +lisp-fixnum-array+) + (emit-getstatic +lisp-fixnum+ "constants" +lisp-fixnum-array+) (emit-push-constant-int n) (emit 'aaload)) ((<= most-negative-fixnum n most-positive-fixnum) (emit-push-constant-int n) - (emit-invokestatic +lisp-fixnum-class+ "getInstance" - '("I") +lisp-fixnum+)) + (emit-invokestatic +lisp-fixnum+ "getInstance" + '(:int) +lisp-fixnum+)) ((<= most-negative-java-long n most-positive-java-long) (emit-push-constant-long n) - (emit-invokestatic +lisp-bignum-class+ "getInstance" - '("J") +lisp-integer+)) + (emit-invokestatic +lisp-bignum+ "getInstance" + '(:long) +lisp-integer+)) (t (let* ((*print-base* 10) (s (with-output-to-string (stream) (dump-form n stream)))) (emit 'ldc (pool-string s)) (emit-push-constant-int 10) - (emit-invokestatic +lisp-bignum-class+ "getInstance" - (list +java-string+ "I") +lisp-integer+))))) + (emit-invokestatic +lisp-bignum+ "getInstance" + (list +java-string+ :int) +lisp-integer+))))) (defun serialize-character (c) "Generates code to restore a serialized character." (emit-push-constant-int (char-code c)) - (emit-invokestatic +lisp-character-class+ "getInstance" '("C") + (emit-invokestatic +lisp-character+ "getInstance" '(:char) +lisp-character+)) (defun serialize-float (s) "Generates code to restore a serialized single-float." - (emit 'new +lisp-single-float-class+) + (emit-new +lisp-single-float+) (emit 'dup) (emit 'ldc (pool-float s)) - (emit-invokespecial-init +lisp-single-float-class+ '("F"))) + (emit-invokespecial-init +lisp-single-float+ '(:float))) (defun serialize-double (d) "Generates code to restore a serialized double-float." - (emit 'new +lisp-double-float-class+) + (emit-new +lisp-double-float+) (emit 'dup) (emit 'ldc2_w (pool-double d)) - (emit-invokespecial-init +lisp-double-float-class+ '("D"))) + (emit-invokespecial-init +lisp-double-float+ '(:double))) (defun serialize-string (string) "Generate code to restore a serialized string." - (emit 'new +lisp-simple-string-class+) + (emit-new +lisp-simple-string+) (emit 'dup) (emit 'ldc (pool-string string)) - (emit-invokespecial-init +lisp-simple-string-class+ (list +java-string+))) + (emit-invokespecial-init +lisp-simple-string+ (list +java-string+))) (defun serialize-package (pkg) "Generate code to restore a serialized package." (emit 'ldc (pool-string (concatenate 'string "#.(FIND-PACKAGE \"" (package-name pkg) "\")"))) - (emit-invokestatic +lisp-class+ "readObjectFromString" + (emit-invokestatic +lisp+ "readObjectFromString" (list +java-string+) +lisp-object+)) (defun serialize-object (object) @@ -2101,7 +1032,7 @@ (let ((s (with-output-to-string (stream) (dump-form object stream)))) (emit 'ldc (pool-string s)) - (emit-invokestatic +lisp-class+ "readObjectFromString" + (emit-invokestatic +lisp+ "readObjectFromString" (list +java-string+) +lisp-object+))) (defun serialize-symbol (symbol) @@ -2114,17 +1045,17 @@ (emit-getstatic class name +lisp-symbol+)) ((null (symbol-package symbol)) (emit-push-constant-int (dump-uninterned-symbol-index symbol)) - (emit-invokestatic +lisp-load-class+ "getUninternedSymbol" '("I") + (emit-invokestatic +lisp-load+ "getUninternedSymbol" '(:int) +lisp-object+) - (emit 'checkcast +lisp-symbol-class+)) + (emit-checkcast +lisp-symbol+)) ((keywordp symbol) (emit 'ldc (pool-string (symbol-name symbol))) - (emit-invokestatic +lisp-class+ "internKeyword" + (emit-invokestatic +lisp+ "internKeyword" (list +java-string+) +lisp-symbol+)) (t (emit 'ldc (pool-string (symbol-name symbol))) (emit 'ldc (pool-string (package-name (symbol-package symbol)))) - (emit-invokestatic +lisp-class+ "internInPackage" + (emit-invokestatic +lisp+ "internInPackage" (list +java-string+ +java-string+) +lisp-symbol+))))) @@ -2146,7 +1077,7 @@ 4. The function to dispatch serialization to 5. The type of the field to save the serialized result to") -(defknown emit-load-externalized-object (t) string) +(defknown emit-load-externalized-object (t &optional t) string) (defun emit-load-externalized-object (object &optional cast) "Externalizes `object' for use in a FASL. @@ -2175,12 +1106,12 @@ (when existing (emit-getstatic *this-class* (cdr existing) field-type) (when cast - (emit 'checkcast cast)) + (emit-checkcast cast)) (return-from emit-load-externalized-object field-type))) ;; We need to set up the serialized value (let ((field-name (symbol-name (gensym prefix)))) - (declare-field field-name field-type +field-access-private+) + (declare-field field-name field-type) (push (cons object field-name) *externalized-objects*) (cond @@ -2188,10 +1119,10 @@ (let ((*code* *static-code*)) (remember field-name object) (emit 'ldc (pool-string field-name)) - (emit-invokestatic +lisp-class+ "recall" + (emit-invokestatic +lisp+ "recall" (list +java-string+) +lisp-object+) - (when (string/= field-type +lisp-object+) - (emit 'checkcast (subseq field-type 1 (1- (length field-type))))) + (when (not (eq field-type +lisp-object+)) + (emit-checkcast field-type)) (emit-putstatic *this-class* field-name field-type) (setf *static-code* *code*))) (*declare-inline* @@ -2205,7 +1136,7 @@ (emit-getstatic *this-class* field-name field-type) (when cast - (emit 'checkcast cast)) + (emit-checkcast cast)) field-type))) (defknown declare-function (symbol &optional setf) string) @@ -2217,7 +1148,7 @@ (let ((s (sanitize symbol))) (when s (setf f (concatenate 'string f "_" s)))) - (declare-field f +lisp-object+ +field-access-private+) + (declare-field f +lisp-object+) (multiple-value-bind (name class) (lookup-known-symbol symbol) @@ -2236,16 +1167,16 @@ (if (eq class *this-class*) (progn ;; generated by the DECLARE-OBJECT*'s above (emit-getstatic class name +lisp-object+) - (emit 'checkcast +lisp-symbol-class+)) + (emit-checkcast +lisp-symbol+)) (emit-getstatic class name +lisp-symbol+)) - (emit-invokevirtual +lisp-symbol-class+ + (emit-invokevirtual +lisp-symbol+ (if setf "getSymbolSetfFunctionOrDie" "getSymbolFunctionOrDie") nil +lisp-object+) ;; make sure we're not cacheing a proxied function ;; (AutoloadedFunctionProxy) by allowing it to resolve itself - (emit-invokevirtual +lisp-object-class+ + (emit-invokevirtual +lisp-object+ "resolve" nil +lisp-object+) (emit-putstatic *this-class* f +lisp-object+) (if *declare-inline* @@ -2266,23 +1197,14 @@ (declare-with-hashtable 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*)) + (let* ((class-name (abcl-class-file-class-name + (local-function-class-file local-function))) + (*code* *static-code*)) ;; fixme *declare-inline* - (declare-field g +lisp-object+ +field-access-private+) - (emit 'new class-name) + (declare-field g +lisp-object+) + (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)))) @@ -2304,9 +1226,9 @@ (*code* (if *declare-inline* *code* *static-code*))) ;; strings may contain evaluated bits which may depend on ;; previous statements - (declare-field g +lisp-object+ +field-access-private+) + (declare-field g +lisp-object+) (emit 'ldc (pool-string s)) - (emit-invokestatic +lisp-class+ "readObjectFromString" + (emit-invokestatic +lisp+ "readObjectFromString" (list +java-string+) +lisp-object+) (emit-putstatic *this-class* g +lisp-object+) (if *declare-inline* @@ -2324,11 +1246,11 @@ ;; The readObjectFromString call may require evaluation of ;; lisp code in the string (think #.() syntax), of which the outcome ;; may depend on something which was declared inline - (declare-field g +lisp-object+ +field-access-private+) + (declare-field g +lisp-object+) (emit 'ldc (pool-string s)) - (emit-invokestatic +lisp-class+ "readObjectFromString" + (emit-invokestatic +lisp+ "readObjectFromString" (list +java-string+) +lisp-object+) - (emit-invokestatic +lisp-class+ "loadTimeValue" + (emit-invokestatic +lisp+ "loadTimeValue" (lisp-object-arg-types 1) +lisp-object+) (emit-putstatic *this-class* g +lisp-object+) (if *declare-inline* @@ -2338,9 +1260,8 @@ (setf *code* saved-code)) g)) -(declaim (ftype (function (t &optional t) string) declare-object)) -(defun declare-object (obj &optional (obj-ref +lisp-object+) - obj-class) +(declaim (ftype (function (t) string) declare-object)) +(defun declare-object (obj) "Stores the object OBJ in the object-lookup-table, loading the object value into a field upon class-creation time. @@ -2349,13 +1270,11 @@ ;; fixme *declare-inline*? (remember g obj) (let* ((*code* *static-code*)) - (declare-field g obj-ref +field-access-private+) + (declare-field g +lisp-object+) (emit 'ldc (pool-string g)) - (emit-invokestatic +lisp-class+ "recall" + (emit-invokestatic +lisp+ "recall" (list +java-string+) +lisp-object+) - (when (and obj-class (string/= obj-class +lisp-object-class+)) - (emit 'checkcast obj-class)) - (emit-putstatic *this-class* g obj-ref) + (emit-putstatic *this-class* g +lisp-object+) (setf *static-code* *code*) g))) @@ -2369,7 +1288,7 @@ (emit-push-constant-int form)) ((integerp form) (emit-load-externalized-object form) - (emit-invokevirtual +lisp-object-class+ "intValue" nil "I")) + (emit-invokevirtual +lisp-object+ "intValue" nil :int)) (t (sys::%format t "compile-constant int representation~%") (assert nil))) @@ -2380,7 +1299,7 @@ (emit-push-constant-long form)) ((integerp form) (emit-load-externalized-object form) - (emit-invokevirtual +lisp-object-class+ "longValue" nil "J")) + (emit-invokevirtual +lisp-object+ "longValue" nil :long)) (t (sys::%format t "compile-constant long representation~%") (assert nil))) @@ -2506,11 +1425,11 @@ (compile-forms-and-maybe-emit-clear-values arg 'stack nil) (ecase representation (:boolean - (emit-invokevirtual +lisp-object-class+ + (emit-invokevirtual +lisp-object+ unboxed-method-name - nil "Z")) + nil :boolean)) ((NIL) - (emit-invokevirtual +lisp-object-class+ + (emit-invokevirtual +lisp-object+ boxed-method-name nil +lisp-object+))) (emit-move-from-stack target representation))) @@ -2578,7 +1497,7 @@ (arg2 (cadr args))) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil) - (emit-invokevirtual +lisp-object-class+ op + (emit-invokevirtual +lisp-object+ op (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation))) @@ -2643,7 +1562,7 @@ t) (defun emit-ifne-for-eql (representation instruction-type) - (emit-invokevirtual +lisp-object-class+ "eql" instruction-type "Z") + (emit-invokevirtual +lisp-object+ "eql" instruction-type :boolean) (convert-representation :boolean representation)) (defknown p2-eql (t t t) t) @@ -2669,30 +1588,30 @@ ((fixnum-type-p type2) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-ifne-for-eql representation '("I"))) + (emit-ifne-for-eql representation '(:int))) ((fixnum-type-p type1) (compile-forms-and-maybe-emit-clear-values arg1 'stack :int arg2 'stack nil) (emit 'swap) - (emit-ifne-for-eql representation '("I"))) + (emit-ifne-for-eql representation '(:int))) ((eq type2 'CHARACTER) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :char) - (emit-ifne-for-eql representation '("C"))) + (emit-ifne-for-eql representation '(:char))) ((eq type1 'CHARACTER) (compile-forms-and-maybe-emit-clear-values arg1 'stack :char arg2 'stack nil) (emit 'swap) - (emit-ifne-for-eql representation '("C"))) + (emit-ifne-for-eql representation '(:char))) (t (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil) (ecase representation (:boolean - (emit-invokevirtual +lisp-object-class+ "eql" - (lisp-object-arg-types 1) "Z")) + (emit-invokevirtual +lisp-object+ "eql" + (lisp-object-arg-types 1) :boolean)) ((NIL) - (emit-invokevirtual +lisp-object-class+ "EQL" + (emit-invokevirtual +lisp-object+ "EQL" (lisp-object-arg-types 1) +lisp-object+))))) (emit-move-from-stack target representation))) @@ -2705,8 +1624,8 @@ (arg2 (second args))) (compile-form arg1 'stack nil) (compile-form arg2 'stack nil) - (emit-invokestatic +lisp-class+ "memq" - (lisp-object-arg-types 2) "Z") + (emit-invokestatic +lisp+ "memq" + (lisp-object-arg-types 2) :boolean) (emit-move-from-stack target representation))) (t (compile-function-call form target representation)))) @@ -2722,11 +1641,11 @@ (compile-form arg1 'stack nil) (compile-form arg2 'stack nil) (cond ((eq type1 'SYMBOL) ; FIXME - (emit-invokestatic +lisp-class+ "memq" - (lisp-object-arg-types 2) "Z")) + (emit-invokestatic +lisp+ "memq" + (lisp-object-arg-types 2) :boolean)) (t - (emit-invokestatic +lisp-class+ "memql" - (lisp-object-arg-types 2) "Z"))) + (emit-invokestatic +lisp+ "memql" + (lisp-object-arg-types 2) :boolean))) (emit-move-from-stack target representation))) (t (compile-function-call form target representation)))) @@ -2734,7 +1653,7 @@ (defun p2-gensym (form target representation) (cond ((and (null representation) (null (cdr form))) (emit-push-current-thread) - (emit-invokestatic +lisp-class+ "gensym" + (emit-invokestatic +lisp+ "gensym" (list +lisp-thread+) +lisp-symbol+) (emit-move-from-stack target)) (t @@ -2755,7 +1674,7 @@ (t (compile-form arg3 'stack nil) (maybe-emit-clear-values arg1 arg2 arg3))) - (emit-invokestatic +lisp-class+ "get" + (emit-invokestatic +lisp+ "get" (lisp-object-arg-types (if arg3 3 2)) +lisp-object+) (fix-boxing representation nil) @@ -2777,7 +1696,7 @@ (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil arg3 'stack nil) - (emit-invokestatic +lisp-class+ "getf" + (emit-invokestatic +lisp+ "getf" (lisp-object-arg-types 3) +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation))) @@ -2792,10 +1711,10 @@ (let ((key-form (%cadr form)) (ht-form (%caddr form))) (compile-form ht-form 'stack nil) - (emit 'checkcast +lisp-hash-table-class+) + (emit-checkcast +lisp-hash-table+) (compile-form key-form 'stack nil) (maybe-emit-clear-values ht-form key-form) - (emit-invokevirtual +lisp-hash-table-class+ "gethash1" + (emit-invokevirtual +lisp-hash-table+ "gethash1" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation))) @@ -2810,17 +1729,17 @@ (ht-form (%caddr form)) (value-form (fourth form))) (compile-form ht-form 'stack nil) - (emit 'checkcast +lisp-hash-table-class+) + (emit-checkcast +lisp-hash-table+) (compile-form key-form 'stack nil) (compile-form value-form 'stack nil) (maybe-emit-clear-values ht-form key-form value-form) (cond (target - (emit-invokevirtual +lisp-hash-table-class+ "puthash" + (emit-invokevirtual +lisp-hash-table+ "puthash" (lisp-object-arg-types 2) +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation)) (t - (emit-invokevirtual +lisp-hash-table-class+ "put" + (emit-invokevirtual +lisp-hash-table+ "put" (lisp-object-arg-types 2) nil))))) (t (compile-function-call form target representation)))) @@ -2857,7 +1776,7 @@ (setf must-clear-values t))))) (t (emit-push-constant-int numargs) - (emit 'anewarray +lisp-object-class+) + (emit-anewarray +lisp-object+) (let ((i 0)) (dolist (arg args) (emit 'dup) @@ -2890,7 +1809,7 @@ (lisp-object-arg-types numargs) (list +lisp-object-array+))) (return-type +lisp-object+)) - (emit-invokevirtual +lisp-object-class+ "execute" arg-types return-type))) + (emit-invokevirtual +lisp-object+ "execute" arg-types return-type))) (declaim (ftype (function (t) t) emit-call-thread-execute)) (defun emit-call-thread-execute (numargs) @@ -2898,7 +1817,7 @@ (lisp-object-arg-types (1+ numargs)) (list +lisp-object+ +lisp-object-array+))) (return-type +lisp-object+)) - (emit-invokevirtual +lisp-thread-class+ "execute" arg-types return-type))) + (emit-invokevirtual +lisp-thread+ "execute" arg-types return-type))) (defknown compile-function-call (t t t) t) (defun compile-function-call (form target representation) @@ -3032,14 +1951,14 @@ (aload (compiland-closure-register compiland)) ;; src (emit-push-constant-int 0) ;; srcPos (emit-push-constant-int (length *closure-variables*)) - (emit 'anewarray +closure-binding-class+) ;; dest + (emit-anewarray +lisp-closure-binding+) ;; dest (emit 'dup) (astore register) ;; save dest value (emit-push-constant-int 0) ;; destPos (emit-push-constant-int (length *closure-variables*)) ;; length - (emit-invokestatic "java/lang/System" "arraycopy" - (list +java-object+ "I" - +java-object+ "I" "I") nil) + (emit-invokestatic +java-system+ "arraycopy" + (list +java-object+ :int + +java-object+ :int :int) nil) (aload register))) ;; reload dest value @@ -3067,9 +1986,9 @@ (assert (not *file-compilation*)) (emit-load-externalized-object (local-function-environment local-function) - +lisp-environment-class+) + +lisp-environment+) (emit-load-externalized-object (local-function-name local-function)) - (emit-invokevirtual +lisp-environment-class+ "lookupFunction" + (emit-invokevirtual +lisp-environment+ "lookupFunction" (list +lisp-object+) +lisp-object+)) (t @@ -3081,9 +2000,9 @@ (emit-getstatic *this-class* g +lisp-object+) ; Stack: template-function (when *closure-variables* - (emit 'checkcast +lisp-compiled-closure-class+) + (emit-checkcast +lisp-compiled-closure+) (duplicate-closure-array compiland) - (emit-invokestatic +lisp-class+ "makeCompiledClosure" + (emit-invokestatic +lisp+ "makeCompiledClosure" (list +lisp-object+ +closure-binding-array+) +lisp-object+))))) (process-args args) @@ -3155,15 +2074,15 @@ ((fixnump arg2) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) (emit-push-constant-int arg2) - (emit-invokevirtual +lisp-object-class+ + (emit-invokevirtual +lisp-object+ (case op (< "isLessThan") (<= "isLessThanOrEqualTo") (> "isGreaterThan") (>= "isGreaterThanOrEqualTo") (= "isEqualTo")) - '("I") - "Z") + '(:int) + :boolean) ;; Java boolean on stack here (convert-representation :boolean representation) (emit-move-from-stack target representation) @@ -3288,7 +2207,7 @@ (when (check-arg-count form 1) (let ((arg (%cadr form))) (compile-forms-and-maybe-emit-clear-values arg 'stack nil) - (emit-invokevirtual +lisp-object-class+ java-predicate nil "Z") + (emit-invokevirtual +lisp-object+ java-predicate nil :boolean) 'ifeq))) (declaim (ftype (function (t t) t) p2-test-instanceof-predicate)) @@ -3296,21 +2215,21 @@ (when (check-arg-count form 1) (let ((arg (%cadr form))) (compile-forms-and-maybe-emit-clear-values arg 'stack nil) - (emit 'instanceof java-class) + (emit-instanceof java-class) 'ifeq))) (defun p2-test-bit-vector-p (form) - (p2-test-instanceof-predicate form +lisp-abstract-bit-vector-class+)) + (p2-test-instanceof-predicate form +lisp-abstract-bit-vector+)) (defun p2-test-characterp (form) - (p2-test-instanceof-predicate form +lisp-character-class+)) + (p2-test-instanceof-predicate form +lisp-character+)) ;; constantp form &optional environment => generalized-boolean (defun p2-test-constantp (form) (when (= (length form) 2) (let ((arg (%cadr form))) (compile-forms-and-maybe-emit-clear-values arg 'stack nil) - (emit-invokevirtual +lisp-object-class+ "constantp" nil "Z") + (emit-invokevirtual +lisp-object+ "constantp" nil :boolean) 'ifeq))) (defun p2-test-endp (form) @@ -3371,7 +2290,7 @@ (p2-test-predicate form "numberp")) (defun p2-test-packagep (form) - (p2-test-instanceof-predicate form +lisp-package-class+)) + (p2-test-instanceof-predicate form +lisp-package+)) (defun p2-test-rationalp (form) (p2-test-predicate form "rationalp")) @@ -3386,26 +2305,26 @@ (p2-test-predicate form "isSpecialVariable")) (defun p2-test-symbolp (form) - (p2-test-instanceof-predicate form +lisp-symbol-class+)) + (p2-test-instanceof-predicate form +lisp-symbol+)) (defun p2-test-consp (form) - (p2-test-instanceof-predicate form +lisp-cons-class+)) + (p2-test-instanceof-predicate form +lisp-cons+)) (defun p2-test-atom (form) - (p2-test-instanceof-predicate form +lisp-cons-class+) + (p2-test-instanceof-predicate form +lisp-cons+) 'ifne) (defun p2-test-fixnump (form) - (p2-test-instanceof-predicate form +lisp-fixnum-class+)) + (p2-test-instanceof-predicate form +lisp-fixnum+)) (defun p2-test-stringp (form) - (p2-test-instanceof-predicate form +lisp-abstract-string-class+)) + (p2-test-instanceof-predicate form +lisp-abstract-string+)) (defun p2-test-vectorp (form) - (p2-test-instanceof-predicate form +lisp-abstract-vector-class+)) + (p2-test-instanceof-predicate form +lisp-abstract-vector+)) (defun p2-test-simple-vector-p (form) - (p2-test-instanceof-predicate form +lisp-simple-vector-class+)) + (p2-test-instanceof-predicate form +lisp-simple-vector+)) (defknown compile-test-form (t) t) (defun compile-test-form (test-form) @@ -3501,30 +2420,30 @@ ((eq type2 'CHARACTER) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :char) - (emit-invokevirtual +lisp-object-class+ "eql" '("C") "Z") + (emit-invokevirtual +lisp-object+ "eql" '(:char) :boolean) 'ifeq) ((eq type1 'CHARACTER) (compile-forms-and-maybe-emit-clear-values arg1 'stack :char arg2 'stack nil) (emit 'swap) - (emit-invokevirtual +lisp-object-class+ "eql" '("C") "Z") + (emit-invokevirtual +lisp-object+ "eql" '(:char) :boolean) 'ifeq) ((fixnum-type-p type2) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ "eql" '("I") "Z") + (emit-invokevirtual +lisp-object+ "eql" '(:int) :boolean) 'ifeq) ((fixnum-type-p type1) (compile-forms-and-maybe-emit-clear-values arg1 'stack :int arg2 'stack nil) (emit 'swap) - (emit-invokevirtual +lisp-object-class+ "eql" '("I") "Z") + (emit-invokevirtual +lisp-object+ "eql" '(:int) :boolean) 'ifeq) (t (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil) - (emit-invokevirtual +lisp-object-class+ "eql" - (lisp-object-arg-types 1) "Z") + (emit-invokevirtual +lisp-object+ "eql" + (lisp-object-arg-types 1) :boolean) 'ifeq))))) (defun p2-test-equality (form) @@ -3538,15 +2457,15 @@ (cond ((fixnum-type-p (derive-compiler-type arg2)) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ + (emit-invokevirtual +lisp-object+ translated-op - '("I") "Z")) + '(:int) :boolean)) (t (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil) - (emit-invokevirtual +lisp-object-class+ + (emit-invokevirtual +lisp-object+ translated-op - (lisp-object-arg-types 1) "Z"))) + (lisp-object-arg-types 1) :boolean))) 'ifeq))) (defun p2-test-simple-typep (form) @@ -3555,7 +2474,7 @@ (arg2 (%caddr form))) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil) - (emit-invokevirtual +lisp-object-class+ "typep" + (emit-invokevirtual +lisp-object+ "typep" (lisp-object-arg-types 1) +lisp-object+) (emit-push-nil) 'if_acmpeq))) @@ -3566,8 +2485,8 @@ (arg2 (%caddr form))) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil) - (emit-invokestatic +lisp-class+ "memq" - (lisp-object-arg-types 2) "Z") + (emit-invokestatic +lisp+ "memq" + (lisp-object-arg-types 2) :boolean) 'ifeq))) (defun p2-test-memql (form) @@ -3576,8 +2495,8 @@ (arg2 (%caddr form))) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil) - (emit-invokestatic +lisp-class+ "memql" - (lisp-object-arg-types 2) "Z") + (emit-invokestatic +lisp+ "memql" + (lisp-object-arg-types 2) :boolean) 'ifeq))) (defun p2-test-/= (form) @@ -3596,7 +2515,7 @@ ((fixnum-type-p type2) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ "isNotEqualTo" '("I") "Z") + (emit-invokevirtual +lisp-object+ "isNotEqualTo" '(:int) :boolean) 'ifeq) ((fixnum-type-p type1) ;; FIXME Compile the args in reverse order and avoid the swap if @@ -3604,13 +2523,13 @@ (compile-forms-and-maybe-emit-clear-values arg1 'stack :int arg2 'stack nil) (emit 'swap) - (emit-invokevirtual +lisp-object-class+ "isNotEqualTo" '("I") "Z") + (emit-invokevirtual +lisp-object+ "isNotEqualTo" '(:int) :boolean) 'ifeq) (t (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil) - (emit-invokevirtual +lisp-object-class+ "isNotEqualTo" - (lisp-object-arg-types 1) "Z") + (emit-invokevirtual +lisp-object+ "isNotEqualTo" + (lisp-object-arg-types 1) :boolean) 'ifeq))))) (defun p2-test-numeric-comparison (form) @@ -3646,14 +2565,14 @@ ((fixnum-type-p type2) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ + (emit-invokevirtual +lisp-object+ (ecase op (< "isLessThan") (<= "isLessThanOrEqualTo") (> "isGreaterThan") (>= "isGreaterThanOrEqualTo") (= "isEqualTo")) - '("I") "Z") + '(:int) :boolean) 'ifeq) ((fixnum-type-p type1) ;; FIXME We can compile the args in reverse order and avoid @@ -3661,26 +2580,26 @@ (compile-forms-and-maybe-emit-clear-values arg1 'stack :int arg2 'stack nil) (emit 'swap) - (emit-invokevirtual +lisp-object-class+ + (emit-invokevirtual +lisp-object+ (ecase op (< "isGreaterThan") (<= "isGreaterThanOrEqualTo") (> "isLessThan") (>= "isLessThanOrEqualTo") (= "isEqualTo")) - '("I") "Z") + '(:int) :boolean) 'ifeq) (t (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil) - (emit-invokevirtual +lisp-object-class+ + (emit-invokevirtual +lisp-object+ (ecase op (< "isLessThan") (<= "isLessThanOrEqualTo") (> "isGreaterThan") (>= "isGreaterThanOrEqualTo") (= "isEqualTo")) - (lisp-object-arg-types 1) "Z") + (lisp-object-arg-types 1) :boolean) 'ifeq)))))) (defknown p2-if-or (t t t) t) @@ -3816,7 +2735,7 @@ (defun compile-multiple-value-list (form target representation) (emit-clear-values) (compile-form (second form) 'stack nil) - (emit-invokestatic +lisp-class+ "multipleValueList" + (emit-invokestatic +lisp+ "multipleValueList" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target)) @@ -3831,14 +2750,14 @@ (compile-form first-subform result-register nil) ;; Save multiple values returned by first subform. (emit-push-current-thread) - (emit 'getfield +lisp-thread-class+ "_values" +lisp-object-array+) + (emit-getfield +lisp-thread+ "_values" +lisp-object-array+) (astore values-register) (dolist (subform subforms) (compile-form subform nil nil)) ;; Restore multiple values returned by first subform. (emit-push-current-thread) (aload values-register) - (emit 'putfield +lisp-thread-class+ "_values" +lisp-object-array+) + (emit-putfield +lisp-thread+ "_values" +lisp-object-array+) ;; Result. (aload result-register) (fix-boxing representation nil) @@ -3852,9 +2771,9 @@ (error "Wrong number of arguments for MULTIPLE-VALUE-CALL.")) (2 (compile-form (second form) 'stack nil) - (emit-invokestatic +lisp-class+ "coerceToFunction" + (emit-invokestatic +lisp+ "coerceToFunction" (lisp-object-arg-types 1) +lisp-object+) - (emit-invokevirtual +lisp-object-class+ "execute" nil +lisp-object+)) + (emit-invokevirtual +lisp-object+ "execute" nil +lisp-object+)) (3 (let* ((*register* *register*) (function-register (allocate-register))) @@ -3862,7 +2781,7 @@ (compile-form (third form) 'stack nil) (aload function-register) (emit-push-current-thread) - (emit-invokestatic +lisp-class+ "multipleValueCall1" + (emit-invokestatic +lisp+ "multipleValueCall1" (list +lisp-object+ +lisp-object+ +lisp-thread+) +lisp-object+))) (t @@ -3871,7 +2790,7 @@ (function-register (allocate-register)) (values-register (allocate-register))) (compile-form (second form) 'stack nil) - (emit-invokestatic +lisp-class+ "coerceToFunction" + (emit-invokestatic +lisp+ "coerceToFunction" (lisp-object-arg-types 1) +lisp-object+) (emit-move-from-stack function-register) (emit 'aconst_null) @@ -3881,14 +2800,14 @@ (emit-push-current-thread) (emit 'swap) (aload values-register) - (emit-invokevirtual +lisp-thread-class+ "accumulateValues" + (emit-invokevirtual +lisp-thread+ "accumulateValues" (list +lisp-object+ +lisp-object-array+) +lisp-object-array+) (astore values-register) (maybe-emit-clear-values values-form)) (aload function-register) (aload values-register) - (emit-invokevirtual +lisp-object-class+ "dispatch" + (emit-invokevirtual +lisp-object+ "dispatch" (list +lisp-object-array+) +lisp-object+)))) (fix-boxing representation nil) (emit-move-from-stack target)) @@ -3911,10 +2830,10 @@ (declaim (ftype (function (t) t) emit-new-closure-binding)) (defun emit-new-closure-binding (variable) "" - (emit 'new +closure-binding-class+) ;; value c-b + (emit-new +lisp-closure-binding+) ;; value c-b (emit 'dup_x1) ;; c-b value c-b (emit 'swap) ;; c-b c-b value - (emit-invokespecial-init +closure-binding-class+ + (emit-invokespecial-init +lisp-closure-binding+ (list +lisp-object+)) ;; c-b (aload (compiland-closure-register *current-compiland*)) ;; c-b array @@ -3934,7 +2853,7 @@ (emit 'swap) (emit-push-variable-name variable) (emit 'swap) - (emit-invokevirtual +lisp-thread-class+ "bindSpecial" + (emit-invokevirtual +lisp-thread+ "bindSpecial" (list +lisp-symbol+ +lisp-object+) +lisp-special-binding+) (if (variable-binding-register variable) @@ -3975,13 +2894,13 @@ (defun restore-dynamic-environment (register) (emit-push-current-thread) (aload register) - (emit-invokevirtual +lisp-thread-class+ "resetSpecialBindings" + (emit-invokevirtual +lisp-thread+ "resetSpecialBindings" (list +lisp-special-bindings-mark+) nil) ) (defun save-dynamic-environment (register) (emit-push-current-thread) - (emit-invokevirtual +lisp-thread-class+ "markSpecialBindings" + (emit-invokevirtual +lisp-thread+ "markSpecialBindings" nil +lisp-special-bindings-mark+) (astore register) ) @@ -3996,10 +2915,7 @@ ;; Restore dynamic environment. (label label-EXIT) (restore-dynamic-environment register) - (push (make-handler :from label-START - :to label-END - :code label-END - :catch-type 0) *handlers*))) + (add-exception-handler label-START label-END label-END nil))) (defun p2-m-v-b-node (block target) (let* ((*register* *register*) @@ -4040,7 +2956,7 @@ (compile-form (third form) result-register nil) ;; Store values from values form in values register. (emit-push-current-thread) - (emit 'getfield +lisp-thread-class+ "_values" +lisp-object-array+) + (emit-getfield +lisp-thread+ "_values" +lisp-object-array+) (emit-move-from-stack values-register) ;; Did we get just one value? (aload values-register) @@ -4059,8 +2975,8 @@ (emit-push-current-thread) (aload result-register) (emit-push-constant-int (length vars)) - (emit-invokevirtual +lisp-thread-class+ "getValues" - (list +lisp-object+ "I") +lisp-object-array+) + (emit-invokevirtual +lisp-thread+ "getValues" + (list +lisp-object+ :int) +lisp-object-array+) ;; Values array is now on the stack at runtime. (label LABEL2) (let ((index 0)) @@ -4215,15 +3131,15 @@ (emit-push-constant-int (variable-closure-index variable)) (emit 'aaload) (emit-swap representation nil) - (emit 'putfield +closure-binding-class+ "value" +lisp-object+)) + (emit-putfield +lisp-closure-binding+ "value" +lisp-object+)) ((variable-environment variable) (assert (not *file-compilation*)) (emit-load-externalized-object (variable-environment variable) - +lisp-environment-class+) + +lisp-environment+) (emit 'swap) (emit-push-variable-name variable) (emit 'swap) - (emit-invokevirtual +lisp-environment-class+ "rebind" + (emit-invokevirtual +lisp-environment+ "rebind" (list +lisp-symbol+ +lisp-object+) nil)) (t @@ -4247,13 +3163,13 @@ (aload (compiland-closure-register *current-compiland*)) (emit-push-constant-int (variable-closure-index variable)) (emit 'aaload) - (emit 'getfield +closure-binding-class+ "value" +lisp-object+)) + (emit-getfield +lisp-closure-binding+ "value" +lisp-object+)) ((variable-environment variable) (assert (not *file-compilation*)) (emit-load-externalized-object (variable-environment variable) - +lisp-environment-class+) + +lisp-environment+) (emit-push-variable-name variable) - (emit-invokevirtual +lisp-environment-class+ "lookup" + (emit-invokevirtual +lisp-environment+ "lookup" (list +lisp-object+) +lisp-object+)) (t @@ -4346,7 +3262,7 @@ ;; The special case of binding a special to its current value. (emit-push-current-thread) (emit-push-variable-name variable) - (emit-invokevirtual +lisp-thread-class+ + (emit-invokevirtual +lisp-thread+ "bindSpecialToCurrentValue" (list +lisp-symbol+) +lisp-special-binding+) @@ -4472,9 +3388,9 @@ (when (tagbody-id-variable block) ;; we have a block variable; that should be a closure variable (assert (not (null (variable-closure-index (tagbody-id-variable block))))) - (emit 'new +lisp-object-class+) + (emit-new +lisp-object+) (emit 'dup) - (emit-invokespecial-init +lisp-object-class+ '()) + (emit-invokespecial-init +lisp-object+ '()) (emit-new-closure-binding (tagbody-id-variable block))) (label BEGIN-BLOCK) (do* ((rest body (cdr rest)) @@ -4506,11 +3422,11 @@ (emit 'dup) (astore go-register) ;; Get the tag. - (emit 'getfield +lisp-go-class+ "tagbody" +lisp-object+) ; Stack depth is still 1. + (emit-getfield +lisp-go+ "tagbody" +lisp-object+) ; Stack depth is still 1. (emit-push-variable (tagbody-id-variable block)) (emit 'if_acmpne RETHROW) ;; Not this TAGBODY (aload go-register) - (emit 'getfield +lisp-go-class+ "tag" +lisp-object+) ; Stack depth is still 1. + (emit-getfield +lisp-go+ "tag" +lisp-object+) ; Stack depth is still 1. (astore tag-register) ;; Don't actually generate comparisons for tags ;; to which there is no non-local GO instruction @@ -4531,16 +3447,8 @@ (emit-move-to-variable (tagbody-id-variable block)) (emit 'athrow) ;; Finally... - (push (make-handler :from BEGIN-BLOCK - :to END-BLOCK - :code HANDLER - :catch-type (pool-class +lisp-go-class+)) - *handlers*) - (push (make-handler :from BEGIN-BLOCK - :to END-BLOCK - :code EXTENT-EXIT-HANDLER - :catch-type 0) - *handlers*))) + (add-exception-handler BEGIN-BLOCK END-BLOCK HANDLER +lisp-go+) + (add-exception-handler BEGIN-BLOCK END-BLOCK EXTENT-EXIT-HANDLER nil))) (label EXIT) (when (tagbody-non-local-go-p block) (emit 'aconst_null) ;; load null value @@ -4576,7 +3484,7 @@ ;; Non-local GO. (emit-push-variable (tagbody-id-variable tag-block)) (emit-load-externalized-object (tag-label tag)) ; Tag. - (emit-invokestatic +lisp-class+ "nonLocalGo" (lisp-object-arg-types 2) + (emit-invokestatic +lisp+ "nonLocalGo" (lisp-object-arg-types 2) +lisp-object+) ;; Following code will not be reached, but is needed for JVM stack ;; consistency. @@ -4587,7 +3495,7 @@ ((aver (or (null representation) (eq representation :boolean))) (check-arg-count form 1)) (compile-forms-and-maybe-emit-clear-values (cadr form) 'stack nil) - (emit 'instanceof +lisp-cons-class+) + (emit-instanceof +lisp-cons+) (let ((LABEL1 (gensym)) (LABEL2 (gensym))) (emit 'ifeq LABEL1) @@ -4616,44 +3524,44 @@ (compile-forms-and-maybe-emit-clear-values arg nil nil)) (t (compile-forms-and-maybe-emit-clear-values arg 'stack nil) - (emit 'instanceof java-class) + (emit-instanceof java-class) (convert-representation :boolean representation) (emit-move-from-stack target representation))))) (defun p2-bit-vector-p (form target representation) - (p2-instanceof-predicate form target representation +lisp-abstract-bit-vector-class+)) + (p2-instanceof-predicate form target representation +lisp-abstract-bit-vector+)) (defun p2-characterp (form target representation) - (p2-instanceof-predicate form target representation +lisp-character-class+)) + (p2-instanceof-predicate form target representation +lisp-character+)) (defun p2-consp (form target representation) - (p2-instanceof-predicate form target representation +lisp-cons-class+)) + (p2-instanceof-predicate form target representation +lisp-cons+)) (defun p2-fixnump (form target representation) - (p2-instanceof-predicate form target representation +lisp-fixnum-class+)) + (p2-instanceof-predicate form target representation +lisp-fixnum+)) (defun p2-packagep (form target representation) - (p2-instanceof-predicate form target representation +lisp-package-class+)) + (p2-instanceof-predicate form target representation +lisp-package+)) (defun p2-readtablep (form target representation) - (p2-instanceof-predicate form target representation +lisp-readtable-class+)) + (p2-instanceof-predicate form target representation +lisp-readtable+)) (defun p2-simple-vector-p (form target representation) - (p2-instanceof-predicate form target representation +lisp-simple-vector-class+)) + (p2-instanceof-predicate form target representation +lisp-simple-vector+)) (defun p2-stringp (form target representation) - (p2-instanceof-predicate form target representation +lisp-abstract-string-class+)) + (p2-instanceof-predicate form target representation +lisp-abstract-string+)) (defun p2-symbolp (form target representation) - (p2-instanceof-predicate form target representation +lisp-symbol-class+)) + (p2-instanceof-predicate form target representation +lisp-symbol+)) (defun p2-vectorp (form target representation) - (p2-instanceof-predicate form target representation +lisp-abstract-vector-class+)) + (p2-instanceof-predicate form target representation +lisp-abstract-vector+)) (define-inlined-function p2-coerce-to-function (form target representation) ((check-arg-count form 1)) (compile-forms-and-maybe-emit-clear-values (%cadr form) 'stack nil) - (emit-invokestatic +lisp-class+ "coerceToFunction" + (emit-invokestatic +lisp+ "coerceToFunction" (lisp-object-arg-types 1) +lisp-object+) (emit-move-from-stack target)) @@ -4670,9 +3578,9 @@ (when (block-id-variable block) ;; we have a block variable; that should be a closure variable (assert (not (null (variable-closure-index (block-id-variable block))))) - (emit 'new +lisp-object-class+) + (emit-new +lisp-object+) (emit 'dup) - (emit-invokespecial-init +lisp-object-class+ '()) + (emit-invokespecial-init +lisp-object+ '()) (emit-new-closure-binding (block-id-variable block))) (dformat t "*all-variables* = ~S~%" (mapcar #'variable-name *all-variables*)) @@ -4689,7 +3597,7 @@ (label HANDLER) ;; The Return object is on the runtime stack. Stack depth is 1. (emit 'dup) ; Stack depth is 2. - (emit 'getfield +lisp-return-class+ "tag" +lisp-object+) ; Still 2. + (emit-getfield +lisp-return+ "tag" +lisp-object+) ; Still 2. (emit-push-variable (block-id-variable block)) ;; If it's not the block we're looking for... (emit 'if_acmpeq THIS-BLOCK) ; Stack depth is 1. @@ -4699,19 +3607,11 @@ (emit-move-to-variable (block-id-variable block)) (emit 'athrow) (label THIS-BLOCK) - (emit 'getfield +lisp-return-class+ "result" +lisp-object+) + (emit-getfield +lisp-return+ "result" +lisp-object+) (emit-move-from-stack target) ; Stack depth is 0. ;; Finally... - (push (make-handler :from BEGIN-BLOCK - :to END-BLOCK - :code HANDLER - :catch-type (pool-class +lisp-return-class+)) - *handlers*) - (push (make-handler :from BEGIN-BLOCK - :to END-BLOCK - :code EXTENT-EXIT-HANDLER - :catch-type 0) - *handlers*))) + (add-exception-handler BEGIN-BLOCK END-BLOCK HANDLER +lisp-return+) + (add-exception-handler BEGIN-BLOCK END-BLOCK EXTENT-EXIT-HANDLER nil))) (label BLOCK-EXIT) (when (block-id-variable block) (emit 'aconst_null) ;; load null value @@ -4746,7 +3646,7 @@ (emit-load-externalized-object (block-name block)) (emit-clear-values) (compile-form result-form 'stack nil) - (emit-invokestatic +lisp-class+ "nonLocalReturn" (lisp-object-arg-types 3) + (emit-invokestatic +lisp+ "nonLocalReturn" (lisp-object-arg-types 3) +lisp-object+) ;; Following code will not be reached, but is needed for JVM stack ;; consistency. @@ -4774,14 +3674,14 @@ (define-inlined-function p2-cons (form target representation) ((check-arg-count form 2)) - (emit 'new +lisp-cons-class+) + (emit-new +lisp-cons+) (emit 'dup) (let* ((args (%cdr form)) (arg1 (%car args)) (arg2 (%cadr args))) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil)) - (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2)) + (emit-invokespecial-init +lisp-cons+ (lisp-object-arg-types 2)) (emit-move-from-stack target)) (defun compile-progn (form target representation) @@ -4823,7 +3723,7 @@ (label label-START) ;; Compile call to Lisp.progvBindVars(). (emit-push-current-thread) - (emit-invokestatic +lisp-class+ "progvBindVars" + (emit-invokestatic +lisp+ "progvBindVars" (list +lisp-object+ +lisp-object+ +lisp-thread+) nil) ;; Implicit PROGN. (let ((*blocks* (cons block *blocks*))) @@ -4858,7 +3758,7 @@ (when target (emit 'dup)) (compile-form (second args) 'stack nil) - (emit-invokevirtual +lisp-object-class+ + (emit-invokevirtual +lisp-object+ "setCdr" (lisp-object-arg-types 1) nil) @@ -4874,7 +3774,7 @@ (compile-form (%cadr args) 'stack nil) (when target (emit-dup nil :past nil)) - (emit-invokevirtual +lisp-object-class+ + (emit-invokevirtual +lisp-object+ (if (eq op 'sys:set-car) "setCar" "setCdr") (lisp-object-arg-types 1) nil) @@ -4888,45 +3788,41 @@ (emit-push-nil) (emit-move-from-stack target))) -(defun compile-and-write-to-stream (class-file compiland stream) - (with-class-file class-file - (let ((*current-compiland* compiland)) - (with-saved-compiler-policy - (p2-compiland compiland) - (write-class-file (compiland-class-file compiland) stream))))) - -(defun set-compiland-and-write-class (class-file compiland stream) - (setf (compiland-class-file compiland) class-file) - (compile-and-write-to-stream class-file compiland stream)) - - -(defmacro with-temp-class-file (pathname class-file lambda-list &body body) - `(let* ((,pathname (make-temp-file)) - (,class-file (make-class-file :pathname ,pathname - :lambda-list ,lambda-list))) - (unwind-protect - (progn , at body) - (delete-file pathname)))) +(defun compile-and-write-to-stream (compiland &optional stream) + "Creates a class file associated with `compiland`, writing it +either to stream or the pathname of the class file if `stream' is NIL." + (let* ((pathname (funcall *pathnames-generator*)) + (class-file (make-abcl-class-file + :pathname pathname + :lambda-list + (cadr (compiland-lambda-expression compiland))))) + (setf (compiland-class-file compiland) class-file) + (with-open-stream (f (or stream + (open pathname :direction :output + :element-type '(unsigned-byte 8) + :if-exists :supersede))) + (with-class-file class-file + (let ((*current-compiland* compiland)) + (with-saved-compiler-policy + (p2-compiland compiland) + ;; (finalize-class-file (compiland-class-file compiland)) + (finish-class (compiland-class-file compiland) f))))))) (defknown p2-flet-process-compiland (t) t) (defun p2-flet-process-compiland (local-function) - (let* ((compiland (local-function-compiland local-function)) - (lambda-list (cadr (compiland-lambda-expression compiland)))) + (let* ((compiland (local-function-compiland local-function))) (cond (*file-compilation* - (let* ((pathname (funcall *pathnames-generator*)) - (class-file (make-class-file :pathname pathname - :lambda-list lambda-list))) - (with-open-class-file (f class-file) - (set-compiland-and-write-class class-file compiland f)) - (setf (local-function-class-file local-function) class-file))) + (compile-and-write-to-stream compiland) + (setf (local-function-class-file local-function) + (compiland-class-file compiland))) (t - (let ((class-file (make-class-file :lambda-list lambda-list))) - (with-open-stream (stream (sys::%make-byte-array-output-stream)) - (set-compiland-and-write-class class-file compiland stream) - (setf (local-function-class-file local-function) class-file) - (setf (local-function-function local-function) - (load-compiled-function - (sys::%get-output-stream-bytes stream))))))))) + (with-open-stream (stream (sys::%make-byte-array-output-stream)) + (compile-and-write-to-stream compiland stream) + (setf (local-function-class-file local-function) + (compiland-class-file compiland)) + (setf (local-function-function local-function) + (load-compiled-function + (sys::%get-output-stream-bytes stream)))))))) (defun emit-make-compiled-closure-for-labels (local-function compiland declaration) @@ -4935,37 +3831,33 @@ (when (compiland-closure-register parent) (dformat t "(compiland-closure-register parent) = ~S~%" (compiland-closure-register parent)) - (emit 'checkcast +lisp-compiled-closure-class+) + (emit-checkcast +lisp-compiled-closure+) (duplicate-closure-array parent) - (emit-invokestatic +lisp-class+ "makeCompiledClosure" + (emit-invokestatic +lisp+ "makeCompiledClosure" (list +lisp-object+ +closure-binding-array+) +lisp-object+))) (emit-move-to-variable (local-function-variable local-function))) (defknown p2-labels-process-compiland (t) t) (defun p2-labels-process-compiland (local-function) - (let* ((compiland (local-function-compiland local-function)) - (lambda-list (cadr (compiland-lambda-expression compiland)))) + (let* ((compiland (local-function-compiland local-function))) (cond (*file-compilation* - (let* ((pathname (funcall *pathnames-generator*)) - (class-file (make-class-file :pathname pathname - :lambda-list lambda-list))) - (with-open-class-file (f class-file) - (set-compiland-and-write-class class-file compiland f)) - (setf (local-function-class-file local-function) class-file) - (let ((g (declare-local-function local-function))) - (emit-make-compiled-closure-for-labels - local-function compiland g)))) + (compile-and-write-to-stream compiland) + (setf (local-function-class-file local-function) + (compiland-class-file compiland)) + (let ((g (declare-local-function local-function))) + (emit-make-compiled-closure-for-labels + local-function compiland g))) (t - (let ((class-file (make-class-file :lambda-list lambda-list))) - (with-open-stream (stream (sys::%make-byte-array-output-stream)) - (set-compiland-and-write-class class-file compiland stream) - (setf (local-function-class-file local-function) class-file) - (let ((g (declare-object - (load-compiled-function - (sys::%get-output-stream-bytes stream))))) - (emit-make-compiled-closure-for-labels - local-function compiland g)))))))) + (with-open-stream (stream (sys::%make-byte-array-output-stream)) + (compile-and-write-to-stream compiland stream) + (setf (local-function-class-file local-function) + (compiland-class-file compiland)) + (let ((g (declare-object + (load-compiled-function + (sys::%get-output-stream-bytes stream))))) + (emit-make-compiled-closure-for-labels + local-function compiland g))))))) (defknown p2-flet-node (t t t) t) (defun p2-flet-node (block target representation) @@ -5006,37 +3898,30 @@ (compile-progn-body body target representation)))) (defun p2-lambda (compiland target) - (let* ((lambda-list (cadr (compiland-lambda-expression compiland)))) - (aver (null (compiland-class-file compiland))) - (cond (*file-compilation* - (setf (compiland-class-file compiland) - (make-class-file :pathname (funcall *pathnames-generator*) - :lambda-list lambda-list)) - (let ((class-file (compiland-class-file compiland))) - (with-open-class-file (f class-file) - (compile-and-write-to-stream class-file compiland f)) - (emit-getstatic *this-class* - (declare-local-function (make-local-function :class-file - class-file)) - +lisp-object+))) - (t - (setf (compiland-class-file compiland) - (make-class-file :lambda-list lambda-list)) - (with-open-stream (stream (sys::%make-byte-array-output-stream)) - (compile-and-write-to-stream (compiland-class-file compiland) - compiland stream) - (emit-load-externalized-object (load-compiled-function - (sys::%get-output-stream-bytes stream)))))) - (cond ((null *closure-variables*)) ; Nothing to do. - ((compiland-closure-register *current-compiland*) - (duplicate-closure-array *current-compiland*) - (emit-invokestatic +lisp-class+ "makeCompiledClosure" - (list +lisp-object+ +closure-binding-array+) - +lisp-object+)) + (aver (null (compiland-class-file compiland))) + (cond (*file-compilation* + (compile-and-write-to-stream compiland) + (emit-getstatic *this-class* + (declare-local-function + (make-local-function + :class-file (compiland-class-file compiland))) + +lisp-object+)) + (t + (with-open-stream (stream (sys::%make-byte-array-output-stream)) + (compile-and-write-to-stream compiland stream) + (emit-load-externalized-object (load-compiled-function + (sys::%get-output-stream-bytes stream)))))) + (cond ((null *closure-variables*)) ; Nothing to do. + ((compiland-closure-register *current-compiland*) + (duplicate-closure-array *current-compiland*) + (emit-invokestatic +lisp+ "makeCompiledClosure" + (list +lisp-object+ +closure-binding-array+) + +lisp-object+)) ; Stack: compiled-closure - (t - (aver nil))) ;; Shouldn't happen. - (emit-move-from-stack target))) + (t + (aver nil))) ;; Shouldn't happen. + + (emit-move-from-stack target)) (defknown p2-function (t t t) t) (defun p2-function (form target representation) @@ -5065,9 +3950,9 @@ ; Stack: template-function (when (compiland-closure-register *current-compiland*) - (emit 'checkcast +lisp-compiled-closure-class+) + (emit-checkcast +lisp-compiled-closure+) (duplicate-closure-array *current-compiland*) - (emit-invokestatic +lisp-class+ "makeCompiledClosure" + (emit-invokestatic +lisp+ "makeCompiledClosure" (list +lisp-object+ +closure-binding-array+) +lisp-object+))))) (emit-move-from-stack target)) @@ -5077,7 +3962,7 @@ (emit-move-from-stack target)) (t (emit-load-externalized-object name) - (emit-invokevirtual +lisp-object-class+ "getSymbolFunctionOrDie" + (emit-invokevirtual +lisp-object+ "getSymbolFunctionOrDie" nil +lisp-object+) (emit-move-from-stack target)))) ((and (consp name) (eq (%car name) 'SETF)) @@ -5116,7 +4001,7 @@ (emit-move-from-stack target)) (t (emit-load-externalized-object (cadr name)) - (emit-invokevirtual +lisp-symbol-class+ + (emit-invokevirtual +lisp-symbol+ "getSymbolSetfFunctionOrDie" nil +lisp-object+) (emit-move-from-stack target)))) @@ -5211,7 +4096,7 @@ (t (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ "ash" '("I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "ash" '(:int) +lisp-object+) (fix-boxing representation result-type))) (emit-move-from-stack target representation)) (t @@ -5275,7 +4160,7 @@ ((fixnum-type-p type2) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ "LOGAND" '("I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "LOGAND" '(:int) +lisp-object+) (fix-boxing representation result-type) (emit-move-from-stack target representation)) ((fixnum-type-p type1) @@ -5284,13 +4169,13 @@ arg2 'stack nil) ;; swap args (emit 'swap) - (emit-invokevirtual +lisp-object-class+ "LOGAND" '("I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "LOGAND" '(:int) +lisp-object+) (fix-boxing representation result-type) (emit-move-from-stack target representation)) (t (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil) - (emit-invokevirtual +lisp-object-class+ "LOGAND" + (emit-invokevirtual +lisp-object+ "LOGAND" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation result-type) (emit-move-from-stack target representation))))) @@ -5347,7 +4232,7 @@ ((fixnum-type-p type2) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ "LOGIOR" '("I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "LOGIOR" '(:int) +lisp-object+) (fix-boxing representation result-type) (emit-move-from-stack target representation)) ((fixnum-type-p type1) @@ -5356,13 +4241,13 @@ arg2 'stack nil) ;; swap args (emit 'swap) - (emit-invokevirtual +lisp-object-class+ "LOGIOR" '("I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "LOGIOR" '(:int) +lisp-object+) (fix-boxing representation result-type) (emit-move-from-stack target representation)) (t (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil) - (emit-invokevirtual +lisp-object-class+ "LOGIOR" + (emit-invokevirtual +lisp-object+ "LOGIOR" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation result-type) (emit-move-from-stack target representation))))) @@ -5411,12 +4296,12 @@ ((fixnum-type-p type2) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ "LOGXOR" '("I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "LOGXOR" '(:int) +lisp-object+) (fix-boxing representation result-type)) (t (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil) - (emit-invokevirtual +lisp-object-class+ "LOGXOR" + (emit-invokevirtual +lisp-object+ "LOGXOR" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation result-type))) (emit-move-from-stack target representation))) @@ -5438,7 +4323,7 @@ (t (let ((arg (%cadr form))) (compile-forms-and-maybe-emit-clear-values arg 'stack nil)) - (emit-invokevirtual +lisp-object-class+ "LOGNOT" nil +lisp-object+) + (emit-invokevirtual +lisp-object+ "LOGNOT" nil +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation)))) @@ -5495,7 +4380,7 @@ (compile-forms-and-maybe-emit-clear-values arg3 'stack nil) (emit-push-constant-int size) (emit-push-constant-int position) - (emit-invokevirtual +lisp-object-class+ "LDB" '("I" "I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "LDB" '(:int :int) +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation)))) ((and (fixnum-type-p size-type) @@ -5505,7 +4390,7 @@ arg3 'stack nil) (emit 'dup_x2) ;; use not supported by emit-dup: 3 values involved (emit 'pop) - (emit-invokevirtual +lisp-object-class+ "LDB" '("I" "I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "LDB" '(:int :int) +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation)) (t @@ -5524,18 +4409,18 @@ (fixnum-type-p type2)) (compile-forms-and-maybe-emit-clear-values arg1 'stack :int arg2 'stack :int) - (emit-invokestatic +lisp-class+ "mod" '("I" "I") "I") + (emit-invokestatic +lisp+ "mod" '(:int :int) :int) (emit-move-from-stack target representation)) ((fixnum-type-p type2) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ "MOD" '("I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "MOD" '(:int) +lisp-object+) (fix-boxing representation nil) ; FIXME use derived result type (emit-move-from-stack target representation)) (t (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil) - (emit-invokevirtual +lisp-object-class+ "MOD" + (emit-invokevirtual +lisp-object+ "MOD" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation nil) ; FIXME use derived result type (emit-move-from-stack target representation))))) @@ -5603,16 +4488,16 @@ ;; errorp is true (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) (emit-push-constant-int 1) ; errorp - (emit-invokestatic +lisp-class-class+ "findClass" - (list +lisp-object+ "Z") +lisp-object+) + (emit-invokestatic +lisp-class+ "findClass" + (list +lisp-object+ :boolean) +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation)) (2 (let ((arg2 (second args))) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :boolean) - (emit-invokestatic +lisp-class-class+ "findClass" - (list +lisp-object+ "Z") +lisp-object+) + (emit-invokestatic +lisp-class+ "findClass" + (list +lisp-object+ :boolean) +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation))) (t @@ -5630,12 +4515,12 @@ arg2 'stack nil) (emit 'swap) (cond (target - (emit-invokevirtual +lisp-object-class+ "VECTOR_PUSH_EXTEND" + (emit-invokevirtual +lisp-object+ "VECTOR_PUSH_EXTEND" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation)) (t - (emit-invokevirtual +lisp-object-class+ "vectorPushExtend" + (emit-invokevirtual +lisp-object+ "vectorPushExtend" (lisp-object-arg-types 1) nil)))) (t (compile-function-call form target representation))))) @@ -5648,7 +4533,7 @@ (arg2 (second args))) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil) - (emit-invokevirtual +lisp-object-class+ "SLOT_VALUE" + (emit-invokevirtual +lisp-object+ "SLOT_VALUE" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation))) @@ -5669,7 +4554,7 @@ (when value-register (emit 'dup) (astore value-register)) - (emit-invokevirtual +lisp-object-class+ "setSlotValue" + (emit-invokevirtual +lisp-object+ "setSlotValue" (lisp-object-arg-types 2) nil) (when value-register (aload value-register) @@ -5684,10 +4569,10 @@ (fixnum-type-p (derive-compiler-type (second form))) (null representation)) (let ((arg (second form))) - (emit 'new +lisp-simple-vector-class+) + (emit-new +lisp-simple-vector+) (emit 'dup) (compile-forms-and-maybe-emit-clear-values arg 'stack :int) - (emit-invokespecial-init +lisp-simple-vector-class+ '("I")) + (emit-invokespecial-init +lisp-simple-vector+ '(:int)) (emit-move-from-stack target representation))) (t (compile-function-call form target representation)))) @@ -5709,14 +4594,14 @@ (class (case result-type ((STRING SIMPLE-STRING) - (setf class +lisp-simple-string-class+)) + (setf class +lisp-simple-string+)) ((VECTOR SIMPLE-VECTOR) - (setf class +lisp-simple-vector-class+))))) + (setf class +lisp-simple-vector+))))) (when class - (emit 'new class) + (emit-new class) (emit 'dup) (compile-forms-and-maybe-emit-clear-values arg2 'stack :int) - (emit-invokespecial-init class '("I")) + (emit-invokespecial-init class '(:int)) (emit-move-from-stack target representation) (return-from p2-make-sequence))))) (compile-function-call form target representation)) @@ -5728,10 +4613,10 @@ (= (length form) 2) (null representation)) (let ((arg (second form))) - (emit 'new +lisp-simple-string-class+) + (emit-new +lisp-simple-string+) (emit 'dup) (compile-forms-and-maybe-emit-clear-values arg 'stack :int) - (emit-invokespecial-init +lisp-simple-string-class+ '("I")) + (emit-invokespecial-init +lisp-simple-string+ '(:int)) (emit-move-from-stack target representation))) (t (compile-function-call form target representation)))) @@ -5739,15 +4624,15 @@ (defun p2-%make-structure (form target representation) (cond ((and (check-arg-count form 2) (eq (derive-type (%cadr form)) 'SYMBOL)) - (emit 'new +lisp-structure-object-class+) + (emit-new +lisp-structure-object+) (emit 'dup) (compile-form (%cadr form) 'stack nil) - (emit 'checkcast +lisp-symbol-class+) + (emit-checkcast +lisp-symbol+) (compile-form (%caddr form) 'stack nil) (maybe-emit-clear-values (%cadr form) (%caddr form)) - (emit-invokevirtual +lisp-object-class+ "copyToArray" + (emit-invokevirtual +lisp-object+ "copyToArray" nil +lisp-object-array+) - (emit-invokespecial-init +lisp-structure-object-class+ + (emit-invokespecial-init +lisp-structure-object+ (list +lisp-symbol+ +lisp-object-array+)) (emit-move-from-stack target representation)) (t @@ -5759,14 +4644,14 @@ (slot-count (length slot-forms))) (cond ((and (<= 1 slot-count 6) (eq (derive-type (%car args)) 'SYMBOL)) - (emit 'new +lisp-structure-object-class+) + (emit-new +lisp-structure-object+) (emit 'dup) (compile-form (%car args) 'stack nil) - (emit 'checkcast +lisp-symbol-class+) + (emit-checkcast +lisp-symbol+) (dolist (slot-form slot-forms) (compile-form slot-form 'stack nil)) (apply 'maybe-emit-clear-values args) - (emit-invokespecial-init +lisp-structure-object-class+ + (emit-invokespecial-init +lisp-structure-object+ (append (list +lisp-symbol+) (make-list slot-count :initial-element +lisp-object+))) (emit-move-from-stack target representation)) @@ -5775,9 +4660,9 @@ (defun p2-make-hash-table (form target representation) (cond ((= (length form) 1) ; no args - (emit 'new +lisp-eql-hash-table-class+) + (emit-new +lisp-eql-hash-table+) (emit 'dup) - (emit-invokespecial-init +lisp-eql-hash-table-class+ nil) + (emit-invokespecial-init +lisp-eql-hash-table+ nil) (fix-boxing representation nil) (emit-move-from-stack target representation)) (t @@ -5789,8 +4674,8 @@ (let ((arg (%cadr form))) (cond ((eq (derive-compiler-type arg) 'STREAM) (compile-forms-and-maybe-emit-clear-values arg 'stack nil) - (emit 'checkcast +lisp-stream-class+) - (emit-invokevirtual +lisp-stream-class+ "getElementType" + (emit-checkcast +lisp-stream+) + (emit-invokevirtual +lisp-stream+ "getElementType" nil +lisp-object+) (emit-move-from-stack target representation)) (t @@ -5808,10 +4693,10 @@ (eq type2 'STREAM)) (compile-form arg1 'stack :int) (compile-form arg2 'stack nil) - (emit 'checkcast +lisp-stream-class+) + (emit-checkcast +lisp-stream+) (maybe-emit-clear-values arg1 arg2) (emit 'swap) - (emit-invokevirtual +lisp-stream-class+ "_writeByte" '("I") nil) + (emit-invokevirtual +lisp-stream+ "_writeByte" '(:int) nil) (when target (emit-push-nil) (emit-move-from-stack target))) @@ -5819,8 +4704,8 @@ (compile-form arg1 'stack :int) (compile-form arg2 'stack nil) (maybe-emit-clear-values arg1 arg2) - (emit-invokestatic +lisp-class+ "writeByte" - (list "I" +lisp-object+) nil) + (emit-invokestatic +lisp+ "writeByte" + (list :int +lisp-object+) nil) (when target (emit-push-nil) (emit-move-from-stack target))) @@ -5836,11 +4721,11 @@ (type1 (derive-compiler-type arg1))) (cond ((compiler-subtypep type1 'stream) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) - (emit 'checkcast +lisp-stream-class+) + (emit-checkcast +lisp-stream+) (emit-push-constant-int 1) (emit-push-nil) - (emit-invokevirtual +lisp-stream-class+ "readLine" - (list "Z" +lisp-object+) +lisp-object+) + (emit-invokevirtual +lisp-stream+ "readLine" + (list :boolean +lisp-object+) +lisp-object+) (emit-move-from-stack target)) (t (compile-function-call form target representation))))) @@ -5850,11 +4735,11 @@ (arg2 (%cadr args))) (cond ((and (compiler-subtypep type1 'stream) (null arg2)) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) - (emit 'checkcast +lisp-stream-class+) + (emit-checkcast +lisp-stream+) (emit-push-constant-int 0) (emit-push-nil) - (emit-invokevirtual +lisp-stream-class+ "readLine" - (list "Z" +lisp-object+) +lisp-object+) + (emit-invokevirtual +lisp-stream+ "readLine" + (list :boolean +lisp-object+) +lisp-object+) (emit-move-from-stack target) ) (t @@ -6399,10 +5284,10 @@ (cond ((subtypep type2 'VECTOR) (compile-form arg1 'stack nil) (compile-form arg2 'stack nil) - (emit 'checkcast +lisp-abstract-vector-class+) + (emit-checkcast +lisp-abstract-vector+) (maybe-emit-clear-values arg1 arg2) (emit 'swap) - (emit-invokevirtual +lisp-abstract-vector-class+ + (emit-invokevirtual +lisp-abstract-vector+ (if (eq test 'eq) "deleteEq" "deleteEql") (lisp-object-arg-types 1) +lisp-object+) (emit-move-from-stack target) @@ -6417,20 +5302,20 @@ (compile-forms-and-maybe-emit-clear-values arg 'stack nil) (ecase representation (:int - (emit-invokevirtual +lisp-object-class+ "length" nil "I")) + (emit-invokevirtual +lisp-object+ "length" nil :int)) ((:long :float :double) - (emit-invokevirtual +lisp-object-class+ "length" nil "I") + (emit-invokevirtual +lisp-object+ "length" nil :int) (convert-representation :int representation)) (:boolean ;; FIXME We could optimize this all away in unsafe calls. - (emit-invokevirtual +lisp-object-class+ "length" nil "I") + (emit-invokevirtual +lisp-object+ "length" nil :int) (emit 'pop) (emit 'iconst_1)) (:char (sys::%format t "p2-length: :char case~%") (aver nil)) ((nil) - (emit-invokevirtual +lisp-object-class+ "LENGTH" nil +lisp-object+))) + (emit-invokevirtual +lisp-object+ "LENGTH" nil +lisp-object+))) (emit-move-from-stack target representation))) (defun cons-for-list/list* (form target representation &optional list-star-p) @@ -6441,19 +5326,19 @@ args))) (cond ((>= 4 length 1) (dolist (cons-head cons-heads) - (emit 'new +lisp-cons-class+) + (emit-new +lisp-cons+) (emit 'dup) (compile-form cons-head 'stack nil)) (if list-star-p (compile-form (first (last args)) 'stack nil) (progn (emit-invokespecial-init - +lisp-cons-class+ (lisp-object-arg-types 1)) + +lisp-cons+ (lisp-object-arg-types 1)) (pop cons-heads))) ; we've handled one of the args, so remove it (dolist (cons-head cons-heads) (declare (ignore cons-head)) (emit-invokespecial-init - +lisp-cons-class+ (lisp-object-arg-types 2))) + +lisp-cons+ (lisp-object-arg-types 2))) (if list-star-p (progn (apply #'maybe-emit-clear-values args) @@ -6480,7 +5365,7 @@ (compile-forms-and-maybe-emit-clear-values index-form 'stack :int list-form 'stack nil) (emit 'swap) - (emit-invokevirtual +lisp-object-class+ "NTH" '("I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "NTH" '(:int) +lisp-object+) (fix-boxing representation nil) ; FIXME use derived result type (emit-move-from-stack target representation))) @@ -6519,7 +5404,7 @@ ((fixnump arg2) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) (emit-push-int arg2) - (emit-invokevirtual +lisp-object-class+ "multiplyBy" '("I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "multiplyBy" '(:int) +lisp-object+) (fix-boxing representation result-type) (emit-move-from-stack target representation)) (t @@ -6569,11 +5454,11 @@ (emit-dup nil) (compile-form arg2 'stack nil) (emit-dup nil :past nil) - (emit-invokevirtual +lisp-object-class+ + (emit-invokevirtual +lisp-object+ (if (eq op 'max) "isLessThanOrEqualTo" "isGreaterThanOrEqualTo") - (lisp-object-arg-types 1) "Z") + (lisp-object-arg-types 1) :boolean) (let ((LABEL1 (gensym))) (emit 'ifeq LABEL1) (emit 'swap) @@ -6637,8 +5522,8 @@ arg2 'stack (when (null (fixnum-type-p type1)) :int)) (when (fixnum-type-p type1) (emit 'swap)) - (emit-invokevirtual +lisp-object-class+ "add" - '("I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "add" + '(:int) +lisp-object+) (fix-boxing representation result-type) (emit-move-from-stack target representation)) (t @@ -6676,7 +5561,7 @@ (emit-move-from-stack target representation)) (t (compile-forms-and-maybe-emit-clear-values arg 'stack nil) - (emit-invokevirtual +lisp-object-class+ "negate" + (emit-invokevirtual +lisp-object+ "negate" nil +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation))))) @@ -6708,9 +5593,9 @@ (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ + (emit-invokevirtual +lisp-object+ "subtract" - '("I") +lisp-object+) + '(:int) +lisp-object+) (fix-boxing representation result-type) (emit-move-from-stack target representation)) (t @@ -6732,29 +5617,29 @@ (cond ((and (eq representation :char) (zerop *safety*)) (compile-form arg1 'stack nil) - (emit 'checkcast +lisp-abstract-string-class+) + (emit-checkcast +lisp-abstract-string+) (compile-form arg2 'stack :int) (maybe-emit-clear-values arg1 arg2) - (emit-invokevirtual +lisp-abstract-string-class+ "charAt" - '("I") "C") + (emit-invokevirtual +lisp-abstract-string+ "charAt" + '(:int) :char) (emit-move-from-stack target representation)) ((and (eq representation :char) (or (eq op 'CHAR) (< *safety* 3)) (compiler-subtypep type1 'STRING) (fixnum-type-p type2)) (compile-form arg1 'stack nil) - (emit 'checkcast +lisp-abstract-string-class+) + (emit-checkcast +lisp-abstract-string+) (compile-form arg2 'stack :int) (maybe-emit-clear-values arg1 arg2) - (emit-invokevirtual +lisp-abstract-string-class+ "charAt" - '("I") "C") + (emit-invokevirtual +lisp-abstract-string+ "charAt" + '(:int) :char) (emit-move-from-stack target representation)) ((fixnum-type-p type2) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ + (emit-invokevirtual +lisp-object+ (symbol-name op) ;; "CHAR" or "SCHAR" - '("I") +lisp-object+) + '(:int) +lisp-object+) (when (eq representation :char) (emit-unbox-character)) (emit-move-from-stack target representation)) @@ -6781,17 +5666,17 @@ (let* ((*register* *register*) (value-register (when target (allocate-register))) (class (if (eq op 'SCHAR) - +lisp-simple-string-class+ - +lisp-abstract-string-class+))) + +lisp-simple-string+ + +lisp-abstract-string+))) (compile-form arg1 'stack nil) - (emit 'checkcast class) + (emit-checkcast class) (compile-form arg2 'stack :int) (compile-form arg3 'stack :char) (when target (emit 'dup) (emit-move-from-stack value-register :char)) (maybe-emit-clear-values arg1 arg2 arg3) - (emit-invokevirtual class "setCharAt" '("I" "C") nil) + (emit-invokevirtual class "setCharAt" '(:int :char) nil) (when target (emit 'iload value-register) (convert-representation :char representation) @@ -6807,7 +5692,7 @@ (arg2 (%caddr form))) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ "SVREF" '("I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "SVREF" '(:int) +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation))) (t @@ -6827,7 +5712,7 @@ (emit 'dup) (emit-move-from-stack value-register nil)) (maybe-emit-clear-values arg1 arg2 arg3) - (emit-invokevirtual +lisp-object-class+ "svset" (list "I" +lisp-object+) nil) + (emit-invokevirtual +lisp-object+ "svset" (list :int +lisp-object+) nil) (when value-register (aload value-register) (emit-move-from-stack target nil)))) @@ -6852,7 +5737,7 @@ (return-from p2-truncate))) (compile-form arg1 'stack nil) (compile-form arg2 'stack nil) - (emit-invokevirtual +lisp-object-class+ "truncate" (lisp-object-arg-types 1) +lisp-object+) + (emit-invokevirtual +lisp-object+ "truncate" (lisp-object-arg-types 1) +lisp-object+) (fix-boxing representation nil) ; FIXME use derived result type (emit-move-from-stack target representation))) @@ -6862,7 +5747,7 @@ (neq representation :char)) ; FIXME (compile-form (second form) 'stack nil) (compile-form (third form) 'stack :int) - (emit-invokevirtual +lisp-object-class+ "elt" '("I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "elt" '(:int) +lisp-object+) (fix-boxing representation nil) ; FIXME use derived result type (emit-move-from-stack target representation)) (t @@ -6879,30 +5764,30 @@ (:int (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ "aref" '("I") "I")) + (emit-invokevirtual +lisp-object+ "aref" '(:int) :int)) (:long (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ "aref_long" '("I") "J")) + (emit-invokevirtual +lisp-object+ "aref_long" '(:int) :long)) (:char (cond ((compiler-subtypep type1 'string) (compile-form arg1 'stack nil) ; array - (emit 'checkcast +lisp-abstract-string-class+) + (emit-checkcast +lisp-abstract-string+) (compile-form arg2 'stack :int) ; index (maybe-emit-clear-values arg1 arg2) - (emit-invokevirtual +lisp-abstract-string-class+ - "charAt" '("I") "C")) + (emit-invokevirtual +lisp-abstract-string+ + "charAt" '(:int) :char)) (t (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ "AREF" '("I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "AREF" '(:int) +lisp-object+) (emit-unbox-character)))) ((nil :float :double :boolean) ;;###FIXME for float and double, we probably want ;; separate java methods to retrieve the values. (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ "AREF" '("I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "AREF" '(:int) +lisp-object+) (convert-representation nil representation))) (emit-move-from-stack target representation))) (t @@ -6935,9 +5820,9 @@ (emit-move-from-stack value-register nil)))) (maybe-emit-clear-values arg1 arg2 arg3) (cond ((fixnum-type-p type3) - (emit-invokevirtual +lisp-object-class+ "aset" '("I" "I") nil)) + (emit-invokevirtual +lisp-object+ "aset" '(:int :int) nil)) (t - (emit-invokevirtual +lisp-object-class+ "aset" (list "I" +lisp-object+) nil))) + (emit-invokevirtual +lisp-object+ "aset" (list :int +lisp-object+) nil))) (when value-register (cond ((fixnum-type-p type3) (emit 'iload value-register) @@ -6960,37 +5845,37 @@ (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) (case arg2 (0 - (emit-invokevirtual +lisp-object-class+ "getSlotValue_0" + (emit-invokevirtual +lisp-object+ "getSlotValue_0" nil +lisp-object+)) (1 - (emit-invokevirtual +lisp-object-class+ "getSlotValue_1" + (emit-invokevirtual +lisp-object+ "getSlotValue_1" nil +lisp-object+)) (2 - (emit-invokevirtual +lisp-object-class+ "getSlotValue_2" + (emit-invokevirtual +lisp-object+ "getSlotValue_2" nil +lisp-object+)) (3 - (emit-invokevirtual +lisp-object-class+ "getSlotValue_3" + (emit-invokevirtual +lisp-object+ "getSlotValue_3" nil +lisp-object+)) (t (emit-push-constant-int arg2) - (emit-invokevirtual +lisp-object-class+ "getSlotValue" - '("I") +lisp-object+))) + (emit-invokevirtual +lisp-object+ "getSlotValue" + '(:int) +lisp-object+))) (emit-move-from-stack target representation)) ((fixnump arg2) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) (emit-push-constant-int arg2) (ecase representation (:int - (emit-invokevirtual +lisp-object-class+ "getFixnumSlotValue" - '("I") "I")) + (emit-invokevirtual +lisp-object+ "getFixnumSlotValue" + '(:int) :int)) ((nil :char :long :float :double) - (emit-invokevirtual +lisp-object-class+ "getSlotValue" - '("I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "getSlotValue" + '(:int) +lisp-object+) ;; (convert-representation NIL NIL) is a no-op (convert-representation nil representation)) (:boolean - (emit-invokevirtual +lisp-object-class+ "getSlotValueAsBoolean" - '("I") "Z"))) + (emit-invokevirtual +lisp-object+ "getSlotValueAsBoolean" + '(:int) :boolean))) (emit-move-from-stack target representation)) (t (compile-function-call form target representation))))) @@ -7011,7 +5896,7 @@ (when value-register (emit 'dup) (astore value-register)) - (emit-invokevirtual +lisp-object-class+ + (emit-invokevirtual +lisp-object+ (format nil "setSlotValue_~D" arg2) (lisp-object-arg-types 1) nil) (when value-register @@ -7028,8 +5913,8 @@ (when value-register (emit 'dup) (astore value-register)) - (emit-invokevirtual +lisp-object-class+ "setSlotValue" - (list "I" +lisp-object+) nil) + (emit-invokevirtual +lisp-object+ "setSlotValue" + (list :int +lisp-object+) nil) (when value-register (aload value-register) (fix-boxing representation nil) @@ -7094,7 +5979,7 @@ (compile-forms-and-maybe-emit-clear-values arg1 'stack :int arg2 'stack nil) (emit 'swap) - (emit-invokevirtual +lisp-object-class+ "nthcdr" '("I") +lisp-object+) + (emit-invokevirtual +lisp-object+ "nthcdr" '(:int) +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation)) (t @@ -7170,7 +6055,7 @@ (case len (0 (emit-push-current-thread) - (emit-invokevirtual +lisp-thread-class+ "setValues" nil +lisp-object+) + (emit-invokevirtual +lisp-thread+ "setValues" nil +lisp-object+) (emit-move-from-stack target)) (1 (let ((arg (%car args))) @@ -7190,7 +6075,7 @@ (t (compile-form arg1 'stack nil) (compile-form arg2 'stack nil)))) - (emit-invokevirtual +lisp-thread-class+ + (emit-invokevirtual +lisp-thread+ "setValues" (lisp-object-arg-types len) +lisp-object+) @@ -7200,7 +6085,7 @@ (emit-push-current-thread) (dolist (arg args) (compile-form arg 'stack nil)) - (emit-invokevirtual +lisp-thread-class+ + (emit-invokevirtual +lisp-thread+ "setValues" (lisp-object-arg-types len) +lisp-object+) @@ -7227,18 +6112,18 @@ (cond ((constantp name) ;; "... a reference to a symbol declared with DEFCONSTANT always ;; refers to its global value." - (emit-invokevirtual +lisp-symbol-class+ "getSymbolValue" + (emit-invokevirtual +lisp-symbol+ "getSymbolValue" nil +lisp-object+)) ((and (variable-binding-register variable) (eq (variable-compiland variable) *current-compiland*) (not (enclosed-by-runtime-bindings-creating-block-p (variable-block variable)))) (aload (variable-binding-register variable)) - (emit 'getfield +lisp-special-binding-class+ "value" + (emit-getfield +lisp-special-binding+ "value" +lisp-object+)) (t (emit-push-current-thread) - (emit-invokevirtual +lisp-symbol-class+ "symbolValue" + (emit-invokevirtual +lisp-symbol+ "symbolValue" (list +lisp-thread+) +lisp-object+))) (fix-boxing representation nil) (emit-move-from-stack target representation))) @@ -7269,10 +6154,10 @@ (eq (derive-type (%cadr form)) 'SYMBOL)) (emit-push-current-thread) (compile-form (%cadr form) 'stack nil) - (emit 'checkcast +lisp-symbol-class+) + (emit-checkcast +lisp-symbol+) (compile-form (%caddr form) 'stack nil) (maybe-emit-clear-values (%cadr form) (%caddr form)) - (emit-invokevirtual +lisp-thread-class+ "setSpecialVariable" + (emit-invokevirtual +lisp-thread+ "setSpecialVariable" (list +lisp-symbol+ +lisp-object+) +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation)) @@ -7314,7 +6199,7 @@ (aload (variable-binding-register variable)) (compile-forms-and-maybe-emit-clear-values value-form 'stack nil) (emit 'dup_x1) ;; copy past th - (emit 'putfield +lisp-special-binding-class+ "value" + (emit-putfield +lisp-special-binding+ "value" +lisp-object+)) ((and (consp value-form) (eq (first value-form) 'CONS) @@ -7324,13 +6209,13 @@ (emit-push-current-thread) (emit-load-externalized-object name) (compile-forms-and-maybe-emit-clear-values (second value-form) 'stack nil) - (emit-invokevirtual +lisp-thread-class+ "pushSpecial" + (emit-invokevirtual +lisp-thread+ "pushSpecial" (list +lisp-symbol+ +lisp-object+) +lisp-object+)) (t (emit-push-current-thread) (emit-load-externalized-object name) (compile-forms-and-maybe-emit-clear-values value-form 'stack nil) - (emit-invokevirtual +lisp-thread-class+ "setSpecialVariable" + (emit-invokevirtual +lisp-thread+ "setSpecialVariable" (list +lisp-symbol+ +lisp-object+) +lisp-object+))) (fix-boxing representation nil) (emit-move-from-stack target representation) @@ -7409,7 +6294,7 @@ (cond ((check-arg-count form 1) (let ((arg (%cadr form))) (compile-forms-and-maybe-emit-clear-values arg 'stack nil) - (emit-invokevirtual +lisp-object-class+ "sxhash" nil "I") + (emit-invokevirtual +lisp-object+ "sxhash" nil :int) (convert-representation :int representation) (emit-move-from-stack target representation))) (t @@ -7421,8 +6306,8 @@ (let ((arg (%cadr form))) (cond ((and (eq (derive-compiler-type arg) 'SYMBOL) (< *safety* 3)) (compile-forms-and-maybe-emit-clear-values arg 'stack nil) - (emit 'checkcast +lisp-symbol-class+) - (emit 'getfield +lisp-symbol-class+ "name" +lisp-simple-string+) + (emit-checkcast +lisp-symbol+) + (emit-getfield +lisp-symbol+ "name" +lisp-simple-string+) (emit-move-from-stack target representation)) (t (compile-function-call form target representation))))) @@ -7433,8 +6318,8 @@ (let ((arg (%cadr form))) (cond ((and (eq (derive-compiler-type arg) 'SYMBOL) (< *safety* 3)) (compile-forms-and-maybe-emit-clear-values arg 'stack nil) - (emit 'checkcast +lisp-symbol-class+) - (emit-invokevirtual +lisp-symbol-class+ "getPackage" + (emit-checkcast +lisp-symbol+) + (emit-invokevirtual +lisp-symbol+ "getPackage" nil +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation)) @@ -7447,9 +6332,9 @@ (let ((arg (%cadr form))) (when (eq (derive-compiler-type arg) 'SYMBOL) (compile-forms-and-maybe-emit-clear-values arg 'stack nil) - (emit 'checkcast +lisp-symbol-class+) + (emit-checkcast +lisp-symbol+) (emit-push-current-thread) - (emit-invokevirtual +lisp-symbol-class+ "symbolValue" + (emit-invokevirtual +lisp-symbol+ "symbolValue" (list +lisp-thread+) +lisp-object+) (fix-boxing representation nil) (emit-move-from-stack target representation) @@ -7462,24 +6347,24 @@ ;; The value to be checked is on the stack. (declare (type symbol expected-type)) (let ((instanceof-class (ecase expected-type - (SYMBOL +lisp-symbol-class+) - (CHARACTER +lisp-character-class+) - (CONS +lisp-cons-class+) - (HASH-TABLE +lisp-hash-table-class+) - (FIXNUM +lisp-fixnum-class+) - (STREAM +lisp-stream-class+) - (STRING +lisp-abstract-string-class+) - (VECTOR +lisp-abstract-vector-class+))) + (SYMBOL +lisp-symbol+) + (CHARACTER +lisp-character+) + (CONS +lisp-cons+) + (HASH-TABLE +lisp-hash-table+) + (FIXNUM +lisp-fixnum+) + (STREAM +lisp-stream+) + (STRING +lisp-abstract-string+) + (VECTOR +lisp-abstract-vector+))) (expected-type-java-symbol-name (case expected-type (HASH-TABLE "HASH_TABLE") (t (symbol-name expected-type)))) (LABEL1 (gensym))) (emit 'dup) - (emit 'instanceof instanceof-class) + (emit-instanceof instanceof-class) (emit 'ifne LABEL1) - (emit-getstatic +lisp-symbol-class+ expected-type-java-symbol-name +lisp-symbol+) - (emit-invokestatic +lisp-class+ "type_error" + (emit-getstatic +lisp-symbol+ expected-type-java-symbol-name +lisp-symbol+) + (emit-invokestatic +lisp+ "type_error" (lisp-object-arg-types 2) +lisp-object+) (label LABEL1)) t) @@ -7630,7 +6515,7 @@ (END-PROTECTED-RANGE (gensym)) (EXIT (gensym))) (compile-form (cadr form) 'stack nil) - (emit-invokevirtual +lisp-object-class+ "lockableInstance" nil + (emit-invokevirtual +lisp-object+ "lockableInstance" nil +java-object+) ; value to synchronize (emit 'dup) (astore object-register) @@ -7647,10 +6532,9 @@ (label EXIT) (aload object-register) (emit 'monitorexit) - (push (make-handler :from BEGIN-PROTECTED-RANGE - :to END-PROTECTED-RANGE - :code END-PROTECTED-RANGE - :catch-type 0) *handlers*))) + (add-exception-handler BEGIN-PROTECTED-RANGE + END-PROTECTED-RANGE + END-PROTECTED-RANGE nil))) (defknown p2-catch-node (t t) t) @@ -7671,7 +6555,7 @@ (compile-form (second form) tag-register nil) ; Tag. (emit-push-current-thread) (aload tag-register) - (emit-invokevirtual +lisp-thread-class+ "pushCatchTag" + (emit-invokevirtual +lisp-thread+ "pushCatchTag" (lisp-object-arg-types 1) nil) (let ((*blocks* (cons block *blocks*))) ; Stack depth is 0. @@ -7682,35 +6566,31 @@ (label THROW-HANDLER) ; Start of handler for THROW. ;; The Throw object is on the runtime stack. Stack depth is 1. (emit 'dup) ; Stack depth is 2. - (emit 'getfield +lisp-throw-class+ "tag" +lisp-object+) ; Still 2. + (emit-getfield +lisp-throw+ "tag" +lisp-object+) ; Still 2. (aload tag-register) ; Stack depth is 3. ;; If it's not the tag we're looking for, we branch to the start of the ;; catch-all handler, which will do a re-throw. (emit 'if_acmpne DEFAULT-HANDLER) ; Stack depth is 1. (emit-push-current-thread) - (emit-invokevirtual +lisp-throw-class+ "getResult" + (emit-invokevirtual +lisp-throw+ "getResult" (list +lisp-thread+) +lisp-object+) (emit-move-from-stack target) ; Stack depth is 0. (emit 'goto EXIT) (label DEFAULT-HANDLER) ; Start of handler for all other Throwables. ;; A Throwable object is on the runtime stack here. Stack depth is 1. (emit-push-current-thread) - (emit-invokevirtual +lisp-thread-class+ "popCatchTag" nil nil) + (emit-invokevirtual +lisp-thread+ "popCatchTag" nil nil) (emit 'athrow) ; Re-throw. (label EXIT) ;; Finally... (emit-push-current-thread) - (emit-invokevirtual +lisp-thread-class+ "popCatchTag" nil nil) - (let ((handler1 (make-handler :from BEGIN-PROTECTED-RANGE - :to END-PROTECTED-RANGE - :code THROW-HANDLER - :catch-type (pool-class +lisp-throw-class+))) - (handler2 (make-handler :from BEGIN-PROTECTED-RANGE - :to END-PROTECTED-RANGE - :code DEFAULT-HANDLER - :catch-type 0))) - (push handler1 *handlers*) - (push handler2 *handlers*)))) + (emit-invokevirtual +lisp-thread+ "popCatchTag" nil nil) + (add-exception-handler BEGIN-PROTECTED-RANGE + END-PROTECTED-RANGE + THROW-HANDLER +lisp-throw+) + (add-exception-handler BEGIN-PROTECTED-RANGE + END-PROTECTED-RANGE + DEFAULT-HANDLER nil))) t) (defun p2-throw (form target representation) @@ -7720,7 +6600,7 @@ (compile-form (second form) 'stack nil) ; Tag. (emit-clear-values) ; Do this unconditionally! (MISC.503) (compile-form (third form) 'stack nil) ; Result. - (emit-invokevirtual +lisp-thread-class+ "throwToTag" + (emit-invokevirtual +lisp-thread+ "throwToTag" (lisp-object-arg-types 2) nil) ;; Following code will not be reached. (when target @@ -7763,7 +6643,7 @@ (compile-form protected-form result-register nil) (unless (single-valued-p protected-form) (emit-push-current-thread) - (emit 'getfield +lisp-thread-class+ "_values" +lisp-object-array+) + (emit-getfield +lisp-thread+ "_values" +lisp-object-array+) (astore values-register)) (label END-PROTECTED-RANGE)) (let ((*register* *register*)) @@ -7776,7 +6656,7 @@ ;; The Throwable object is on the runtime stack. Stack depth is 1. (astore exception-register) (emit-push-current-thread) - (emit 'getfield +lisp-thread-class+ "_values" +lisp-object-array+) + (emit-getfield +lisp-thread+ "_values" +lisp-object-array+) (astore values-register) (let ((*register* *register*)) (dolist (subform cleanup-forms) @@ -7784,7 +6664,7 @@ (maybe-emit-clear-values cleanup-forms) (emit-push-current-thread) (aload values-register) - (emit 'putfield +lisp-thread-class+ "_values" +lisp-object-array+) + (emit-putfield +lisp-thread+ "_values" +lisp-object-array+) (aload exception-register) (emit 'athrow) ; Re-throw exception. (label EXIT) @@ -7792,15 +6672,12 @@ (unless (single-valued-p protected-form) (emit-push-current-thread) (aload values-register) - (emit 'putfield +lisp-thread-class+ "_values" +lisp-object-array+)) + (emit-putfield +lisp-thread+ "_values" +lisp-object-array+)) ;; Result. (aload result-register) (emit-move-from-stack target) - (let ((handler (make-handler :from BEGIN-PROTECTED-RANGE - :to END-PROTECTED-RANGE - :code HANDLER - :catch-type 0))) - (push handler *handlers*))))) + (add-exception-handler BEGIN-PROTECTED-RANGE + END-PROTECTED-RANGE HANDLER nil)))) (defknown compile-form (t t t) t) (defun compile-form (form target representation) @@ -7884,97 +6761,33 @@ -;; Returns descriptor. +;; Returns a list with the types of the arguments (defun analyze-args (compiland) (let* ((args (cadr (compiland-p1-result compiland))) (arg-count (length args))) (dformat t "analyze-args args = ~S~%" args) (aver (not (memq '&AUX args))) - (when *child-p* - (when (or (memq '&KEY args) - (memq '&OPTIONAL args) - (memq '&REST args)) - (setf *using-arg-array* t) - (setf *hairy-arglist-p* t) - (return-from analyze-args - (get-descriptor (list +lisp-object-array+) +lisp-object+))) - (return-from analyze-args - (cond ((<= arg-count call-registers-limit) - (get-descriptor (lisp-object-arg-types arg-count) +lisp-object+)) - (t (setf *using-arg-array* t) - (setf (compiland-arity compiland) arg-count) - (get-descriptor (list +lisp-object-array+) +lisp-object+))))) (when (or (memq '&KEY args) (memq '&OPTIONAL args) (memq '&REST args)) - (setf *using-arg-array* t) - (setf *hairy-arglist-p* t) - (return-from analyze-args - (get-descriptor (list +lisp-object-array+) +lisp-object+))) + (setf *using-arg-array* t + *hairy-arglist-p* t) + (return-from analyze-args (list +lisp-object-array+))) + (cond ((<= arg-count call-registers-limit) - (get-descriptor (lisp-object-arg-types (length args)) - +lisp-object+)) - (t - (setf *using-arg-array* t) - (setf (compiland-arity compiland) arg-count) - (get-descriptor (list +lisp-object-array+) +lisp-object+))))) + (lisp-object-arg-types arg-count)) + (t (setf *using-arg-array* t) + (setf (compiland-arity compiland) arg-count) + (list +lisp-object-array+))))) (defmacro with-open-class-file ((var class-file) &body body) `(with-open-file (,var (abcl-class-file-pathname ,class-file) - :direction :output - :element-type '(unsigned-byte 8) - :if-exists :supersede) + :direction :output + :element-type '(unsigned-byte 8) + :if-exists :supersede) , at body)) -(defun write-class-file (class-file stream) - (let* ((super (abcl-class-file-superclass class-file)) - (this-index (pool-class (abcl-class-file-class class-file))) - (super-index (pool-class super)) - (constructor (make-constructor super - (abcl-class-file-lambda-name class-file) - (abcl-class-file-lambda-list class-file)))) - (pool-name "Code") ; Must be in pool! - - (when *file-compilation* - (pool-name "SourceFile") ; Must be in pool! - (pool-name (file-namestring *compile-file-truename*))) - (when (and (boundp '*source-line-number*) - (fixnump *source-line-number*)) - (pool-name "LineNumberTable")) ; Must be in pool! - - (write-u4 #xCAFEBABE stream) - (write-u2 3 stream) - (write-u2 45 stream) - (write-constant-pool stream) - ;; access flags - (write-u2 #x21 stream) - (write-u2 this-index stream) - (write-u2 super-index stream) - ;; interfaces count - (write-u2 0 stream) - ;; fields count - (write-u2 (length *fields*) stream) - ;; fields - (dolist (field *fields*) - (write-field field stream)) - ;; methods count - (write-u2 (1+ (length (abcl-class-file-methods class-file))) stream) - ;; methods - (dolist (method (abcl-class-file-methods class-file)) - (write-method method stream)) - (write-method constructor stream) - ;; attributes count - (cond (*file-compilation* - ;; attributes count - (write-u2 1 stream) - ;; attributes table - (write-source-file-attr (file-namestring *compile-file-truename*) - stream)) - (t - ;; attributes count - (write-u2 0 stream))) - stream)) (defknown p2-compiland-process-type-declarations (list) t) (defun p2-compiland-process-type-declarations (body) @@ -8037,19 +6850,26 @@ (*child-p* (not (null (compiland-parent compiland)))) - (descriptor (analyze-args compiland)) - (execute-method (make-method :name "execute" - :descriptor descriptor)) + (arg-types (analyze-args compiland)) + (method (make-method "execute" +lisp-object+ arg-types + :flags '(:final :public))) + (code (method-add-code method)) + (*current-code-attribute* code) (*code* ()) (*register* 1) ;; register 0: "this" pointer (*registers-allocated* 1) - (*handlers* ()) (*visible-variables* *visible-variables*) (*thread* nil) (*initialize-thread-var* nil) (label-START (gensym))) + (class-add-method class-file method) + (when (fixnump *source-line-number*) + (let ((table (make-line-numbers-attribute))) + (method-add-attribute method table) + (line-numbers-add-line table 0 *source-line-number*))) + (dolist (var (compiland-arg-vars compiland)) (push var *visible-variables*)) (dolist (var (compiland-free-specials compiland)) @@ -8082,10 +6902,10 @@ (progn ;; if we're the ultimate parent: create the closure array (emit-push-constant-int (length *closure-variables*)) - (emit 'anewarray +closure-binding-class+)) + (emit-anewarray +lisp-closure-binding+)) (progn (aload 0) - (emit 'getfield +lisp-compiled-closure-class+ "ctx" + (emit-getfield +lisp-compiled-closure+ "ctx" +closure-binding-array+) (when local-closure-vars ;; in all other cases, it gets stored in the register below @@ -8109,7 +6929,7 @@ ;; we're the parent, or we have a variable to set. (emit 'dup) ; array (emit-push-constant-int i) - (emit 'new +closure-binding-class+) + (emit-new +lisp-closure-binding+) (emit 'dup) (cond ((null variable) @@ -8127,7 +6947,7 @@ (setf (variable-index variable) nil)) (t (assert (not "Can't happen!!")))) - (emit-invokespecial-init +closure-binding-class+ + (emit-invokespecial-init +lisp-closure-binding+ (list +lisp-object+)) (emit 'aastore))))) @@ -8179,7 +6999,7 @@ (emit-push-constant-int (variable-index variable)) (emit 'aaload) (setf (variable-index variable) nil))) - (emit-invokevirtual +lisp-thread-class+ "bindSpecial" + (emit-invokevirtual +lisp-thread+ "bindSpecial" (list +lisp-symbol+ +lisp-object+) +lisp-special-binding+) (astore (variable-binding-register variable))))) @@ -8221,40 +7041,22 @@ +lisp-object-array+))) (astore (compiland-argument-register compiland))) - (maybe-initialize-thread-var) + (unless (and *hairy-arglist-p* + (or (memq '&OPTIONAL args) (memq '&KEY args))) + (maybe-initialize-thread-var)) (setf *code* (nconc code *code*))) (setf (abcl-class-file-superclass class-file) (if (or *hairy-arglist-p* (and *child-p* *closure-variables*)) - +lisp-compiled-closure-class+ - +lisp-primitive-class+)) + +lisp-compiled-closure+ + +lisp-primitive+)) (setf (abcl-class-file-lambda-list class-file) args) - (setf (method-max-locals execute-method) *registers-allocated*) - (push execute-method (abcl-class-file-methods class-file)) + (setf (code-max-locals code) *registers-allocated*) + (setf (code-code code) *code*)) - ;;; Move here - (finalize-code) - (optimize-code) - - (setf *code* (resolve-instructions *code*)) - (setf (method-max-stack execute-method) (analyze-stack)) - (setf (method-code execute-method) (code-bytes *code*)) - - ;; Remove handler if its protected range is empty. - (setf *handlers* - (delete-if (lambda (handler) - (eql (symbol-value (handler-from handler)) - (symbol-value (handler-to handler)))) - *handlers*)) - ;;; to here - ;;; To a separate function which is part of class file finalization - ;;; when we have a section of class-file-generation centered code - - - (setf (method-handlers execute-method) (nreverse *handlers*))) t) (defun p2-with-inline-code (form target representation) @@ -8271,33 +7073,38 @@ (*local-functions* *local-functions*) (*current-compiland* compiland)) (with-saved-compiler-policy - ;; Pass 1. - (p1-compiland compiland) - ;; *all-variables* doesn't contain variables which - ;; are in an enclosing lexical environment (variable-environment) - ;; so we don't need to filter them out - (setf *closure-variables* - (remove-if #'variable-special-p - (remove-if-not #'variable-used-non-locally-p - *all-variables*))) - (let ((i 0)) - (dolist (var (reverse *closure-variables*)) - (setf (variable-closure-index var) i) - (dformat t "var = ~S closure index = ~S~%" (variable-name var) - (variable-closure-index var)) - (incf i))) + ;; Pass 1. + (p1-compiland compiland)) + + ;; *all-variables* doesn't contain variables which + ;; are in an enclosing lexical environment (variable-environment) + ;; so we don't need to filter them out + (setf *closure-variables* + (remove-if #'variable-special-p + (remove-if-not #'variable-used-non-locally-p + *all-variables*))) + (let ((i 0)) + (dolist (var (reverse *closure-variables*)) + (setf (variable-closure-index var) i) + (dformat t "var = ~S closure index = ~S~%" (variable-name var) + (variable-closure-index var)) + (incf i))) ;; Assert that we're not refering to any variables ;; we're not allowed to use - (assert (= 0 - (length (remove-if (complement #'variable-references) - (remove-if #'variable-references-allowed-p - *visible-variables*))))) + + (assert (= 0 + (length (remove-if (complement #'variable-references) + (remove-if #'variable-references-allowed-p + *visible-variables*))))) ;; Pass 2. - (with-class-file (compiland-class-file compiland) + + (with-class-file (compiland-class-file compiland) + (with-saved-compiler-policy (p2-compiland compiland) - (write-class-file (compiland-class-file compiland) stream))))) + ;; (finalize-class-file (compiland-class-file compiland)) + (finish-class (compiland-class-file compiland) stream))))) (defvar *compiler-error-bailout*) @@ -8311,25 +7118,26 @@ to derive a Java class name from." (aver (eq (car form) 'LAMBDA)) (catch 'compile-defun-abort - (let* ((class-file (make-class-file :pathname filespec - :lambda-name name - :lambda-list (cadr form))) + (let* ((class-file (make-abcl-class-file :pathname filespec + :lambda-name name + :lambda-list (cadr form))) (*compiler-error-bailout* `(lambda () - (compile-1 (make-compiland :name ',name - :lambda-expression (make-compiler-error-form ',form) - :class-file - (make-class-file :pathname ,filespec - :lambda-name ',name - :lambda-list (cadr ',form))) - ,stream))) + (compile-1 + (make-compiland :name ',name + :lambda-expression (make-compiler-error-form ',form) + :class-file + (make-abcl-class-file :pathname ,filespec + :lambda-name ',name + :lambda-list (cadr ',form))) + ,stream))) (*compile-file-environment* environment)) - (compile-1 (make-compiland :name name - :lambda-expression - (precompiler:precompile-form form t - environment) - :class-file class-file) - stream)))) + (compile-1 (make-compiland :name name + :lambda-expression + (precompiler:precompile-form form t + environment) + :class-file class-file) + stream)))) (defvar *catch-errors* t) Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Fri Sep 24 18:35:02 2010 @@ -42,9 +42,10 @@ (require "COMPILER-TYPES") (require "COMPILER-ERROR") (require "KNOWN-FUNCTIONS") - (require "KNOWN-SYMBOLS") (require "DUMP-FORM") - (require "OPCODES") + (require "JVM-INSTRUCTIONS") + (require "JVM-CLASS-FILE") + (require "KNOWN-SYMBOLS") (require "JAVA") (require "COMPILER-PASS1") (require "COMPILER-PASS2")) @@ -61,6 +62,40 @@ (defmacro dformat (&rest ignored) (declare (ignore ignored))) +(declaim (inline u2 s1 s2)) + +(defknown u2 (fixnum) cons) +(defun u2 (n) + (declare (optimize speed)) + (declare (type (unsigned-byte 16) n)) + (when (not (<= 0 n 65535)) + (error "u2 argument ~A out of 65k range." n)) + (list (logand (ash n -8) #xff) + (logand n #xff))) + +(defknown s1 (fixnum) fixnum) +(defun s1 (n) + (declare (optimize speed)) + (declare (type (signed-byte 8) n)) + (when (not (<= -128 n 127)) + (error "s2 argument ~A out of 16-bit signed range." n)) + (if (< n 0) + (1+ (logxor (- n) #xFF)) + n)) + + +(defknown s2 (fixnum) cons) +(defun s2 (n) + (declare (optimize speed)) + (declare (type (signed-byte 16) n)) + (when (not (<= -32768 n 32767)) + (error "s2 argument ~A out of 16-bit signed range." n)) + (u2 (if (< n 0) (1+ (logxor (- n) #xFFFF)) + n))) + + + + (defmacro with-saved-compiler-policy (&body body) "Saves compiler policy variables, restoring them after evaluating `body'." @@ -77,25 +112,18 @@ (defvar *compiler-debug* nil) (defvar *pool* nil) -(defvar *pool-count* 1) -(defvar *pool-entries* nil) -(defvar *fields* ()) (defvar *static-code* ()) +(defvar *class-file* nil) (defvar *externalized-objects* nil) (defvar *declared-functions* nil) -(defstruct (abcl-class-file (:constructor %make-abcl-class-file)) +(defstruct (abcl-class-file (:include class-file) + (:constructor %make-abcl-class-file)) pathname ; pathname of output file + class-name lambda-name - class - superclass lambda-list ; as advertised - pool - (pool-count 1) - (pool-entries (make-hash-table :test #'equal)) - fields - methods static-code objects ;; an alist of externalized objects and their field names (functions (make-hash-table :test 'equal)) ;; because of (SETF ...) functions @@ -107,20 +135,23 @@ (dotimes (i (length name)) (declare (type fixnum i)) (when (or (char= (char name i) #\-) - (char= (char name i) #\Space)) + (char= (char name i) #\Space)) (setf (char name i) #\_))) - (concatenate 'string "org/armedbear/lisp/" name))) + (make-class-name + (concatenate 'string "org.armedbear.lisp." name)))) (defun make-unique-class-name () "Creates a random class name for use with a `class-file' structure's `class' slot." - (concatenate 'string "abcl_" - (java:jcall (java:jmethod "java.lang.String" "replace" "char" "char") - (java:jcall (java:jmethod "java.util.UUID" "toString") - (java:jstatic "randomUUID" "java.util.UUID")) - #\- #\_))) + (make-class-name + (concatenate 'string "abcl_" + (substitute #\_ #\- + (java:jcall (java:jmethod "java.util.UUID" + "toString") + (java:jstatic "randomUUID" + "java.util.UUID")))))) -(defun make-class-file (&key pathname lambda-name lambda-list) +(defun make-abcl-class-file (&key pathname lambda-name lambda-list) "Creates a `class-file' structure. If `pathname' is non-NIL, it's used to derive a class name. If it is NIL, a random one created using `make-unique-class-name'." @@ -128,27 +159,28 @@ (class-name-from-filespec pathname) (make-unique-class-name))) (class-file (%make-abcl-class-file :pathname pathname - :class class-name + :class class-name ; to be finalized + :class-name class-name :lambda-name lambda-name - :lambda-list lambda-list))) + :lambda-list lambda-list + :access-flags '(:public :final)))) + (when *file-compilation* + (let ((source-attribute + (make-source-file-attribute + :filename (file-namestring *compile-file-truename*)))) + (class-add-attribute class-file source-attribute))) class-file)) (defmacro with-class-file (class-file &body body) (let ((var (gensym))) - `(let* ((,var ,class-file) - (*pool* (abcl-class-file-pool ,var)) - (*pool-count* (abcl-class-file-pool-count ,var)) - (*pool-entries* (abcl-class-file-pool-entries ,var)) - (*fields* (abcl-class-file-fields ,var)) + `(let* ((,var ,class-file) + (*class-file* ,var) + (*pool* (abcl-class-file-constants ,var)) (*static-code* (abcl-class-file-static-code ,var)) (*externalized-objects* (abcl-class-file-objects ,var)) (*declared-functions* (abcl-class-file-functions ,var))) (progn , at body) - (setf (abcl-class-file-pool ,var) *pool* - (abcl-class-file-pool-count ,var) *pool-count* - (abcl-class-file-pool-entries ,var) *pool-entries* - (abcl-class-file-fields ,var) *fields* - (abcl-class-file-static-code ,var) *static-code* + (setf (abcl-class-file-static-code ,var) *static-code* (abcl-class-file-objects ,var) *externalized-objects* (abcl-class-file-functions ,var) *declared-functions*)))) @@ -195,8 +227,6 @@ (defvar *this-class* nil) -(defvar *code* ()) - ;; All tags visible at the current point of compilation, some of which may not ;; be in the current compiland. (defvar *visible-tags* ()) @@ -207,16 +237,6 @@ ;; Total number of registers allocated. (defvar *registers-allocated* 0) -(defvar *handlers* ()) - -(defstruct handler - from ;; label indicating the start of the protected block - to ;; label indicating the end of the protected block - code ;; label to jump to if the specified exception occurs - catch-type ;; pool index of the class name of the exception, or 0 (zero) - ;; for 'all' - ) - ;; Variables visible at the current point of compilation. (defvar *visible-variables* nil "All variables visible to the form currently being Modified: trunk/abcl/src/org/armedbear/lisp/known-symbols.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/known-symbols.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/known-symbols.lisp Fri Sep 24 18:35:02 2010 @@ -38,7 +38,7 @@ (let ((symbols (make-hash-table :test 'eq :size 2048))) (defun initialize-known-symbols (source ht) (let* ((source-class (java:jclass source)) - (class-designator (substitute #\/ #\. source)) + (class-designator (jvm::make-class-name source)) (symbol-class (java:jclass "org.armedbear.lisp.Symbol")) (fields (java:jclass-fields source-class :declared t :public t))) (dotimes (i (length fields)) Modified: trunk/abcl/test/lisp/ansi/parse-ansi-errors.lisp ============================================================================== --- trunk/abcl/test/lisp/ansi/parse-ansi-errors.lisp (original) +++ trunk/abcl/test/lisp/ansi/parse-ansi-errors.lisp Fri Sep 24 18:35:02 2010 @@ -76,7 +76,7 @@ (defvar *default-database-file* (if (find :asdf2 *features*) (asdf:system-relative-pathname :ansi-compiled "test/lisp/ansi/ansi-test-failures") - (merge-pathnames "ansi-test-failures" (directory-namestring *load-truename*)))) + (merge-pathnames "ansi-test-failures" (directory-namestring *load-truename*))) (defun parse (&optional (file *default-database-file*)) (format t "Parsing test report database from ~A~%" *default-database-file*) @@ -151,4 +151,4 @@ (format t "~A[~A] --> ~A[~A] additional failures:~%~A~%" version-2 id2 version-1 id1 diff-2->1)))))) - \ No newline at end of file + From astalla at common-lisp.net Fri Sep 24 22:39:40 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Fri, 24 Sep 2010 18:39:40 -0400 Subject: [armedbear-cvs] r12919 - branches/invokedynamic Message-ID: Author: astalla Date: Fri Sep 24 18:39:39 2010 New Revision: 12919 Log: invokedynamic branch created. Added: branches/invokedynamic/ From astalla at common-lisp.net Fri Sep 24 22:53:43 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Fri, 24 Sep 2010 18:53:43 -0400 Subject: [armedbear-cvs] r12920 - branches/invokedynamic/abcl Message-ID: Author: astalla Date: Fri Sep 24 18:53:42 2010 New Revision: 12920 Log: Copy trunk to invokedynamic branch Added: branches/invokedynamic/abcl/ - copied from r12919, /trunk/abcl/ From astalla at common-lisp.net Sat Sep 25 00:36:30 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Fri, 24 Sep 2010 20:36:30 -0400 Subject: [armedbear-cvs] r12921 - in branches/invokedynamic/abcl: . src/org/armedbear/lisp Message-ID: Author: astalla Date: Fri Sep 24 20:36:29 2010 New Revision: 12921 Log: preliminary test of invokedynamic (Java only, no compiler integration) Modified: branches/invokedynamic/abcl/build.xml branches/invokedynamic/abcl/src/org/armedbear/lisp/Function.java branches/invokedynamic/abcl/src/org/armedbear/lisp/LispObject.java branches/invokedynamic/abcl/src/org/armedbear/lisp/Main.java branches/invokedynamic/abcl/src/org/armedbear/lisp/Symbol.java Modified: branches/invokedynamic/abcl/build.xml ============================================================================== --- branches/invokedynamic/abcl/build.xml (original) +++ branches/invokedynamic/abcl/build.xml Fri Sep 24 20:36:29 2010 @@ -175,7 +175,7 @@ @@ -246,6 +246,8 @@ inputstring="(handler-case (compile-system :zip nil :quit t :output-path "${abcl.lisp.output}/") (t (x) (progn (format t "~A: ~A~%" (type-of x) x) (exit :status -1))))" classname="org.armedbear.lisp.Main"> + + Modified: branches/invokedynamic/abcl/src/org/armedbear/lisp/Function.java ============================================================================== --- branches/invokedynamic/abcl/src/org/armedbear/lisp/Function.java (original) +++ branches/invokedynamic/abcl/src/org/armedbear/lisp/Function.java Fri Sep 24 20:36:29 2010 @@ -33,6 +33,8 @@ package org.armedbear.lisp; +import java.dyn.CallSite; +import java.dyn.MethodType; import static org.armedbear.lisp.Lisp.*; public abstract class Function extends Operator @@ -393,4 +395,10 @@ { ++hotCount; } + + public static CallSite linkLispFunction(Class caller, String name, MethodType type) { + System.out.println("Linking " + name + " " + caller + " " + type); + CallSite c = ((Symbol) Lisp.readObjectFromString(name)).addCallSite(type); + return c; + } } Modified: branches/invokedynamic/abcl/src/org/armedbear/lisp/LispObject.java ============================================================================== --- branches/invokedynamic/abcl/src/org/armedbear/lisp/LispObject.java (original) +++ branches/invokedynamic/abcl/src/org/armedbear/lisp/LispObject.java Fri Sep 24 20:36:29 2010 @@ -33,8 +33,12 @@ package org.armedbear.lisp; +import java.dyn.MethodHandle; +import java.dyn.MethodHandles; +import java.dyn.MethodType; import static org.armedbear.lisp.Lisp.*; import java.util.WeakHashMap; +import sun.dyn.Access; public class LispObject //extends Lisp { @@ -838,6 +842,18 @@ return type_error(this, Symbol.FUNCTION); } + public MethodHandle asMethodHandle(MethodType type) { + /*Class[] params = new Class[type.parameterCount()]; + if(params.length == 1 && type.parameterType(0).isArray()) { + params[0] = LispObject[].class; + } else for(int i = 0; i < params.length; i++) { + params[i] = LispObject.class; + }*/ + MethodHandle mh = MethodHandles.lookup().findVirtual(getClass(), "execute", type.changeReturnType(LispObject.class)); + mh = MethodHandles.insertArguments(mh, 0, this); + return mh;//MethodType.methodType(LispObject.class, params)); + } + // Used by COMPILE-MULTIPLE-VALUE-CALL. public LispObject dispatch(LispObject[] args) { Modified: branches/invokedynamic/abcl/src/org/armedbear/lisp/Main.java ============================================================================== --- branches/invokedynamic/abcl/src/org/armedbear/lisp/Main.java (original) +++ branches/invokedynamic/abcl/src/org/armedbear/lisp/Main.java Fri Sep 24 20:36:29 2010 @@ -33,10 +33,15 @@ package org.armedbear.lisp; +import java.dyn.InvokeDynamic; +import java.dyn.Linkage; + public final class Main { public static final long startTimeMillis = System.currentTimeMillis(); + static { Linkage.registerBootstrapMethod(Function.class, "linkLispFunction"); } + public static void main(final String[] args) { // Run the interpreter in a secondary thread so we can control the stack @@ -51,5 +56,16 @@ } }; new Thread(null, r, "interpreter", 4194304L).start(); + try { + for(int i = 0; i < 2; i++) { + Thread.sleep(5000); + InvokeDynamic.#"COMMON-LISP:PRINT"((LispObject) new SimpleString("foo")); + InvokeDynamic.#"COMMON-LISP:PRINT"((LispObject) new SimpleString("bar")); + InvokeDynamic.#"CL-USER::FOO"((LispObject) new SimpleString("baz")); + } + } catch(Throwable t) { + t.printStackTrace(); + } + //java.dyn.InvokeDynamic.foo(new SimpleString("foo")); } } Modified: branches/invokedynamic/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- branches/invokedynamic/abcl/src/org/armedbear/lisp/Symbol.java (original) +++ branches/invokedynamic/abcl/src/org/armedbear/lisp/Symbol.java Fri Sep 24 20:36:29 2010 @@ -33,6 +33,11 @@ package org.armedbear.lisp; +import java.dyn.CallSite; +import java.dyn.MethodType; +import java.util.Collections; +import java.util.Set; +import java.util.WeakHashMap; import static org.armedbear.lisp.Lisp.*; public class Symbol extends LispObject implements java.io.Serializable @@ -61,6 +66,7 @@ private transient LispObject function; private transient LispObject propertyList; private int flags; + private final Set callSites = Collections.newSetFromMap(new WeakHashMap()); //Weak, is it correct? // Construct an uninterned symbol. public Symbol(String s) @@ -94,6 +100,15 @@ this.pkg = pkg; } + public CallSite addCallSite(MethodType type) { + LispObject f = getSymbolFunctionOrDie(); + CallSite c = new CallSite(f.asMethodHandle(type)); + synchronized(callSites) { + callSites.add(c); + } + return c; + } + @Override public LispObject typeOf() { @@ -404,7 +419,12 @@ public final void setSymbolFunction(LispObject obj) { - this.function = obj; + synchronized(callSites) { + this.function = obj; + for(CallSite c : callSites) { + c.setTarget(this.function.asMethodHandle(c.getTarget().type())); + } + } } /** See LispObject.getStringValue() */ From ehuelsmann at common-lisp.net Sat Sep 25 10:10:24 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 25 Sep 2010 06:10:24 -0400 Subject: [armedbear-cvs] r12922 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Sep 25 06:10:22 2010 New Revision: 12922 Log: Factor out common code and add documentation to indicate which part of the CLHS it's implementing. Modified: trunk/abcl/src/org/armedbear/lisp/MathFunctions.java Modified: trunk/abcl/src/org/armedbear/lisp/MathFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/MathFunctions.java (original) +++ trunk/abcl/src/org/armedbear/lisp/MathFunctions.java Sat Sep 25 06:10:22 2010 @@ -37,6 +37,24 @@ public final class MathFunctions { + + // Implementation of section 12.1.5.3, which says: + // "If the result of any computation would be a complex number whose + // real part is of type rational and whose imaginary part is zero, + // the result is converted to the rational which is the real part." + private static final LispObject complexToRealFixup(LispObject result, + LispObject arg) + { + if (result instanceof Complex + && ! (arg instanceof Complex)) { + Complex c = (Complex)result; + LispObject im = c.getImaginaryPart(); + if (im.zerop()) + return c.getRealPart(); + } + return result; + } + // ### sin private static final Primitive SIN = new Primitive("sin", "radians") { @@ -135,14 +153,8 @@ result = log(result); result = result.multiplyBy(Complex.getInstance(Fixnum.ZERO, Fixnum.MINUS_ONE)); - if (result instanceof Complex) { - if (arg instanceof Complex) - return result; - LispObject im = ((Complex)result).getImaginaryPart(); - if (im.zerop()) - return ((Complex)result).getRealPart(); - } - return result; + + return complexToRealFixup(result, arg); } // ### acos @@ -177,14 +189,8 @@ result = new SingleFloat((float)((DoubleFloat)result).value); } result = result.subtract(asin(arg)); - if (result instanceof Complex) { - if (arg instanceof Complex) - return result; - LispObject im = ((Complex)result).getImaginaryPart(); - if (im.zerop()) - return ((Complex)result).getRealPart(); - } - return result; + + return complexToRealFixup(result, arg); } // ### atan @@ -277,14 +283,8 @@ LispObject result = exp(arg); result = result.subtract(exp(arg.multiplyBy(Fixnum.MINUS_ONE))); result = result.divideBy(Fixnum.TWO); - if (result instanceof Complex) { - if (arg instanceof Complex) - return result; - LispObject im = ((Complex)result).getImaginaryPart(); - if (im.zerop()) - return ((Complex)result).getRealPart(); - } - return result; + + return complexToRealFixup(result, arg); } // ### cosh @@ -315,14 +315,8 @@ LispObject result = exp(arg); result = result.add(exp(arg.multiplyBy(Fixnum.MINUS_ONE))); result = result.divideBy(Fixnum.TWO); - if (result instanceof Complex) { - if (arg instanceof Complex) - return result; - LispObject im = ((Complex)result).getImaginaryPart(); - if (im.zerop()) - return ((Complex)result).getRealPart(); - } - return result; + + return complexToRealFixup(result, arg); } // ### tanh @@ -365,14 +359,8 @@ result = sqrt(result); result = result.add(arg); result = log(result); - if (result instanceof Complex) { - if (arg instanceof Complex) - return result; - LispObject im = ((Complex)result).getImaginaryPart(); - if (im.zerop()) - return ((Complex)result).getRealPart(); - } - return result; + + return complexToRealFixup(result, arg); } // ### acosh @@ -402,14 +390,8 @@ LispObject result = n1.add(n2); result = log(result); result = result.multiplyBy(Fixnum.TWO); - if (result instanceof Complex) { - if (arg instanceof Complex) - return result; - LispObject im = ((Complex)result).getImaginaryPart(); - if (im.zerop()) - return ((Complex)result).getRealPart(); - } - return result; + + return complexToRealFixup(result, arg); } // ### atanh @@ -434,14 +416,8 @@ LispObject n2 = log(Fixnum.ONE.subtract(arg)); LispObject result = n1.subtract(n2); result = result.divideBy(Fixnum.TWO); - if (result instanceof Complex) { - if (arg instanceof Complex) - return result; - LispObject im = ((Complex)result).getImaginaryPart(); - if (im.zerop()) - return ((Complex)result).getRealPart(); - } - return result; + + return complexToRealFixup(result, arg); } // ### cis From ehuelsmann at common-lisp.net Sun Sep 26 14:02:57 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 26 Sep 2010 10:02:57 -0400 Subject: [armedbear-cvs] r12923 - public_html/releases Message-ID: Author: ehuelsmann Date: Sun Sep 26 10:02:53 2010 New Revision: 12923 Log: Add 0.22.0 release archives. Added: public_html/releases/abcl-bin-0.22.0.tar.gz (contents, props changed) public_html/releases/abcl-bin-0.22.0.tar.gz.asc public_html/releases/abcl-bin-0.22.0.zip (contents, props changed) public_html/releases/abcl-bin-0.22.0.zip.asc public_html/releases/abcl-src-0.22.0.tar.gz (contents, props changed) public_html/releases/abcl-src-0.22.0.tar.gz.asc public_html/releases/abcl-src-0.22.0.zip (contents, props changed) public_html/releases/abcl-src-0.22.0.zip.asc Added: public_html/releases/abcl-bin-0.22.0.tar.gz ============================================================================== Binary file. No diff available. Added: public_html/releases/abcl-bin-0.22.0.tar.gz.asc ============================================================================== --- (empty file) +++ public_html/releases/abcl-bin-0.22.0.tar.gz.asc Sun Sep 26 10:02:53 2010 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAkyfRooACgkQi5O0Epaz9Tk1AgCdFSh2OKb5DOxTSANVhGoG9Ohs +FMEAn1TPKFod4rfNVwy6lerQLa2Yt512 +=Hdmf +-----END PGP SIGNATURE----- Added: public_html/releases/abcl-bin-0.22.0.zip ============================================================================== Binary file. No diff available. Added: public_html/releases/abcl-bin-0.22.0.zip.asc ============================================================================== --- (empty file) +++ public_html/releases/abcl-bin-0.22.0.zip.asc Sun Sep 26 10:02:53 2010 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAkyfRpIACgkQi5O0Epaz9TlIrwCfXVJaMJ5z0OYAFHpNF2WHAkBY +uGkAniG4i6Y2CZ4f6w9w77icDIaxr0xU +=YT3f +-----END PGP SIGNATURE----- Added: public_html/releases/abcl-src-0.22.0.tar.gz ============================================================================== Binary file. No diff available. Added: public_html/releases/abcl-src-0.22.0.tar.gz.asc ============================================================================== --- (empty file) +++ public_html/releases/abcl-src-0.22.0.tar.gz.asc Sun Sep 26 10:02:53 2010 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAkyfRp4ACgkQi5O0Epaz9Tn1IACfQl8X3FtDfu42bzPRZ18S4Bjp +UIwAnim18FumbP6GW+885WKWntOhT4Ug +=9HIh +-----END PGP SIGNATURE----- Added: public_html/releases/abcl-src-0.22.0.zip ============================================================================== Binary file. No diff available. Added: public_html/releases/abcl-src-0.22.0.zip.asc ============================================================================== --- (empty file) +++ public_html/releases/abcl-src-0.22.0.zip.asc Sun Sep 26 10:02:53 2010 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAkyfRqYACgkQi5O0Epaz9TkLwACfWr7GLgRMVkfAELQs/ixJw3M7 +FVcAn3IScctEerOlhwKOCEVJOzCXKAvD +=oX77 +-----END PGP SIGNATURE----- From ehuelsmann at common-lisp.net Sun Sep 26 17:30:36 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 26 Sep 2010 13:30:36 -0400 Subject: [armedbear-cvs] r12924 - in public_html/releases: . older-releases older-releases/0.16.0 older-releases/0.16.1 older-releases/0.17.0 older-releases/0.18.0 older-releases/0.18.1 older-releases/0.19.1 Message-ID: Author: ehuelsmann Date: Sun Sep 26 13:30:22 2010 New Revision: 12924 Log: Reorganize releases into an older releases directory; this allows us to keep only the three most recent ones at top level. Added: public_html/releases/older-releases/ public_html/releases/older-releases/0.16.0/ public_html/releases/older-releases/0.16.0/abcl-src-0.16.0.tar.gz - copied unchanged from r12916, /public_html/releases/abcl-src-0.16.0.tar.gz public_html/releases/older-releases/0.16.0/abcl-src-0.16.0.tar.gz.asc - copied unchanged from r12916, /public_html/releases/abcl-src-0.16.0.tar.gz.asc public_html/releases/older-releases/0.16.0/abcl-src-0.16.0.zip - copied unchanged from r12916, /public_html/releases/abcl-src-0.16.0.zip public_html/releases/older-releases/0.16.0/abcl-src-0.16.0.zip.asc - copied unchanged from r12916, /public_html/releases/abcl-src-0.16.0.zip.asc public_html/releases/older-releases/0.16.1/ public_html/releases/older-releases/0.16.1/abcl-src-0.16.1.tar.gz - copied unchanged from r12916, /public_html/releases/abcl-src-0.16.1.tar.gz public_html/releases/older-releases/0.16.1/abcl-src-0.16.1.tar.gz.asc - copied unchanged from r12916, /public_html/releases/abcl-src-0.16.1.tar.gz.asc public_html/releases/older-releases/0.16.1/abcl-src-0.16.1.zip - copied unchanged from r12916, /public_html/releases/abcl-src-0.16.1.zip public_html/releases/older-releases/0.16.1/abcl-src-0.16.1.zip.asc - copied unchanged from r12916, /public_html/releases/abcl-src-0.16.1.zip.asc public_html/releases/older-releases/0.17.0/ public_html/releases/older-releases/0.17.0/abcl-bin-0.17.0.tar.gz - copied unchanged from r12916, /public_html/releases/abcl-bin-0.17.0.tar.gz public_html/releases/older-releases/0.17.0/abcl-bin-0.17.0.tar.gz.asc - copied unchanged from r12916, /public_html/releases/abcl-bin-0.17.0.tar.gz.asc public_html/releases/older-releases/0.17.0/abcl-bin-0.17.0.zip - copied unchanged from r12916, /public_html/releases/abcl-bin-0.17.0.zip public_html/releases/older-releases/0.17.0/abcl-bin-0.17.0.zip.asc - copied unchanged from r12916, /public_html/releases/abcl-bin-0.17.0.zip.asc public_html/releases/older-releases/0.17.0/abcl-src-0.17.0.tar.gz - copied unchanged from r12916, /public_html/releases/abcl-src-0.17.0.tar.gz public_html/releases/older-releases/0.17.0/abcl-src-0.17.0.tar.gz.asc - copied unchanged from r12916, /public_html/releases/abcl-src-0.17.0.tar.gz.asc public_html/releases/older-releases/0.17.0/abcl-src-0.17.0.zip - copied unchanged from r12916, /public_html/releases/abcl-src-0.17.0.zip public_html/releases/older-releases/0.17.0/abcl-src-0.17.0.zip.asc - copied unchanged from r12916, /public_html/releases/abcl-src-0.17.0.zip.asc public_html/releases/older-releases/0.18.0/ public_html/releases/older-releases/0.18.0/abcl-bin-0.18.0.tar.gz - copied unchanged from r12916, /public_html/releases/abcl-bin-0.18.0.tar.gz public_html/releases/older-releases/0.18.0/abcl-bin-0.18.0.tar.gz.asc - copied unchanged from r12916, /public_html/releases/abcl-bin-0.18.0.tar.gz.asc public_html/releases/older-releases/0.18.0/abcl-bin-0.18.0.zip - copied unchanged from r12916, /public_html/releases/abcl-bin-0.18.0.zip public_html/releases/older-releases/0.18.0/abcl-bin-0.18.0.zip.asc - copied unchanged from r12916, /public_html/releases/abcl-bin-0.18.0.zip.asc public_html/releases/older-releases/0.18.0/abcl-src-0.18.0.tar.gz - copied unchanged from r12916, /public_html/releases/abcl-src-0.18.0.tar.gz public_html/releases/older-releases/0.18.0/abcl-src-0.18.0.tar.gz.asc - copied unchanged from r12916, /public_html/releases/abcl-src-0.18.0.tar.gz.asc public_html/releases/older-releases/0.18.0/abcl-src-0.18.0.zip - copied unchanged from r12916, /public_html/releases/abcl-src-0.18.0.zip public_html/releases/older-releases/0.18.0/abcl-src-0.18.0.zip.asc - copied unchanged from r12916, /public_html/releases/abcl-src-0.18.0.zip.asc public_html/releases/older-releases/0.18.1/ public_html/releases/older-releases/0.18.1/abcl-bin-0.18.1.tar.gz - copied unchanged from r12916, /public_html/releases/abcl-bin-0.18.1.tar.gz public_html/releases/older-releases/0.18.1/abcl-bin-0.18.1.tar.gz.asc - copied unchanged from r12916, /public_html/releases/abcl-bin-0.18.1.tar.gz.asc public_html/releases/older-releases/0.18.1/abcl-bin-0.18.1.zip - copied unchanged from r12916, /public_html/releases/abcl-bin-0.18.1.zip public_html/releases/older-releases/0.18.1/abcl-bin-0.18.1.zip.asc - copied unchanged from r12916, /public_html/releases/abcl-bin-0.18.1.zip.asc public_html/releases/older-releases/0.18.1/abcl-src-0.18.1.tar.gz - copied unchanged from r12916, /public_html/releases/abcl-src-0.18.1.tar.gz public_html/releases/older-releases/0.18.1/abcl-src-0.18.1.tar.gz.asc - copied unchanged from r12916, /public_html/releases/abcl-src-0.18.1.tar.gz.asc public_html/releases/older-releases/0.18.1/abcl-src-0.18.1.zip - copied unchanged from r12916, /public_html/releases/abcl-src-0.18.1.zip public_html/releases/older-releases/0.18.1/abcl-src-0.18.1.zip.asc - copied unchanged from r12916, /public_html/releases/abcl-src-0.18.1.zip.asc public_html/releases/older-releases/0.19.1/ public_html/releases/older-releases/0.19.1/abcl-bin-0.19.1.tar.gz - copied unchanged from r12916, /public_html/releases/abcl-bin-0.19.1.tar.gz public_html/releases/older-releases/0.19.1/abcl-bin-0.19.1.tar.gz.asc - copied unchanged from r12916, /public_html/releases/abcl-bin-0.19.1.tar.gz.asc public_html/releases/older-releases/0.19.1/abcl-bin-0.19.1.zip - copied unchanged from r12916, /public_html/releases/abcl-bin-0.19.1.zip public_html/releases/older-releases/0.19.1/abcl-bin-0.19.1.zip.asc - copied unchanged from r12916, /public_html/releases/abcl-bin-0.19.1.zip.asc public_html/releases/older-releases/0.19.1/abcl-src-0.19.1.tar.gz - copied unchanged from r12916, /public_html/releases/abcl-src-0.19.1.tar.gz public_html/releases/older-releases/0.19.1/abcl-src-0.19.1.tar.gz.asc - copied unchanged from r12916, /public_html/releases/abcl-src-0.19.1.tar.gz.asc public_html/releases/older-releases/0.19.1/abcl-src-0.19.1.zip - copied unchanged from r12916, /public_html/releases/abcl-src-0.19.1.zip public_html/releases/older-releases/0.19.1/abcl-src-0.19.1.zip.asc - copied unchanged from r12916, /public_html/releases/abcl-src-0.19.1.zip.asc Removed: public_html/releases/abcl-bin-0.17.0.tar.gz public_html/releases/abcl-bin-0.17.0.tar.gz.asc public_html/releases/abcl-bin-0.17.0.zip public_html/releases/abcl-bin-0.17.0.zip.asc public_html/releases/abcl-bin-0.18.0.tar.gz public_html/releases/abcl-bin-0.18.0.tar.gz.asc public_html/releases/abcl-bin-0.18.0.zip public_html/releases/abcl-bin-0.18.0.zip.asc public_html/releases/abcl-bin-0.18.1.tar.gz public_html/releases/abcl-bin-0.18.1.tar.gz.asc public_html/releases/abcl-bin-0.18.1.zip public_html/releases/abcl-bin-0.18.1.zip.asc public_html/releases/abcl-bin-0.19.1.tar.gz public_html/releases/abcl-bin-0.19.1.tar.gz.asc public_html/releases/abcl-bin-0.19.1.zip public_html/releases/abcl-bin-0.19.1.zip.asc public_html/releases/abcl-src-0.16.0.tar.gz public_html/releases/abcl-src-0.16.0.tar.gz.asc public_html/releases/abcl-src-0.16.0.zip public_html/releases/abcl-src-0.16.0.zip.asc public_html/releases/abcl-src-0.16.1.tar.gz public_html/releases/abcl-src-0.16.1.tar.gz.asc public_html/releases/abcl-src-0.16.1.zip public_html/releases/abcl-src-0.16.1.zip.asc public_html/releases/abcl-src-0.17.0.tar.gz public_html/releases/abcl-src-0.17.0.tar.gz.asc public_html/releases/abcl-src-0.17.0.zip public_html/releases/abcl-src-0.17.0.zip.asc public_html/releases/abcl-src-0.18.0.tar.gz public_html/releases/abcl-src-0.18.0.tar.gz.asc public_html/releases/abcl-src-0.18.0.zip public_html/releases/abcl-src-0.18.0.zip.asc public_html/releases/abcl-src-0.18.1.tar.gz public_html/releases/abcl-src-0.18.1.tar.gz.asc public_html/releases/abcl-src-0.18.1.zip public_html/releases/abcl-src-0.18.1.zip.asc public_html/releases/abcl-src-0.19.1.tar.gz public_html/releases/abcl-src-0.19.1.tar.gz.asc public_html/releases/abcl-src-0.19.1.zip public_html/releases/abcl-src-0.19.1.zip.asc From ehuelsmann at common-lisp.net Sun Sep 26 17:39:24 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 26 Sep 2010 13:39:24 -0400 Subject: [armedbear-cvs] r12925 - in public_html: . releases releases/0.20.0 releases/0.21.0 releases/0.22.0 Message-ID: Author: ehuelsmann Date: Sun Sep 26 13:39:13 2010 New Revision: 12925 Log: Publish 0.22 on the front page. Added: public_html/release-notes-0.22.shtml (contents, props changed) public_html/releases/0.20.0/ public_html/releases/0.20.0/abcl-bin-0.20.0.tar.gz - copied unchanged from r12916, /public_html/releases/abcl-bin-0.20.0.tar.gz public_html/releases/0.20.0/abcl-bin-0.20.0.tar.gz.asc - copied unchanged from r12916, /public_html/releases/abcl-bin-0.20.0.tar.gz.asc public_html/releases/0.20.0/abcl-bin-0.20.0.zip - copied unchanged from r12916, /public_html/releases/abcl-bin-0.20.0.zip public_html/releases/0.20.0/abcl-bin-0.20.0.zip.asc - copied unchanged from r12916, /public_html/releases/abcl-bin-0.20.0.zip.asc public_html/releases/0.20.0/abcl-src-0.20.0.tar.gz - copied unchanged from r12916, /public_html/releases/abcl-src-0.20.0.tar.gz public_html/releases/0.20.0/abcl-src-0.20.0.tar.gz.asc - copied unchanged from r12916, /public_html/releases/abcl-src-0.20.0.tar.gz.asc public_html/releases/0.20.0/abcl-src-0.20.0.zip - copied unchanged from r12916, /public_html/releases/abcl-src-0.20.0.zip public_html/releases/0.20.0/abcl-src-0.20.0.zip.asc - copied unchanged from r12916, /public_html/releases/abcl-src-0.20.0.zip.asc public_html/releases/0.21.0/ public_html/releases/0.21.0/abcl-bin-0.21.0.tar.gz - copied unchanged from r12916, /public_html/releases/abcl-bin-0.21.0.tar.gz public_html/releases/0.21.0/abcl-bin-0.21.0.tar.gz.asc - copied unchanged from r12916, /public_html/releases/abcl-bin-0.21.0.tar.gz.asc public_html/releases/0.21.0/abcl-bin-0.21.0.zip - copied unchanged from r12916, /public_html/releases/abcl-bin-0.21.0.zip public_html/releases/0.21.0/abcl-bin-0.21.0.zip.asc - copied unchanged from r12916, /public_html/releases/abcl-bin-0.21.0.zip.asc public_html/releases/0.21.0/abcl-src-0.21.0.tar.gz - copied unchanged from r12916, /public_html/releases/abcl-src-0.21.0.tar.gz public_html/releases/0.21.0/abcl-src-0.21.0.tar.gz.asc - copied unchanged from r12916, /public_html/releases/abcl-src-0.21.0.tar.gz.asc public_html/releases/0.21.0/abcl-src-0.21.0.zip - copied unchanged from r12916, /public_html/releases/abcl-src-0.21.0.zip public_html/releases/0.21.0/abcl-src-0.21.0.zip.asc - copied unchanged from r12916, /public_html/releases/abcl-src-0.21.0.zip.asc public_html/releases/0.22.0/ public_html/releases/0.22.0/abcl-bin-0.22.0.tar.gz - copied unchanged from r12923, /public_html/releases/abcl-bin-0.22.0.tar.gz public_html/releases/0.22.0/abcl-bin-0.22.0.tar.gz.asc - copied unchanged from r12923, /public_html/releases/abcl-bin-0.22.0.tar.gz.asc public_html/releases/0.22.0/abcl-bin-0.22.0.zip - copied unchanged from r12923, /public_html/releases/abcl-bin-0.22.0.zip public_html/releases/0.22.0/abcl-bin-0.22.0.zip.asc - copied unchanged from r12923, /public_html/releases/abcl-bin-0.22.0.zip.asc public_html/releases/0.22.0/abcl-src-0.22.0.tar.gz - copied unchanged from r12923, /public_html/releases/abcl-src-0.22.0.tar.gz public_html/releases/0.22.0/abcl-src-0.22.0.tar.gz.asc - copied unchanged from r12923, /public_html/releases/abcl-src-0.22.0.tar.gz.asc public_html/releases/0.22.0/abcl-src-0.22.0.zip - copied unchanged from r12923, /public_html/releases/abcl-src-0.22.0.zip public_html/releases/0.22.0/abcl-src-0.22.0.zip.asc - copied unchanged from r12923, /public_html/releases/abcl-src-0.22.0.zip.asc Removed: public_html/releases/abcl-bin-0.20.0.tar.gz public_html/releases/abcl-bin-0.20.0.tar.gz.asc public_html/releases/abcl-bin-0.20.0.zip public_html/releases/abcl-bin-0.20.0.zip.asc public_html/releases/abcl-bin-0.21.0.tar.gz public_html/releases/abcl-bin-0.21.0.tar.gz.asc public_html/releases/abcl-bin-0.21.0.zip public_html/releases/abcl-bin-0.21.0.zip.asc public_html/releases/abcl-bin-0.22.0.tar.gz public_html/releases/abcl-bin-0.22.0.tar.gz.asc public_html/releases/abcl-bin-0.22.0.zip public_html/releases/abcl-bin-0.22.0.zip.asc public_html/releases/abcl-src-0.20.0.tar.gz public_html/releases/abcl-src-0.20.0.tar.gz.asc public_html/releases/abcl-src-0.20.0.zip public_html/releases/abcl-src-0.20.0.zip.asc public_html/releases/abcl-src-0.21.0.tar.gz public_html/releases/abcl-src-0.21.0.tar.gz.asc public_html/releases/abcl-src-0.21.0.zip public_html/releases/abcl-src-0.21.0.zip.asc public_html/releases/abcl-src-0.22.0.tar.gz public_html/releases/abcl-src-0.22.0.tar.gz.asc public_html/releases/abcl-src-0.22.0.zip public_html/releases/abcl-src-0.22.0.zip.asc Modified: public_html/index.shtml public_html/left-menu Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Sun Sep 26 13:39:13 2010 @@ -61,24 +61,24 @@ Binary - abcl-bin-0.21.0.tar.gz - (pgp) + abcl-bin-0.22.0.tar.gz + (pgp) - abcl-bin-0.21.0.zip - (pgp) + abcl-bin-0.22.0.zip + (pgp) Source - abcl-src-0.21.0.tar.gz - (pgp) + abcl-src-0.22.0.tar.gz + (pgp) - abcl-src-0.21.0.zip - (pgp) + abcl-src-0.22.0.zip + (pgp) Modified: public_html/left-menu ============================================================================== --- public_html/left-menu (original) +++ public_html/left-menu Sun Sep 26 13:39:13 2010 @@ -1,7 +1,7 @@
Project page
Testimonials
-Release notes
+Release notes
Paid support
Added: public_html/release-notes-0.22.shtml ============================================================================== --- (empty file) +++ public_html/release-notes-0.22.shtml Sun Sep 26 13:39:13 2010 @@ -0,0 +1,49 @@ + + + + + ABCL - Release notes v0.21 + + + + + +
+

ABCL - Release notes for version 0.22

+
+ + + +
+ +

Most notable changes in ABCL 0.22

+ + +

Release notes for older releases.

+ +
+
Fix reading non-UTF8 characters on UTF-8 input streams.
+
Some non-conformant characters on UTF-8 input streams cause java's + CharsetDecoder to cause infinite loops. Detection and handling of those + situations has been added. +
+
DOCUMENTATION + not autoloaded
+
The function DOCUMENTATION wasn't autoloaded on first use.
+
+ + + + +
+
+

Back to Common-lisp.net.

+ +
+ Valid XHTML 1.0 Strict +
+
$Id$
+
+ + From vvoutilainen at common-lisp.net Mon Sep 27 20:31:44 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Mon, 27 Sep 2010 16:31:44 -0400 Subject: [armedbear-cvs] r12926 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Mon Sep 27 16:31:43 2010 New Revision: 12926 Log: This patch fixes these two issues in ABCL 0.22.0: 1) Keyword evaluation in the repl is broken. The repl assumes all keywords are, in fact, repl commands. 2) Repl commands are case sensitive: :help :HELP mean two different things. Patch by Mahmud Mohamed. On behalf of abcl developers, welcome aboard! Modified: trunk/abcl/src/org/armedbear/lisp/top-level.lisp Modified: trunk/abcl/src/org/armedbear/lisp/top-level.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/top-level.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/top-level.lisp Mon Sep 27 16:31:43 2010 @@ -348,8 +348,8 @@ (setf string (subseq string 1) len (1- len))) (dolist (entry *command-table*) - (when (or (string= string (entry-abbreviation entry)) - (string= string (entry-name entry))) + (when (or (string-equal string (entry-abbreviation entry)) + (string-equal string (entry-name entry))) (return (entry-command entry)))))) (defun process-cmd (form) @@ -376,13 +376,17 @@ (defun read-cmd (stream) (let ((c (peek-char-non-whitespace stream))) - (cond ((eql c *command-char*) - (read-line stream)) - ((eql c #\newline) - (read-line stream) - *null-cmd*) - (t - (read stream nil))))) + (if (eql c #\Newline) + (progn + (read-line stream) + *null-cmd*) + (let ((input (read stream nil))) + (if (not (keywordp input)) + input + (let ((name (string-downcase (symbol-name input)))) + (if (find-command name) + (concatenate 'string ":" name) + input))))))) (defun repl-read-form-fun (in out) (loop From astalla at common-lisp.net Mon Sep 27 21:49:42 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Mon, 27 Sep 2010 17:49:42 -0400 Subject: [armedbear-cvs] r12927 - trunk/abcl/src/org/armedbear/lisp/scripting/lisp Message-ID: Author: astalla Date: Mon Sep 27 17:49:41 2010 New Revision: 12927 Log: Fixed JSR-223 breakage: a file was still referring to ext:make-thread instead of threads:make-thread Modified: trunk/abcl/src/org/armedbear/lisp/scripting/lisp/config.lisp Modified: trunk/abcl/src/org/armedbear/lisp/scripting/lisp/config.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/scripting/lisp/config.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/scripting/lisp/config.lisp Mon Sep 27 17:49:41 2010 @@ -47,7 +47,7 @@ (error "Swank directory not specified, please set *swank-dir*")) (pushnew *swank-dir* asdf:*central-registry* :test #'equal) (asdf:oos 'asdf:load-op :swank) - (ext:make-thread (lambda () (funcall (find-symbol + (threads:make-thread (lambda () (funcall (find-symbol (symbol-name '#:create-server) :swank) :port *swank-port*)) From astalla at common-lisp.net Tue Sep 28 18:21:09 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Tue, 28 Sep 2010 14:21:09 -0400 Subject: [armedbear-cvs] r12928 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Tue Sep 28 14:21:06 2010 New Revision: 12928 Log: Fixes in java collections support (iterators) and dosequence (wrong call to parse-body) Modified: trunk/abcl/src/org/armedbear/lisp/extensible-sequences.lisp trunk/abcl/src/org/armedbear/lisp/java-collections.lisp Modified: trunk/abcl/src/org/armedbear/lisp/extensible-sequences.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/extensible-sequences.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/extensible-sequences.lisp Tue Sep 28 14:21:06 2010 @@ -996,7 +996,7 @@ ;; just like DOLIST, but with one-dimensional arrays (defmacro dovector ((elt vector &optional result) &body body) (multiple-value-bind (forms decls) - (sys:parse-body body :doc-string-allowed nil) + (sys:parse-body body nil) (let ((index (gensym "INDEX")) (length (gensym "LENGTH")) (vec (gensym "VEC"))) `(let ((,vec ,vector)) (declare (type vector ,vec)) @@ -1015,7 +1015,7 @@ from-end start end) &body body) (declare (ignore from-end start end)) (multiple-value-bind (forms decls) - (sys:parse-body body :doc-string-allowed nil) + (sys:parse-body body nil) (let ((s sequence) (sequence (gensym "SEQUENCE"))) `(block nil Modified: trunk/abcl/src/org/armedbear/lisp/java-collections.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/java-collections.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/java-collections.lisp Tue Sep 28 14:21:06 2010 @@ -64,12 +64,11 @@ (defmethod sequence:make-simple-sequence-iterator ((s (jclass "java.util.List")) &key from-end (start 0) end) (let* ((end (or end (length s))) - (index (if from-end (1- end) start)) + (index (if from-end end start)) (it (jcall "listIterator" s index)) (iter (make-jlist-iterator :native-iterator it - :index (if from-end (1+ index) - (1- index)))) - (limit (if from-end start (1- end)))) + :index (if from-end (1+ index) (1- index)))) + (limit (if from-end (1+ start) (1- end)))) ;;CL iterator semantics are that first element is present from the start (unless (sequence:iterator-endp s iter limit from-end) (sequence:iterator-step s iter from-end)) @@ -78,22 +77,25 @@ ;;Collection, and not List, because we want to reuse this for Set when applicable (defmethod sequence:iterator-step ((s (jclass "java.util.Collection")) it from-end) - (if from-end - (progn - (setf (jlist-it-element it) - (jcall "previous" (jlist-it-native-iterator it))) - (decf (jlist-it-index it))) - (progn - (setf (jlist-it-element it) - (jcall "next" (jlist-it-native-iterator it))) - (incf (jlist-it-index it)))) + (let ((native-it (jlist-it-native-iterator it))) + (if from-end + (progn + (setf (jlist-it-element it) + (when (jcall "hasPrevious" native-it) + (jcall "previous" native-it))) + (decf (jlist-it-index it))) + (progn + (setf (jlist-it-element it) + (when (jcall "hasNext" native-it) + (jcall "next" native-it))) + (incf (jlist-it-index it))))) it) (defmethod sequence:iterator-endp ((s (jclass "java.util.Collection")) it limit from-end) (if from-end - (<= (jlist-it-index it) limit) - (>= (jlist-it-index it) limit))) + (< (jlist-it-index it) limit) + (> (jlist-it-index it) limit))) (defmethod sequence:iterator-element ((s (jclass "java.util.Collection")) iterator) From ehuelsmann at common-lisp.net Wed Sep 29 21:43:59 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 29 Sep 2010 17:43:59 -0400 Subject: [armedbear-cvs] r12929 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Sep 29 17:43:56 2010 New Revision: 12929 Log: Don't trap floating point underflows: Raymond Toy explains how most CL implementations don't signal errors in this case anyway; this fixes tests in Maxima. Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java 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 Wed Sep 29 17:43:56 2010 @@ -2704,7 +2704,7 @@ // Floating point traps. protected static boolean TRAP_OVERFLOW = true; - protected static boolean TRAP_UNDERFLOW = true; + protected static boolean TRAP_UNDERFLOW = false; // Extentions From ehuelsmann at common-lisp.net Thu Sep 30 19:22:38 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 30 Sep 2010 15:22:38 -0400 Subject: [armedbear-cvs] r12930 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Sep 30 15:22:36 2010 New Revision: 12930 Log: Additional check to make sure constant symbols aren't being assigned values. Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java 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 Thu Sep 30 15:22:36 2010 @@ -287,6 +287,9 @@ */ public final void setSymbolValue(LispObject value) { + if (isConstant()) + // Complement the check already done in SpecialOperators.sf_setq + error(new ProgramError("Can't change value of constant symbol " + writeToString() + ".")); this.value = value; } From ehuelsmann at common-lisp.net Thu Sep 30 19:37:40 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 30 Sep 2010 15:37:40 -0400 Subject: [armedbear-cvs] r12931 - trunk/abcl Message-ID: Author: ehuelsmann Date: Thu Sep 30 15:37:39 2010 New Revision: 12931 Log: Add fixes on trunk to be released with 0.23. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Thu Sep 30 15:37:39 2010 @@ -1,3 +1,20 @@ +Version 0.23 +============ +svn://common-lisp.net/project/armedbear/svn/tags/0.23.0/abcl +(????, 2010) + +Fixes +----- + +* [svn r12930] Fix non-constantness of constant symbols when using SET + +* [svn r12929] Don't throw conditions on floating point underflow + (fixes Maxima failures) + +* [svn r12928] Fix for Java-collections-as-lisp-sequences support + +* [svn r12927] Fix for regression to moved threads related symbols + Version 0.22 ============ svn://common-lisp.net/project/armedbear/svn/tags/0.22.0/abcl