From mevenson at common-lisp.net Mon Aug 1 21:34:27 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 01 Aug 2011 14:34:27 -0700 Subject: [armedbear-cvs] r13430 - in trunk/abcl/contrib: abcl-asdf jss Message-ID: Author: mevenson Date: Mon Aug 1 14:34:26 2011 New Revision: 13430 Log: Refactor ASDF extensions from JSS into ABCL-ASDF. The JAR-FILE, JAR-DIRECTORY, and CLASS-FILE-DIRECTORY ASDF extensions are now part of the ABCL-ASDF contrib as we aim to centralize all such things in one place. *ADDED-TO-CLASSPATH* is now part of the ABCL-ASDF package as well. There is currently a (mostly) recursive relationship between JSS and ABCL-ASDF, as each (mostly) requires the other for operation. JSS:ENSURE-COMPATIBILITY will ensure that JSS continues to understand the refactored extensions. Added: trunk/abcl/contrib/abcl-asdf/asdf-jar.lisp - copied, changed from r13429, trunk/abcl/contrib/jss/asdf-jar.lisp Deleted: trunk/abcl/contrib/jss/asdf-jar.lisp Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp trunk/abcl/contrib/jss/compat.lisp trunk/abcl/contrib/jss/invoke.lisp trunk/abcl/contrib/jss/jss.asd trunk/abcl/contrib/jss/packages.lisp Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd ============================================================================== --- trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd Sun Jul 31 06:01:43 2011 (r13429) +++ trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd Mon Aug 1 14:34:26 2011 (r13430) @@ -3,9 +3,12 @@ (defsystem :abcl-asdf :author "Mark Evenson" - :version "0.2.0" - :depends-on ("jss") ;;; XXX move the JSS ASDf defintions here? uggh. + :version "0.3.0" + :depends-on ("jss") :components ((:module base :pathname "" :components ((:file "abcl-asdf") - (:file "maven-embedder" :depends-on ("abcl-asdf")))))) + (:file "asdf-jar" + :depends-on ("abcl-asdf")) + (:file "maven-embedder" + :depends-on ("abcl-asdf" "asdf-jar")))))) Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Sun Jul 31 06:01:43 2011 (r13429) +++ trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Mon Aug 1 14:34:26 2011 (r13430) @@ -5,7 +5,13 @@ #:as-classpath #:resolve-artifact - #:resolve-dependencies)) + #:resolve-dependencies + + #:add-directory-jars-to-class-path + #:need-to-add-directory-jar? + + #:*added-to-classpath* + #:*inhibit-add-to-classpath*)) (in-package :asdf) (defclass iri (static-class) Copied and modified: trunk/abcl/contrib/abcl-asdf/asdf-jar.lisp (from r13429, trunk/abcl/contrib/jss/asdf-jar.lisp) ============================================================================== --- trunk/abcl/contrib/jss/asdf-jar.lisp Sun Jul 31 06:01:43 2011 (r13429, copy source) +++ trunk/abcl/contrib/abcl-asdf/asdf-jar.lisp Mon Aug 1 14:34:26 2011 (r13430) @@ -1,34 +1,65 @@ +(in-package :abcl-asdf) + +(defvar *added-to-classpath* nil) + +(defvar *inhibit-add-to-classpath* nil) + +(defun add-directory-jars-to-class-path (directory recursive-p) + (loop :for jar :in (if recursive-p + (all-jars-below directory) + (directory (merge-pathnames "*.jar" directory))) + :do (java:add-to-classpath jar))) + +(defun all-jars-below (directory) + (loop :with q = (system:list-directory directory) + :while q :for top = (pop q) + :if (null (pathname-name top)) + :do (setq q (append q (all-jars-below top))) + :if (equal (pathname-type top) "jar") + :collect top)) + +(defun need-to-add-directory-jar? (directory recursive-p) + (loop :for jar :in (if recursive-p + (all-jars-below directory) + (directory (merge-pathnames "*.jar" directory))) + :doing (if (not (member (namestring (truename jar)) *added-to-classpath* :test 'equal)) + (return-from need-to-add-directory-jar? t))) + nil) + (in-package :asdf) (defclass jar-directory (static-file) ()) (defmethod perform ((operation compile-op) (c jar-directory)) - (unless jss:*inhibit-add-to-classpath* - (jss:add-directory-jars-to-class-path (truename (component-pathname c)) t))) + (unless abcl-asdf:*inhibit-add-to-classpath* + (abcl-asdf:add-directory-jars-to-class-path (truename (component-pathname c)) t))) (defmethod perform ((operation load-op) (c jar-directory)) - (unless jss:*inhibit-add-to-classpath* - (jss:add-directory-jars-to-class-path (truename (component-pathname c)) t))) + (unless abcl-asdf:*inhibit-add-to-classpath* + (abcl-asdf:add-directory-jars-to-class-path (truename (component-pathname c)) t))) (defmethod operation-done-p ((operation load-op) (c jar-directory)) - (or jss:*inhibit-add-to-classpath* - (not (jss:need-to-add-directory-jar? (component-pathname c) t)))) + (or abcl-asdf:*inhibit-add-to-classpath* + (not (abcl-asdf:need-to-add-directory-jar? (component-pathname c) t)))) (defmethod operation-done-p ((operation compile-op) (c jar-directory)) t) (defclass jar-file (static-file) ()) +(defmethod source-file-type ((c jar-file) (s module)) "jar") + (defmethod perform ((operation compile-op) (c jar-file)) - (jss:add-to-classpath (component-pathname c))) + (java:add-to-classpath (component-pathname c))) (defmethod perform ((operation load-op) (c jar-file)) - (or jss:*inhibit-add-to-classpath* - (jss:add-to-classpath (component-pathname c)))) + (or abcl-asdf:*inhibit-add-to-classpath* + (java:add-to-classpath (component-pathname c)))) (defmethod operation-done-p ((operation load-op) (c jar-file)) - (or jss:*inhibit-add-to-classpath* - (member (namestring (truename (component-pathname c))) jss:*added-to-classpath* :test 'equal))) + (or abcl-asdf:*inhibit-add-to-classpath* + (member (namestring (truename (component-pathname c))) + abcl-asdf:*added-to-classpath* :test 'equal))) (defmethod operation-done-p ((operation compile-op) (c jar-file)) t) @@ -36,12 +67,11 @@ (defclass class-file-directory (static-file) ()) (defmethod perform ((operation compile-op) (c class-file-directory)) - (jss:add-to-classpath (component-pathname c))) + (java:add-to-classpath (component-pathname c))) (defmethod perform ((operation load-op) (c class-file-directory)) - (jss:add-to-classpath (component-pathname c))) + (java:add-to-classpath (component-pathname c))) -(defmethod source-file-type ((c jar-file) (s module)) "jar") Modified: trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Sun Jul 31 06:01:43 2011 (r13429) +++ trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Mon Aug 1 14:34:26 2011 (r13430) @@ -81,7 +81,7 @@ (error "You must download maven-3.0.3 from http://maven.apache.org/download.html, then set ABCL-ASDF:*MVN-DIRECTORY* appropiately.")) (unless (ensure-mvn-version) (error "We need maven-3.0.3 or later.")) - (jss:add-directory-jars-to-class-path *mvn-libs-directory* nil) + (add-directory-jars-to-class-path *mvn-libs-directory* nil) (setf *init* t)) (defun make-wagon-provider () Modified: trunk/abcl/contrib/jss/compat.lisp ============================================================================== --- trunk/abcl/contrib/jss/compat.lisp Sun Jul 31 06:01:43 2011 (r13429) +++ trunk/abcl/contrib/jss/compat.lisp Mon Aug 1 14:34:26 2011 (r13430) @@ -4,13 +4,24 @@ "Whether backwards compatibility with JSS's use of CL-USER has been enabled.") (defun ensure-compatibility () - (setf *cl-user-compatibility* t) - (let ((dont-export '(add-to-classpath *cl-user-compatibility*))) + (require 'abcl-asdf) + (loop :for symbol :in '("add-directory-jars-to-class-path" + "need-to-add-directory-jar?") + :do + (unintern (intern symbol "CL-USER") :cl-user) + :do + (import (intern symbol "ABCL-ASDF") :cl-user)) + (let ((dont-export '(*cl-user-compatibility* add-to-classpath))) (loop :for symbol :being :each :external-symbol :in :jss :when (not (find symbol dont-export)) - :do - (unintern symbol :cl-user) - :and :do - (import symbol :cl-user)))) + :do + (unintern symbol :cl-user) + :and :do + (import symbol :cl-user))) + (setf *cl-user-compatibility* t)) + +;;; Because we're the last file in the ASDF system at the moment +(provide 'jss) + Modified: trunk/abcl/contrib/jss/invoke.lisp ============================================================================== --- trunk/abcl/contrib/jss/invoke.lisp Sun Jul 31 06:01:43 2011 (r13429) +++ trunk/abcl/contrib/jss/invoke.lisp Mon Aug 1 14:34:26 2011 (r13430) @@ -446,30 +446,6 @@ for i below (#"size" classesv) collect (#"getName" (#"elementAt" classesv i)))))) -(defvar *added-to-classpath* nil) - -(defvar *inhibit-add-to-classpath* nil) - -(defun add-to-classpath (path &optional force) - (unless *inhibit-add-to-classpath* -;;; (ensure-dynamic-classpath) -;;; (clear-invoke-imports) - (let ((absolute (namestring (truename path)))) -;; (when (not (equal (pathname-type absolute) (pathname-type path))) -;; (warn "HEY! ~a, ~a ~a, ~a" path (pathname-type path) absolute (pathname-type absolute)) -;; (setq @ (list path absolute))) - ;; NOTE: for jar files, specified as a component, the ".jar" is part of the pathname-name :( - (when (or force (not (member absolute *added-to-classpath* :test 'equalp))) -;;; (#"addClassPath" *classpath-manager* (new 'java.net.url (#"replaceAll" (#"replaceAll" (concatenate 'string "file://" absolute) "\\\\" "/") "C:" ""))) -;;; (#"setClassLoader" '|jsint.Import| (#"getBaseLoader" *classpath-manager*)) -; (format t "path=~a type=~a~%" absolute (pathname-type absolute)) - (java:add-to-classpath path) - (cond ((equal (pathname-type absolute) "jar") - (jar-import absolute)) - ((file-directory-p absolute) - (classfiles-import absolute))) - (push absolute *added-to-classpath*))))) - (defun get-dynamic-class-path () (rest (find-if (lambda (loader) @@ -525,23 +501,6 @@ (pushnew full-class-name (gethash name *class-name-to-full-case-insensitive*) :test 'equal))) -(defun add-directory-jars-to-class-path (directory recursive-p) - (if recursive-p - (loop for jar in (all-jars-below directory) do (add-to-classpath jar)) - (loop for jar in (directory (merge-pathnames "*.jar" directory)) do (add-to-classpath jar)))) - -(defun need-to-add-directory-jar? (directory recursive-p) - (if recursive-p - (loop for jar in (all-jars-below directory) - do - (if (not (member (namestring (truename jar)) *added-to-classpath* :test 'equal)) - (return-from need-to-add-directory-jar? t))) - (loop for jar in (directory (merge-pathnames "*.jar" directory)) - do - (if (not (member (namestring (truename jar)) *added-to-classpath* :test 'equal)) - (return-from need-to-add-directory-jar? t)))) - nil) - (defun set-to-list (set) (declare (optimize (speed 3) (safety 0))) (with-constant-signature ((iterator "iterator" t) (hasnext "hasNext") (next "next")) Modified: trunk/abcl/contrib/jss/jss.asd ============================================================================== --- trunk/abcl/contrib/jss/jss.asd Sun Jul 31 06:01:43 2011 (r13429) +++ trunk/abcl/contrib/jss/jss.asd Mon Aug 1 14:34:26 2011 (r13430) @@ -3,12 +3,13 @@ (defsystem :jss :author "Alan Ruttenberg, Mark Evenson" - :version "2.2.0" + :version "3.0.0" :components - ((:module base :pathname "" :serial t + ((:module base + :pathname "" :serial t :components ((:file "packages") (:file "invoke") - (:file "asdf-jar") + (:file "classpath") (:file "compat"))))) Modified: trunk/abcl/contrib/jss/packages.lisp ============================================================================== --- trunk/abcl/contrib/jss/packages.lisp Sun Jul 31 06:01:43 2011 (r13429) +++ trunk/abcl/contrib/jss/packages.lisp Mon Aug 1 14:34:26 2011 (r13430) @@ -10,13 +10,13 @@ #:with-constant-signature #:invoke-add-imports - #:add-directory-jars-to-class-path - #:add-to-classpath #:find-java-class - #:need-to-add-directory-jar? #:jcmn #:japropos #:new + + #:jar-import + #:classfiles-import ;;; Useful utilities to convert common Java items to Lisp counterparts #:hashmap-to-hashtable @@ -34,6 +34,6 @@ #:jclass-all-interfaces ;;; Enable compatibility with jss-1.0 by placing symbols in CL-USER - #:ensure-compatibility #:*cl-user-compatibility*) - (:shadow #:add-to-classpath)) + #:ensure-compatibility #:*cl-user-compatibility*)) + From mevenson at common-lisp.net Mon Aug 1 21:34:35 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 01 Aug 2011 14:34:35 -0700 Subject: [armedbear-cvs] r13431 - in trunk/abcl/contrib: abcl-asdf jss Message-ID: Author: mevenson Date: Mon Aug 1 14:34:35 2011 New Revision: 13431 Log: Allow ASDF definitions for JAR-FILE to include ".jar". This increases compatibility with the original version of JSS. The only possible situation where this doesn't make sense would be if a jar where to end in something other than ".jar", like perhaps ".zip" or ".war". In this case, additional ASDF classes should be defined extending JAR-FILE. Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd trunk/abcl/contrib/abcl-asdf/asdf-jar.lisp trunk/abcl/contrib/jss/jss.asd Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd ============================================================================== --- trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd Mon Aug 1 14:34:26 2011 (r13430) +++ trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd Mon Aug 1 14:34:35 2011 (r13431) @@ -3,7 +3,7 @@ (defsystem :abcl-asdf :author "Mark Evenson" - :version "0.3.0" + :version "0.3.1" :depends-on ("jss") :components ((:module base :pathname "" :components Modified: trunk/abcl/contrib/abcl-asdf/asdf-jar.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/asdf-jar.lisp Mon Aug 1 14:34:26 2011 (r13430) +++ trunk/abcl/contrib/abcl-asdf/asdf-jar.lisp Mon Aug 1 14:34:35 2011 (r13431) @@ -22,7 +22,8 @@ (loop :for jar :in (if recursive-p (all-jars-below directory) (directory (merge-pathnames "*.jar" directory))) - :doing (if (not (member (namestring (truename jar)) *added-to-classpath* :test 'equal)) + :doing (if (not (member (namestring (truename jar)) + *added-to-classpath* :test 'equal)) (return-from need-to-add-directory-jar? t))) nil) @@ -56,6 +57,29 @@ (or abcl-asdf:*inhibit-add-to-classpath* (java:add-to-classpath (component-pathname c)))) +;;; The original JSS specified jar pathnames as having a NAME ending +;;; in ".jar" without a TYPE. If we encounter such a definition, we +;;; clean it up. +(defmethod perform :before ((operation load-op) (c jar-file)) + (when (#"endsWith" (slot-value c 'name) ".jar") + (with-slots (name absolute-pathname) c + (let* ((new-name + (subseq name 0 (- (length name) 4))) + (new-absolute-pathname + (make-pathname :defaults absolute-pathname :name new-name))) + (setf name new-name + absolute-pathname new-absolute-pathname))))) + +(defmethod operation-done-p :before ((operation load-op) (c jar-file)) + (when (#"endsWith" (slot-value c 'name) ".jar") + (with-slots (name absolute-pathname) c + (let* ((new-name + (subseq name 0 (- (length name) 4))) + (new-absolute-pathname + (make-pathname :defaults absolute-pathname :name new-name))) + (setf name new-name + absolute-pathname new-absolute-pathname))))) + (defmethod operation-done-p ((operation load-op) (c jar-file)) (or abcl-asdf:*inhibit-add-to-classpath* (member (namestring (truename (component-pathname c))) Modified: trunk/abcl/contrib/jss/jss.asd ============================================================================== --- trunk/abcl/contrib/jss/jss.asd Mon Aug 1 14:34:26 2011 (r13430) +++ trunk/abcl/contrib/jss/jss.asd Mon Aug 1 14:34:35 2011 (r13431) @@ -3,7 +3,7 @@ (defsystem :jss :author "Alan Ruttenberg, Mark Evenson" - :version "3.0.0" + :version "3.0.1" :components ((:module base :pathname "" :serial t From mevenson at common-lisp.net Mon Aug 1 21:34:43 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 01 Aug 2011 14:34:43 -0700 Subject: [armedbear-cvs] r13432 - trunk/abcl/contrib/abcl-asdf Message-ID: Author: mevenson Date: Mon Aug 1 14:34:43 2011 New Revision: 13432 Log: Fix the ABCL-ASDF:*ADDED-TO-CLASSPATH* to actually record additions. The use of this variable is perhaps slightly obsolescent with the use of JAVA:DUMP-CLASSPATH, but provides a convenient shortcut to quickly find out what has been added by JAVA:ADD-TO-CLASSPATH. Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd trunk/abcl/contrib/abcl-asdf/asdf-jar.lisp Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd ============================================================================== --- trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd Mon Aug 1 14:34:35 2011 (r13431) +++ trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd Mon Aug 1 14:34:43 2011 (r13432) @@ -3,7 +3,7 @@ (defsystem :abcl-asdf :author "Mark Evenson" - :version "0.3.1" + :version "0.3.2" :depends-on ("jss") :components ((:module base :pathname "" :components Modified: trunk/abcl/contrib/abcl-asdf/asdf-jar.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/asdf-jar.lisp Mon Aug 1 14:34:35 2011 (r13431) +++ trunk/abcl/contrib/abcl-asdf/asdf-jar.lisp Mon Aug 1 14:34:43 2011 (r13432) @@ -27,6 +27,14 @@ (return-from need-to-add-directory-jar? t))) nil) +(defmethod java:add-to-classpath :around ((uri-or-uris t) &optional classloader) + (declare (ignore classloader)) + (call-next-method) + (if (listp uri-or-uris) + (dolist (uri uri-or-uris) + (pushnew uri *added-to-classpath*)) + (pushnew uri-or-uris *added-to-classpath*))) + (in-package :asdf) (defclass jar-directory (static-file) ()) From mevenson at common-lisp.net Tue Aug 2 16:05:24 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 02 Aug 2011 09:05:24 -0700 Subject: [armedbear-cvs] r13433 - trunk/abcl/doc/design/amop Message-ID: Author: mevenson Date: Tue Aug 2 09:05:24 2011 New Revision: 13433 Log: Note that finalize-inheritance isn't a generic function. Modified: trunk/abcl/doc/design/amop/missing.markdown Modified: trunk/abcl/doc/design/amop/missing.markdown ============================================================================== --- trunk/abcl/doc/design/amop/missing.markdown Mon Aug 1 14:34:43 2011 (r13432) +++ trunk/abcl/doc/design/amop/missing.markdown Tue Aug 2 09:05:24 2011 (r13433) @@ -77,3 +77,6 @@ funcallable-standard-instance-access +## Problems + +finalize-inheritance is not a generic function From ehuelsmann at common-lisp.net Tue Aug 2 20:57:39 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 02 Aug 2011 13:57:39 -0700 Subject: [armedbear-cvs] r13434 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Aug 2 13:57:38 2011 New Revision: 13434 Log: Correct stream being modified to be *DEBUG-IO* bound streams. Modified: trunk/abcl/src/org/armedbear/lisp/debug.lisp trunk/abcl/src/org/armedbear/lisp/signal.lisp Modified: trunk/abcl/src/org/armedbear/lisp/debug.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/debug.lisp Tue Aug 2 09:05:24 2011 (r13433) +++ trunk/abcl/src/org/armedbear/lisp/debug.lisp Tue Aug 2 13:57:38 2011 (r13434) @@ -130,7 +130,7 @@ (*print-structure* nil) (*debug-condition* condition) (level *debug-level*)) - (clear-input) + (clear-input *debug-io*) (if (> level 0) (with-simple-restart (abort "Return to debug level ~D." level) (debug-loop)) Modified: trunk/abcl/src/org/armedbear/lisp/signal.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/signal.lisp Tue Aug 2 09:05:24 2011 (r13433) +++ trunk/abcl/src/org/armedbear/lisp/signal.lisp Tue Aug 2 13:57:38 2011 (r13434) @@ -66,7 +66,8 @@ (signal condition) (let ((*current-error-depth* (1+ *current-error-depth*))) (cond ((> *current-error-depth* *maximum-error-depth*) - (%format t "~%Maximum error depth exceeded (~D nested errors).~%" + (%format *debug-io* + "~%Maximum error depth exceeded (~D nested errors).~%" *current-error-depth*) (if (fboundp 'internal-debug) (internal-debug) From ehuelsmann at common-lisp.net Tue Aug 2 21:15:55 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 02 Aug 2011 14:15:55 -0700 Subject: [armedbear-cvs] r13435 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Aug 2 14:15:54 2011 New Revision: 13435 Log: Correct function name. Modified: trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Tue Aug 2 13:57:38 2011 (r13434) +++ trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Tue Aug 2 14:15:54 2011 (r13435) @@ -533,7 +533,7 @@ (defun class-add-method (class method) "Adds a `method' to `class'; the method must have been created using -`make-method'." +`make-jvm-method'." (push method (class-file-methods class))) (defun class-methods-by-name (class name) From mevenson at common-lisp.net Thu Aug 4 15:07:26 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 04 Aug 2011 08:07:26 -0700 Subject: [armedbear-cvs] r13436 - trunk/abcl/contrib/jss Message-ID: Author: mevenson Date: Thu Aug 4 08:07:25 2011 New Revision: 13436 Log: Fix JSS load by adding missing file. Added: trunk/abcl/contrib/jss/classpath.lisp Added: trunk/abcl/contrib/jss/classpath.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/contrib/jss/classpath.lisp Thu Aug 4 08:07:25 2011 (r13436) @@ -0,0 +1,14 @@ +(in-package :java) + +(defmethod add-to-classpath :after ((uri-or-uris t) &optional classloader) + (declare (ignore classloader)) + (let ((paths (if (listp uri-or-uris) + uri-or-uris + (list uri-or-uris)))) + (dolist (path paths) + (let ((absolute (namestring (truename path)))) + (cond ((equal (pathname-type absolute) "jar") + (jss:jar-import absolute)) + ((ext:file-directory-p absolute) + (jss:classfiles-import absolute))))))) + From mevenson at common-lisp.net Thu Aug 4 16:04:45 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 04 Aug 2011 09:04:45 -0700 Subject: [armedbear-cvs] r13437 - trunk/abcl/doc/manual Message-ID: Author: mevenson Date: Thu Aug 4 09:04:45 2011 New Revision: 13437 Log: Working through manual printing issues (incomplete). Added: trunk/abcl/doc/manual/index.tex - copied, changed from r13436, trunk/abcl/doc/manual/index.sty Deleted: trunk/abcl/doc/manual/index.sty Modified: trunk/abcl/doc/manual/abcl.tex trunk/abcl/doc/manual/extensions.tex trunk/abcl/doc/manual/java.tex trunk/abcl/doc/manual/threads.tex Modified: trunk/abcl/doc/manual/abcl.tex ============================================================================== --- trunk/abcl/doc/manual/abcl.tex Thu Aug 4 08:07:25 2011 (r13436) +++ trunk/abcl/doc/manual/abcl.tex Thu Aug 4 09:04:45 2011 (r13437) @@ -1,160 +1,20 @@ % http://en.wikibooks.org/wiki/LaTeX/ - -\include{index.sty} +\include{index} \begin{document} \title{A Manual for Armed Bear Common Lisp} -\date{June 17, 2011} +\date{August 4, 2011} \author{Mark Evenson, Erik Huelsmann, Alessio Stallo, Ville Voutilainen} \section{Introduction} -\subsection{Version} - -This manual corresponds to abcl-0.26.0, as yet unreleased. - -\section{Obtaining} - -\subsection{Source Repositories} - -\begin[shell]{code} - svn co http://svn.common-lisp.net/armedbear/trunk abcl -\end{code} - -\subsection{Requirements} - -java-1.5.xx, java-1.6.0__10+ recommended. - -% Omit the build instructions? This really doesn't belong in a User -% Manual, or if it does, then in an appendix. --ME 20110725 -\subsection{Building from Source} - - - -There are three ways to build ABCL from the source release with the -preferred (and most tested way) is to being to use the Ant build tool: - -\begin{itemize} - -\item Use the Ant build tool for Java environments. - -\item Use the Netbeans 6.x IDE to open ABCL as a project. - -\item Bootstrap ABCL using a Common Lisp implementation. Supported - implementations for this process: SBCL, CMUCL, OpenMCL, Allegro - CL, LispWorks or CLISP. -\end{itemize} - -In all cases you need a Java 5 or later JDK (JDK 1.5 and 1.6 have been -tested). Just the JRE isn't enough, as you need the Java compiler -('javac') to compile the Java source of the ABCL implementation. - -Note that when deploying ABCL having JDK isn't a requirement for the -installation site, just the equivalent JRE, as ABCL compiles directly -to byte code, avoiding the need for the 'javac' compiler in deployment -environments. - - -\subsubsection{Using Ant} - -Download a binary distribution [Ant version 1.7.1 or greater][1]. -Unpack the files somewhere convenient, ensuring that the 'ant' (or -'ant.bat' under Windows) executable is in your path and executable. - -[1]: http://ant.apache.org/bindownload.cgi - -Then simply executing - -\begin[shell]{code} - unix$ ant -\end{code} - -or - -\begin[shell]{code} - dos> ant.bat -\end{code} -from the directory containing this README file will create an -executable wrapper ('abcl' under UNIX, 'abcl.bat' under Windows). Use -this wrapper to start ABCL. +Armed Bear is a mostly conforming implementation of the ANSI Common +Lisp standard. This manual documents the Armed Bear Common Lisp +implementation for users of the system. +\subsection{Version} +This manual corresponds to abcl-0.27.0, as yet unreleased. -\subsubsection{Using NetBeans} - -Obtain and install the [Netbeans IDE][2]. One should be able to open -the ABCL directory as a project in the Netbeans 6.x application, -whereupon the usual build, run, and debug targets as invoked in the -GUI are available. - -[2]: http://netbeans.org/downloads/ - - -\subsubsection{Building from Lisp} - - -Building from a Lisp is the most venerable and untested way of -building ABCL. It produces a "non-standard" version of the -distribution that doesn't share build instructions with the previous -two methods, but it still may be of interest to those who absolutely -don't want to know anything about Java. - -First, copy the file 'customizations.lisp.in' to 'customization.lisp', -in the directory containing this README file, editing to suit your -situation, paying attention to the comments in the file. The critical -step is to have Lisp special variable '*JDK*' point to the root of the -Java Development Kit. Underneath the directory referenced by the -value of '*JDK*' there should be an exectuable Java compiler in -'bin/javac' ('bin/java.exe' under Windows). - -Then, one may either use the 'build-from-lisp.sh' shell script or load -the necessary files into your Lisp image by hand. - -\paragraph{Using the 'build-from-lisp.sh' script} - -Under UNIX-like systems, you may simply invoke the -'build-from-lisp.sh' script as './build-from-lisp.sh -', e.g. - -\begin[shell]{code} - unix$ ./build-from-lisp.sh sbcl -\end{code} - -After a successful build, you may use \file{abcl} (\file{abcl.bat} on -Windows) to start ABCL. Note that this wrappers contain absolute -paths, so you'll need to edit them if you move things around after the -build. - -If you're developing on ABCL, you may want to use - -\begin[shell]{code} - unix$ ./build-from-lisp.sh --clean=nil -\end{code} - -to not do a full rebuild. - -In case of failure in the javac stage, you might try this: - -\begin[shell]{code} - unix$ ./build-from-lisp.sh --full=t --clean=t --batch=nil -\end{code} - -This invokes javac separately for each .java file, which avoids running -into limitations on command line length (but is a lot slower). - -\subsubsubsection{Building from another Lisp by hand} - -There is also an ASDF definition in 'abcl.asd' for the BUILD-ABCL -which can be used to load the necessary Lisp definitions, after which - -\begin[lisp]{code} - CL-USER> (build-abcl:build-abcl :clean t :full t) -\end{code} - -will build ABCL. If ASDF isn't present, simply LOAD the -'customizations.lisp' and 'build-abcl.lisp' files to achieve the same -effect as loading the ASDF definition. - -\subsection{Contributing} \section{Interaction with host JVM} @@ -193,8 +53,8 @@ Symbol.java instance or by dynamically introspecting the corresponding Package.java instance. \item The Lisp dynamic environment may be saved via - \code{LispThread.bindSpecial(BINDING)} and restored via - LispThread.resetSpecialBindings(mark). + \code{LispThread.bindSpecial(Binding)} and restored via + \code{LispThread.resetSpecialBindings(Mark)}. \item Functions may be executed by invocation of the Function.execute(args [...]) \end{itemize} @@ -208,16 +68,17 @@ from Java, considering the hosted Lisp as the "Foreign Function" that needs to be "Interfaced". -\subsubsubsection{Calling Lisp from Java} +\subsubsection{Calling Lisp from Java} Note: As the entire ABCL Lisp system resides in the org.armedbear.lisp package the following code snippets do not show the relevant import statements in the interest of brevity. An example of the import statement would be -\begin[java]{code} +\lstset{language=Java} +\begin{lstlisting} import org.armedbear.lisp.*; -\end{document} +\end{lstliting} to potentially import all the JVM symbol from the `org.armedbear.lisp' namespace. @@ -225,7 +86,7 @@ Per JVM, there can only ever be a single Lisp interpreter. This is started by calling the static method `Interpreter.createInstance()`. -\begin[java]{code} +\begin{code}[java] Interpreter interpreter = Interpreter.createInstance(); \end{code} @@ -234,7 +95,7 @@ life-cycle is a bit out of your control (like in a Java servlet), a safer invocation pattern might be: -\begin[java]{code} +\begin{code}[java] Interpreter interpreter = Interpreter.getInstance(); if (interpreter == null) { interpreter = Interpreter.createInstance(); @@ -245,7 +106,7 @@ The Lisp \code{eval} primitive may be simply passed strings for evaluation, as follows -\begin[java]{code} +\begin{code}[java] String line = "(load \"file.lisp\")"; LispObject result = interpreter.eval(line); \end{code} @@ -255,7 +116,7 @@ further computation on the ``LispObject'' depends on knowing what the result of the computation might be, usually involves some amount of \code{instanceof} introspection, and forms a whole topic to itself -(c.f. [Introspecting a LispObject](#introspecting)). +(c.f. [Introspecting a LispObject]) Using ``EVAL'' involves the Lisp interpreter. Lisp functions may be directly invoked by Java method calls as follows. One simply locates @@ -263,7 +124,7 @@ symbol, and then invokes the `execute()` method with the desired parameters. -\begin[java]{code} +\begin{code}[java] interpreter.eval("(defun foo (msg) (format nil \"You told me '~A'~%\" msg))"); Package pkg = Packages.findPackage("CL-USER"); Symbol foo = pkg.findAccessibleSymbol("FOO"); @@ -279,7 +140,7 @@ definition in the ABCL source, we can invoke the symbol directly. To tell if a `LispObject` contains a reference to a symbol. -\begin[java]{code} +\begin{code}[java] boolean nullp(LispObject object) { LispObject result = Primitives.NULL.execute(object); if (result == NIL) { @@ -296,12 +157,12 @@ `LispObject` which can represent the result of every Lisp evaluation into semantics that Java can meaniningfully deal with. -\paragragh{LispObject as \code{boolean}} +\paragraph{LispObject as \code{boolean}} If the LispObject a generalized boolean values, one can use -\java{getBooleanValue()} to convert to Java: +\code{getBooleanValue()} to convert to Java: -\begin[java]{code} +\begin{code}[java] LispObject object = Symbol.NIL; boolean javaValue = object.getBooleanValue(); \end{code} @@ -309,17 +170,17 @@ Although since in Lisp, any value other than NIL means "true", the use of Java equality it quite a bit easier and more optimal: -\begin[java]{code}} +\begin{code}[java] boolean javaValue = (object != Symbol.NIL); \end{code} -\subsubsubsubsection{LispObject is a list} +\paragraph{LispObject is a list} If LispObject is a list, it will have the type `Cons`. One can then use the \code{copyToArray} to make things a bit more suitable for Java iteration. -\begin[java]{code} +\begin{code}[java] LispObject result = interpreter.eval("'(1 2 4 5)"); if (result instanceof Cons) { LispObject array[] = ((Cons)result.copyToArray()); @@ -330,7 +191,7 @@ A more Lispy way to iterated down a list is to use the `cdr()` access function just as like one would traverse a list in Lisp:; -\begin[java]{code} +\begin{code}[java] LispObject result = interpreter.eval("'(1 2 4 5)"); while (result != Symbol.NIL) { doSomething(result.car()); @@ -381,35 +242,35 @@ \subsubsection{Extensions to CLOS} There is an additional syntax for specializing the parameter of a -generic function on a java class, viz. (java:jclass CLASS__STRING) -where CLASS__STRING is a string naming a Java class in dotted package +generic function on a java class, viz. \code{(java:jclass CLASS-STRING)} +where \code{CLASS-STRING} is a string naming a Java class in dotted package form. For instance the following specialization would perhaps allow one to print more information about the contents of a java.util.Collection object -\begin[java]{code} +\begin{code}[lisp] (defmethod print-object ((coll (java:jclass "java.util.Collection")) stream) - ? - \end[java]{code} +\ldots +\end{code} If the class had been loaded via a classloader other than the original the class you wish to specialize on, one needs to specify the classloader as an optional third argument. -\begin[java]{code} -(defmethod print-object ((device-id (java:jclass "dto.nbi.service.hdm.alcatel.com.NBIDeviceID" - (#"getBaseLoader" cl-user::*classpath-manager*))) - ? - \end[java]{code} +\begin{code}[lisp] +(defmethod print-object ((device-id (java:jclass "dto.nbi.service.hdm.alcatel.com.nNBIDeviceID" + (\#"getBaseLoader" cl-user::*classpath-manager*))) +\ldots +\end{code} \subsubsection{Extensions to the Reader} We implement a special hexadecimal escape sequence for specifying characters to the Lisp reader, namely we allow a sequences of the form -#\Uxxxx to be processed by the reader as character whose code is -specified by the hexadecimal digits `xxxx'. The hexadecimal sequence +\# \textbackslash Uxxxx to be processed by the reader as character whose code is +specified by the hexadecimal digits ``xxxx''. The hexadecimal sequence must be exactly four digits long, padded by leading zeros for values less than 0x1000. Modified: trunk/abcl/doc/manual/extensions.tex ============================================================================== --- trunk/abcl/doc/manual/extensions.tex Thu Aug 4 08:07:25 2011 (r13436) +++ trunk/abcl/doc/manual/extensions.tex Thu Aug 4 09:04:45 2011 (r13437) @@ -1,3 +1,4 @@ +\begin{verbatim} %CADDR Function: (not documented) %CADR @@ -246,3 +247,4 @@ Class: (not documented) WEAK-REFERENCE-VALUE Function: (not documented) +\end{verbatim} Copied and modified: trunk/abcl/doc/manual/index.tex (from r13436, trunk/abcl/doc/manual/index.sty) ============================================================================== --- trunk/abcl/doc/manual/index.sty Thu Aug 4 08:07:25 2011 (r13436, copy source) +++ trunk/abcl/doc/manual/index.tex Thu Aug 4 09:04:45 2011 (r13437) @@ -14,3 +14,16 @@ \usepackage{a4wide} +\newcommand{\code}[1]{ + \texttt{#1} +} + +\usepackage{listings} + + +\newenvironment{xx}[1]% + {\begin{lstlisting} }% + {\end{lstlisting}} + +\usepackage{verbatim} + Modified: trunk/abcl/doc/manual/java.tex ============================================================================== --- trunk/abcl/doc/manual/java.tex Thu Aug 4 08:07:25 2011 (r13436) +++ trunk/abcl/doc/manual/java.tex Thu Aug 4 09:04:45 2011 (r13437) @@ -1,3 +1,4 @@ +\begin{verbatim} %JGET-PROPERTY-VALUE Function: Gets a JavaBeans property on JAVA-OBJECT. %JSET-PROPERTY-VALUE @@ -146,3 +147,4 @@ Function: Registers the Java Throwable named by the symbol EXCEPTION-NAME as the condition designated by CONDITION-SYMBOL. Returns T if successful, NIL if not. UNREGISTER-JAVA-EXCEPTION Function: Unregisters the Java Throwable EXCEPTION-NAME previously registered by REGISTER-JAVA-EXCEPTION. +\end{verbatim} Modified: trunk/abcl/doc/manual/threads.tex ============================================================================== --- trunk/abcl/doc/manual/threads.tex Thu Aug 4 08:07:25 2011 (r13436) +++ trunk/abcl/doc/manual/threads.tex Thu Aug 4 09:04:45 2011 (r13437) @@ -1,3 +1,4 @@ +\begin{verbatim} THREADS:CURRENT-THREAD Function: (not documented) THREADS:DESTROY-THREAD @@ -48,3 +49,4 @@ Function: (not documented) THREADS:WITH-THREAD-LOCK Function: (not documented) +\end{verbatim} From mevenson at common-lisp.net Fri Aug 5 09:30:50 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 05 Aug 2011 02:30:50 -0700 Subject: [armedbear-cvs] r13438 - trunk/abcl/doc/manual Message-ID: Author: mevenson Date: Fri Aug 5 02:30:50 2011 New Revision: 13438 Log: Manual renders to pdf via pdflatex. Added: trunk/abcl/doc/manual/abcl.sty - copied, changed from r13437, trunk/abcl/doc/manual/index.tex Deleted: trunk/abcl/doc/manual/index.tex Modified: trunk/abcl/doc/manual/abcl.tex trunk/abcl/doc/manual/java.tex Copied and modified: trunk/abcl/doc/manual/abcl.sty (from r13437, trunk/abcl/doc/manual/index.tex) ============================================================================== --- trunk/abcl/doc/manual/index.tex Thu Aug 4 09:04:45 2011 (r13437, copy source) +++ trunk/abcl/doc/manual/abcl.sty Fri Aug 5 02:30:50 2011 (r13438) @@ -4,8 +4,6 @@ % leaving the manual itself as much as a pure content to be % comfortably read and modified with a text editor. -\documentclass[10pt]{article} - \usepackage{color,hyperref} \definecolor{darkblue}{rgb}{0.0,0.0,0.3} \hypersetup{colorlinks,breaklinks, @@ -21,9 +19,15 @@ \usepackage{listings} -\newenvironment{xx}[1]% - {\begin{lstlisting} }% - {\end{lstlisting}} +\lstnewenvironment{listing-java} + {\lstset{language=Java}} + {} + + +\lstnewenvironment{listing-lisp} + {\lstset{language=Lisp}} + {} \usepackage{verbatim} +\ProvidesPackage{abcl} Modified: trunk/abcl/doc/manual/abcl.tex ============================================================================== --- trunk/abcl/doc/manual/abcl.tex Thu Aug 4 09:04:45 2011 (r13437) +++ trunk/abcl/doc/manual/abcl.tex Fri Aug 5 02:30:50 2011 (r13438) @@ -1,12 +1,16 @@ +% -*- mode: latex; -*- % http://en.wikibooks.org/wiki/LaTeX/ -\include{index} +\documentclass[10pt]{book} +\usepackage{abcl} \begin{document} \title{A Manual for Armed Bear Common Lisp} \date{August 4, 2011} -\author{Mark Evenson, Erik Huelsmann, Alessio Stallo, Ville Voutilainen} +\author{Mark~Evenson, Erik~Huelsmann, Alessio~Stallo, Ville~Voutilainen} -\section{Introduction} +\maketitle + +\chapter{Introduction} Armed Bear is a mostly conforming implementation of the ANSI Common Lisp standard. This manual documents the Armed Bear Common Lisp @@ -15,15 +19,42 @@ \subsection{Version} This manual corresponds to abcl-0.27.0, as yet unreleased. +\chapter{Conformance} + + +\section{ANSI Common Lisp} +ABCL is currently a non-conforming ANSI Common Lisp implementation due +to the following (known) issues: + +\begin{itemize} + \item Lack of long form of DEFINE-METHOD-COMBINATION + \item Missing statement of conformance in accompanying documentation +\end{itemize} + +ABCL aims to be be a fully conforming ANSI Common Lisp +implementation. Any other behavior should be reported as a bug. + +\section{Contemporary Common Lisp} +In addition to ANSI conformance, ABCL strives to implement features +expected of a contemporary Common Lisp. +\begin{itemize} + \item Incomplete MOP + % N.B. + % TODO go through AMOP with symbols, starting by looking for + % matching function signature. + % XXX is this really blocking ANSI conformance? Answer: we have + % to start with such a ``census'' to determine what we have. + \item Incomplete Gray Streams +\end{itemize} -\section{Interaction with host JVM} +\chapter{Interaction with host JVM} % describe calling Java from Lisp, and calling Lisp from Java, % probably in two separate sections. Presumably, we can partition our % audience into those who are more comfortable with Java, and those % that are more comforable with Lisp -\subsection{Lisp to Java} +\section{Lisp to Java} ABCL offers a number of mechanisms to manipulate Java libraries from Lisp. @@ -42,7 +73,7 @@ classpath at runtime (JAVA:ADD-TO-CLASSPATH). \end{itemize} -\subsection{Lisp from Java} +\section{Lisp from Java} Manipulation of the Lisp API is currently lacking a stable interface, so what is documented here is subject to change. @@ -59,7 +90,7 @@ Function.execute(args [...]) \end{itemize} -\subsubsection{Lisp FFI} +\subsection{Lisp FFI} FFI stands for "Foreign Function Interface" which is the phase which the contemporary Lisp world refers to methods of "calling out" from @@ -68,17 +99,16 @@ from Java, considering the hosted Lisp as the "Foreign Function" that needs to be "Interfaced". -\subsubsection{Calling Lisp from Java} +\subsection{Calling Lisp from Java} Note: As the entire ABCL Lisp system resides in the org.armedbear.lisp package the following code snippets do not show the relevant import statements in the interest of brevity. An example of the import statement would be -\lstset{language=Java} -\begin{lstlisting} +\begin{listing-java} import org.armedbear.lisp.*; -\end{lstliting} +\end{listing-java} to potentially import all the JVM symbol from the `org.armedbear.lisp' namespace. @@ -86,9 +116,9 @@ Per JVM, there can only ever be a single Lisp interpreter. This is started by calling the static method `Interpreter.createInstance()`. -\begin{code}[java] +\begin{listing-java} Interpreter interpreter = Interpreter.createInstance(); -\end{code} +\end{listing-java} If this method has already been invoked in the lifetime of the current Java process it will return null, so if you are writing Java whose @@ -102,14 +132,13 @@ } \end{code} - The Lisp \code{eval} primitive may be simply passed strings for evaluation, as follows -\begin{code}[java] +\begin{listing-java} String line = "(load \"file.lisp\")"; LispObject result = interpreter.eval(line); -\end{code} +\end{listing-java} Notice that all possible return values from an arbitrary Lisp computation are collapsed into a single return value. Doing useful @@ -118,13 +147,13 @@ of \code{instanceof} introspection, and forms a whole topic to itself (c.f. [Introspecting a LispObject]) -Using ``EVAL'' involves the Lisp interpreter. Lisp functions may be -directly invoked by Java method calls as follows. One simply locates -the package containing the symbol, then obtains a reference to the -symbol, and then invokes the `execute()` method with the desired -parameters. +Using \code{eval} involves the Lisp interpreter. Lisp functions may +be directly invoked by Java method calls as follows. One simply +locates the package containing the symbol, then obtains a reference to +the symbol, and then invokes the \code{execute()} method with the +desired parameters. -\begin{code}[java] +\begin{listing-java} interpreter.eval("(defun foo (msg) (format nil \"You told me '~A'~%\" msg))"); Package pkg = Packages.findPackage("CL-USER"); Symbol foo = pkg.findAccessibleSymbol("FOO"); @@ -133,14 +162,14 @@ LispObject result = fooFunction.execute(parameter); // How to get the "naked string value"? System.out.println("The result was " + result.writeToString()); -\end{code} +\end{listing-java} If one is calling an primitive function in the CL package the syntax becomes considerably simpler if we can locate the instance of definition in the ABCL source, we can invoke the symbol directly. To tell if a `LispObject` contains a reference to a symbol. -\begin{code}[java] +\begin{listing-java} boolean nullp(LispObject object) { LispObject result = Primitives.NULL.execute(object); if (result == NIL) { @@ -148,31 +177,31 @@ } return true; } -\end{code} +\end{listing-java} -\paragraph{Introspecting a LispObject} +\subsubsection{Introspecting a LispObject} \label{topic:Introspecting a LispObject} We present various patterns for introspecting an an arbitrary `LispObject` which can represent the result of every Lisp evaluation into semantics that Java can meaniningfully deal with. -\paragraph{LispObject as \code{boolean}} +\subsubsection{LispObject as \code{boolean}} If the LispObject a generalized boolean values, one can use \code{getBooleanValue()} to convert to Java: -\begin{code}[java] +\begin{listing-java} LispObject object = Symbol.NIL; boolean javaValue = object.getBooleanValue(); -\end{code} +\end{listing-java} Although since in Lisp, any value other than NIL means "true", the use of Java equality it quite a bit easier and more optimal: -\begin{code}[java] +\begin{listing-java} boolean javaValue = (object != Symbol.NIL); -\end{code} +\end{listing-java} \paragraph{LispObject is a list} @@ -180,47 +209,35 @@ the \code{copyToArray} to make things a bit more suitable for Java iteration. -\begin{code}[java] +\begin{listing-java} LispObject result = interpreter.eval("'(1 2 4 5)"); if (result instanceof Cons) { LispObject array[] = ((Cons)result.copyToArray()); ... } -\end{code} +\end{listing-java} A more Lispy way to iterated down a list is to use the `cdr()` access function just as like one would traverse a list in Lisp:; -\begin{code}[java] +\begin{listing-java} LispObject result = interpreter.eval("'(1 2 4 5)"); while (result != Symbol.NIL) { doSomething(result.car()); result = result.cdr(); } -\end{code} +\end{listing-java} -\subsection{JAVA} +\section{Java} % include autogen docs for the JAVA package. +\include{java} -\section{ANSI Common Lisp Conformance} - -ABCL is currently a non-conforming ANSI Common Lisp implementation due -to the following (known) issues: - -\begin{itemize} - \item Lack of long form of DEFINE-METHOD-COMBINATION - \item Missing statement of conformance in accompanying documentation - \item Incomplete MOP - % TODO go through AMOP with symbols, starting by looking for - % matching function signature. - % XXX is this really blocking ANSI conformance? Answer: we have - % to start with such a ``census'' to determine what we have. -\end{itemize} +\section{Multithreading} -ABCL aims to be be a fully conforming ANSI Common Lisp -implementation. Any other behavior should be reported as a bug. +% TODO document the THREADS package. +\include{threads} \section{Extensions} @@ -232,14 +249,14 @@ \include{extensions} -\subsection{Beyond ANSI} +\chapter{Beyond ANSI} Naturally, in striving to be a useful contemporary Common Lisp implementation, ABCL endeavors to include extensions beyond the ANSI specification which are either widely adopted or are especially useful in working with the hosting JVM. -\subsubsection{Extensions to CLOS} +\section{Extensions to CLOS} There is an additional syntax for specializing the parameter of a generic function on a java class, viz. \code{(java:jclass CLASS-STRING)} @@ -250,22 +267,29 @@ print more information about the contents of a java.util.Collection object -\begin{code}[lisp] -(defmethod print-object ((coll (java:jclass "java.util.Collection")) stream) -\ldots -\end{code} +\begin{listing-lisp} +(defmethod print-object ((coll (java:jclass "java.util.Collection")) + stream) + ;;; ... +) +\end{listing-lisp} If the class had been loaded via a classloader other than the original the class you wish to specialize on, one needs to specify the classloader as an optional third argument. -\begin{code}[lisp] -(defmethod print-object ((device-id (java:jclass "dto.nbi.service.hdm.alcatel.com.nNBIDeviceID" - (\#"getBaseLoader" cl-user::*classpath-manager*))) -\ldots -\end{code} +\begin{listing-lisp} -\subsubsection{Extensions to the Reader} +(defparameter *other-classloader* + (jcall "getBaseLoader" cl-user::*classpath-manager*)) + +(defmethod print-object ((device-id (java:jclass "dto.nbi.service.hdm.alcatel.com.NBIDeviceID" *other-classloader*)) + stream) + ;;; ... +) +\end{listing-lisp} + +\section{Extensions to the Reader} We implement a special hexadecimal escape sequence for specifying characters to the Lisp reader, namely we allow a sequences of the form @@ -278,12 +302,7 @@ the corresponding Unicode character is output for characters whose code is greater than 0x00ff. -\section{Multithreading} - -% TODO document the THREADS package. -\include{threads} - -\section{History} +\chapter{History} ABCL was originally the extension language for the J editor, which was started in 1998 by Peter Graves. Sometime in 2003, it seems that a Modified: trunk/abcl/doc/manual/java.tex ============================================================================== --- trunk/abcl/doc/manual/java.tex Thu Aug 4 09:04:45 2011 (r13437) +++ trunk/abcl/doc/manual/java.tex Fri Aug 5 02:30:50 2011 (r13438) @@ -1,150 +1,248 @@ \begin{verbatim} + %JGET-PROPERTY-VALUE Function: Gets a JavaBeans property on JAVA-OBJECT. + %JSET-PROPERTY-VALUE Function: Sets a JavaBean property on JAVA-OBJECT. -*JAVA-OBJECT-TO-STRING-LENGTH* - Variable: Length to truncate toString() PRINT-OBJECT output for an otherwise unspecialized JAVA-OBJECT. Can be set to NIL to indicate no limit. + +*JAVA-OBJECT-TO-STRING-LENGTH* + Variable: Length to truncate toString() + PRINT-OBJECT output for an otherwise unspecialized JAVA-OBJECT. Can + be set to NIL to indicate no limit. + ADD-TO-CLASSPATH Function: (not documented) + CHAIN Function: (not documented) + DESCRIBE-JAVA-OBJECT Function: (not documented) + DUMP-CLASSPATH Function: (not documented) + ENSURE-JAVA-CLASS Function: (not documented) + ENSURE-JAVA-OBJECT Function: Ensures OBJ is wrapped in a JAVA-OBJECT, wrapping it if necessary. + GET-DEFAULT-CLASSLOADER Function: (not documented) + JARRAY-COMPONENT-TYPE Function: Returns the component type of the array type ATYPE + JARRAY-LENGTH Function: (not documented) + JARRAY-REF - Function: Dereferences the Java array JAVA-ARRAY using the given INDICIES, coercing the result into a Lisp object, if possible. + Function: Dereferences the Java array JAVA-ARRAY using the given + INDICIES, coercing the result into a Lisp object, if possible. + JARRAY-REF-RAW - Function: Dereference the Java array JAVA-ARRAY using the given INDICIES. Does not attempt to coerce the result into a Lisp object. + Function: Dereference the Java array JAVA-ARRAY using the given + INDICIES. Does not attempt to coerce the result into a Lisp object. + JARRAY-SET Function: Stores NEW-VALUE at the given index in JAVA-ARRAY. + JAVA-CLASS Class: (not documented) + JAVA-EXCEPTION Class: (not documented) + JAVA-EXCEPTION-CAUSE Function: Returns the cause of JAVA-EXCEPTION. (The cause is the Java Throwable + JAVA-OBJECT Class: (not documented) + JAVA-OBJECT-P Function: Returns T if OBJECT is a JAVA-OBJECT. + JCALL - Function: Invokes the Java method METHOD-REF on INSTANCE with arguments ARGS, coercing the result into a Lisp object, if possible. + Function: Invokes the Java method METHOD-REF on INSTANCE with + arguments ARGS, coercing the result into a Lisp object, if possible. + JCALL-RAW - Function: Invokes the Java method METHOD-REF on INSTANCE with arguments ARGS. Does not attempt to coerce the result into a Lisp object. + Function: Invokes the Java method METHOD-REF on INSTANCE with + arguments ARGS. Does not attempt to coerce the result into a Lisp + object. + JCLASS - Function: Returns a reference to the Java class designated by NAME-OR-CLASS-REF. If the CLASS-LOADER parameter is passed, the class is resolved with respect to the given ClassLoader. + Function: Returns a reference to the Java class designated by + NAME-OR-CLASS-REF. If the CLASS-LOADER parameter is passed, the class + is resolved with respect to the given ClassLoader. + JCLASS-ARRAY-P Function: Returns T if CLASS is an array class + JCLASS-CONSTRUCTORS Function: Returns a vector of constructors for CLASS + JCLASS-FIELD Function: Returns the field named FIELD-NAME of CLASS + JCLASS-FIELDS - Function: Returns a vector of all (or just the declared/public, if DECLARED/PUBLIC is true) fields of CLASS + Function: Returns a vector of all (or just the declared/public, if + DECLARED/PUBLIC is true) fields of CLASS + JCLASS-INTERFACE-P Function: Returns T if CLASS is an interface + JCLASS-INTERFACES Function: Returns the vector of interfaces of CLASS + JCLASS-METHODS - Function: Return a vector of all (or just the declared/public, if DECLARED/PUBLIC is true) methods of CLASS + Function: Return a vector of all (or just the declared/public, if + DECLARED/PUBLIC is true) methods of CLASS + JCLASS-NAME Function: When called with one argument, returns the name of the Java class + JCLASS-OF Function: (not documented) + JCLASS-SUPERCLASS Function: Returns the superclass of CLASS, or NIL if it hasn't got one + JCLASS-SUPERCLASS-P Function: Returns T if CLASS-1 is a superclass or interface of CLASS-2 + JCOERCE - Function: Attempts to coerce OBJECT into a JavaObject of class INTENDED-CLASS. Raises a TYPE-ERROR if no conversion is possible. + Function: Attempts to coerce OBJECT into a JavaObject of class + INTENDED-CLASS. Raises a TYPE-ERROR if no conversion is possible. + JCONSTRUCTOR - Function: Returns a reference to the Java constructor of CLASS-REF with the given PARAMETER-CLASS-REFS. + Function: Returns a reference to the Java constructor of CLASS-REF + with the given PARAMETER-CLASS-REFS. + JCONSTRUCTOR-PARAMS Function: Returns a vector of parameter types (Java classes) for CONSTRUCTOR + JEQUAL Function: Compares obj1 with obj2 using java.lang.Object.equals() + JFIELD Function: Retrieves or modifies a field in a Java class or instance. + JFIELD-NAME Function: Returns the name of FIELD as a Lisp string + JFIELD-RAW Function: Retrieves or modifies a field in a Java class or instance. Does not + JFIELD-TYPE Function: Returns the type (Java class) of FIELD + JINSTANCE-OF-P Function: OBJ is an instance of CLASS (or one of its subclasses) + JINTERFACE-IMPLEMENTATION Function: Creates and returns an implementation of a Java interface with + JMAKE-INVOCATION-HANDLER Function: (not documented) + JMAKE-PROXY Function: (not documented) + JMEMBER-PROTECTED-P Function: MEMBER is a protected member of its declaring class + JMEMBER-PUBLIC-P Function: MEMBER is a public member of its declaring class + JMEMBER-STATIC-P Function: MEMBER is a static member of its declaring class + JMETHOD - Function: Returns a reference to the Java method METHOD-NAME of CLASS-REF with the given PARAMETER-CLASS-REFS. + Function: Returns a reference to the Java method METHOD-NAME of + CLASS-REF with the given PARAMETER-CLASS-REFS. + JMETHOD-LET Function: (not documented) + JMETHOD-NAME Function: Returns the name of METHOD as a Lisp string + JMETHOD-PARAMS Function: Returns a vector of parameter types (Java classes) for METHOD + JMETHOD-RETURN-TYPE Function: Returns the result type (Java class) of the METHOD + JNEW Function: Invokes the Java constructor CONSTRUCTOR with the arguments ARGS. + JNEW-ARRAY Function: Creates a new Java array of type ELEMENT-TYPE, with the given DIMENSIONS. + JNEW-ARRAY-FROM-ARRAY Function: Returns a new Java array with base type ELEMENT-TYPE (a string or a class-ref) + JNEW-ARRAY-FROM-LIST Function: (not documented) + JNEW-RUNTIME-CLASS Function: (not documented) + JNULL-REF-P Function: Returns a non-NIL value when the JAVA-OBJECT `object` is `null`, + JOBJECT-CLASS Function: Returns the Java class that OBJ belongs to + JOBJECT-LISP-VALUE Function: Attempts to coerce JAVA-OBJECT into a Lisp object. + JPROPERTY-VALUE Function: (not documented) + JREDEFINE-METHOD Function: (not documented) + JREGISTER-HANDLER Function: (not documented) + JRESOLVE-METHOD - Function: Finds the most specific Java method METHOD-NAME on INSTANCE applicable to arguments ARGS. Returns NIL if no suitable method is found. The algorithm used for resolution is the same used by JCALL when it is called with a string as the first parameter (METHOD-REF). + Function: Finds the most specific Java method METHOD-NAME on + INSTANCE applicable to arguments ARGS. Returns NIL if no suitable + method is found. The algorithm used for resolution is the same used + by JCALL when it is called with a string as the first parameter + (METHOD-REF). + JRUN-EXCEPTION-PROTECTED - Function: Invokes the function CLOSURE and returns the result. Signals an error if stack or heap exhaustion occurs. + Function: Invokes the function CLOSURE and returns the result. + Signals an error if stack or heap exhaustion occurs. + JRUNTIME-CLASS-EXISTS-P Function: (not documented) + JSTATIC Function: Invokes the static method METHOD on class CLASS with ARGS. + JSTATIC-RAW - Function: Invokes the static method METHOD on class CLASS with ARGS. Does not attempt to coerce the arguments or result into a Lisp object. + Function: Invokes the static method METHOD on class CLASS with + ARGS. Does not attempt to coerce the arguments or result into a Lisp + object. + MAKE-CLASSLOADER Function: (not documented) + MAKE-IMMEDIATE-OBJECT Function: Attempts to coerce a given Lisp object into a java-object of the + REGISTER-JAVA-EXCEPTION - Function: Registers the Java Throwable named by the symbol EXCEPTION-NAME as the condition designated by CONDITION-SYMBOL. Returns T if successful, NIL if not. + Function: Registers the Java Throwable named by the symbol + EXCEPTION-NAME as the condition designated by CONDITION-SYMBOL. + Returns T if successful, NIL if not. + UNREGISTER-JAVA-EXCEPTION Function: Unregisters the Java Throwable EXCEPTION-NAME previously registered by REGISTER-JAVA-EXCEPTION. + \end{verbatim} From mevenson at common-lisp.net Fri Aug 5 13:05:59 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 05 Aug 2011 06:05:59 -0700 Subject: [armedbear-cvs] r13439 - trunk/abcl Message-ID: Author: mevenson Date: Fri Aug 5 06:05:58 2011 New Revision: 13439 Log: Fix #131: Don't include ':' in the version string. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml Fri Aug 5 02:30:50 2011 (r13438) +++ trunk/abcl/build.xml Fri Aug 5 06:05:58 2011 (r13439) @@ -297,7 +297,7 @@ @@ -305,7 +305,7 @@ @@ -313,6 +313,16 @@ + + + + + + + + abcl.version.svn: ${abcl.version.svn} From ehuelsmann at common-lisp.net Fri Aug 5 21:25:12 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 05 Aug 2011 14:25:12 -0700 Subject: [armedbear-cvs] r13440 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 5 14:25:10 2011 New Revision: 13440 Log: Rename writeToString() to printObject() since that's what it's being used for. Additionally, create princToString() for use in error messages, making the required replacement where appropriate. Modified: trunk/abcl/src/org/armedbear/lisp/AbstractArray.java trunk/abcl/src/org/armedbear/lisp/AbstractBitVector.java trunk/abcl/src/org/armedbear/lisp/AbstractString.java trunk/abcl/src/org/armedbear/lisp/AbstractVector.java trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/AutoloadMacro.java trunk/abcl/src/org/armedbear/lisp/Bignum.java trunk/abcl/src/org/armedbear/lisp/BroadcastStream.java trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java trunk/abcl/src/org/armedbear/lisp/CaseFrobStream.java trunk/abcl/src/org/armedbear/lisp/CellError.java trunk/abcl/src/org/armedbear/lisp/Closure.java trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java trunk/abcl/src/org/armedbear/lisp/Complex.java trunk/abcl/src/org/armedbear/lisp/ComplexArray.java trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte32.java trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte8.java trunk/abcl/src/org/armedbear/lisp/Condition.java trunk/abcl/src/org/armedbear/lisp/Cons.java trunk/abcl/src/org/armedbear/lisp/DoubleFloat.java trunk/abcl/src/org/armedbear/lisp/Environment.java trunk/abcl/src/org/armedbear/lisp/FileStream.java trunk/abcl/src/org/armedbear/lisp/Fixnum.java trunk/abcl/src/org/armedbear/lisp/FloatFunctions.java trunk/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java trunk/abcl/src/org/armedbear/lisp/Function.java trunk/abcl/src/org/armedbear/lisp/Go.java trunk/abcl/src/org/armedbear/lisp/HashTable.java trunk/abcl/src/org/armedbear/lisp/HashTableFunctions.java trunk/abcl/src/org/armedbear/lisp/Interpreter.java trunk/abcl/src/org/armedbear/lisp/JarStream.java trunk/abcl/src/org/armedbear/lisp/Java.java trunk/abcl/src/org/armedbear/lisp/JavaObject.java trunk/abcl/src/org/armedbear/lisp/JavaStackFrame.java trunk/abcl/src/org/armedbear/lisp/Layout.java trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/LispCharacter.java trunk/abcl/src/org/armedbear/lisp/LispClass.java trunk/abcl/src/org/armedbear/lisp/LispObject.java trunk/abcl/src/org/armedbear/lisp/LispStackFrame.java trunk/abcl/src/org/armedbear/lisp/LispThread.java trunk/abcl/src/org/armedbear/lisp/Load.java trunk/abcl/src/org/armedbear/lisp/LogicalPathname.java trunk/abcl/src/org/armedbear/lisp/MacroObject.java trunk/abcl/src/org/armedbear/lisp/MathFunctions.java trunk/abcl/src/org/armedbear/lisp/Package.java trunk/abcl/src/org/armedbear/lisp/PackageFunctions.java trunk/abcl/src/org/armedbear/lisp/Pathname.java trunk/abcl/src/org/armedbear/lisp/Primitives.java trunk/abcl/src/org/armedbear/lisp/PrintNotReadable.java trunk/abcl/src/org/armedbear/lisp/RandomState.java trunk/abcl/src/org/armedbear/lisp/Ratio.java trunk/abcl/src/org/armedbear/lisp/Readtable.java trunk/abcl/src/org/armedbear/lisp/Return.java trunk/abcl/src/org/armedbear/lisp/ShellCommand.java trunk/abcl/src/org/armedbear/lisp/SimpleArray_T.java trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte16.java trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte32.java trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte8.java trunk/abcl/src/org/armedbear/lisp/SingleFloat.java trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java trunk/abcl/src/org/armedbear/lisp/SpecialOperator.java trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java trunk/abcl/src/org/armedbear/lisp/StandardClass.java trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java trunk/abcl/src/org/armedbear/lisp/StandardMethod.java trunk/abcl/src/org/armedbear/lisp/StandardObject.java trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java trunk/abcl/src/org/armedbear/lisp/Stream.java trunk/abcl/src/org/armedbear/lisp/StructureClass.java trunk/abcl/src/org/armedbear/lisp/StructureObject.java trunk/abcl/src/org/armedbear/lisp/Symbol.java trunk/abcl/src/org/armedbear/lisp/SynonymStream.java trunk/abcl/src/org/armedbear/lisp/Throw.java trunk/abcl/src/org/armedbear/lisp/TwoWayStream.java trunk/abcl/src/org/armedbear/lisp/TypeError.java trunk/abcl/src/org/armedbear/lisp/URLStream.java trunk/abcl/src/org/armedbear/lisp/UnboundSlot.java trunk/abcl/src/org/armedbear/lisp/UnboundVariable.java trunk/abcl/src/org/armedbear/lisp/UndefinedFunction.java trunk/abcl/src/org/armedbear/lisp/Utilities.java trunk/abcl/src/org/armedbear/lisp/WeakHashTable.java trunk/abcl/src/org/armedbear/lisp/WeakReference.java trunk/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java trunk/abcl/src/org/armedbear/lisp/ZeroRankArray.java trunk/abcl/src/org/armedbear/lisp/delete_file.java trunk/abcl/src/org/armedbear/lisp/jclass_name.java trunk/abcl/src/org/armedbear/lisp/jmethod_return_type.java trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp trunk/abcl/src/org/armedbear/lisp/zip.java Modified: trunk/abcl/src/org/armedbear/lisp/AbstractArray.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/AbstractArray.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/AbstractArray.java Fri Aug 5 14:25:10 2011 (r13440) @@ -160,7 +160,7 @@ // ### i18n final String errorMsg = "Invalid index %d for array %s."; - error(new ProgramError(String.format(errorMsg, n, writeToString()))); + error(new ProgramError(String.format(errorMsg, n, printObject()))); } sum += n * lastSize; } @@ -218,7 +218,7 @@ sb.append('('); if (this instanceof SimpleArray_T) sb.append("SIMPLE-"); - sb.append("ARRAY " + getElementType().writeToString() + " ("); + sb.append("ARRAY " + getElementType().printObject() + " ("); for (int i = 0; i < dimv.length; i++) { sb.append(dimv[i]); if (i < dimv.length - 1) @@ -228,7 +228,7 @@ return unreadableString(sb.toString()); } - // Helper for writeToString(). + // Helper for printObject(). private void appendContents(int[] dimensions, int index, StringBuilder sb, LispThread thread) @@ -240,7 +240,7 @@ AREF(index), stream); sb.append(stream.getString().getStringValue()); } else - sb.append(AREF(index).writeToString()); + sb.append(AREF(index).printObject()); } else { final LispObject printReadably = Symbol.PRINT_READABLY.symbolValue(thread); Modified: trunk/abcl/src/org/armedbear/lisp/AbstractBitVector.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/AbstractBitVector.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/AbstractBitVector.java Fri Aug 5 14:25:10 2011 (r13440) @@ -172,7 +172,7 @@ } @Override - public String writeToString() + public String printObject() { final LispThread thread = LispThread.currentThread(); final int length = length(); Modified: trunk/abcl/src/org/armedbear/lisp/AbstractString.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/AbstractString.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/AbstractString.java Fri Aug 5 14:25:10 2011 (r13440) @@ -110,7 +110,7 @@ } @Override - public String writeToString() + public String printObject() { return writeToString(0, length()); } Modified: trunk/abcl/src/org/armedbear/lisp/AbstractVector.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/AbstractVector.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/AbstractVector.java Fri Aug 5 14:25:10 2011 (r13440) @@ -154,7 +154,7 @@ StringBuilder sb = new StringBuilder("Invalid array index "); sb.append(index); sb.append(" for "); - sb.append(writeToString()); + sb.append(princToString()); if (limit > 0) { sb.append(" (should be >= 0 and < "); @@ -204,7 +204,7 @@ } @Override - public String writeToString() + public String printObject() { final LispThread thread = LispThread.currentThread(); if (Symbol.PRINT_READABLY.symbolValue(thread) != NIL) @@ -215,7 +215,7 @@ { if (i > 0) sb.append(' '); - sb.append(AREF(i).writeToString()); + sb.append(AREF(i).printObject()); } sb.append(')'); return sb.toString(); @@ -248,7 +248,7 @@ { if (i > 0) sb.append(' '); - sb.append(AREF(i).writeToString()); + sb.append(AREF(i).printObject()); } } finally Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Autoload.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Fri Aug 5 14:25:10 2011 (r13440) @@ -153,7 +153,7 @@ if (debug) { if (symbol != null) { if (symbol.getSymbolFunction() instanceof Autoload) { - Debug.trace("Unable to autoload " + symbol.writeToString()); + Debug.trace("Unable to autoload " + symbol.princToString()); throw new IntegrityError(); } } @@ -259,10 +259,10 @@ } @Override - public String writeToString() + public String printObject() { StringBuffer sb = new StringBuffer("#"); Modified: trunk/abcl/src/org/armedbear/lisp/Bignum.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Bignum.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/Bignum.java Fri Aug 5 14:25:10 2011 (r13440) @@ -289,7 +289,7 @@ { float f = value.floatValue(); if (Float.isInfinite(f)) - error(new TypeError("The value " + writeToString() + + error(new TypeError("The value " + princToString() + " is too large to be converted to a single float.")); return f; } @@ -299,7 +299,7 @@ { double d = value.doubleValue(); if (Double.isInfinite(d)) - error(new TypeError("The value " + writeToString() + + error(new TypeError("The value " + princToString() + " is too large to be converted to a double float.")); return d; } @@ -755,7 +755,7 @@ } @Override - public String writeToString() + public String printObject() { final LispThread thread = LispThread.currentThread(); final int base = Fixnum.getValue(Symbol.PRINT_BASE.symbolValue(thread)); Modified: trunk/abcl/src/org/armedbear/lisp/BroadcastStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/BroadcastStream.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/BroadcastStream.java Fri Aug 5 14:25:10 2011 (r13440) @@ -219,7 +219,7 @@ } @Override - public String writeToString() + public String printObject() { return unreadableString("BROADCAST-STREAM"); } Modified: trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java Fri Aug 5 14:25:10 2011 (r13440) @@ -73,14 +73,14 @@ @Override public LispObject getDescription() { - return new SimpleString(writeToString()); + return new SimpleString(princToString()); } @Override - public String writeToString() + public String printObject() { StringBuilder sb = new StringBuilder("#'); return sb.toString(); } Modified: trunk/abcl/src/org/armedbear/lisp/CaseFrobStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/CaseFrobStream.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/CaseFrobStream.java Fri Aug 5 14:25:10 2011 (r13440) @@ -209,7 +209,7 @@ } @Override - public String writeToString() + public String printObject() { return unreadableString("CASE-FROB-STREAM"); } Modified: trunk/abcl/src/org/armedbear/lisp/CellError.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/CellError.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/CellError.java Fri Aug 5 14:25:10 2011 (r13440) @@ -102,9 +102,9 @@ { if (Symbol.PRINT_ESCAPE.symbolValue() == NIL) return super.getMessage(); - StringBuffer sb = new StringBuffer(typeOf().writeToString()); + StringBuffer sb = new StringBuffer(typeOf().princToString()); sb.append(' '); - sb.append(getCellName().writeToString()); + sb.append(getCellName().princToString()); return unreadableString(sb.toString()); } } Modified: trunk/abcl/src/org/armedbear/lisp/Closure.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Closure.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/Closure.java Fri Aug 5 14:25:10 2011 (r13440) @@ -131,7 +131,7 @@ final LispObject lambdaList = lambdaExpression.cadr(); setLambdaList(lambdaList); if (!(lambdaList == NIL || lambdaList instanceof Cons)) - error(new ProgramError("The lambda list " + lambdaList.writeToString() + + error(new ProgramError("The lambda list " + lambdaList.princToString() + " is invalid.")); boolean _andKey = false; boolean _allowOtherKeys = false; @@ -387,7 +387,7 @@ private static final void invalidParameter(LispObject obj) { - error(new ProgramError(obj.writeToString() + + error(new ProgramError(obj.princToString() + " may not be used as a variable in a lambda list.")); } @@ -860,7 +860,7 @@ if (!allowOtherKeys && (allowOtherKeysValue == null || allowOtherKeysValue == NIL)) error(new ProgramError("Unrecognized keyword argument " + - unrecognizedKeyword.writeToString())); + unrecognizedKeyword.printObject())); } } } Modified: trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java Fri Aug 5 14:25:10 2011 (r13440) @@ -236,10 +236,10 @@ return loadClassBytes((byte[]) arg.javaInstance(byte[].class)); } catch(Throwable t) { Debug.trace(t); - return error(new LispError("Unable to load " + arg.writeToString())); + return error(new LispError("Unable to load " + arg.princToString())); } } - return error(new LispError("Unable to load " + arg.writeToString())); + return error(new LispError("Unable to load " + arg.princToString())); } }; Modified: trunk/abcl/src/org/armedbear/lisp/Complex.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Complex.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/Complex.java Fri Aug 5 14:25:10 2011 (r13440) @@ -343,12 +343,12 @@ } @Override - public String writeToString() + public String printObject() { StringBuilder sb = new StringBuilder("#C("); - sb.append(realpart.writeToString()); + sb.append(realpart.printObject()); sb.append(' '); - sb.append(imagpart.writeToString()); + sb.append(imagpart.printObject()); sb.append(')'); return sb.toString(); } Modified: trunk/abcl/src/org/armedbear/lisp/ComplexArray.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ComplexArray.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/ComplexArray.java Fri Aug 5 14:25:10 2011 (r13440) @@ -233,7 +233,7 @@ } @Override - public String writeToString() + public String printObject() { return writeToString(dimv); } Modified: trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte32.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte32.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte32.java Fri Aug 5 14:25:10 2011 (r13440) @@ -229,7 +229,7 @@ } @Override - public String writeToString() + public String printObject() { return writeToString(dimv); } Modified: trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte8.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte8.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte8.java Fri Aug 5 14:25:10 2011 (r13440) @@ -226,7 +226,7 @@ } @Override - public String writeToString() + public String printObject() { if (Symbol.PRINT_READABLY.symbolValue() != NIL) { error(new PrintNotReadable(list(Keyword.OBJECT, this))); Modified: trunk/abcl/src/org/armedbear/lisp/Condition.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Condition.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/Condition.java Fri Aug 5 14:25:10 2011 (r13440) @@ -178,11 +178,11 @@ { return format(formatControl, getFormatArguments()); } - return unreadableString(typeOf().writeToString()); + return unreadableString(typeOf().princToString()); } @Override - public final String writeToString() + public final String printObject() { final LispThread thread = LispThread.currentThread(); if (Symbol.PRINT_ESCAPE.symbolValue(thread) == NIL) @@ -216,6 +216,6 @@ int currentLevel = ((Fixnum)currentPrintLevel).value; if (currentLevel >= maxLevel) return "#"; - return unreadableString(typeOf().writeToString()); + return unreadableString(typeOf().princToString()); } } Modified: trunk/abcl/src/org/armedbear/lisp/Cons.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Cons.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/Cons.java Fri Aug 5 14:25:10 2011 (r13440) @@ -498,7 +498,7 @@ } @Override - public String writeToString() + public String printObject() { final LispThread thread = LispThread.currentThread(); final LispObject printLength = Symbol.PRINT_LENGTH.symbolValue(thread); @@ -522,7 +522,7 @@ if (cdr.cdr() == NIL) { sb.append('\''); - sb.append(cdr.car().writeToString()); + sb.append(cdr.car().printObject()); return sb.toString(); } } @@ -535,7 +535,7 @@ if (cdr.cdr() == NIL) { sb.append("#'"); - sb.append(cdr.car().writeToString()); + sb.append(cdr.car().printObject()); return sb.toString(); } } @@ -555,14 +555,14 @@ if (count < maxLength) { LispObject p = this; - sb.append(p.car().writeToString()); + sb.append(p.car().printObject()); ++count; while ((p = p.cdr()) instanceof Cons) { sb.append(' '); if (count < maxLength) { - sb.append(p.car().writeToString()); + sb.append(p.car().printObject()); ++count; } else @@ -574,7 +574,7 @@ if (!truncated && p != NIL) { sb.append(" . "); - sb.append(p.writeToString()); + sb.append(p.printObject()); } } else Modified: trunk/abcl/src/org/armedbear/lisp/DoubleFloat.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/DoubleFloat.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/DoubleFloat.java Fri Aug 5 14:25:10 2011 (r13440) @@ -529,26 +529,26 @@ else m = (bits & 0xfffffffffffffL) | 0x10000000000000L; LispObject significand = number(m); -// Debug.trace("significand = " + significand.writeToString()); +// Debug.trace("significand = " + significand.printObject()); Fixnum exponent = Fixnum.getInstance(e - 1075); -// Debug.trace("exponent = " + exponent.writeToString()); +// Debug.trace("exponent = " + exponent.printObject()); Fixnum sign = Fixnum.getInstance(s); -// Debug.trace("sign = " + sign.writeToString()); +// Debug.trace("sign = " + sign.printObject()); LispObject result = significand; -// Debug.trace("result = " + result.writeToString()); +// Debug.trace("result = " + result.printObject()); result = result.multiplyBy(MathFunctions.EXPT.execute(Fixnum.TWO, exponent)); -// Debug.trace("result = " + result.writeToString()); +// Debug.trace("result = " + result.printObject()); result = result.truncate(Fixnum.ONE); LispObject remainder = coerceToFloat(thread._values[1]); result = result.multiplyBy(sign); -// Debug.trace("result = " + result.writeToString()); +// Debug.trace("result = " + result.printObject()); // // Calculate remainder. // LispObject product = result.multiplyBy(obj); -// Debug.trace("product = " + product.writeToString()); +// Debug.trace("product = " + product.printObject()); // LispObject remainder = subtract(product); return thread.setValues(result, remainder); } @@ -572,16 +572,16 @@ } @Override - public String writeToString() + public String printObject() { if (value == Double.POSITIVE_INFINITY) { StringBuilder sb = new StringBuilder("#."); - sb.append(Symbol.DOUBLE_FLOAT_POSITIVE_INFINITY.writeToString()); + sb.append(Symbol.DOUBLE_FLOAT_POSITIVE_INFINITY.printObject()); return sb.toString(); } if (value == Double.NEGATIVE_INFINITY) { StringBuilder sb = new StringBuilder("#."); - sb.append(Symbol.DOUBLE_FLOAT_NEGATIVE_INFINITY.writeToString()); + sb.append(Symbol.DOUBLE_FLOAT_NEGATIVE_INFINITY.printObject()); return sb.toString(); } @@ -646,7 +646,7 @@ return new DoubleFloat(((SingleFloat)obj).value); if (obj instanceof Ratio) return new DoubleFloat(((Ratio)obj).doubleValue()); - error(new TypeError("The value " + obj.writeToString() + + error(new TypeError("The value " + obj.princToString() + " cannot be converted to type DOUBLE-FLOAT.")); // Not reached. return null; Modified: trunk/abcl/src/org/armedbear/lisp/Environment.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Environment.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/Environment.java Fri Aug 5 14:25:10 2011 (r13440) @@ -245,7 +245,7 @@ } @Override - public String writeToString() + public String printObject() { return unreadableString(Symbol.ENVIRONMENT); } Modified: trunk/abcl/src/org/armedbear/lisp/FileStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/FileStream.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/FileStream.java Fri Aug 5 14:25:10 2011 (r13440) @@ -183,7 +183,7 @@ String namestring = pathname.getNamestring(); if (namestring == null) return error(new SimpleError("Pathname has no namestring: " + - pathname.writeToString())); + pathname.princToString())); File file = new File(namestring); length = file.length(); // in 8-bit bytes } @@ -263,7 +263,7 @@ } @Override - public String writeToString() + public String printObject() { return unreadableString(Symbol.FILE_STREAM); } Modified: trunk/abcl/src/org/armedbear/lisp/Fixnum.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Fixnum.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/Fixnum.java Fri Aug 5 14:25:10 2011 (r13440) @@ -939,7 +939,7 @@ } @Override - public String writeToString() + public String printObject() { final LispThread thread = LispThread.currentThread(); int base = Fixnum.getValue(Symbol.PRINT_BASE.symbolValue(thread)); Modified: trunk/abcl/src/org/armedbear/lisp/FloatFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/FloatFunctions.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/FloatFunctions.java Fri Aug 5 14:25:10 2011 (r13440) @@ -63,13 +63,13 @@ trap_underflow = true; else error(new LispError("Unsupported floating point trap: " + - car.writeToString())); + car.princToString())); value = value.cdr(); } TRAP_OVERFLOW = trap_overflow; TRAP_UNDERFLOW = trap_underflow; } else - error(new LispError("Unrecognized keyword: " + key.writeToString())); + error(new LispError("Unrecognized keyword: " + key.princToString())); } return LispThread.currentThread().nothing(); } Modified: trunk/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java Fri Aug 5 14:25:10 2011 (r13440) @@ -65,13 +65,13 @@ } @Override - public String writeToString() + public String printObject() { StringBuffer sb = - new StringBuffer(Symbol.FORWARD_REFERENCED_CLASS.writeToString()); + new StringBuffer(Symbol.FORWARD_REFERENCED_CLASS.printObject()); if (getName() != null) { sb.append(' '); - sb.append(getName().writeToString()); + sb.append(getName().printObject()); } return unreadableString(sb.toString()); } @@ -90,7 +90,7 @@ LispClass.addClass(name, c); return c; } - return error(new TypeError(arg.writeToString() + + return error(new TypeError(arg.princToString() + " is not a valid class name.")); } }; Modified: trunk/abcl/src/org/armedbear/lisp/Function.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Function.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/Function.java Fri Aug 5 14:25:10 2011 (r13440) @@ -313,12 +313,12 @@ } @Override - public String writeToString() + public String printObject() { LispObject name = getLambdaName(); if (name != null && name != NIL) { StringBuffer sb = new StringBuffer("#"); @@ -336,7 +336,7 @@ final SpecialBindingsMark mark = thread.markSpecialBindings(); thread.bindSpecial(Symbol.PRINT_LENGTH, Fixnum.THREE); try { - sb.append(lambdaList.writeToString()); + sb.append(lambdaList.printObject()); } finally { thread.resetSpecialBindings(mark); Modified: trunk/abcl/src/org/armedbear/lisp/Go.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Go.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/Go.java Fri Aug 5 14:25:10 2011 (r13440) @@ -58,7 +58,7 @@ public LispObject getCondition() { StringBuffer sb = new StringBuffer("No tag named "); - sb.append(tag.writeToString()); + sb.append(tag.princToString()); sb.append(" is currently visible"); return new ControlError(sb.toString()); } Modified: trunk/abcl/src/org/armedbear/lisp/HashTable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/HashTable.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/HashTable.java Fri Aug 5 14:25:10 2011 (r13440) @@ -225,14 +225,14 @@ } @Override - public String writeToString() { + public String printObject() { if (Symbol.PRINT_READABLY.symbolValue(LispThread.currentThread()) != NIL) { error(new PrintNotReadable(list(Keyword.OBJECT, this))); return null; // Not reached. } - StringBuilder sb = new StringBuilder(getTest().writeToString()); + StringBuilder sb = new StringBuilder(getTest().princToString()); sb.append(' '); - sb.append(Symbol.HASH_TABLE.writeToString()); + sb.append(Symbol.HASH_TABLE.princToString()); sb.append(' '); sb.append(count); if (count == 1) { Modified: trunk/abcl/src/org/armedbear/lisp/HashTableFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/HashTableFunctions.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/HashTableFunctions.java Fri Aug 5 14:25:10 2011 (r13440) @@ -69,7 +69,7 @@ if (test == FUNCTION_EQUALP) return HashTable.newEqualpHashTable(n, rehashSize, rehashThreshold); return error(new LispError("Unsupported test for MAKE-HASH-TABLE: " + - test.writeToString())); + test.princToString())); } }; @@ -102,7 +102,7 @@ return WeakHashTable.newEqualpHashTable(n, rehashSize, rehashThreshold, weakness); return error(new LispError("Unsupported test for MAKE-HASH-TABLE: " + - test.writeToString())); + test.princToString())); } }; Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Interpreter.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/Interpreter.java Fri Aug 5 14:25:10 2011 (r13440) @@ -309,14 +309,14 @@ StringBuilder sb = new StringBuilder(); sb.append(separator); sb.append("Caught "); - sb.append(c.getCondition().typeOf().writeToString()); + sb.append(c.getCondition().typeOf().printObject()); sb.append(" while processing --eval option \"" + args[i + 1] + "\":"); sb.append(separator); sb.append(" "); final LispThread thread = LispThread.currentThread(); thread.bindSpecial(Symbol.PRINT_ESCAPE, NIL); - sb.append(c.getCondition().writeToString()); + sb.append(c.getCondition().princToString()); sb.append(separator); System.err.print(sb.toString()); exit(2); // FIXME @@ -408,10 +408,10 @@ slash = new Cons(values[i], slash); Symbol.SLASH.setSymbolValue(slash); for (int i = 0; i < values.length; i++) - out._writeLine(values[i].writeToString()); + out._writeLine(values[i].printObject()); } else { Symbol.SLASH.setSymbolValue(new Cons(result)); - out._writeLine(result.writeToString()); + out._writeLine(result.printObject()); } out._finishOutput(); } @@ -445,7 +445,7 @@ out.freshLine(); Condition condition = (Condition) c.getCondition(); out._writeLine("Error: unhandled condition: " + - condition.writeToString()); + condition.princToString()); if (thread != null) thread.printBacktrace(); } @@ -457,7 +457,7 @@ out.freshLine(); Condition condition = (Condition) c.getCondition(); out._writeLine("Error: unhandled condition: " + - condition.writeToString()); + condition.princToString()); if (thread != null) thread.printBacktrace(); } @@ -516,7 +516,7 @@ SpecialBindingsMark mark = thread.markSpecialBindings(); thread.bindSpecial(Symbol.PRINT_ESCAPE, NIL); try { - conditionText = getCondition().writeToString(); + conditionText = getCondition().princToString(); } catch (Throwable t) { conditionText = ""; } finally { @@ -552,14 +552,14 @@ final int offset = ((Stream)stream).getOffset(); Debug.trace("Error loading " + - truename.writeToString() + + truename.princToString() + " at line " + lineNumber + " (offset " + offset + ")"); } } Debug.trace("Encountered unhandled condition of type " + - condition.typeOf().writeToString() + ':'); - Debug.trace(" " + condition.writeToString()); + condition.typeOf().princToString() + ':'); + Debug.trace(" " + condition.princToString()); } catch (Throwable t) {} // catch any exception to throw below finally { Modified: trunk/abcl/src/org/armedbear/lisp/JarStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/JarStream.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/JarStream.java Fri Aug 5 14:25:10 2011 (r13440) @@ -136,10 +136,10 @@ } @Override - public String writeToString() + public String printObject() { StringBuffer sb = new StringBuffer(); - sb.append(Symbol.JAR_STREAM.writeToString()); + sb.append(Symbol.JAR_STREAM.princToString()); String namestring = pathname.getNamestring(); if (namestring != null) { sb.append(" "); Modified: trunk/abcl/src/org/armedbear/lisp/Java.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Java.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/Java.java Fri Aug 5 14:25:10 2011 (r13440) @@ -413,7 +413,7 @@ sb.append(methodName); sb.append('('); for (int i = 2; i < args.length; i++) { - sb.append(args[i].writeToString()); + sb.append(args[i].princToString()); if (i < args.length - 1) sb.append(','); } @@ -558,7 +558,7 @@ } else if(object instanceof Class) { constructor = findConstructor((Class) object, args); } else { - return error(new LispError(classRef.writeToString() + " is neither a Constructor nor a Class")); + return error(new LispError(classRef.princToString() + " is neither a Constructor nor a Class")); } } Class[] argTypes = constructor.getParameterTypes(); @@ -1393,7 +1393,7 @@ if (javaObjectgetObject instanceof Class) { return (Class) javaObjectgetObject; } - error(new LispError(obj.writeToString() + " does not designate a Java class.")); + error(new LispError(obj.princToString() + " does not designate a Java class.")); return null; } Modified: trunk/abcl/src/org/armedbear/lisp/JavaObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/JavaObject.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/JavaObject.java Fri Aug 5 14:25:10 2011 (r13440) @@ -354,7 +354,7 @@ } @Override - public String writeToString() + public String printObject() { if (obj instanceof ControlTransfer) return obj.toString(); @@ -540,9 +540,9 @@ { final Object obj = javaObject.getObject(); final StringBuilder sb = - new StringBuilder(javaObject.writeToString()); + new StringBuilder(javaObject.princToString()); sb.append(" is an object of type "); - sb.append(Symbol.JAVA_OBJECT.writeToString()); + sb.append(Symbol.JAVA_OBJECT.princToString()); sb.append("."); sb.append(System.getProperty("line.separator")); sb.append("The wrapped Java object is "); Modified: trunk/abcl/src/org/armedbear/lisp/JavaStackFrame.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/JavaStackFrame.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/JavaStackFrame.java Fri Aug 5 14:25:10 2011 (r13440) @@ -54,7 +54,7 @@ public LispObject classOf() { return BuiltInClass.JAVA_STACK_FRAME; } @Override - public String writeToString() { + public String printObject() { final String JAVA_STACK_FRAME = "JAVA-STACK-FRAME"; return unreadableString(JAVA_STACK_FRAME + " " + toLispString().toString()); Modified: trunk/abcl/src/org/armedbear/lisp/Layout.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Layout.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/Layout.java Fri Aug 5 14:25:10 2011 (r13440) @@ -135,7 +135,7 @@ } @Override - public String writeToString() + public String printObject() { return unreadableString(Symbol.LAYOUT); } Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Lisp.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Fri Aug 5 14:25:10 2011 (r13440) @@ -514,7 +514,7 @@ } else return error(new ProgramError("Illegal function object: " + - first.writeToString())); + first.princToString())); } } else @@ -707,7 +707,7 @@ { if (tagbody == null) return error(new ControlError("Unmatched tag " - + tag.writeToString() + + + tag.princToString() + " for GO outside lexical extent.")); throw new Go(tagbody, tag); @@ -724,7 +724,7 @@ { if (binding.env.inactive) return error(new ControlError("Unmatched tag " - + binding.symbol.writeToString() + + + binding.symbol.princToString() + " for GO outside of lexical extent.")); throw new Go(binding.env, binding.symbol); @@ -743,7 +743,7 @@ { if (blockId == null) return error(new ControlError("Unmatched block " - + blockName.writeToString() + " for " + + + blockName.princToString() + " for " + "RETURN-FROM outside lexical extent.")); throw new Return(blockId, result); @@ -767,7 +767,7 @@ if (binding.env.inactive) return error(new ControlError("Unmatched block " - + binding.symbol.writeToString() + + + binding.symbol.princToString() + " for RETURN-FROM outside of" + " lexical extent.")); @@ -796,7 +796,7 @@ Binding binding = env.getTagBinding(tag); if (binding == null) return error(new ControlError("No tag named " + - tag.writeToString() + + tag.princToString() + " is currently visible.")); else if (memql(tag, localTags)) { @@ -1118,7 +1118,7 @@ else { Symbol.GENSYM_COUNTER.setSymbolValue(Fixnum.ZERO); error(new TypeError("The value of *GENSYM-COUNTER* was not a nonnegative integer. Old value: " + - oldValue.writeToString() + " New value: 0")); + oldValue.princToString() + " New value: 0")); } } else { // we're manipulating a global resource @@ -1131,7 +1131,7 @@ else { Symbol.GENSYM_COUNTER.setSymbolValue(Fixnum.ZERO); error(new TypeError("The value of *GENSYM-COUNTER* was not a nonnegative integer. Old value: " + - oldValue.writeToString() + " New value: 0")); + oldValue.princToString() + " New value: 0")); } } } @@ -1421,7 +1421,7 @@ public static final String safeWriteToString(LispObject obj) { try { - return obj.writeToString(); + return obj.printObject(); } catch (NullPointerException e) { @@ -1635,7 +1635,7 @@ if (stream.isCharacterInputStream()) return stream; return (Stream) // Not reached. - error(new TypeError("The value " + obj.writeToString() + + error(new TypeError("The value " + obj.princToString() + " is not a character input stream.")); } @@ -1646,7 +1646,7 @@ if (stream.isCharacterOutputStream()) return stream; return (Stream) // Not reached. - error(new TypeError("The value " + obj.writeToString() + + error(new TypeError("The value " + obj.princToString() + " is not a character output stream.")); } @@ -1657,7 +1657,7 @@ if (stream.isBinaryInputStream()) return stream; return (Stream) // Not reached. - error(new TypeError("The value " + obj.writeToString() + + error(new TypeError("The value " + obj.princToString() + " is not a binary input stream.")); } @@ -1786,7 +1786,7 @@ Package pkg = Packages.findPackage(javaString(obj)); if (pkg != null) return pkg; - error(new PackageError(obj.writeToString() + " is not the name of a package.")); + error(new PackageError(obj.princToString() + " is not the name of a package.")); // Not reached. return null; } @@ -1873,7 +1873,7 @@ list = list.cddr(); else return error(new TypeError("Malformed property list: " + - plist.writeToString())); + plist.princToString())); } return defaultValue; } @@ -1956,7 +1956,7 @@ while (list != NIL) { if (!(list.cdr() instanceof Cons)) - error(new ProgramError("The symbol " + symbol.writeToString() + + error(new ProgramError("The symbol " + symbol.princToString() + " has an odd number of items in its property list.")); if (list.car() == indicator) { @@ -2010,7 +2010,7 @@ thread.bindSpecial(Symbol.PRINT_ESCAPE, NIL); thread.bindSpecial(Symbol.PRINT_READABLY, NIL); try { - sb.append(obj.writeToString()); + sb.append(obj.printObject()); } finally { thread.resetSpecialBindings(mark); @@ -2025,7 +2025,7 @@ final SpecialBindingsMark mark = thread.markSpecialBindings(); thread.bindSpecial(Symbol.PRINT_ESCAPE, T); try { - sb.append(obj.writeToString()); + sb.append(obj.printObject()); } finally { thread.resetSpecialBindings(mark); @@ -2042,7 +2042,7 @@ thread.bindSpecial(Symbol.PRINT_RADIX, NIL); thread.bindSpecial(Symbol.PRINT_BASE, Fixnum.constants[10]); try { - sb.append(obj.writeToString()); + sb.append(obj.printObject()); } finally { thread.resetSpecialBindings(mark); @@ -2059,7 +2059,7 @@ thread.bindSpecial(Symbol.PRINT_RADIX, NIL); thread.bindSpecial(Symbol.PRINT_BASE, Fixnum.constants[16]); try { - sb.append(obj.writeToString()); + sb.append(obj.printObject()); } finally { thread.resetSpecialBindings(mark); @@ -2703,7 +2703,7 @@ static class unboundValue extends LispObject { @Override - public String writeToString() + public String printObject() { return "#"; } @@ -2713,7 +2713,7 @@ static class nullValue extends LispObject { @Override - public String writeToString() + public String printObject() { return "null"; } Modified: trunk/abcl/src/org/armedbear/lisp/LispCharacter.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispCharacter.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/LispCharacter.java Fri Aug 5 14:25:10 2011 (r13440) @@ -223,7 +223,7 @@ } @Override - public final String writeToString() + public final String printObject() { final LispThread thread = LispThread.currentThread(); boolean printReadably = (Symbol.PRINT_READABLY.symbolValue(thread) != NIL); Modified: trunk/abcl/src/org/armedbear/lisp/LispClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispClass.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/LispClass.java Fri Aug 5 14:25:10 2011 (r13440) @@ -75,7 +75,7 @@ { StringBuilder sb = new StringBuilder("There is no class named "); - sb.append(name.writeToString()); + sb.append(name.princToString()); sb.append('.'); return error(new LispError(sb.toString())); } Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispObject.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/LispObject.java Fri Aug 5 14:25:10 2011 (r13440) @@ -65,7 +65,7 @@ public LispObject getDescription() { StringBuilder sb = new StringBuilder("An object of type "); - sb.append(typeOf().writeToString()); + sb.append(typeOf().princToString()); sb.append(" at #x"); sb.append(Integer.toHexString(System.identityHashCode(this)).toUpperCase()); return new SimpleString(sb); @@ -130,7 +130,7 @@ { if (c.isAssignableFrom(getClass())) return this; - return error(new LispError("The value " + writeToString() + + return error(new LispError("The value " + princToString() + " is not of class " + c.getName())); } @@ -731,7 +731,25 @@ return type_error(this, Symbol.SYMBOL); } - public String writeToString() + /** PRINC-TO-STRING function to be used with Java objects + * + * @return A string in human-readable format, as per PRINC definition + */ + public String princToString() + { + LispThread thread = LispThread.currentThread(); + SpecialBindingsMark mark = thread.markSpecialBindings(); + try { + thread.bindSpecial(Symbol.PRINT_READABLY, NIL); + thread.bindSpecial(Symbol.PRINT_ESCAPE, NIL); + return printObject(); + } + finally { + thread.resetSpecialBindings(mark); + } + } + + public String printObject() { return toString(); } @@ -759,7 +777,7 @@ public final String unreadableString(Symbol symbol, boolean identity) { - return unreadableString(symbol.writeToString(), identity); + return unreadableString(symbol.printObject(), identity); } // Special operator @@ -1149,7 +1167,7 @@ public LispObject STRING() { - return error(new TypeError(writeToString() + " cannot be coerced to a string.")); + return error(new TypeError(princToString() + " cannot be coerced to a string.")); } public char[] chars() Modified: trunk/abcl/src/org/armedbear/lisp/LispStackFrame.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispStackFrame.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/LispStackFrame.java Fri Aug 5 14:25:10 2011 (r13440) @@ -48,7 +48,7 @@ { public UnavailableArgument () { } @Override - public String writeToString() { + public String printObject() { return unreadableString("unavailable arg", false); } } @@ -114,12 +114,12 @@ } @Override - public String writeToString() + public String printObject() { String result = ""; final String LISP_STACK_FRAME = "LISP-STACK-FRAME"; try { - result = Symbol.PRIN1_TO_STRING.execute(this.toLispList()).writeToString(); + result = Symbol.PRIN1_TO_STRING.execute(this.toLispList()).printObject(); } catch (Throwable t) { // error while printing stack Debug.trace("Serious printing error: "); Debug.trace(t); @@ -190,7 +190,7 @@ { String result; try { - result = this.toLispList().writeToString(); + result = this.toLispList().printObject(); } catch (Throwable t) { // error while printing stack Debug.trace("Serious printing error: "); Debug.trace(t); Modified: trunk/abcl/src/org/armedbear/lisp/LispThread.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispThread.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/LispThread.java Fri Aug 5 14:25:10 2011 (r13440) @@ -586,7 +586,7 @@ rest = rest.cdr(); } error(new ControlError("Attempt to throw to the nonexistent tag " + - tag.writeToString() + ".")); + tag.princToString() + ".")); } @@ -871,7 +871,7 @@ sb.append(' '); stream._writeString(sb.toString()); } - String raw = obj.writeToString(); + String raw = obj.printObject(); if (stream.getCharPos() + raw.length() < 80) { // It fits. stream._writeString(raw); @@ -917,7 +917,7 @@ } @Override - public String writeToString() + public String printObject() { StringBuffer sb = new StringBuffer("THREAD"); if (name != NIL) { @@ -948,7 +948,7 @@ name = args[2].STRING(); else error(new ProgramError("Unrecognized keyword argument " + - args[1].writeToString() + ".")); + args[1].princToString() + ".")); } return new LispThread(checkFunction(args[0]), name); } Modified: trunk/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Load.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/Load.java Fri Aug 5 14:25:10 2011 (r13440) @@ -288,7 +288,7 @@ // Look for a init FASL inside a packed FASL if (truename != null - && truename.type.writeToString().equals(COMPILE_FILE_TYPE) && Utilities.checkZipFile(truename)) { + && truename.type.princToString().equals(COMPILE_FILE_TYPE) && Utilities.checkZipFile(truename)) { Pathname init = new Pathname(truename.getNamestring()); init.type = COMPILE_FILE_INIT_FASL_TYPE; LispObject t = Pathname.truename(init); @@ -416,10 +416,10 @@ } return error(new SimpleError("FASL version mismatch; found '" - + second.writeToString() + "' but expected '" - + _FASL_VERSION_.getSymbolValue().writeToString() + + second.princToString() + "' but expected '" + + _FASL_VERSION_.getSymbolValue().princToString() + "' in " - + Symbol.LOAD_PATHNAME.symbolValue(thread).writeToString())); + + Symbol.LOAD_PATHNAME.symbolValue(thread).princToString())); } } @@ -525,7 +525,7 @@ out.freshLine(); out._writeString(prefix); out._writeString(auto ? " Autoloading " : " Loading "); - out._writeString(!truename.equals(NIL) ? truePathname.writeToString() : "stream"); + out._writeString(!truename.equals(NIL) ? truePathname.princToString() : "stream"); out._writeLine(" ..."); out._finishOutput(); LispObject result = loadStream(in, print, thread, returnLastResult); @@ -533,7 +533,7 @@ out.freshLine(); out._writeString(prefix); out._writeString(auto ? " Autoloaded " : " Loaded "); - out._writeString(!truename.equals(NIL) ? truePathname.writeToString() : "stream"); + out._writeString(!truename.equals(NIL) ? truePathname.princToString() : "stream"); out._writeString(" ("); out._writeString(String.valueOf(((float)elapsed)/1000)); out._writeLine(" seconds)"); @@ -576,7 +576,7 @@ if (print) { Stream out = checkCharacterOutputStream(Symbol.STANDARD_OUTPUT.symbolValue(thread)); - out._writeLine(result.writeToString()); + out._writeLine(result.printObject()); out._finishOutput(); } } Modified: trunk/abcl/src/org/armedbear/lisp/LogicalPathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LogicalPathname.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/LogicalPathname.java Fri Aug 5 14:25:10 2011 (r13440) @@ -215,7 +215,7 @@ } else if (part == Keyword.RELATIVE) sb.append(';'); else - error(new FileError("Unsupported directory component " + part.writeToString() + ".", + error(new FileError("Unsupported directory component " + part.princToString() + ".", this)); temp = temp.cdr(); while (temp != NIL) { @@ -229,7 +229,7 @@ else if (part == Keyword.UP) sb.append(".."); else - error(new FileError("Unsupported directory component " + part.writeToString() + ".", + error(new FileError("Unsupported directory component " + part.princToString() + ".", this)); sb.append(';'); temp = temp.cdr(); @@ -239,7 +239,7 @@ } @Override - public String writeToString() + public String printObject() { final LispThread thread = LispThread.currentThread(); boolean printReadably = (Symbol.PRINT_READABLY.symbolValue(thread) != NIL); Modified: trunk/abcl/src/org/armedbear/lisp/MacroObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/MacroObject.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/MacroObject.java Fri Aug 5 14:25:10 2011 (r13440) @@ -129,7 +129,7 @@ } @Override - public String writeToString() + public String printObject() { return unreadableString("MACRO-OBJECT"); } Modified: trunk/abcl/src/org/armedbear/lisp/MathFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/MathFunctions.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/MathFunctions.java Fri Aug 5 14:25:10 2011 (r13440) @@ -667,7 +667,7 @@ x = ((DoubleFloat)base).value; else return error(new LispError("EXPT: unsupported case: base is of type " + - base.typeOf().writeToString())); + base.typeOf().princToString())); if (power instanceof Fixnum) y = ((Fixnum)power).value; @@ -681,7 +681,7 @@ y = ((DoubleFloat)power).value; else return error(new LispError("EXPT: unsupported case: power is of type " + - power.typeOf().writeToString())); + power.typeOf().princToString())); double r = Math.pow(x, y); if (Double.isNaN(r)) { if (x < 0) { Modified: trunk/abcl/src/org/armedbear/lisp/Package.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Package.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/Package.java Fri Aug 5 14:25:10 2011 (r13440) @@ -846,7 +846,7 @@ } @Override - public String writeToString() + public String printObject() { if (_PRINT_FASL_.symbolValue() != NIL && name != null) { StringBuilder sb = new StringBuilder("#.(FIND-PACKAGE \""); Modified: trunk/abcl/src/org/armedbear/lisp/PackageFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/PackageFunctions.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/PackageFunctions.java Fri Aug 5 14:25:10 2011 (r13440) @@ -342,7 +342,7 @@ LispObject string = obj.STRING(); Package p = Packages.findPackage(string.getStringValue()); if (p == null) - return error(new LispError(obj.writeToString() + + return error(new LispError(obj.princToString() + " is not the name of a package.")); pkg.usePackage(p); } Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Fri Aug 5 14:25:10 2011 (r13440) @@ -773,7 +773,7 @@ // else: Nothing to do. } else { error(new FileError("Unsupported directory component " - + part.writeToString() + ".", + + part.printObject() + ".", this)); } while (temp != NIL) { @@ -787,7 +787,7 @@ } else if (part == Keyword.UP) { sb.append(".."); } else { - error(new FileError("Unsupported directory component " + part.writeToString() + ".", + error(new FileError("Unsupported directory component " + part.princToString() + ".", this)); } sb.append(separatorChar); @@ -886,7 +886,7 @@ } @Override - public String writeToString() { + public String printObject() { final LispThread thread = LispThread.currentThread(); final boolean printReadably = (Symbol.PRINT_READABLY.symbolValue(thread) != NIL); final boolean printEscape = (Symbol.PRINT_ESCAPE.symbolValue(thread) != NIL); @@ -939,32 +939,32 @@ sb.append("PATHNAME (with no namestring) "); if (host != NIL) { sb.append(":HOST "); - sb.append(host.writeToString()); + sb.append(host.printObject()); sb.append(" "); } if (device != NIL) { sb.append(":DEVICE "); - sb.append(device.writeToString()); + sb.append(device.printObject()); sb.append(" "); } if (directory != NIL) { sb.append(":DIRECTORY "); - sb.append(directory.writeToString()); + sb.append(directory.printObject()); sb.append(" "); } if (name != NIL) { sb.append(":NAME "); - sb.append(name.writeToString()); + sb.append(name.printObject()); sb.append(" "); } if (type != NIL) { sb.append(":TYPE "); - sb.append(type.writeToString()); + sb.append(type.printObject()); sb.append(" "); } if (version != NIL) { sb.append(":VERSION "); - sb.append(version.writeToString()); + sb.append(version.printObject()); sb.append(" "); } if (sb.charAt(sb.length() - 1) == ' ') { @@ -1067,7 +1067,7 @@ // A defined logical pathname host. return new LogicalPathname(host.getStringValue(), s); } - error(new LispError(host.writeToString() + " is not defined as a logical pathname host.")); + error(new LispError(host.princToString() + " is not defined as a logical pathname host.")); // Not reached. return null; } @@ -1184,7 +1184,7 @@ String namestring = pathname.getNamestring(); if (namestring == null) { error(new SimpleError("Pathname has no namestring: " - + pathname.writeToString())); + + pathname.princToString())); } return new SimpleString(namestring); } @@ -1374,7 +1374,7 @@ } if (LOGICAL_PATHNAME_TRANSLATIONS.get(logicalHost) == null) { // Not a defined logical pathname host -- A UNC path - //warning(new LispError(host.writeToString() + " is not defined as a logical pathname host.")); + //warning(new LispError(host.printObject() + " is not defined as a logical pathname host.")); p = new Pathname(); logical = false; p.host = host; @@ -1415,7 +1415,7 @@ } else if (directory == Keyword.WILD || directory == Keyword.WILD_INFERIORS) { p.directory = directory; } else { - error(new LispError("Invalid directory component for logical pathname: " + directory.writeToString())); + error(new LispError("Invalid directory component for logical pathname: " + directory.princToString())); } } else { p.directory = directory; @@ -1468,9 +1468,9 @@ if (second == Keyword.UP || second == Keyword.BACK) { if (signalError) { StringBuilder sb = new StringBuilder(); - sb.append(first.writeToString()); + sb.append(first.printObject()); sb.append(" may not be followed immediately by "); - sb.append(second.writeToString()); + sb.append(second.printObject()); sb.append('.'); error(new FileError(sb.toString(), this)); } @@ -1630,7 +1630,7 @@ result = new Cons(p, result); } } catch (IOException e) { - return error(new FileError("Unable to list directory " + pathname.writeToString() + ".", + return error(new FileError("Unable to list directory " + pathname.princToString() + ".", pathname)); } catch (SecurityException e) { Debug.trace(e); @@ -1807,7 +1807,7 @@ Cons d = (Cons) directory; while (true) { if (d.car() instanceof AbstractString) { - String s = d.car().writeToString(); + String s = d.car().printObject(); if (s.contains("*")) { return true; } @@ -1822,7 +1822,7 @@ return true; } if (name instanceof AbstractString) { - if (name.writeToString().contains("*")) { + if (name.printObject().contains("*")) { return true; } } @@ -1830,7 +1830,7 @@ return true; } if (type instanceof AbstractString) { - if (type.writeToString().contains("*")) { + if (type.printObject().contains("*")) { return true; } } @@ -1882,7 +1882,7 @@ value = pathname.version; } else { return error(new ProgramError("Unrecognized keyword " - + second.writeToString() + ".")); + + second.princToString() + ".")); } if (value == Keyword.WILD || value == Keyword.WILD_INFERIORS) { return T; @@ -2126,7 +2126,7 @@ final String namestring = pathname.getNamestring(); if (namestring == null) { return error(new FileError("Pathname has no namestring: " - + pathname.writeToString(), + + pathname.princToString(), pathname)); } @@ -2231,7 +2231,7 @@ error: if (errorIfDoesNotExist) { StringBuilder sb = new StringBuilder("The file "); - sb.append(pathname.writeToString()); + sb.append(pathname.princToString()); sb.append(" does not exist."); return error(new FileError(sb.toString(), pathname)); } @@ -2461,8 +2461,8 @@ } } return error(new FileError("Unable to rename " - + original.writeToString() - + " to " + newName.writeToString() + + original.princToString() + + " to " + newName.princToString() + ".")); } } Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Fri Aug 5 14:25:10 2011 (r13440) @@ -677,7 +677,7 @@ final LispObject value; value = checkSymbol(arg).symbolValue(); if (value instanceof SymbolMacro) - return error(new LispError(arg.writeToString() + + return error(new LispError(arg.princToString() + " has no dynamic value.")); return value; } @@ -884,7 +884,7 @@ public LispObject execute(LispObject first, LispObject second) { - checkStream(second)._writeString(first.writeToString()); + checkStream(second)._writeString(first.printObject()); return first; } }; @@ -907,7 +907,7 @@ out = Symbol.STANDARD_OUTPUT.symbolValue(); else out = second; - String output = first.writeToString(); + String output = first.printObject(); if (Symbol.PRINT_READABLY.symbolValue(LispThread.currentThread()) != NIL && output.contains("#<")) { //### Ticket #160: the cause lies here. @@ -934,7 +934,7 @@ @Override public LispObject execute(LispObject arg) { - return new SimpleString(arg.writeToString()); + return new SimpleString(arg.printObject()); } }; @@ -1596,11 +1596,11 @@ System.out.println("ERROR placeholder called with arguments:"); if (args.length == 1 && args[0] instanceof Condition) { - System.out.println(args[0].writeToString()); + System.out.println(args[0].princToString()); System.out.println(((Condition)args[0]).getConditionReport()); } else for (LispObject a : args) - System.out.println(a.writeToString()); + System.out.println(a.princToString()); throw e; } @@ -1733,7 +1733,7 @@ return NIL; } error(new TypeError("The value " + - destination.writeToString() + + destination.princToString() + " is not a character output stream.")); } if (destination instanceof Stream) { @@ -2423,7 +2423,7 @@ array = (ZeroRankArray) first; } else { return error(new TypeError("The value " + - first.writeToString() + + first.princToString() + " is not an array of rank 0.")); } array.aset(0, second); @@ -3262,7 +3262,7 @@ String s = javaString(obj); Package p = Packages.findPackage(s); if (p == null) { - error(new LispError(obj.writeToString() + + error(new LispError(obj.princToString() + " is not the name of a package.")); return NIL; } @@ -3287,7 +3287,7 @@ String s = javaString(obj); Package p = Packages.findPackage(s); if (p == null) { - error(new LispError(obj.writeToString() + + error(new LispError(obj.princToString() + " is not the name of a package.")); return NIL; } @@ -3713,7 +3713,7 @@ Binding binding = env.getTagBinding(args.car()); if (binding == null) return error(new ControlError("No tag named " + - args.car().writeToString() + + args.car().princToString() + " is currently visible.")); return nonLocalGo(binding, args.car()); @@ -4014,7 +4014,7 @@ } else if (obj instanceof Function) { function = obj; } else { - error(new LispError(obj.writeToString() + + error(new LispError(obj.princToString() + " is not a function name.")); return NIL; } Modified: trunk/abcl/src/org/armedbear/lisp/PrintNotReadable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/PrintNotReadable.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/PrintNotReadable.java Fri Aug 5 14:25:10 2011 (r13440) @@ -85,16 +85,7 @@ LispObject object = UNBOUND_VALUE; object = getInstanceSlotValue(Symbol.OBJECT); if (object != UNBOUND_VALUE) { - final LispThread thread = LispThread.currentThread(); - final SpecialBindingsMark mark = thread.markSpecialBindings(); - thread.bindSpecial(Symbol.PRINT_READABLY, NIL); - thread.bindSpecial(Symbol.PRINT_ARRAY, NIL); - try { - sb.append(object.writeToString()); - } - finally { - thread.resetSpecialBindings(mark); - } + sb.append(object.princToString()); } else sb.append("Object"); sb.append(" cannot be printed readably."); Modified: trunk/abcl/src/org/armedbear/lisp/RandomState.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/RandomState.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/RandomState.java Fri Aug 5 14:25:10 2011 (r13440) @@ -91,7 +91,7 @@ } @Override - public String writeToString() + public String printObject() { return unreadableString(Symbol.RANDOM_STATE); } Modified: trunk/abcl/src/org/armedbear/lisp/Ratio.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Ratio.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/Ratio.java Fri Aug 5 14:25:10 2011 (r13440) @@ -553,7 +553,7 @@ } @Override - public String writeToString() + public String printObject() { final LispThread thread = LispThread.currentThread(); int base = Fixnum.getValue(Symbol.PRINT_BASE.symbolValue(thread)); Modified: trunk/abcl/src/org/armedbear/lisp/Readtable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Readtable.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/Readtable.java Fri Aug 5 14:25:10 2011 (r13440) @@ -291,7 +291,7 @@ if (dispatchTable == null) { LispCharacter c = LispCharacter.getInstance(dispChar); - return error(new LispError(c.writeToString() + + return error(new LispError(c.princToString() + " is not a dispatch character.")); } LispObject function = @@ -307,7 +307,7 @@ if (dispatchTable == null) { LispCharacter c = LispCharacter.getInstance(dispChar); - error(new LispError(c.writeToString() + + error(new LispError(c.princToString() + " is not a dispatch character.")); } dispatchTable.functions.put(LispCharacter.toUpperCase(subChar), function); @@ -426,7 +426,7 @@ else if (second instanceof Symbol) designator = second; else - return error(new LispError(second.writeToString() + + return error(new LispError(second.princToString() + " does not designate a function.")); byte syntaxType; if (third != NIL) Modified: trunk/abcl/src/org/armedbear/lisp/Return.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Return.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/Return.java Fri Aug 5 14:25:10 2011 (r13440) @@ -72,7 +72,7 @@ public LispObject getCondition() { StringBuilder sb = new StringBuilder("No block named "); - sb.append(tag.writeToString()); + sb.append(tag.princToString()); sb.append(" is currently visible."); return new ControlError(sb.toString()); } Modified: trunk/abcl/src/org/armedbear/lisp/ShellCommand.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ShellCommand.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/ShellCommand.java Fri Aug 5 14:25:10 2011 (r13440) @@ -259,7 +259,7 @@ Pathname pathname = coerceToPathname(second); namestring = pathname.getNamestring(); if (namestring == null) { - return error(new FileError("Pathname has no namestring: " + pathname.writeToString(), + return error(new FileError("Pathname has no namestring: " + pathname.princToString(), pathname)); } } Modified: trunk/abcl/src/org/armedbear/lisp/SimpleArray_T.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SimpleArray_T.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/SimpleArray_T.java Fri Aug 5 14:25:10 2011 (r13440) @@ -319,7 +319,7 @@ } @Override - public String writeToString() + public String printObject() { return writeToString(dimv); } Modified: trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte16.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte16.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte16.java Fri Aug 5 14:25:10 2011 (r13440) @@ -291,7 +291,7 @@ } @Override - public String writeToString() + public String printObject() { if (Symbol.PRINT_READABLY.symbolValue() != NIL) { error(new PrintNotReadable(list(Keyword.OBJECT, this))); Modified: trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte32.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte32.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte32.java Fri Aug 5 14:25:10 2011 (r13440) @@ -281,7 +281,7 @@ } @Override - public String writeToString() + public String printObject() { if (Symbol.PRINT_READABLY.symbolValue() != NIL) { error(new PrintNotReadable(list(Keyword.OBJECT, this))); Modified: trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte8.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte8.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte8.java Fri Aug 5 14:25:10 2011 (r13440) @@ -278,7 +278,7 @@ } @Override - public String writeToString() + public String printObject() { if (Symbol.PRINT_READABLY.symbolValue() != NIL) { error(new PrintNotReadable(list(Keyword.OBJECT, this))); Modified: trunk/abcl/src/org/armedbear/lisp/SingleFloat.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SingleFloat.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/SingleFloat.java Fri Aug 5 14:25:10 2011 (r13440) @@ -561,16 +561,16 @@ } @Override - public String writeToString() + public String printObject() { if (value == Float.POSITIVE_INFINITY) { StringBuffer sb = new StringBuffer("#."); - sb.append(Symbol.SINGLE_FLOAT_POSITIVE_INFINITY.writeToString()); + sb.append(Symbol.SINGLE_FLOAT_POSITIVE_INFINITY.printObject()); return sb.toString(); } if (value == Float.NEGATIVE_INFINITY) { StringBuffer sb = new StringBuffer("#."); - sb.append(Symbol.SINGLE_FLOAT_NEGATIVE_INFINITY.writeToString()); + sb.append(Symbol.SINGLE_FLOAT_NEGATIVE_INFINITY.printObject()); return sb.toString(); } @@ -640,7 +640,7 @@ return new SingleFloat(((Bignum)obj).floatValue()); if (obj instanceof Ratio) return new SingleFloat(((Ratio)obj).floatValue()); - error(new TypeError("The value " + obj.writeToString() + + error(new TypeError("The value " + obj.princToString() + " cannot be converted to type SINGLE-FLOAT.")); // Not reached. return null; Modified: trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java Fri Aug 5 14:25:10 2011 (r13440) @@ -116,15 +116,15 @@ } @Override - public String writeToString() + public String printObject() { StringBuilder sb = - new StringBuilder(Symbol.SLOT_DEFINITION.writeToString()); + new StringBuilder(Symbol.SLOT_DEFINITION.printObject()); LispObject name = slots[SlotDefinitionClass.SLOT_INDEX_NAME]; if (name != null && name != NIL) { sb.append(' '); - sb.append(name.writeToString()); + sb.append(name.printObject()); } return unreadableString(sb.toString()); } Modified: trunk/abcl/src/org/armedbear/lisp/SpecialOperator.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SpecialOperator.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/SpecialOperator.java Fri Aug 5 14:25:10 2011 (r13440) @@ -146,10 +146,10 @@ } @Override - public String writeToString() + public String printObject() { StringBuffer sb = new StringBuffer("#"); return sb.toString(); } Modified: trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java Fri Aug 5 14:25:10 2011 (r13440) @@ -141,7 +141,7 @@ if (obj.length() > 2) return error(new LispError("The " + (sequential ? "LET*" : "LET") + " binding specification " + - obj.writeToString() + " is invalid.")); + obj.princToString() + " is invalid.")); symbol = checkSymbol(((Cons)obj).car); value = eval(obj.cadr(), sequential ? ext : env, thread); } else { @@ -201,14 +201,14 @@ || ext.isDeclaredSpecial(symbol)) { return error(new ProgramError( "Attempt to bind the special variable " + - symbol.writeToString() + + symbol.princToString() + " with SYMBOL-MACROLET.")); } bindArg(null, symbol, new SymbolMacro(obj.cadr()), ext, thread); } else { return error(new ProgramError( "Malformed symbol-expansion pair in SYMBOL-MACROLET: " + - obj.writeToString())); + obj.princToString())); } } return progn(body, ext, thread); @@ -519,7 +519,7 @@ while (args != NIL) { Symbol symbol = checkSymbol(args.car()); if (symbol.isConstant()) { - return error(new ProgramError(symbol.writeToString() + + return error(new ProgramError(symbol.princToString() + " is a constant and thus cannot be set.")); } args = args.cdr(); Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardClass.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Fri Aug 5 14:25:10 2011 (r13440) @@ -139,9 +139,9 @@ (new Error()).printStackTrace(); LispThread.currentThread().printBacktrace(); return (Layout)Lisp.error(Symbol.TYPE_ERROR, - new SimpleString("The value " + layout.writeToString() - + " is not of expected type " + Symbol.LAYOUT.writeToString() - + " in class " + this.writeToString() + ".")); + new SimpleString("The value " + layout.princToString() + + " is not of expected type " + Symbol.LAYOUT.princToString() + + " in class " + this.princToString() + ".")); } return (layout == UNBOUND_VALUE) ? null : (Layout)layout; @@ -320,14 +320,14 @@ } @Override - public String writeToString() + public String printObject() { StringBuilder sb = - new StringBuilder(Symbol.STANDARD_CLASS.writeToString()); + new StringBuilder(Symbol.STANDARD_CLASS.printObject()); if (getName() != null) { sb.append(' '); - sb.append(getName().writeToString()); + sb.append(getName().printObject()); } return unreadableString(sb.toString()); } Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Fri Aug 5 14:25:10 2011 (r13440) @@ -203,7 +203,7 @@ } @Override - public String writeToString() + public String printObject() { LispObject name = getGenericFunctionName(); if (name != null) @@ -216,12 +216,12 @@ else className = Symbol.CLASS_NAME.execute(lispClass); - sb.append(className.writeToString()); + sb.append(className.princToString()); sb.append(' '); - sb.append(name.writeToString()); + sb.append(name.princToString()); return unreadableString(sb.toString()); } - return super.writeToString(); + return super.printObject(); } // Profiling. Modified: trunk/abcl/src/org/armedbear/lisp/StandardMethod.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardMethod.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/StandardMethod.java Fri Aug 5 14:25:10 2011 (r13440) @@ -145,7 +145,7 @@ } @Override - public String writeToString() + public String printObject() { LispObject genericFunction = slots[StandardMethodClass.SLOT_INDEX_GENERIC_FUNCTION]; @@ -163,9 +163,9 @@ else className = Symbol.CLASS_NAME.execute(lispClass); - sb.append(className.writeToString()); + sb.append(className.printObject()); sb.append(' '); - sb.append(name.writeToString()); + sb.append(name.printObject()); LispObject specializers = slots[StandardMethodClass.SLOT_INDEX_SPECIALIZERS]; if (specializers != null) @@ -182,12 +182,12 @@ specs = specs.cdr(); } sb.append(' '); - sb.append(names.nreverse().writeToString()); + sb.append(names.nreverse().printObject()); } return unreadableString(sb.toString()); } } - return super.writeToString(); + return super.printObject(); } // ### %method-generic-function Modified: trunk/abcl/src/org/armedbear/lisp/StandardObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardObject.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/StandardObject.java Fri Aug 5 14:25:10 2011 (r13440) @@ -196,7 +196,7 @@ } @Override - public String writeToString() + public String printObject() { final LispThread thread = LispThread.currentThread(); int maxLevel = Integer.MAX_VALUE; @@ -208,7 +208,7 @@ int currentLevel = Fixnum.getValue(currentPrintLevel); if (currentLevel >= maxLevel) return "#"; - return unreadableString(typeOf().writeToString()); + return unreadableString(typeOf().printObject()); } Layout updateLayout() @@ -304,7 +304,7 @@ int index = layout.getSlotIndex(slotName); //### FIXME: should call SLOT-MISSING (clhs) if (index < 0) - return error(new LispError("Missing slot " + slotName.writeToString())); + return error(new LispError("Missing slot " + slotName.princToString())); return slots[index]; } @@ -322,7 +322,7 @@ int index = layout.getSlotIndex(slotName); //### FIXME: should call SLOT-MISSING (clhs) if (index < 0) - error(new LispError("Missing slot " + slotName.writeToString())); + error(new LispError("Missing slot " + slotName.princToString())); slots[index] = newValue; } Modified: trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java Fri Aug 5 14:25:10 2011 (r13440) @@ -51,7 +51,7 @@ if (arg.typep(StandardClass.STANDARD_CLASS) != NIL) { LispObject l = Symbol.CLASS_LAYOUT.execute(arg); if (! (l instanceof Layout)) - return error(new ProgramError("Invalid standard class layout for: " + arg.writeToString())); + return error(new ProgramError("Invalid standard class layout for: " + arg.princToString())); return new StandardObject((Layout)l); } Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Stream.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/Stream.java Fri Aug 5 14:25:10 2011 (r13440) @@ -576,7 +576,7 @@ final int length = args.length(); if ((length % 2) != 0) return error(new ReaderError("Odd number of keyword arguments following #S: " + - obj.writeToString(), + obj.princToString(), this)); LispObject[] array = new LispObject[length]; LispObject rest = args; @@ -594,7 +594,7 @@ thread); } return error(new ReaderError("Non-list following #S: " + - obj.writeToString(), + obj.princToString(), this)); } @@ -666,9 +666,9 @@ if (requireProperList) { if (!obj.listp()) error(new ReaderError("The value " + - obj.writeToString() + + obj.princToString() + " is not of type " + - Symbol.LIST.writeToString() + ".", + Symbol.LIST.princToString() + ".", this)); } last.cdr = obj; @@ -929,7 +929,7 @@ case 1: { if (obj.listp() || obj instanceof AbstractVector) return new SimpleVector(obj); - return error(new ReaderError(obj.writeToString() + " is not a sequence.", + return error(new ReaderError(obj.princToString() + " is not a sequence.", this)); } default: @@ -960,7 +960,7 @@ sb.append(_getFilePosition()); } sb.append(": #C"); - sb.append(obj.writeToString()); + sb.append(obj.printObject()); return error(new ReaderError(sb.toString(), this)); } @@ -1619,7 +1619,7 @@ final SpecialBindingsMark mark = thread.markSpecialBindings(); thread.bindSpecial(Symbol.PRINT_ESCAPE, T); try { - _writeString(obj.writeToString()); + _writeString(obj.printObject()); } finally { thread.resetSpecialBindings(mark); } @@ -1671,7 +1671,7 @@ } return number(arg.length()); } - return error(new TypeError(arg.writeToString() + + return error(new TypeError(arg.princToString() + " is neither a string nor a character.")); } @@ -1971,23 +1971,23 @@ } protected LispObject streamNotInputStream() { - return error(new StreamError(this, writeToString() + " is not an input stream.")); + return error(new StreamError(this, princToString() + " is not an input stream.")); } protected LispObject streamNotCharacterInputStream() { - return error(new StreamError(this, writeToString() + " is not a character input stream.")); + return error(new StreamError(this, princToString() + " is not a character input stream.")); } protected LispObject streamNotOutputStream() { - return error(new StreamError(this, writeToString() + " is not an output stream.")); + return error(new StreamError(this, princToString() + " is not an output stream.")); } protected LispObject streamNotBinaryOutputStream() { - return error(new StreamError(this, writeToString() + " is not a binary output stream.")); + return error(new StreamError(this, princToString() + " is not a binary output stream.")); } protected LispObject streamNotCharacterOutputStream() { - return error(new StreamError(this, writeToString() + " is not a character output stream.")); + return error(new StreamError(this, princToString() + " is not a character output stream.")); } // ### %stream-write-char character output-stream => character @@ -2130,7 +2130,7 @@ if (second == Keyword.ABORT) return stream.close(third); return error(new ProgramError("Unrecognized keyword argument " + - second.writeToString() + ".")); + second.princToString() + ".")); } }; Modified: trunk/abcl/src/org/armedbear/lisp/StructureClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StructureClass.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/StructureClass.java Fri Aug 5 14:25:10 2011 (r13440) @@ -72,14 +72,14 @@ @Override public LispObject getDescription() { - return new SimpleString(writeToString()); + return new SimpleString(princToString()); } @Override - public String writeToString() + public String printObject() { StringBuffer sb = new StringBuffer("#'); return sb.toString(); } Modified: trunk/abcl/src/org/armedbear/lisp/StructureObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StructureObject.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/StructureObject.java Fri Aug 5 14:25:10 2011 (r13440) @@ -421,9 +421,9 @@ private LispObject badIndex(int n) { StringBuilder sb = new StringBuilder("Invalid slot index "); - sb.append(Fixnum.getInstance(n).writeToString()); + sb.append(Fixnum.getInstance(n).princToString()); sb.append(" for "); - sb.append(writeToString()); + sb.append(princToString()); return error(new LispError(sb.toString())); } @@ -449,7 +449,7 @@ } @Override - public String writeToString() + public String printObject() { try { @@ -464,7 +464,7 @@ return stream.getString().getStringValue(); } if (_PRINT_STRUCTURE_.symbolValue(thread) == NIL) - return unreadableString(structureClass.getName().writeToString()); + return unreadableString(structureClass.getName().printObject()); int maxLevel = Integer.MAX_VALUE; LispObject printLevel = Symbol.PRINT_LEVEL.symbolValue(thread); if (printLevel instanceof Fixnum) @@ -475,7 +475,7 @@ if (currentLevel >= maxLevel && slots.length > 0) return "#"; StringBuilder sb = new StringBuilder("#S("); - sb.append(structureClass.getName().writeToString()); + sb.append(structureClass.getName().printObject()); if (currentLevel < maxLevel) { LispObject effectiveSlots = structureClass.getSlotDefinitions(); @@ -507,7 +507,7 @@ sb.append(stream.getString().getStringValue()); } else - sb.append(slots[i].writeToString()); + sb.append(slots[i].printObject()); } if (limit < slots.length) sb.append(" ..."); Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Fri Aug 5 14:25:10 2011 (r13440) @@ -130,7 +130,7 @@ try { StringBuilder sb = new StringBuilder("The symbol "); - sb.append(name.writeToString()); + sb.append(name.princToString()); sb.append(" at #x"); sb.append(Integer.toHexString(System.identityHashCode(this)).toUpperCase()); if (pkg instanceof Package) @@ -300,7 +300,7 @@ { if (isConstant()) // Complement the check already done in SpecialOperators.sf_setq - error(new ProgramError("Can't change value of constant symbol " + writeToString() + ".")); + error(new ProgramError("Can't change value of constant symbol " + princToString() + ".")); this.value = value; } @@ -445,7 +445,7 @@ } @Override - public String writeToString() + public String printObject() { final String n = name.getStringValue(); final LispThread thread = LispThread.currentThread(); Modified: trunk/abcl/src/org/armedbear/lisp/SynonymStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SynonymStream.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/SynonymStream.java Fri Aug 5 14:25:10 2011 (r13440) @@ -215,10 +215,10 @@ } @Override - public String writeToString() + public String printObject() { StringBuffer sb = new StringBuffer("SYNONYM-STREAM "); - sb.append(symbol.writeToString()); + sb.append(symbol.printObject()); return unreadableString(sb.toString()); } Modified: trunk/abcl/src/org/armedbear/lisp/Throw.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Throw.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/Throw.java Fri Aug 5 14:25:10 2011 (r13440) @@ -57,6 +57,6 @@ public LispObject getCondition() { return new ControlError("Attempt to throw to the nonexistent tag " + - tag.writeToString() + "."); + tag.princToString() + "."); } } Modified: trunk/abcl/src/org/armedbear/lisp/TwoWayStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/TwoWayStream.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/TwoWayStream.java Fri Aug 5 14:25:10 2011 (r13440) @@ -214,7 +214,7 @@ } @Override - public String writeToString() + public String printObject() { return unreadableString(Symbol.TWO_WAY_STREAM); } Modified: trunk/abcl/src/org/armedbear/lisp/TypeError.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/TypeError.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/TypeError.java Fri Aug 5 14:25:10 2011 (r13440) @@ -139,10 +139,10 @@ final LispObject datum = getDatum(); final LispObject expectedType = getExpectedType(); StringBuilder sb = new StringBuilder(); - String name = datum != null ? datum.writeToString() : null; + String name = datum != null ? datum.princToString() : null; String type = null; if (expectedType != null) - type = expectedType.writeToString(); + type = expectedType.princToString(); if (type != null) { if (name != null) { sb.append("The value "); Modified: trunk/abcl/src/org/armedbear/lisp/URLStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/URLStream.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/URLStream.java Fri Aug 5 14:25:10 2011 (r13440) @@ -135,10 +135,10 @@ } @Override - public String writeToString() + public String printObject() { StringBuffer sb = new StringBuffer(); - sb.append(Symbol.URL_STREAM.writeToString()); + sb.append(Symbol.URL_STREAM.printObject()); String namestring = pathname.getNamestring(); if (namestring != null) { sb.append(" "); Modified: trunk/abcl/src/org/armedbear/lisp/UnboundSlot.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/UnboundSlot.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/UnboundSlot.java Fri Aug 5 14:25:10 2011 (r13440) @@ -76,9 +76,9 @@ thread.bindSpecial(Symbol.PRINT_ESCAPE, T); try { StringBuilder sb = new StringBuilder("The slot "); - sb.append(getCellName().writeToString()); + sb.append(getCellName().princToString()); sb.append(" is unbound in the object "); - sb.append(getInstance().writeToString()); + sb.append(getInstance().princToString()); sb.append('.'); return sb.toString(); } Modified: trunk/abcl/src/org/armedbear/lisp/UnboundVariable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/UnboundVariable.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/UnboundVariable.java Fri Aug 5 14:25:10 2011 (r13440) @@ -55,7 +55,7 @@ thread.bindSpecial(Symbol.PRINT_ESCAPE, T); StringBuffer sb = new StringBuffer("The variable "); try { - sb.append(getCellName().writeToString()); + sb.append(getCellName().princToString()); } finally { thread.resetSpecialBindings(mark); Modified: trunk/abcl/src/org/armedbear/lisp/UndefinedFunction.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/UndefinedFunction.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/UndefinedFunction.java Fri Aug 5 14:25:10 2011 (r13440) @@ -73,7 +73,7 @@ public String getMessage() { StringBuilder sb = new StringBuilder("The function "); - sb.append(getCellName().writeToString()); + sb.append(getCellName().princToString()); sb.append(" is undefined."); return sb.toString(); } Modified: trunk/abcl/src/org/armedbear/lisp/Utilities.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Utilities.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/Utilities.java Fri Aug 5 14:25:10 2011 (r13440) @@ -104,7 +104,7 @@ String namestring = merged.getNamestring(); if (namestring != null) return new File(namestring); - error(new FileError("Pathname has no namestring: " + merged.writeToString(), + error(new FileError("Pathname has no namestring: " + merged.princToString(), merged)); // Not reached. return null; Modified: trunk/abcl/src/org/armedbear/lisp/WeakHashTable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/WeakHashTable.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/WeakHashTable.java Fri Aug 5 14:25:10 2011 (r13440) @@ -315,14 +315,14 @@ } @Override - public String writeToString() { + public String printObject() { if (Symbol.PRINT_READABLY.symbolValue(LispThread.currentThread()) != NIL) { error(new PrintNotReadable(list(Keyword.OBJECT, this))); return null; // Not reached. } - StringBuilder sb = new StringBuilder(getTest().writeToString()); + StringBuilder sb = new StringBuilder(getTest().princToString()); sb.append(' '); - sb.append(Symbol.HASH_TABLE.writeToString()); + sb.append(Symbol.HASH_TABLE.princToString()); sb.append(' '); if (bucketType instanceof HashEntryWeakKey) { sb.append("WEAKNESS :KEY"); Modified: trunk/abcl/src/org/armedbear/lisp/WeakReference.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/WeakReference.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/WeakReference.java Fri Aug 5 14:25:10 2011 (r13440) @@ -53,7 +53,7 @@ } @Override - public String writeToString() { + public String printObject() { return unreadableString("WEAK-REFERENCE " + toString()); } Modified: trunk/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java Fri Aug 5 14:25:10 2011 (r13440) @@ -76,7 +76,7 @@ LispObject lambdaName = operator.getLambdaName(); if (lambdaName != null && lambdaName != NIL) { sb.append(" for "); - sb.append(operator.getLambdaName().writeToString()); + sb.append(operator.getLambdaName().princToString()); } if(expectedArgs >= 0) { sb.append("; "); Modified: trunk/abcl/src/org/armedbear/lisp/ZeroRankArray.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ZeroRankArray.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/ZeroRankArray.java Fri Aug 5 14:25:10 2011 (r13440) @@ -134,7 +134,7 @@ } @Override - public String writeToString() + public String printObject() { final LispThread thread = LispThread.currentThread(); boolean printReadably = (Symbol.PRINT_READABLY.symbolValue(thread) != NIL); @@ -153,14 +153,14 @@ data, stream); sb.append(stream.getString().getStringValue()); } else - sb.append(data.writeToString()); + sb.append(data.printObject()); return sb.toString(); } StringBuffer sb = new StringBuffer(); if (!adjustable) sb.append("SIMPLE-"); sb.append("ARRAY "); - sb.append(elementType.writeToString()); + sb.append(elementType.printObject()); sb.append(" NIL"); return unreadableString(sb.toString()); } Modified: trunk/abcl/src/org/armedbear/lisp/delete_file.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/delete_file.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/delete_file.java Fri Aug 5 14:25:10 2011 (r13440) @@ -65,7 +65,7 @@ NIL); final String namestring = defaultedPathname.getNamestring(); if (namestring == null) - return error(new FileError("Pathname has no namestring: " + defaultedPathname.writeToString(), + return error(new FileError("Pathname has no namestring: " + defaultedPathname.princToString(), defaultedPathname)); final File file = new File(namestring); ZipCache.remove(file); @@ -80,7 +80,7 @@ Pathname truename = new Pathname(file.getAbsolutePath()); StringBuilder sb = new StringBuilder("Unable to delete "); sb.append(file.isDirectory() ? "directory " : "file "); - sb.append(truename.writeToString()); + sb.append(truename.princToString()); sb.append('.'); return error(new FileError(sb.toString(), truename)); } else { Modified: trunk/abcl/src/org/armedbear/lisp/jclass_name.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jclass_name.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/jclass_name.java Fri Aug 5 14:25:10 2011 (r13440) @@ -66,7 +66,7 @@ return new SimpleString(((Class)obj).getName()); // Fall through. } - return error(new LispError(arg.writeToString() + " does not designate a Java class.")); + return error(new LispError(arg.princToString() + " does not designate a Java class.")); } // When called with two arguments, JCLASS-NAME tests whether CLASS-REF @@ -88,7 +88,7 @@ className = ((Class)obj).getName(); } if (className == null) - return error(new LispError(first.writeToString() + " does not designate a Java class.")); + return error(new LispError(first.princToString() + " does not designate a Java class.")); final AbstractString name = checkString(second); return LispThread.currentThread().setValues(name.getStringValue().equals(className) ? T : NIL, new SimpleString(className)); Modified: trunk/abcl/src/org/armedbear/lisp/jmethod_return_type.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jmethod_return_type.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/jmethod_return_type.java Fri Aug 5 14:25:10 2011 (r13440) @@ -55,7 +55,7 @@ if (method instanceof Method) return new JavaObject(((Method)method).getReturnType()); } - return error(new LispError(arg.writeToString() + " does not designate a Java method.")); + return error(new LispError(arg.princToString() + " does not designate a Java method.")); } private static final Primitive JMETHOD_RETURN_TYPE = new jmethod_return_type(); Modified: trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Fri Aug 5 14:25:10 2011 (r13440) @@ -903,21 +903,22 @@ (push attribute (method-attributes method)) attribute) -(defun method-add-code (method) +(defun method-add-code (method &optional (optimize t)) "Creates an (empty) 'Code' attribute for the method, returning the created attribute." (method-add-attribute method (make-code-attribute (+ (length (cdr (method-descriptor method))) (if (member :static (method-access-flags method)) - 0 1))))) ;; 1 == implicit 'this' + 0 1)) ;; 1 == implicit 'this' + optimize))) -(defun method-ensure-code (method) +(defun method-ensure-code (method &optional (optimize t)) "Ensures the existence of a 'Code' attribute for the method, returning the attribute." (let ((code (method-attribute method "Code"))) (if (null code) - (method-add-code method) + (method-add-code method optimize) code))) (defun method-attribute (method name) @@ -1002,7 +1003,7 @@ ;; labels contains offsets into the code array after it's finalized labels ;; an alist - + optimize (current-local 0)) ;; used for handling nested WITH-CODE-TO-METHOD blocks @@ -1026,7 +1027,7 @@ (nconc (mapcar #'exception-start-pc handlers) (mapcar #'exception-end-pc handlers) (mapcar #'exception-handler-pc handlers)) - t))) + (code-optimize code)))) (invoke-callbacks :code-finalized class parent (coerce c 'list) handlers) (unless (code-max-stack code) @@ -1086,10 +1087,10 @@ (write-attributes (code-attributes code) stream)) -(defun make-code-attribute (arg-count) +(defun make-code-attribute (arg-count &optional optimize) "Creates an empty 'Code' attribute for a method which takes `arg-count` parameters, including the implicit `this` parameter." - (%make-code-attribute :max-locals arg-count)) + (%make-code-attribute :max-locals arg-count :optimize optimize)) (defun code-add-attribute (code attribute) "Adds `attribute' to `code', returning `attribute'." @@ -1192,20 +1193,24 @@ `(progn (when *current-code-attribute* (save-code-specials *current-code-attribute*)) - (let* ((,m ,method) - (*method* ,m) - (,c (method-ensure-code ,method)) - (*pool* (class-file-constants ,class-file)) - (*code* (code-code ,c)) - (*registers-allocated* (code-max-locals ,c)) - (*register* (code-current-local ,c)) - (*current-code-attribute* ,c)) - , at body - (setf (code-code ,c) *code* - (code-current-local ,c) *register* - (code-max-locals ,c) *registers-allocated*)) - (when *current-code-attribute* - (restore-code-specials *current-code-attribute*))))) + (unwind-protect + (let* ((,m ,method) + (*method* ,m) + (,c (method-ensure-code ,method)) + (*pool* (class-file-constants ,class-file)) + (*code* (code-code ,c)) + (*registers-allocated* (code-max-locals ,c)) + (*register* (code-current-local ,c)) + (*current-code-attribute* ,c)) + (unwind-protect + , at body + ;; in case of a RETURN-FROM or GO, save the current state + (setf (code-code ,c) *code* + (code-current-local ,c) *register* + (code-max-locals ,c) *registers-allocated*))) + ;; using the same line of reasoning, restore the outer-scope state + (when *current-code-attribute* + (restore-code-specials *current-code-attribute*)))))) (defstruct (source-file-attribute (:conc-name source-) Modified: trunk/abcl/src/org/armedbear/lisp/zip.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/zip.java Fri Aug 5 06:05:58 2011 (r13439) +++ trunk/abcl/src/org/armedbear/lisp/zip.java Fri Aug 5 14:25:10 2011 (r13440) @@ -72,7 +72,7 @@ String zipfileNamestring = zipfilePathname.getNamestring(); if (zipfileNamestring == null) return error(new SimpleError("Pathname has no namestring: " + - zipfilePathname.writeToString())); + zipfilePathname.princToString())); ZipOutputStream out = new ZipOutputStream(new FileOutputStream(zipfileNamestring)); LispObject list = second; @@ -85,7 +85,7 @@ File zipfile = new File(zipfileNamestring); zipfile.delete(); return error(new SimpleError("Pathname has no namestring: " - + pathname.writeToString())); + + pathname.princToString())); } File file = new File(namestring); makeEntry(out, file); @@ -109,7 +109,7 @@ String zipfileNamestring = zipfilePathname.getNamestring(); if (zipfileNamestring == null) return error(new SimpleError("Pathname has no namestring: " + - zipfilePathname.writeToString())); + zipfilePathname.princToString())); ZipOutputStream out = new ZipOutputStream(new FileOutputStream(zipfileNamestring)); Pathname root = (Pathname) Pathname.truename(coerceToPathname(third)); @@ -126,7 +126,7 @@ File zipfile = new File(zipfileNamestring); zipfile.delete(); return error(new SimpleError("Pathname has no namestring: " + - pathname.writeToString())); + pathname.princToString())); } String directory = ""; String dir = pathname.getDirectoryNamestring(); @@ -199,7 +199,7 @@ String zipfileNamestring = zipfilePathname.getNamestring(); if (zipfileNamestring == null) return error(new SimpleError("Pathname has no namestring: " + - zipfilePathname.writeToString())); + zipfilePathname.princToString())); ZipOutputStream out = null; try { out = new ZipOutputStream(new FileOutputStream(zipfileNamestring)); From ehuelsmann at common-lisp.net Fri Aug 5 21:47:45 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 05 Aug 2011 14:47:45 -0700 Subject: [armedbear-cvs] r13441 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 5 14:47:44 2011 New Revision: 13441 Log: Add missing file properties. Modified: trunk/abcl/src/org/armedbear/lisp/ByteArrayInputStream.java (contents, props changed) Modified: trunk/abcl/src/org/armedbear/lisp/ByteArrayInputStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ByteArrayInputStream.java Fri Aug 5 14:25:10 2011 (r13440) +++ trunk/abcl/src/org/armedbear/lisp/ByteArrayInputStream.java Fri Aug 5 14:47:44 2011 (r13441) @@ -2,7 +2,7 @@ * ByteArrayInputStream.java * * Copyright (C) 2010 Alessio Stalla - * $Id: ByteArrayInputStream.java 12513 2010-03-02 22:35:36Z ehuelsmann $ + * $Id$ * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License From ehuelsmann at common-lisp.net Fri Aug 5 21:51:28 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 05 Aug 2011 14:51:28 -0700 Subject: [armedbear-cvs] r13442 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 5 14:51:28 2011 New Revision: 13442 Log: Remove .toString() methods which override default Java output to be 'lispy'; we have princToString() for that now... Modified: trunk/abcl/src/org/armedbear/lisp/ByteArrayInputStream.java trunk/abcl/src/org/armedbear/lisp/ByteArrayOutputStream.java trunk/abcl/src/org/armedbear/lisp/EchoStream.java trunk/abcl/src/org/armedbear/lisp/Nil.java trunk/abcl/src/org/armedbear/lisp/NilVector.java trunk/abcl/src/org/armedbear/lisp/Package.java trunk/abcl/src/org/armedbear/lisp/Pathname.java trunk/abcl/src/org/armedbear/lisp/Readtable.java trunk/abcl/src/org/armedbear/lisp/SlimeInputStream.java trunk/abcl/src/org/armedbear/lisp/SlimeOutputStream.java trunk/abcl/src/org/armedbear/lisp/SocketStream.java trunk/abcl/src/org/armedbear/lisp/Stream.java trunk/abcl/src/org/armedbear/lisp/StringInputStream.java trunk/abcl/src/org/armedbear/lisp/StringOutputStream.java trunk/abcl/src/org/armedbear/lisp/Symbol.java Modified: trunk/abcl/src/org/armedbear/lisp/ByteArrayInputStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ByteArrayInputStream.java Fri Aug 5 14:47:44 2011 (r13441) +++ trunk/abcl/src/org/armedbear/lisp/ByteArrayInputStream.java Fri Aug 5 14:51:28 2011 (r13442) @@ -69,12 +69,6 @@ return super.typep(type); //TODO } - @Override - public String toString() - { - return unreadableString("BYTE-ARRAY-INPUT-STREAM"); - } - // ### %make-byte-array-input-stream // %make-byte-array-input-stream bytes &optional element-type => byte-array-input-stream private static final Primitive MAKE_BYTE_ARRAY_INPUT_STREAM = Modified: trunk/abcl/src/org/armedbear/lisp/ByteArrayOutputStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ByteArrayOutputStream.java Fri Aug 5 14:47:44 2011 (r13441) +++ trunk/abcl/src/org/armedbear/lisp/ByteArrayOutputStream.java Fri Aug 5 14:51:28 2011 (r13442) @@ -92,12 +92,6 @@ } } - @Override - public String toString() - { - return unreadableString("BYTE-ARRAY-OUTPUT-STREAM"); - } - // ### %make-byte-array-output-stream // %make-byte-array-output-stream &optional element-type => byte-array-output-stream private static final Primitive MAKE_BYTE_ARRAY_OUTPUT_STREAM = Modified: trunk/abcl/src/org/armedbear/lisp/EchoStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/EchoStream.java Fri Aug 5 14:47:44 2011 (r13441) +++ trunk/abcl/src/org/armedbear/lisp/EchoStream.java Fri Aug 5 14:51:28 2011 (r13442) @@ -239,12 +239,6 @@ return out.freshLine(); } - @Override - public String toString() - { - return unreadableString("ECHO-STREAM"); - } - // ### make-echo-stream // input-stream output-stream => echo-stream private static final Primitive MAKE_ECHO_STREAM = Modified: trunk/abcl/src/org/armedbear/lisp/Nil.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Nil.java Fri Aug 5 14:47:44 2011 (r13441) +++ trunk/abcl/src/org/armedbear/lisp/Nil.java Fri Aug 5 14:51:28 2011 (r13442) @@ -157,14 +157,6 @@ return null; } - @Override - public String toString() - { - if (Symbol.PRINT_READABLY.symbolValueNoThrow() != NIL) - return "|COMMON-LISP|::|NIL|"; - return "NIL"; - } - public Object readResolve() throws java.io.ObjectStreamException { return NIL; } Modified: trunk/abcl/src/org/armedbear/lisp/NilVector.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/NilVector.java Fri Aug 5 14:47:44 2011 (r13441) +++ trunk/abcl/src/org/armedbear/lisp/NilVector.java Fri Aug 5 14:51:28 2011 (r13442) @@ -237,12 +237,6 @@ } @Override - public String toString() - { - return unreadableString("NIL-VECTOR"); - } - - @Override public int sxhash() { return 0; Modified: trunk/abcl/src/org/armedbear/lisp/Package.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Package.java Fri Aug 5 14:47:44 2011 (r13441) +++ trunk/abcl/src/org/armedbear/lisp/Package.java Fri Aug 5 14:51:28 2011 (r13442) @@ -853,19 +853,15 @@ sb.append(name); sb.append("\")"); return sb.toString(); - } else - return toString(); - } - - @Override - public String toString() { - if (name != null) { - StringBuilder sb = new StringBuilder("#"); - return sb.toString(); - } else - return unreadableString("PACKAGE"); + } else { + if (name != null) { + StringBuilder sb = new StringBuilder("#"); + return sb.toString(); + } else + return unreadableString("PACKAGE"); + } } public Object readResolve() throws java.io.ObjectStreamException { Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java Fri Aug 5 14:47:44 2011 (r13441) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Fri Aug 5 14:51:28 2011 (r13442) @@ -2513,10 +2513,6 @@ } } - public String toString() { - return getNamestring(); - } - public URL toURL() { try { if (isURL()) { Modified: trunk/abcl/src/org/armedbear/lisp/Readtable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Readtable.java Fri Aug 5 14:47:44 2011 (r13441) +++ trunk/abcl/src/org/armedbear/lisp/Readtable.java Fri Aug 5 14:51:28 2011 (r13442) @@ -192,12 +192,6 @@ return super.typep(type); } - @Override - public final String toString() - { - return unreadableString("READTABLE"); - } - public final LispObject getReadtableCase() { return readtableCase; Modified: trunk/abcl/src/org/armedbear/lisp/SlimeInputStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SlimeInputStream.java Fri Aug 5 14:47:44 2011 (r13441) +++ trunk/abcl/src/org/armedbear/lisp/SlimeInputStream.java Fri Aug 5 14:51:28 2011 (r13442) @@ -138,13 +138,6 @@ lineNumber = 0; } - - @Override - public String toString() - { - return unreadableString("SLIME-INPUT-STREAM"); - } - // ### make-slime-input-stream // make-slime-input-stream function output-stream => slime-input-stream private static final Primitive MAKE_SLIME_INPUT_STREAM = Modified: trunk/abcl/src/org/armedbear/lisp/SlimeOutputStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SlimeOutputStream.java Fri Aug 5 14:47:44 2011 (r13441) +++ trunk/abcl/src/org/armedbear/lisp/SlimeOutputStream.java Fri Aug 5 14:51:28 2011 (r13442) @@ -137,12 +137,6 @@ } } - @Override - public String toString() - { - return unreadableString("SLIME-OUTPUT-STREAM"); - } - // ### %make-slime-output-stream // %make-slime-output-stream function => stream private static final Primitive MAKE_SLIME_OUTPUT_STREAM = Modified: trunk/abcl/src/org/armedbear/lisp/SocketStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SocketStream.java Fri Aug 5 14:47:44 2011 (r13441) +++ trunk/abcl/src/org/armedbear/lisp/SocketStream.java Fri Aug 5 14:51:28 2011 (r13442) @@ -80,10 +80,4 @@ return error(new LispError(e.getMessage())); } } - - @Override - public String toString() - { - return unreadableString("SOCKET-STREAM"); - } } Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Stream.java Fri Aug 5 14:47:44 2011 (r13441) +++ trunk/abcl/src/org/armedbear/lisp/Stream.java Fri Aug 5 14:51:28 2011 (r13442) @@ -1576,11 +1576,6 @@ return T; } - @Override - public String toString() { - return unreadableString("STREAM"); - } - // read-byte stream &optional eof-error-p eof-value => byte // Reads an 8-bit byte. public LispObject readByte(boolean eofError, LispObject eofValue) Modified: trunk/abcl/src/org/armedbear/lisp/StringInputStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StringInputStream.java Fri Aug 5 14:47:44 2011 (r13441) +++ trunk/abcl/src/org/armedbear/lisp/StringInputStream.java Fri Aug 5 14:51:28 2011 (r13442) @@ -92,12 +92,6 @@ } @Override - public String toString() - { - return unreadableString("STRING-INPUT-STREAM"); - } - - @Override public int getOffset() { return start + super.getOffset(); } Modified: trunk/abcl/src/org/armedbear/lisp/StringOutputStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StringOutputStream.java Fri Aug 5 14:47:44 2011 (r13441) +++ trunk/abcl/src/org/armedbear/lisp/StringOutputStream.java Fri Aug 5 14:51:28 2011 (r13442) @@ -98,12 +98,6 @@ return s; } - @Override - public String toString() - { - return unreadableString("STRING-OUTPUT-STREAM"); - } - // ### %make-string-output-stream // %make-string-output-stream element-type => string-stream private static final Primitive MAKE_STRING_OUTPUT_STREAM = Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java Fri Aug 5 14:47:44 2011 (r13441) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Fri Aug 5 14:51:28 2011 (r13442) @@ -271,11 +271,6 @@ return sb.toString(); } - @Override - public String toString() { - return getQualifiedName(); - } - /** Gets the value associated with the symbol * as set by SYMBOL-VALUE. * From ehuelsmann at common-lisp.net Sat Aug 6 13:03:02 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 06 Aug 2011 06:03:02 -0700 Subject: [armedbear-cvs] r13443 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 6 06:03:00 2011 New Revision: 13443 Log: Rename more occurrances of writeToString to printObject. Modified: trunk/abcl/src/org/armedbear/lisp/AbstractArray.java trunk/abcl/src/org/armedbear/lisp/AbstractString.java trunk/abcl/src/org/armedbear/lisp/ComplexArray.java trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte32.java trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte8.java trunk/abcl/src/org/armedbear/lisp/SimpleArray_T.java trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte16.java trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte32.java trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte8.java Modified: trunk/abcl/src/org/armedbear/lisp/AbstractArray.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/AbstractArray.java Fri Aug 5 14:51:28 2011 (r13442) +++ trunk/abcl/src/org/armedbear/lisp/AbstractArray.java Sat Aug 6 06:03:00 2011 (r13443) @@ -180,7 +180,7 @@ public abstract void fill(LispObject obj); - public String writeToString(int[] dimv) + public String printObject(int[] dimv) { StringBuilder sb = new StringBuilder(); LispThread thread = LispThread.currentThread(); Modified: trunk/abcl/src/org/armedbear/lisp/AbstractString.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/AbstractString.java Fri Aug 5 14:51:28 2011 (r13442) +++ trunk/abcl/src/org/armedbear/lisp/AbstractString.java Sat Aug 6 06:03:00 2011 (r13443) @@ -83,7 +83,7 @@ public abstract void setCharAt(int index, char c); - public final String writeToString(int beginIndex, int endIndex) + public final String printObject(int beginIndex, int endIndex) { if (beginIndex < 0) @@ -112,7 +112,7 @@ @Override public String printObject() { - return writeToString(0, length()); + return printObject(0, length()); } public String toString() { Modified: trunk/abcl/src/org/armedbear/lisp/ComplexArray.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ComplexArray.java Fri Aug 5 14:51:28 2011 (r13442) +++ trunk/abcl/src/org/armedbear/lisp/ComplexArray.java Sat Aug 6 06:03:00 2011 (r13443) @@ -235,7 +235,7 @@ @Override public String printObject() { - return writeToString(dimv); + return printObject(dimv); } @Override Modified: trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte32.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte32.java Fri Aug 5 14:51:28 2011 (r13442) +++ trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte32.java Sat Aug 6 06:03:00 2011 (r13443) @@ -231,7 +231,7 @@ @Override public String printObject() { - return writeToString(dimv); + return printObject(dimv); } Modified: trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte8.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte8.java Fri Aug 5 14:51:28 2011 (r13442) +++ trunk/abcl/src/org/armedbear/lisp/ComplexArray_UnsignedByte8.java Sat Aug 6 06:03:00 2011 (r13443) @@ -233,7 +233,7 @@ // Not reached. return null; } - return writeToString(dimv); + return printObject(dimv); } Modified: trunk/abcl/src/org/armedbear/lisp/SimpleArray_T.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SimpleArray_T.java Fri Aug 5 14:51:28 2011 (r13442) +++ trunk/abcl/src/org/armedbear/lisp/SimpleArray_T.java Sat Aug 6 06:03:00 2011 (r13443) @@ -321,7 +321,7 @@ @Override public String printObject() { - return writeToString(dimv); + return printObject(dimv); } @Override Modified: trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte16.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte16.java Fri Aug 5 14:51:28 2011 (r13442) +++ trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte16.java Sat Aug 6 06:03:00 2011 (r13443) @@ -298,7 +298,7 @@ // Not reached. return null; } - return writeToString(dimv); + return printObject(dimv); } public AbstractArray adjustArray(int[] dimv, LispObject initialElement, Modified: trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte32.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte32.java Fri Aug 5 14:51:28 2011 (r13442) +++ trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte32.java Sat Aug 6 06:03:00 2011 (r13443) @@ -288,7 +288,7 @@ // Not reached. return null; } - return writeToString(dimv); + return printObject(dimv); } public AbstractArray adjustArray(int[] dimv, LispObject initialElement, Modified: trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte8.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte8.java Fri Aug 5 14:51:28 2011 (r13442) +++ trunk/abcl/src/org/armedbear/lisp/SimpleArray_UnsignedByte8.java Sat Aug 6 06:03:00 2011 (r13443) @@ -285,7 +285,7 @@ // Not reached. return null; } - return writeToString(dimv); + return printObject(dimv); } public AbstractArray adjustArray(int[] dimv, LispObject initialElement, From ehuelsmann at common-lisp.net Sat Aug 6 13:51:28 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 06 Aug 2011 06:51:28 -0700 Subject: [armedbear-cvs] r13444 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 6 06:51:26 2011 New Revision: 13444 Log: Reduce the number of required unreadableString() methods by removing the ones taking a symbol argument: all invocations involved a constant parameter, now replaced with a constant string instead. Modified: trunk/abcl/src/org/armedbear/lisp/EndOfFile.java trunk/abcl/src/org/armedbear/lisp/Environment.java trunk/abcl/src/org/armedbear/lisp/FileStream.java trunk/abcl/src/org/armedbear/lisp/Layout.java trunk/abcl/src/org/armedbear/lisp/LispObject.java trunk/abcl/src/org/armedbear/lisp/RandomState.java trunk/abcl/src/org/armedbear/lisp/TwoWayStream.java Modified: trunk/abcl/src/org/armedbear/lisp/EndOfFile.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/EndOfFile.java Sat Aug 6 06:03:00 2011 (r13443) +++ trunk/abcl/src/org/armedbear/lisp/EndOfFile.java Sat Aug 6 06:51:26 2011 (r13444) @@ -74,6 +74,6 @@ @Override public String getMessage() { - return unreadableString(Symbol.END_OF_FILE); + return unreadableString("END-OF-STREAM"); } } Modified: trunk/abcl/src/org/armedbear/lisp/Environment.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Environment.java Sat Aug 6 06:03:00 2011 (r13443) +++ trunk/abcl/src/org/armedbear/lisp/Environment.java Sat Aug 6 06:51:26 2011 (r13444) @@ -247,7 +247,7 @@ @Override public String printObject() { - return unreadableString(Symbol.ENVIRONMENT); + return unreadableString("ENVIRONMENT"); } // ### make-environment Modified: trunk/abcl/src/org/armedbear/lisp/FileStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/FileStream.java Sat Aug 6 06:03:00 2011 (r13443) +++ trunk/abcl/src/org/armedbear/lisp/FileStream.java Sat Aug 6 06:51:26 2011 (r13444) @@ -265,7 +265,7 @@ @Override public String printObject() { - return unreadableString(Symbol.FILE_STREAM); + return unreadableString("FILE-STREAM"); } // ### make-file-stream pathname namestring element-type direction if-exists external-format => stream Modified: trunk/abcl/src/org/armedbear/lisp/Layout.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Layout.java Sat Aug 6 06:03:00 2011 (r13443) +++ trunk/abcl/src/org/armedbear/lisp/Layout.java Sat Aug 6 06:51:26 2011 (r13444) @@ -137,7 +137,7 @@ @Override public String printObject() { - return unreadableString(Symbol.LAYOUT); + return unreadableString("LAYOUT"); } // Generates a list of slot definitions for the slot names in this layout. Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispObject.java Sat Aug 6 06:03:00 2011 (r13443) +++ trunk/abcl/src/org/armedbear/lisp/LispObject.java Sat Aug 6 06:51:26 2011 (r13444) @@ -754,13 +754,27 @@ return toString(); } + /** Calls unreadableString(String s, boolean identity) with a default + * identity value of 'true'. + * + * @param s String representation of this object. + * @return String enclosed in the non-readable #< ... > markers + */ public final String unreadableString(String s) { return unreadableString(s, true); } - public final String unreadableString(Symbol sym) { - return unreadableString(sym, true); - } + /** Creates a non-readably (as per CLHS terminology) representation + * of the 'this' object, using string 's'. + * + * If the current value of the variable *PRINT-READABLY* is T, a + * Lisp error is thrown and no value is returned. + * + * @param s + * @param identity when 'true', includes Java's identityHash for the object + * in the output. + * @return a non reabable string (i.e. one enclosed in the #< > markers) + */ public final String unreadableString(String s, boolean identity) { StringBuilder sb = new StringBuilder("#<"); @@ -774,12 +788,6 @@ return sb.toString(); } - public final String unreadableString(Symbol symbol, boolean identity) - - { - return unreadableString(symbol.printObject(), identity); - } - // Special operator public LispObject execute(LispObject args, Environment env) Modified: trunk/abcl/src/org/armedbear/lisp/RandomState.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/RandomState.java Sat Aug 6 06:03:00 2011 (r13443) +++ trunk/abcl/src/org/armedbear/lisp/RandomState.java Sat Aug 6 06:51:26 2011 (r13444) @@ -93,7 +93,7 @@ @Override public String printObject() { - return unreadableString(Symbol.RANDOM_STATE); + return unreadableString("RANDOM-STATE"); } public LispObject random(LispObject arg) Modified: trunk/abcl/src/org/armedbear/lisp/TwoWayStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/TwoWayStream.java Sat Aug 6 06:03:00 2011 (r13443) +++ trunk/abcl/src/org/armedbear/lisp/TwoWayStream.java Sat Aug 6 06:51:26 2011 (r13444) @@ -216,7 +216,7 @@ @Override public String printObject() { - return unreadableString(Symbol.TWO_WAY_STREAM); + return unreadableString("TWO-WAY-STREAM"); } // ### make-two-way-stream input-stream output-stream => two-way-stream From ehuelsmann at common-lisp.net Sat Aug 6 14:46:29 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 06 Aug 2011 07:46:29 -0700 Subject: [armedbear-cvs] r13445 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 6 07:46:28 2011 New Revision: 13445 Log: Print unreadable strings with unreadableString() exclusively, so it can throw a Lisp error when printing something unreadable. Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/AutoloadMacro.java trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java trunk/abcl/src/org/armedbear/lisp/DoubleFloat.java trunk/abcl/src/org/armedbear/lisp/EndOfFile.java trunk/abcl/src/org/armedbear/lisp/Function.java trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/LispObject.java trunk/abcl/src/org/armedbear/lisp/Package.java trunk/abcl/src/org/armedbear/lisp/SingleFloat.java trunk/abcl/src/org/armedbear/lisp/SpecialOperator.java trunk/abcl/src/org/armedbear/lisp/StructureClass.java Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Autoload.java Sat Aug 6 06:51:26 2011 (r13444) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Sat Aug 6 07:46:28 2011 (r13445) @@ -261,7 +261,7 @@ @Override public String printObject() { - StringBuffer sb = new StringBuffer("#"); - return sb.toString(); + return unreadableString(sb.toString()); } // ### autoload Modified: trunk/abcl/src/org/armedbear/lisp/AutoloadMacro.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/AutoloadMacro.java Sat Aug 6 06:51:26 2011 (r13444) +++ trunk/abcl/src/org/armedbear/lisp/AutoloadMacro.java Sat Aug 6 07:46:28 2011 (r13445) @@ -66,12 +66,11 @@ @Override public String printObject() { - StringBuffer sb = new StringBuffer("#"); - return sb.toString(); + return unreadableString(sb.toString()); } // ### autoload-macro Modified: trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java Sat Aug 6 06:51:26 2011 (r13444) +++ trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java Sat Aug 6 07:46:28 2011 (r13445) @@ -79,10 +79,7 @@ @Override public String printObject() { - StringBuilder sb = new StringBuilder("#'); - return sb.toString(); + return unreadableString(getName().princToString()); } private static BuiltInClass addClass(Symbol symbol) Modified: trunk/abcl/src/org/armedbear/lisp/DoubleFloat.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/DoubleFloat.java Sat Aug 6 06:51:26 2011 (r13444) +++ trunk/abcl/src/org/armedbear/lisp/DoubleFloat.java Sat Aug 6 07:46:28 2011 (r13445) @@ -592,7 +592,7 @@ if (printReadably) return "#.(progn \"Comment: create a NaN.\" (/ 0.0d0 0.0d0))"; else - return "#"; + return unreadableString("DOUBLE-FLOAT NaN", false); } String s1 = String.valueOf(value); if (printReadably || Modified: trunk/abcl/src/org/armedbear/lisp/EndOfFile.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/EndOfFile.java Sat Aug 6 06:51:26 2011 (r13444) +++ trunk/abcl/src/org/armedbear/lisp/EndOfFile.java Sat Aug 6 07:46:28 2011 (r13445) @@ -70,10 +70,4 @@ return T; return super.typep(type); } - - @Override - public String getMessage() - { - return unreadableString("END-OF-STREAM"); - } } Modified: trunk/abcl/src/org/armedbear/lisp/Function.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Function.java Sat Aug 6 06:51:26 2011 (r13444) +++ trunk/abcl/src/org/armedbear/lisp/Function.java Sat Aug 6 07:46:28 2011 (r13445) @@ -317,17 +317,12 @@ { LispObject name = getLambdaName(); if (name != null && name != NIL) { - StringBuffer sb = new StringBuffer("#"); - return sb.toString(); + return unreadableString(name.princToString()); } // No name. LispObject lambdaList = getLambdaList(); if (lambdaList != null) { - StringBuffer sb = new StringBuffer("#"); - return sb.toString(); + return unreadableString(sb.toString()); } return unreadableString("FUNCTION"); } Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Lisp.java Sat Aug 6 06:51:26 2011 (r13444) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Sat Aug 6 07:46:28 2011 (r13445) @@ -2705,7 +2705,7 @@ @Override public String printObject() { - return "#"; + return unreadableString("UNBOUND", false); } } @@ -2715,7 +2715,7 @@ @Override public String printObject() { - return "null"; + return unreadableString("null", false); } } Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispObject.java Sat Aug 6 06:51:26 2011 (r13444) +++ trunk/abcl/src/org/armedbear/lisp/LispObject.java Sat Aug 6 07:46:28 2011 (r13445) @@ -757,6 +757,8 @@ /** Calls unreadableString(String s, boolean identity) with a default * identity value of 'true'. * + * This function is a helper for printObject() + * * @param s String representation of this object. * @return String enclosed in the non-readable #< ... > markers */ @@ -770,6 +772,8 @@ * If the current value of the variable *PRINT-READABLY* is T, a * Lisp error is thrown and no value is returned. * + * This function is a helper for printObject() + * * @param s * @param identity when 'true', includes Java's identityHash for the object * in the output. Modified: trunk/abcl/src/org/armedbear/lisp/Package.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Package.java Sat Aug 6 06:51:26 2011 (r13444) +++ trunk/abcl/src/org/armedbear/lisp/Package.java Sat Aug 6 07:46:28 2011 (r13445) @@ -855,10 +855,7 @@ return sb.toString(); } else { if (name != null) { - StringBuilder sb = new StringBuilder("#"); - return sb.toString(); + return unreadableString("PACKAGE " + name, false); } else return unreadableString("PACKAGE"); } Modified: trunk/abcl/src/org/armedbear/lisp/SingleFloat.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SingleFloat.java Sat Aug 6 06:51:26 2011 (r13444) +++ trunk/abcl/src/org/armedbear/lisp/SingleFloat.java Sat Aug 6 07:46:28 2011 (r13445) @@ -581,7 +581,7 @@ if (printReadably) return "#.(progn \"Comment: create a NaN.\" (/ 0.0s0 0.0s0))"; else - return "#"; + return unreadableString("SINGLE-FLOAT NaN", false); } String s1 = String.valueOf(value); if (printReadably || Modified: trunk/abcl/src/org/armedbear/lisp/SpecialOperator.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SpecialOperator.java Sat Aug 6 06:51:26 2011 (r13444) +++ trunk/abcl/src/org/armedbear/lisp/SpecialOperator.java Sat Aug 6 07:46:28 2011 (r13445) @@ -148,10 +148,9 @@ @Override public String printObject() { - StringBuffer sb = new StringBuffer("#"); - return sb.toString(); + return unreadableString(sb.toString(), false); } // Profiling. Modified: trunk/abcl/src/org/armedbear/lisp/StructureClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StructureClass.java Sat Aug 6 06:51:26 2011 (r13444) +++ trunk/abcl/src/org/armedbear/lisp/StructureClass.java Sat Aug 6 07:46:28 2011 (r13445) @@ -78,10 +78,9 @@ @Override public String printObject() { - StringBuffer sb = new StringBuffer("#'); - return sb.toString(); + return unreadableString(sb.toString(), false); } // ### make-structure-class name direct-slots slots include => class From ehuelsmann at common-lisp.net Sat Aug 6 16:59:35 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 06 Aug 2011 09:59:35 -0700 Subject: [armedbear-cvs] r13446 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 6 09:59:33 2011 New Revision: 13446 Log: Fix #158: Print "#" fails with *PRINT-READABLY* non-NIL. Note: This commit also fixes some failures in the random testing ANSI tests, notably PRINT.RANDOM.SYMBOL.*. Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java trunk/abcl/src/org/armedbear/lisp/Primitives.java trunk/abcl/src/org/armedbear/lisp/print.lisp Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispObject.java Sat Aug 6 07:46:28 2011 (r13445) +++ trunk/abcl/src/org/armedbear/lisp/LispObject.java Sat Aug 6 09:59:33 2011 (r13446) @@ -781,6 +781,10 @@ */ public final String unreadableString(String s, boolean identity) { + if (Symbol.PRINT_READABLY.symbolValue() != NIL) { + error(new PrintNotReadable(list(Keyword.OBJECT, this))); + return null; // not reached + } StringBuilder sb = new StringBuilder("#<"); sb.append(s); if (identity) { Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java Sat Aug 6 07:46:28 2011 (r13445) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Sat Aug 6 09:59:33 2011 (r13446) @@ -908,18 +908,6 @@ else out = second; String output = first.printObject(); - if (Symbol.PRINT_READABLY.symbolValue(LispThread.currentThread()) != NIL - && output.contains("#<")) { - //### Ticket #160: the cause lies here. - // You can't just go scan the content of the printed string, - // because the marker being sought may be part of the readable - // presentation - LispObject args = NIL; - args = args.push(first); - args = args.push(Keyword.OBJECT); - args = args.nreverse(); - return error(new PrintNotReadable(args)); - } checkStream(out)._writeString(output); return first; } Modified: trunk/abcl/src/org/armedbear/lisp/print.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/print.lisp Sat Aug 6 07:46:28 2011 (r13445) +++ trunk/abcl/src/org/armedbear/lisp/print.lisp Sat Aug 6 09:59:33 2011 (r13446) @@ -280,10 +280,6 @@ (symbol-package x)))) (defun %print-object (object stream) - (when (and *print-readably* - (typep object 'string) - (search "#<" object)) - (error 'print-not-readable :object object)) (if *print-pretty* (xp::output-pretty-object object stream) (output-ugly-object object stream))) From ehuelsmann at common-lisp.net Sun Aug 7 12:51:59 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 07 Aug 2011 05:51:59 -0700 Subject: [armedbear-cvs] r13447 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 7 05:51:58 2011 New Revision: 13447 Log: Add documentation. Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp Sat Aug 6 09:59:33 2011 (r13446) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Sun Aug 7 05:51:58 2011 (r13447) @@ -287,14 +287,27 @@ ignorable-p representation special-p ; indicates whether a variable is special + +;; A variable can be stored in a number of locations. +;; 1. if it's passed as a normal argument, it'll be in a register (max 8) +;; the same is true if the variable is a local variable (at any index) +;; 2. if it's passed in the argument array, it'll be in the array in +;; register 1 (register 0 contains the function object) +;; 3. if the variable is part of a closure, it'll be in the closure array +;; 4. if the variable is part of the outer scope of a function with a +;; non-null lexical environment, the variable is to be looked up +;; from a lexical environment object + +;; a variable can be either special-p *or* have a register *or* +;; have an index *or* a closure-index *or* an environment + register ; register number for a local variable binding-register ; register number containing the binding reference index ; index number for a variable in the argument array closure-index ; index number for a variable in the closure context array environment ; the environment for the variable, if we're compiling in ; a non-null lexical environment with variables - ;; a variable can be either special-p *or* have a register *or* - ;; have an index *or* a closure-index *or* an environment + (reads 0 :type fixnum) (writes 0 :type fixnum) references From ehuelsmann at common-lisp.net Sun Aug 7 14:14:34 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 07 Aug 2011 07:14:34 -0700 Subject: [armedbear-cvs] r13448 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 7 07:14:33 2011 New Revision: 13448 Log: Add more documentation. Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp Sun Aug 7 05:51:58 2011 (r13447) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Sun Aug 7 07:14:33 2011 (r13448) @@ -297,6 +297,8 @@ ;; 4. if the variable is part of the outer scope of a function with a ;; non-null lexical environment, the variable is to be looked up ;; from a lexical environment object +;; 5. the variable is a special variable and its binding has been looked +;; up and cached in a local register (binding-register) ;; a variable can be either special-p *or* have a register *or* ;; have an index *or* a closure-index *or* an environment From ehuelsmann at common-lisp.net Sun Aug 7 14:20:58 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 07 Aug 2011 07:20:58 -0700 Subject: [armedbear-cvs] r13449 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 7 07:20:58 2011 New Revision: 13449 Log: Dead code removal. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Aug 7 07:14:33 2011 (r13448) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Aug 7 07:20:58 2011 (r13449) @@ -3115,26 +3115,13 @@ (astore register) ) -(defun restore-environment-and-make-handler (register label-START) - (let ((label-END (gensym "U")) - (label-EXIT (gensym "E"))) - (emit 'goto label-EXIT) - (label label-END) - (restore-dynamic-environment register) - (emit 'athrow) - ;; Restore dynamic environment. - (label label-EXIT) - (restore-dynamic-environment register) - (add-exception-handler label-START label-END label-END nil))) - (defun p2-m-v-b-node (block target) (let* ((*register* *register*) (form (m-v-b-form block)) (*visible-variables* *visible-variables*) (vars (second form)) (bind-special-p nil) - (variables (m-v-b-vars block)) - (label-START (gensym "F"))) + (variables (m-v-b-vars block))) (dolist (variable variables) (let ((special-p (variable-special-p variable))) (cond (special-p @@ -3148,8 +3135,7 @@ (dformat t "p2-m-v-b-node lastSpecialBinding~%") ;; Save current dynamic environment. (setf (m-v-b-environment-register block) (allocate-register nil)) - (save-dynamic-environment (m-v-b-environment-register block)) - (label label-START)) + (save-dynamic-environment (m-v-b-environment-register block))) ;; Make sure there are no leftover values from previous calls. (emit-clear-values) ;; Bind the variables. @@ -3538,8 +3524,7 @@ (*register* *register*) (form (let-form block)) (*visible-variables* *visible-variables*) - (specialp nil) - (label-START (gensym "F"))) + (specialp nil)) ;; Walk the variable list looking for special bindings and unused lexicals. (dolist (variable (let-vars block)) (cond ((variable-special-p variable) @@ -3550,8 +3535,7 @@ (when specialp ;; We need to save current dynamic environment. (setf (let-environment-register block) (allocate-register nil)) - (save-dynamic-environment (let-environment-register block)) - (label label-START)) + (save-dynamic-environment (let-environment-register block))) (propagate-vars block) (ecase (car form) (LET @@ -3952,8 +3936,7 @@ (values-form (caddr form)) (*register* *register*) (environment-register - (setf (progv-environment-register block) (allocate-register nil))) - (label-START (gensym "F"))) + (setf (progv-environment-register block) (allocate-register nil)))) (with-operand-accumulation ((compile-operand symbols-form nil) (compile-operand values-form nil)) @@ -3961,7 +3944,6 @@ (single-valued-p values-form)) (emit-clear-values)) (save-dynamic-environment environment-register) - (label label-START) ;; Compile call to Lisp.progvBindVars(). (emit-push-current-thread) (emit-invokestatic +lisp+ "progvBindVars" @@ -7138,8 +7120,7 @@ (*visible-variables* *visible-variables*) (*thread* nil) - (*initialize-thread-var* nil) - (label-START (gensym "F"))) + (*initialize-thread-var* nil)) (class-add-method class-file method) @@ -7282,7 +7263,6 @@ (setf (compiland-environment-register compiland) (allocate-register nil)) (save-dynamic-environment (compiland-environment-register compiland)) - (label label-START) (dolist (variable (compiland-arg-vars compiland)) (when (variable-special-p variable) (setf (variable-binding-register variable) (allocate-register nil)) From ehuelsmann at common-lisp.net Sun Aug 7 20:18:01 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 07 Aug 2011 13:18:01 -0700 Subject: [armedbear-cvs] r13450 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 7 13:17:59 2011 New Revision: 13450 Log: Fix #141 (SETF of APPLY not working with arbitrary function) by "adding" the feature. Modified: trunk/abcl/src/org/armedbear/lisp/late-setf.lisp Modified: trunk/abcl/src/org/armedbear/lisp/late-setf.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/late-setf.lisp Sun Aug 7 07:20:58 2011 (r13449) +++ trunk/abcl/src/org/armedbear/lisp/late-setf.lisp Sun Aug 7 13:17:59 2011 (r13450) @@ -88,11 +88,6 @@ `(getf ,get ,ptemp ,@(if default `(,def-temp))))))) (define-setf-expander apply (functionoid &rest args) - (unless (and (listp functionoid) - (= (length functionoid) 2) - (eq (first functionoid) 'function) - (memq (second functionoid) '(aref bit sbit))) - (error "SETF of APPLY is only defined for #'AREF, #'BIT and #'SBIT.")) (let ((function (second functionoid)) (new-var (gensym)) (vars (make-gensym-list (length args)))) From ehuelsmann at common-lisp.net Sun Aug 7 22:11:32 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 07 Aug 2011 15:11:32 -0700 Subject: [armedbear-cvs] r13451 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 7 15:11:31 2011 New Revision: 13451 Log: Use pre-compiled closures to populate the reader/writer accessors for structures. In order to make sure they are pre-compiled in our build too, compile defstruct.lisp earlier in the compilation phase. (Saves roughly 20s on my compilation runs.) Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp trunk/abcl/src/org/armedbear/lisp/defstruct.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Sun Aug 7 13:17:59 2011 (r13450) +++ trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Sun Aug 7 15:11:31 2011 (r13451) @@ -89,6 +89,7 @@ :defaults (merge-pathnames file output-path)))) (compile-file-if-needed file :output-file out)))) + (load (do-compile "defstruct.lisp")) (load (do-compile "coerce.lisp")) (load (do-compile "open.lisp")) (load (do-compile "dump-form.lisp")) @@ -157,7 +158,6 @@ "defmacro.lisp" "defpackage.lisp" "defsetf.lisp" - "defstruct.lisp" "deftype.lisp" "delete-duplicates.lisp" "deposit-field.lisp" Modified: trunk/abcl/src/org/armedbear/lisp/defstruct.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/defstruct.lisp Sun Aug 7 13:17:59 2011 (r13450) +++ trunk/abcl/src/org/armedbear/lisp/defstruct.lisp Sun Aug 7 15:11:31 2011 (r13451) @@ -329,44 +329,82 @@ `((defun ,pred (object) (simple-typep object ',*dd-name*)))))))) +(defun make-list-reader (index) + #'(lambda (instance) + (elt instance index))) + +(defun make-vector-reader (index) + #'(lambda (instance) + (aref instance index))) + +(defun make-structure-reader (index structure-type) + (declare (ignore structure-type)) + #'(lambda (instance) + ;; (unless (typep instance structure-type) + ;; (error 'type-error + ;; :datum instance + ;; :expected-type structure-type)) + (structure-ref instance index))) + (defun define-reader (slot) (let ((accessor-name (dsd-reader slot)) (index (dsd-index slot)) (type (dsd-type slot))) (cond ((eq *dd-type* 'list) `((declaim (ftype (function * ,type) ,accessor-name)) - (defun ,accessor-name (instance) (elt instance ,index)))) + (setf (symbol-function ',accessor-name) + (make-list-reader ,index)))) ((or (eq *dd-type* 'vector) (and (consp *dd-type*) (eq (car *dd-type*) 'vector))) `((declaim (ftype (function * ,type) ,accessor-name)) - (defun ,accessor-name (instance) (aref instance ,index)) + (setf (symbol-function ',accessor-name) + (make-vector-reader ,index)) (define-source-transform ,accessor-name (instance) `(aref (truly-the ,',*dd-type* ,instance) ,,index)))) (t `((declaim (ftype (function * ,type) ,accessor-name)) - (defun ,accessor-name (instance) - (structure-ref (the ,*dd-name* instance) ,index)) + (setf (symbol-function ',accessor-name) + (make-structure-reader ,index ',*dd-name*)) (define-source-transform ,accessor-name (instance) ,(if (eq type 't) ``(structure-ref (the ,',*dd-name* ,instance) ,,index) ``(the ,',type (structure-ref (the ,',*dd-name* ,instance) ,,index))))))))) +(defun make-list-writer (index) + #'(lambda (value instance) + (%set-elt instance index value))) + +(defun make-vector-writer (index) + #'(lambda (value instance) + (aset instance index value))) + +(defun make-structure-writer (index structure-type) + (declare (ignore structure-type)) + #'(lambda (value instance) + ;; (unless (typep instance structure-type) + ;; (error 'type-error + ;; :datum instance + ;; :expected-type structure-type)) + (structure-set instance index value))) + + + (defun define-writer (slot) (let ((accessor-name (dsd-reader slot)) (index (dsd-index slot))) (cond ((eq *dd-type* 'list) - `((defun (setf ,accessor-name) (value instance) - (%set-elt instance ,index value)))) + `((setf (get ',accessor-name 'setf-function) + (make-list-writer ,index)))) ((or (eq *dd-type* 'vector) (and (consp *dd-type*) (eq (car *dd-type*) 'vector))) - `((defun (setf ,accessor-name) (value instance) - (aset instance ,index value)) + `((setf (get ',accessor-name 'setf-function) + (make-vector-writer ,index)) (define-source-transform (setf ,accessor-name) (value instance) `(aset (truly-the ,',*dd-type* ,instance) ,,index ,value)))) (t - `((defun (setf ,accessor-name) (value instance) - (structure-set (the ,*dd-name* instance) ,index value)) + `((setf (get ',accessor-name 'setf-function) + (make-structure-writer ,index ',*dd-name*)) (define-source-transform (setf ,accessor-name) (value instance) `(structure-set (the ,',*dd-name* ,instance) ,,index ,value))))))) From ehuelsmann at common-lisp.net Tue Aug 9 20:54:48 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 09 Aug 2011 13:54:48 -0700 Subject: [armedbear-cvs] r13452 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Aug 9 13:54:47 2011 New Revision: 13452 Log: Include filename in the error string being reported. Found by: Blake McBride Fixed by: me :-) Modified: trunk/abcl/src/org/armedbear/lisp/Load.java Modified: trunk/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Load.java Sun Aug 7 15:11:31 2011 (r13451) +++ trunk/abcl/src/org/armedbear/lisp/Load.java Tue Aug 9 13:54:47 2011 (r13452) @@ -144,7 +144,7 @@ if (truename == null || truename.equals(NIL)) { if (ifDoesNotExist) { - return error(new FileError("File not found.", pathname)); + return error(new FileError("File not found: " + pathname.princToString(), pathname)); } else { Debug.warn("Failed to load " + pathname.getNamestring()); return NIL; From ehuelsmann at common-lisp.net Thu Aug 11 07:30:41 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Thu, 11 Aug 2011 00:30:41 -0700 Subject: [armedbear-cvs] r13453 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Aug 11 00:30:40 2011 New Revision: 13453 Log: Remove code duplication: operators know how to print themselves perfectly well; this improves printing of "Wrong number of args" errors. Modified: trunk/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java Modified: trunk/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java Tue Aug 9 13:54:47 2011 (r13452) +++ trunk/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java Thu Aug 11 00:30:40 2011 (r13453) @@ -72,12 +72,8 @@ return message; } StringBuilder sb = - new StringBuilder("Wrong number of arguments"); - LispObject lambdaName = operator.getLambdaName(); - if (lambdaName != null && lambdaName != NIL) { - sb.append(" for "); - sb.append(operator.getLambdaName().princToString()); - } + new StringBuilder("Wrong number of arguments for " + + operator.princToString()); if(expectedArgs >= 0) { sb.append("; "); sb.append(expectedArgs); From mevenson at common-lisp.net Thu Aug 11 09:45:42 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 11 Aug 2011 02:45:42 -0700 Subject: [armedbear-cvs] r13454 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Thu Aug 11 02:45:41 2011 New Revision: 13454 Log: Tweak appearance and contents of help message. Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.java Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Interpreter.java Thu Aug 11 00:30:40 2011 (r13453) +++ trunk/abcl/src/org/armedbear/lisp/Interpreter.java Thu Aug 11 02:45:41 2011 (r13454) @@ -241,7 +241,6 @@ // --eval options. Copy all unrecognized arguments into // ext:*command-line-argument-list* private static void preprocessCommandLineArguments(String[] args) - { LispObject arglist = NIL; @@ -654,23 +653,34 @@ final String sep = System.getProperty("line.separator"); StringBuilder sb = new StringBuilder("Parameters:"); sb.append(sep); - sb.append("--help displays this help"); + sb.append("--help").append(sep) + .append(" Displays this message."); + sb.append(sep); + sb.append("--noinform").append(sep) + .append(" Suppresses the printing of startup information and banner."); sb.append(sep); - sb.append("--noinform suppresses the printing of version info"); + sb.append("--noinit").append(sep) + .append(" Suppresses the loading of the '~/.abclrc' startup file."); + sb.append(sep); + sb.append("--nosystem").append(sep) + .append(" Suppresses loading the 'system.lisp' customization file. "); sb.append(sep); - sb.append("--eval
evaluates the before initializing REPL"); + sb.append("--eval ").append(sep) + .append(" Evaluates the before initializing REPL."); sb.append(sep); - sb.append("--load loads the file before initializing REPL"); + sb.append("--load ").append(sep) + .append(" Loads the file before initializing REPL."); sb.append(sep); - sb.append("--load-system-file loads the system file before initializing REPL"); + sb.append("--load-system-file ").append(sep) + .append(" Loads the system file before initializing REPL."); sb.append(sep); - sb.append("--batch enables batch mode. The --load, --load-system-file and --eval parameters are handled, and abcl exits without entering REPL"); + sb.append("--batch").append(sep) + .append(" The process evaluates forms specified by arguments and possibly by those").append(sep) + .append(" by those in the intialization file '~/.abcl', and then exits."); sb.append(sep); - sb.append("--noinit suppresses loading a .abclrc startup file"); - sb.append(sep); - sb.append("--nosystem suppresses loading the system startup file"); sb.append(sep); - sb.append("-- alone prevents further argument handling"); + sb.append("The occurance of '--' copies the remaining arguments, unprocessed, into").append(sep) + .append("the variable EXTENSIONS:*COMMAND-LINE-ARGUMENT-LIST*."); sb.append(sep); return sb.toString(); From mevenson at common-lisp.net Thu Aug 11 09:45:52 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 11 Aug 2011 02:45:52 -0700 Subject: [armedbear-cvs] r13455 - trunk/abcl/doc/manual Message-ID: Author: mevenson Date: Thu Aug 11 02:45:52 2011 New Revision: 13455 Log: Document running ABCL in the manual. Modified: trunk/abcl/doc/manual/abcl.sty trunk/abcl/doc/manual/abcl.tex Modified: trunk/abcl/doc/manual/abcl.sty ============================================================================== --- trunk/abcl/doc/manual/abcl.sty Thu Aug 11 02:45:41 2011 (r13454) +++ trunk/abcl/doc/manual/abcl.sty Thu Aug 11 02:45:52 2011 (r13455) @@ -28,6 +28,10 @@ {\lstset{language=Lisp}} {} +\lstnewenvironment{listing-shell} + {\lstset{language=sh}} + {} + \usepackage{verbatim} \ProvidesPackage{abcl} Modified: trunk/abcl/doc/manual/abcl.tex ============================================================================== --- trunk/abcl/doc/manual/abcl.tex Thu Aug 11 02:45:41 2011 (r13454) +++ trunk/abcl/doc/manual/abcl.tex Thu Aug 11 02:45:52 2011 (r13455) @@ -19,8 +19,71 @@ \subsection{Version} This manual corresponds to abcl-0.27.0, as yet unreleased. -\chapter{Conformance} +\chapter{Running} + +ABCL is packaged as a single jar file (usually named either +``abcl.jar'' or something like``abcl-0.27.1.jar'' if you are using a +versioned package) that can be executed under the +control of a suitable JVM as follows + +\begin{listing-shell} + cmd\$ java -jar abcl.jar +\end{listing-shell} + +For this command to work, the ``java'' exectuable needs to be in your +path. + +To make it easier to faciliate the use of ABCL in tool chains (such as +SLIME) the invocation is wrapped in a Bourne shell script under UNIX +or a DOS command script under Windows so that ABCL may be executed +simplly as: + +\begin{listing-shell} + cmd\$ abcl +\end{listing-shell} + +\section{Options} + +ABCL supports the following options: + +\begin{verbatim} +--help + Displays this message. +--noinform + Suppresses the printing of startup information and banner. +--noinit + Suppresses the loading of the '~/.abclrc' startup file. +--nosystem + Suppresses loading the 'system.lisp' customization file. +--eval + Evaluates the before initializing REPL. +--load + Loads the file before initializing REPL. +--load-system-file + Loads the system file before initializing REPL. +--batch + The process evaluates forms specified by arguments and possibly by those + by those in the intialization file '~/.abcl', and then exits. + +The occurance of '--' copies the remaining arguments, unprocessed, into +the variable EXTENSIONS:*COMMAND-LINE-ARGUMENT-LIST*. +\end{verbatim} + +All of the command line arguments which follow the occurance of ``--'' +are passed into a list bound to the EXT:*COMMAND-LINE-ARGUMENT-LIST* +variable. + +\section{Initialization} + +If the ABCL process is started without the ``--noinit'' flag, it +attempts to load a file named ``.abclrc'' located in the user's home +directory and then interpret its contents. + +The user's home directory is determined by the value of the JVM system +property ``user.home''. + +\chapter{Conformance} \section{ANSI Common Lisp} ABCL is currently a non-conforming ANSI Common Lisp implementation due From mevenson at common-lisp.net Thu Aug 11 14:07:28 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 11 Aug 2011 07:07:28 -0700 Subject: [armedbear-cvs] r13456 - trunk/abcl Message-ID: Author: mevenson Date: Thu Aug 11 07:07:26 2011 New Revision: 13456 Log: Include ASDF definition in source release. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml Thu Aug 11 02:45:52 2011 (r13455) +++ trunk/abcl/build.xml Thu Aug 11 07:07:26 2011 (r13456) @@ -590,6 +590,8 @@ + + From mevenson at common-lisp.net Thu Aug 11 15:21:46 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 11 Aug 2011 08:21:46 -0700 Subject: [armedbear-cvs] r13457 - trunk/abcl/test/lisp/abcl Message-ID: Author: mevenson Date: Thu Aug 11 08:21:45 2011 New Revision: 13457 Log: Fix JAR-PATHNAME tests. Remove the wrong-headed use of TRUENAME at compile time which would error unless the test directory had previously been created. Remove the use of the readtime #. macro to create the success conditions for tests which were failing based on the presence of the temporary jar directory. These bugs seem show the need for a more explicit test build-up/tear-down sequence as the complexity in manage Lisp macros here leads to a lot of unncessary bugs. Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/jar-pathname.lisp Thu Aug 11 07:07:26 2011 (r13456) +++ trunk/abcl/test/lisp/abcl/jar-pathname.lisp Thu Aug 11 08:21:45 2011 (r13457) @@ -5,17 +5,6 @@ (defparameter *tmp-jar-path* nil) (defparameter *tmp-jar-path-whitespace* nil) -(eval-when (:compile-toplevel :load-toplevel) - (let ((temp-file (java:jcall "getAbsolutePath" - (java:jstatic "createTempFile" "java.io.File" "jar" "tmp")))) - (setf *tmp-directory* - (truename (make-pathname :directory - (append - (pathname-directory (pathname temp-file)) - '("jar-pathname-tests")))) - *tmp-directory-whitespace* - (merge-pathnames "a/directory with/s p a/" *tmp-directory*)))) - (defvar *foo.lisp* `((defun foo () (labels ((output () @@ -53,6 +42,16 @@ (print form s))))) (defun jar-file-init () + (let* ((temp-file (java:jcall "getAbsolutePath" + (java:jstatic "createTempFile" "java.io.File" "jar" "tmp"))) + (temp-dir (make-pathname :directory (append + (pathname-directory (pathname temp-file)) + '("jar-pathname-tests"))))) + (ensure-directories-exist temp-dir) + (setf *tmp-directory* + (truename temp-dir) + *tmp-directory-whitespace* + (merge-pathnames "a/directory with/s p a/" *tmp-directory*))) (format t "~&Using ~A to create files for testing jar-pathnames.~%" *tmp-directory*) (ensure-directories-exist *tmp-directory*) (let* ((*default-pathname-defaults* *tmp-directory*) @@ -110,10 +109,10 @@ (delete-directory-and-files *tmp-directory*))) (defmacro with-jar-file-init (&rest body) - `(let ((*default-pathname-defaults* *tmp-directory*)) - (progn - (unless (and *tmp-jar-path* (probe-file *tmp-jar-path*)) - (jar-file-init)) + `(progn + (unless (and *tmp-jar-path* (probe-file *tmp-jar-path*)) + (jar-file-init)) + (let ((*default-pathname-defaults* *tmp-directory*)) , at body))) (defun jar-pathname-escaped (jar path) @@ -124,6 +123,13 @@ `(with-jar-file-init (load (jar-pathname-escaped ,jar ,path)))) +;;; XXX Figure out correct use of macros so this isn't necessary +(push 'jar-pathname.load.init *expected-failures*) +(deftest jar-pathname.load.init + (with-jar-file-init + nil) + t) + (deftest jar-pathname.load.1 (load-from-jar *tmp-jar-path* "foo") t) @@ -243,42 +249,68 @@ t)) (deftest jar-pathname.probe-file.1 - (with-jar-file-init - (probe-file "jar:file:baz.jar!/eek.lisp")) - #p#.(format nil "jar:file:~A/baz.jar!/eek.lisp" - (namestring *tmp-directory*))) + (let ((result + (with-jar-file-init + (probe-file "jar:file:baz.jar!/eek.lisp")))) + (string= + (if result (namestring result) "") + (format nil "jar:file:~Abaz.jar!/eek.lisp" + (namestring *tmp-directory*)))) + t) (deftest jar-pathname.probe-file.2 - (with-jar-file-init - (probe-file "jar:file:baz.jar!/a/b/bar.abcl")) - #p#.(format nil "jar:file:~A/baz.jar!/a/b/bar.abcl" - (namestring *tmp-directory*))) + (let ((result + (with-jar-file-init + (probe-file "jar:file:baz.jar!/a/b/bar.abcl")))) + (string= + (if result (namestring result) "") + (format nil "jar:file:~Abaz.jar!/a/b/bar.abcl" + (namestring *tmp-directory*)))) + t) (deftest jar-pathname.probe-file.3 - (with-jar-file-init - (probe-file "jar:jar:file:baz.jar!/a/b/bar.abcl!/bar._")) - #p#.(format nil "jar:jar:file:~Abaz.jar!/a/b/bar.abcl!/bar._" - (namestring *tmp-directory*))) + (let ((result + (with-jar-file-init + (probe-file "jar:jar:file:baz.jar!/a/b/bar.abcl!/bar._")))) + (string= + (if result (namestring result) "") + (format nil "jar:jar:file:~Abaz.jar!/a/b/bar.abcl!/bar._" + (namestring *tmp-directory*)))) + t) + (push 'jar-pathname.probe-file.4 *expected-failures*) (deftest jar-pathname.probe-file.4 - (with-jar-file-init - (probe-file "jar:file:baz.jar!/a/b")) - #p#.(format nil "jar:file:~Abaz.jar!/a/b/" - (namestring *tmp-directory*))) + (let ((result + (with-jar-file-init + (probe-file "jar:file:baz.jar!/a/b")))) + (string= + (if result (namestring result) "") + (format nil "jar:file:~Abaz.jar!/a/b/" + (namestring *tmp-directory*)))) + t) (push 'jar-pathname.probe-file.5 *expected-failures*) (deftest jar-pathname.probe-file.5 - (with-jar-file-init - (probe-file "jar:file:baz.jar!/a/b/")) - #p#.(format nil "jar:file:~Abaz.jar!/a/b/" - (namestring *tmp-directory*))) + (let ((result + (with-jar-file-init + (probe-file "jar:file:baz.jar!/a/b/")))) + (string= + (if result (namestring result) "") + (format nil "jar:file:~Abaz.jar!/a/b/" + (namestring *tmp-directory*)))) + t) + (deftest jar-pathname.probe-file.6 - (with-jar-file-init - (probe-file "jar:file:baz.jar!/d/e+f/bar.abcl")) - #p#.(format nil "jar:file:~Abaz.jar!/d/e+f/bar.abcl" - (namestring *tmp-directory*))) + (let ((result + (with-jar-file-init + (probe-file "jar:file:baz.jar!/d/e+f/bar.abcl")))) + (string= + (if result (namestring result) "") + (format nil "jar:file:~Abaz.jar!/d/e+f/bar.abcl" + (namestring *tmp-directory*)))) + t) (deftest jar-pathname.merge-pathnames.1 (merge-pathnames From mevenson at common-lisp.net Thu Aug 11 15:21:54 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 11 Aug 2011 08:21:54 -0700 Subject: [armedbear-cvs] r13458 - trunk/abcl Message-ID: Author: mevenson Date: Thu Aug 11 08:21:54 2011 New Revision: 13458 Log: Include the test source in the release. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml Thu Aug 11 08:21:45 2011 (r13457) +++ trunk/abcl/build.xml Thu Aug 11 08:21:54 2011 (r13458) @@ -596,6 +596,8 @@ + + @@ -605,8 +607,6 @@ - - From mevenson at common-lisp.net Thu Aug 11 15:44:20 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 11 Aug 2011 08:44:20 -0700 Subject: [armedbear-cvs] r13459 - trunk/abcl/test/lisp/abcl Message-ID: Author: mevenson Date: Thu Aug 11 08:44:20 2011 New Revision: 13459 Log: TRANSLATE-PATHNAME.5 is no longer failing. Modified: trunk/abcl/test/lisp/abcl/pathname-tests.lisp Modified: trunk/abcl/test/lisp/abcl/pathname-tests.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/pathname-tests.lisp Thu Aug 11 08:21:54 2011 (r13458) +++ trunk/abcl/test/lisp/abcl/pathname-tests.lisp Thu Aug 11 08:44:20 2011 (r13459) @@ -896,13 +896,9 @@ t) (deftest translate-pathname.5 - #-abcl (equal (translate-pathname "foobar" "foo*" "") #+(or allegro clisp) #p"bar" - #+(or cmu sbcl lispworks) #p"foobar") - #+abcl - ;; ABCL doesn't implement this translation. Verify that it signals an error. - (signals-error (translate-pathname "foobar" "foo*" "") 'error) + #+(or cmu sbcl lispworks abcl) #p"foobar") t) (deftest translate-pathname.6 From mevenson at common-lisp.net Thu Aug 11 15:44:30 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 11 Aug 2011 08:44:30 -0700 Subject: [armedbear-cvs] r13460 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Thu Aug 11 08:44:29 2011 New Revision: 13460 Log: Fix loading from fasls under Windows with whitespace in pathname. A bad regression presumably introduced r13533. Found by @acelent on #abcl (and possibly Theam Yong Chew but I didn't have time to properly respond to his last email). Modified: trunk/abcl/src/org/armedbear/lisp/Load.java trunk/abcl/src/org/armedbear/lisp/Pathname.java Modified: trunk/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Load.java Thu Aug 11 08:44:20 2011 (r13459) +++ trunk/abcl/src/org/armedbear/lisp/Load.java Thu Aug 11 08:44:29 2011 (r13460) @@ -158,7 +158,7 @@ n = "jar:" + n + "!/" + name + "." + COMPILE_FILE_INIT_FASL_TYPE; } else { - n = "jar:file:" + n + "!/" + name + "." + n = "jar:file:" + Pathname.uriEncode(n) + "!/" + name + "." + COMPILE_FILE_INIT_FASL_TYPE; } mergedPathname = new Pathname(n); Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java Thu Aug 11 08:44:20 2011 (r13459) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Thu Aug 11 08:44:29 2011 (r13460) @@ -373,9 +373,13 @@ + "'" + url.toString() + "'" + ": " + ex.toString())); } - final String uriPath = uri.getPath(); + String uriPath = uri.getPath(); if (null == uriPath) { - error(new LispError("The URI has no path: " + uri)); + // We make an exception for forms like "file:z:/foo/path" + uriPath = uri.getSchemeSpecificPart(); + if (uriPath == null || uriPath.equals("")) { + error(new LispError("The URI has no path: " + uri)); + } } final File file = new File(uriPath); final Pathname p = new Pathname(file.getPath()); From ehuelsmann at common-lisp.net Thu Aug 11 17:01:42 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Thu, 11 Aug 2011 10:01:42 -0700 Subject: [armedbear-cvs] r13461 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Aug 11 10:01:41 2011 New Revision: 13461 Log: Print expected minimum and maximum argument list lengths in WrongNumberOfArguments program errors. Modified: trunk/abcl/src/org/armedbear/lisp/CharacterFunctions.java trunk/abcl/src/org/armedbear/lisp/Closure.java trunk/abcl/src/org/armedbear/lisp/Extensions.java trunk/abcl/src/org/armedbear/lisp/JHandler.java trunk/abcl/src/org/armedbear/lisp/JProxy.java trunk/abcl/src/org/armedbear/lisp/Java.java trunk/abcl/src/org/armedbear/lisp/LispThread.java trunk/abcl/src/org/armedbear/lisp/PackageFunctions.java trunk/abcl/src/org/armedbear/lisp/Pathname.java trunk/abcl/src/org/armedbear/lisp/Primitives.java trunk/abcl/src/org/armedbear/lisp/Readtable.java trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java trunk/abcl/src/org/armedbear/lisp/Stream.java trunk/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java trunk/abcl/src/org/armedbear/lisp/adjust_array.java trunk/abcl/src/org/armedbear/lisp/make_array.java trunk/abcl/src/org/armedbear/lisp/peek_char.java trunk/abcl/src/org/armedbear/lisp/room.java Modified: trunk/abcl/src/org/armedbear/lisp/CharacterFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/CharacterFunctions.java Thu Aug 11 08:44:29 2011 (r13460) +++ trunk/abcl/src/org/armedbear/lisp/CharacterFunctions.java Thu Aug 11 10:01:41 2011 (r13461) @@ -44,7 +44,7 @@ @Override public LispObject execute() { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); } @Override public LispObject execute(LispObject arg) @@ -79,7 +79,7 @@ @Override public LispObject execute() { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); } @Override public LispObject execute(LispObject arg) @@ -129,7 +129,7 @@ @Override public LispObject execute() { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); } @Override public LispObject execute(LispObject arg) @@ -168,7 +168,7 @@ @Override public LispObject execute() { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); } @Override public LispObject execute(LispObject arg) @@ -207,7 +207,7 @@ @Override public LispObject execute() { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); } @Override public LispObject execute(LispObject arg) @@ -245,7 +245,7 @@ @Override public LispObject execute() { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); } @Override public LispObject execute(LispObject arg) @@ -294,7 +294,7 @@ @Override public LispObject execute() { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); } @Override public LispObject execute(LispObject arg) @@ -333,7 +333,7 @@ @Override public LispObject execute() { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); } @Override public LispObject execute(LispObject arg) Modified: trunk/abcl/src/org/armedbear/lisp/Closure.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Closure.java Thu Aug 11 08:44:29 2011 (r13460) +++ trunk/abcl/src/org/armedbear/lisp/Closure.java Thu Aug 11 10:01:41 2011 (r13461) @@ -666,12 +666,12 @@ { // Fixed arity. if (argsLength != arity) - error(new WrongNumberOfArgumentsException(this)); + error(new WrongNumberOfArgumentsException(this, arity)); return args; } // Not fixed arity. if (argsLength < minArgs) - error(new WrongNumberOfArgumentsException(this)); + error(new WrongNumberOfArgumentsException(this, minArgs, -1)); final LispObject[] array = new LispObject[variables.length]; int index = 0; // The bindings established here (if any) are lost when this function @@ -925,12 +925,12 @@ { // Fixed arity. if (argsLength != arity) - error(new WrongNumberOfArgumentsException(this)); + error(new WrongNumberOfArgumentsException(this, arity)); return args; } // Not fixed arity. if (argsLength < minArgs) - error(new WrongNumberOfArgumentsException(this)); + error(new WrongNumberOfArgumentsException(this, minArgs, -1)); final LispObject[] array = new LispObject[variables.length]; int index = 0; // Required parameters. Modified: trunk/abcl/src/org/armedbear/lisp/Extensions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Extensions.java Thu Aug 11 08:44:29 2011 (r13460) +++ trunk/abcl/src/org/armedbear/lisp/Extensions.java Thu Aug 11 10:01:41 2011 (r13461) @@ -55,7 +55,7 @@ public LispObject execute(LispObject args, Environment env) { if (args.length() != 2) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 2)); return eval(args.cadr(), env, LispThread.currentThread()); } } Modified: trunk/abcl/src/org/armedbear/lisp/JHandler.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/JHandler.java Thu Aug 11 08:44:29 2011 (r13460) +++ trunk/abcl/src/org/armedbear/lisp/JHandler.java Thu Aug 11 10:01:41 2011 (r13461) @@ -103,7 +103,7 @@ public LispObject execute(LispObject[] args) { if (args.length != 5) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 5)); Map entryTable = null; Object object = args[0].javaInstance(); String event = ((Symbol)args[1]).getName(); Modified: trunk/abcl/src/org/armedbear/lisp/JProxy.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/JProxy.java Thu Aug 11 08:44:29 2011 (r13460) +++ trunk/abcl/src/org/armedbear/lisp/JProxy.java Thu Aug 11 10:01:41 2011 (r13461) @@ -199,7 +199,7 @@ public LispObject execute(LispObject[] args) { int length = args.length; if (length != 1) { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1)); } if(!(args[0] instanceof Function)) { return error(new TypeError(args[0], Symbol.FUNCTION)); @@ -215,7 +215,7 @@ public LispObject execute(final LispObject[] args) { int length = args.length; if (length != 3) { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 3)); } if(!(args[0] instanceof Cons)) { return error(new TypeError(args[0], new SimpleString("CONS"))); Modified: trunk/abcl/src/org/armedbear/lisp/Java.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Java.java Thu Aug 11 08:44:29 2011 (r13460) +++ trunk/abcl/src/org/armedbear/lisp/Java.java Thu Aug 11 10:01:41 2011 (r13461) @@ -168,7 +168,7 @@ { if (args.length < 2 || args.length > 4) - error(new WrongNumberOfArgumentsException(fun)); + error(new WrongNumberOfArgumentsException(fun, 2, 4)); String fieldName = null; Class c; Field f; @@ -330,7 +330,7 @@ public LispObject execute(LispObject[] args) { if (args.length < 1) - error(new WrongNumberOfArgumentsException(this)); + error(new WrongNumberOfArgumentsException(this, 1, -1)); try { final Class c = javaClass(args[0]); int argCount = 0; @@ -382,7 +382,7 @@ public LispObject execute(LispObject[] args) { if (args.length < 2) - error(new WrongNumberOfArgumentsException(this)); + error(new WrongNumberOfArgumentsException(this, 2, -1)); final Class c = javaClass(args[0]); String methodName = args[1].getStringValue(); try { @@ -435,7 +435,7 @@ { if (args.length < 2) - error(new WrongNumberOfArgumentsException(fun)); + error(new WrongNumberOfArgumentsException(fun, 2, -1)); try { Method m = null; LispObject methodRef = args[0]; @@ -545,7 +545,7 @@ public LispObject execute(LispObject[] args) { if (args.length < 1) - error(new WrongNumberOfArgumentsException(this)); + error(new WrongNumberOfArgumentsException(this, 1, -1)); LispObject classRef = args[0]; try { Constructor constructor; @@ -610,7 +610,7 @@ public LispObject execute(LispObject[] args) { if (args.length < 2) - error(new WrongNumberOfArgumentsException(this)); + error(new WrongNumberOfArgumentsException(this, 2, -1)); try { Class c = javaClass(args[0]); int[] dimensions = new int[args.length - 1]; @@ -630,7 +630,7 @@ { if (args.length < 2) - error(new WrongNumberOfArgumentsException(fun)); + error(new WrongNumberOfArgumentsException(fun, 2, -1)); try { Object a = args[0].javaInstance(); for (int i = 1; i 1) { LispObject type = args[1]; Modified: trunk/abcl/src/org/armedbear/lisp/LispThread.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispThread.java Thu Aug 11 08:44:29 2011 (r13460) +++ trunk/abcl/src/org/armedbear/lisp/LispThread.java Thu Aug 11 10:01:41 2011 (r13461) @@ -604,6 +604,10 @@ stack = stack.getNext(); } + public final Environment setEnv(Environment env) { + return (stack != null) ? stack.setEnv(env) : null; + } + public void resetStack() { stack = null; @@ -928,22 +932,22 @@ return unreadableString(sb.toString()); } - @DocString(name="make-thread", args="function &optional &key name") + @DocString(name="make-thread", args="function &key name") private static final Primitive MAKE_THREAD = - new Primitive("make-thread", PACKAGE_THREADS, true, "function &optional &key name") + new Primitive("make-thread", PACKAGE_THREADS, true, "function &key name") { @Override public LispObject execute(LispObject[] args) { final int length = args.length; if (length == 0) - error(new WrongNumberOfArgumentsException(this)); + error(new WrongNumberOfArgumentsException(this, 1, -1)); LispObject name = NIL; if (length > 1) { if ((length - 1) % 2 != 0) error(new ProgramError("Odd number of keyword arguments.")); if (length > 3) - error(new WrongNumberOfArgumentsException(this)); + error(new WrongNumberOfArgumentsException(this, -1, 2)); // don't count the keyword itself as an argument if (args[1] == Keyword.NAME) name = args[2].STRING(); else @@ -1115,7 +1119,7 @@ public LispObject execute(LispObject[] args) { if (args.length < 2) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 2, -1)); final LispThread thread; if (args[0] instanceof LispThread) { thread = (LispThread) args[0]; @@ -1154,7 +1158,7 @@ { if (args.length > 1) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, -1, 1)); int limit = args.length > 0 ? Fixnum.getValue(args[0]) : 0; return currentThread().backtrace(limit); } @@ -1168,7 +1172,7 @@ { if (args.length != 1) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1)); return checkStackFrame(args[0]).toLispString(); } @@ -1183,7 +1187,7 @@ { if (args.length != 1) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1)); return checkStackFrame(args[0]).toLispList(); } @@ -1212,7 +1216,7 @@ { if (args == NIL) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1)); LispThread thread = LispThread.currentThread(); synchronized (eval(args.car(), env, thread).lockableInstance()) { Modified: trunk/abcl/src/org/armedbear/lisp/PackageFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/PackageFunctions.java Thu Aug 11 08:44:29 2011 (r13460) +++ trunk/abcl/src/org/armedbear/lisp/PackageFunctions.java Thu Aug 11 10:01:41 2011 (r13461) @@ -105,7 +105,7 @@ public LispObject execute(LispObject[] args) { if (args.length == 0 || args.length > 2) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, 2)); LispObject symbols = args[0]; Package pkg = args.length == 2 ? coerceToPackage(args[1]) : getCurrentPackage(); @@ -129,7 +129,7 @@ public LispObject execute(LispObject[] args) { if (args.length == 0 || args.length > 2) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, 2)); LispObject symbols = args[0]; Package pkg = args.length == 2 ? coerceToPackage(args[1]) : getCurrentPackage(); @@ -153,7 +153,7 @@ public LispObject execute(LispObject[] args) { if (args.length == 0 || args.length > 2) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, 2)); LispObject symbols = args[0]; Package pkg = args.length == 2 ? coerceToPackage(args[1]) : getCurrentPackage(); @@ -177,7 +177,7 @@ public LispObject execute(LispObject[] args) { if (args.length == 0 || args.length > 2) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, 2)); LispObject symbols = args[0]; Package pkg = args.length == 2 ? coerceToPackage(args[1]) : getCurrentPackage(); @@ -224,7 +224,7 @@ public LispObject execute(LispObject[] args) { if (args.length < 1 || args.length > 2) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, 2)); Package pkg; if (args.length == 2) pkg = coerceToPackage(args[1]); @@ -251,7 +251,7 @@ public LispObject execute(LispObject[] args) { if (args.length < 2 || args.length > 3) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 2, 3)); Package pkg = coerceToPackage(args[0]); String newName = javaString(args[1]); LispObject nicknames = args.length == 3 ? checkList(args[2]) : NIL; @@ -279,7 +279,7 @@ public LispObject execute(LispObject[] args) { if (args.length != 10) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 10)); final String packageName = args[0].getStringValue(); LispObject nicknames = checkList(args[1]); // FIXME size is ignored Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java Thu Aug 11 08:44:29 2011 (r13460) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Thu Aug 11 10:01:41 2011 (r13461) @@ -1538,7 +1538,7 @@ case 1: return NIL; default: - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 0, 1)); } } } Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java Thu Aug 11 08:44:29 2011 (r13460) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Thu Aug 11 10:01:41 2011 (r13461) @@ -82,7 +82,7 @@ @Override public LispObject execute() { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); } @Override public LispObject execute(LispObject arg) { @@ -112,7 +112,7 @@ @Override public LispObject execute() { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); } @Override public LispObject execute(LispObject arg) { @@ -148,7 +148,7 @@ @Override public LispObject execute() { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); } @Override public LispObject execute(LispObject arg) { @@ -793,7 +793,7 @@ @Override public LispObject execute() { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); } @Override public LispObject execute(LispObject arg) { @@ -839,7 +839,7 @@ { if (args == NIL) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); final LispThread thread = LispThread.currentThread(); if (eval(args.car(), env, thread) != NIL) { args = args.cdr(); @@ -862,7 +862,7 @@ { if (args == NIL) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); final LispThread thread = LispThread.currentThread(); if (eval(args.car(), env, thread) == NIL) { args = args.cdr(); @@ -1244,7 +1244,7 @@ @Override public LispObject execute() { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); } @Override public LispObject execute(LispObject arg) { @@ -1288,7 +1288,7 @@ @Override public LispObject execute() { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); } @Override public LispObject execute(LispObject arg) { @@ -1337,7 +1337,7 @@ @Override public LispObject execute() { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); } @Override public LispObject execute(LispObject arg) { @@ -1379,7 +1379,7 @@ @Override public LispObject execute() { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); } @Override public LispObject execute(LispObject arg) { @@ -1421,7 +1421,7 @@ @Override public LispObject execute() { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); } @Override public LispObject execute(LispObject arg) { @@ -1463,7 +1463,7 @@ @Override public LispObject execute() { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); } @Override public LispObject execute(LispObject arg) { @@ -1624,7 +1624,7 @@ @Override public LispObject execute(LispObject[] args) { if (args.length < 1) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); if (args[0] instanceof Condition) return error((Condition)args[0]); return error(new SimpleCondition()); @@ -1685,7 +1685,7 @@ @Override public LispObject execute(LispObject[] args) { if (args.length < 2) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 2, -1)); LispObject destination = args[0]; // Copy remaining arguments. LispObject[] _args = new LispObject[args.length - 1]; @@ -2299,7 +2299,7 @@ @Override public LispObject execute(LispObject[] args) { if (args.length < 1) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); final AbstractArray array; LispObject r = args[0]; array = checkArray(r); @@ -2355,7 +2355,7 @@ @Override public LispObject execute() { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); } @Override public LispObject execute(LispObject arg) { @@ -2679,7 +2679,7 @@ @Override public LispObject execute() { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); } @Override public LispObject execute(LispObject arg) { @@ -2772,11 +2772,11 @@ @Override public LispObject execute() { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 2, -1)); } @Override public LispObject execute(LispObject arg) { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 2, -1)); } @Override public LispObject execute(LispObject fun, LispObject args) @@ -2910,7 +2910,7 @@ { final int numArgs = args.length; if (numArgs < 2) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 2, -1)); int commonLength = -1; for (int i = 1; i < numArgs; i++) { if (!args[i].listp()) @@ -2986,7 +2986,7 @@ { final int numArgs = args.length; if (numArgs < 2) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 2, -1)); int commonLength = -1; for (int i = 1; i < numArgs; i++) { if (!args[i].listp()) @@ -3154,7 +3154,7 @@ @Override public LispObject execute(LispObject[] args) { if (args.length == 0 || args.length > 2) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, 2)); Symbol symbol = checkSymbol(args[0]); Package pkg; if (args.length == 2) @@ -3322,7 +3322,7 @@ @Override public LispObject execute(LispObject[] args) { if (args.length < 1 || args.length > 2) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, 2)); Package pkg; if (args.length == 2) pkg = coerceToPackage(args[1]); @@ -3697,7 +3697,7 @@ { if (args.length() != 1) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1)); Binding binding = env.getTagBinding(args.car()); if (binding == null) return error(new ControlError("No tag named " + @@ -3720,7 +3720,7 @@ { if (args == NIL) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); LispObject tag; tag = checkSymbol(args.car()); LispObject body = ((Cons)args).cdr(); @@ -3756,7 +3756,7 @@ { final int length = args.length(); if (length < 1 || length > 2) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, 2)); Symbol symbol; symbol = checkSymbol(args.car()); @@ -3779,7 +3779,7 @@ { if (args.length() < 1) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); final LispThread thread = LispThread.currentThread(); LispObject tag = eval(args.car(), env, thread); thread.pushCatchTag(tag); @@ -3813,7 +3813,7 @@ { if (args.length() != 2) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 2)); final LispThread thread = LispThread.currentThread(); thread.throwToTag(eval(args.car(), env, thread), eval(args.cadr(), env, thread)); @@ -3964,7 +3964,7 @@ { if (args.length() == 0) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); final LispThread thread = LispThread.currentThread(); LispObject result = eval(args.car(), env, thread); LispObject[] values = thread._values; @@ -3990,7 +3990,7 @@ { if (args.length() == 0) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); final LispThread thread = LispThread.currentThread(); LispObject function; LispObject obj = eval(args.car(), env, thread); @@ -4096,7 +4096,7 @@ { if (args.length() != 1) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1)); final LispThread thread = LispThread.currentThread(); LispObject result = eval(((Cons)args).car, env, thread); LispObject[] values = thread._values; @@ -4125,7 +4125,7 @@ { if (args.length() != 2) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 2)); final LispThread thread = LispThread.currentThread(); int n = Fixnum.getValue(eval(args.car(), env, thread)); if (n < 0) @@ -4391,7 +4391,7 @@ @Override public LispObject execute() { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); } @Override public LispObject execute(LispObject arg) { Modified: trunk/abcl/src/org/armedbear/lisp/Readtable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Readtable.java Thu Aug 11 08:44:29 2011 (r13460) +++ trunk/abcl/src/org/armedbear/lisp/Readtable.java Thu Aug 11 10:01:41 2011 (r13461) @@ -445,7 +445,7 @@ public LispObject execute(LispObject[] args) { if (args.length < 1 || args.length > 3) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, 3)); char dispChar = LispCharacter.getValue(args[0]); LispObject non_terminating_p; if (args.length > 1) @@ -472,7 +472,7 @@ public LispObject execute(LispObject[] args) { if (args.length < 2 || args.length > 3) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, 3)); char dispChar = LispCharacter.getValue(args[0]); char subChar = LispCharacter.getValue(args[1]); Readtable readtable; @@ -494,7 +494,7 @@ public LispObject execute(LispObject[] args) { if (args.length < 3 || args.length > 4) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 3, 4)); char dispChar = LispCharacter.getValue(args[0]); char subChar = LispCharacter.getValue(args[1]); LispObject function = coerceToFunction(args[2]); @@ -518,7 +518,7 @@ public LispObject execute(LispObject[] args) { if (args.length < 2 || args.length > 4) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 2, 4)); char toChar = LispCharacter.getValue(args[0]); char fromChar = LispCharacter.getValue(args[1]); Readtable toReadtable; Modified: trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java Thu Aug 11 08:44:29 2011 (r13460) +++ trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java Thu Aug 11 10:01:41 2011 (r13461) @@ -50,7 +50,7 @@ { if (args.cdr() != NIL) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1)); return args.car(); } }; @@ -80,7 +80,7 @@ return eval((((Cons)args).cdr).cadr(), env, thread); } default: - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 2, 3)); } } }; @@ -97,7 +97,7 @@ { if (args == NIL) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); return _let(args, env, false); } }; @@ -114,7 +114,7 @@ { if (args == NIL) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, -1)); return _let(args, env, true); } }; @@ -237,7 +237,7 @@ return eval(args.car(), new Environment(), LispThread.currentThread()); default: - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, 2)); } } }; @@ -378,7 +378,7 @@ { if (args.length() != 2) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 2)); LispObject rv = eval(args.cadr(), env, LispThread.currentThread()); // check only the most simple types: single symbols @@ -416,7 +416,7 @@ { if (args.length() < 2) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 2, -1)); final LispThread thread = LispThread.currentThread(); final LispObject symbols = checkList(eval(args.car(), env, thread)); LispObject values = checkList(eval(args.cadr(), env, thread)); Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Stream.java Thu Aug 11 08:44:29 2011 (r13460) +++ trunk/abcl/src/org/armedbear/lisp/Stream.java Thu Aug 11 10:01:41 2011 (r13461) @@ -2080,7 +2080,7 @@ @Override public LispObject execute(LispObject[] args) { if (args.length > 1) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, -1, 1)); final Stream in; if (args.length == 0) in = checkCharacterInputStream(Symbol.STANDARD_INPUT.symbolValue()); @@ -2178,7 +2178,7 @@ public LispObject execute (LispObject[] args) { int length = args.length; if (length < 1 || length > 3) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1, 3)); final Stream in = checkBinaryInputStream(args[0]); boolean eofError = length > 1 ? (args[1] != NIL) : true; LispObject eofValue = length > 2 ? args[2] : NIL; @@ -2351,7 +2351,7 @@ public LispObject execute(LispObject[] args) { int length = args.length; if (length > 4) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, -1, 4)); Stream stream = length > 0 ? inSynonymOf(args[0]) : getStandardInput(); boolean eofError = length > 1 ? (args[1] != NIL) : true; @@ -2408,7 +2408,7 @@ public LispObject execute(LispObject[] args) { int length = args.length; if (length > 4) - error(new WrongNumberOfArgumentsException(this)); + error(new WrongNumberOfArgumentsException(this, -1, 4)); Stream stream = length > 0 ? inSynonymOf(args[0]) : getStandardInput(); boolean eofError = length > 1 ? (args[1] != NIL) : true; @@ -2427,7 +2427,7 @@ public LispObject execute(LispObject[] args) { int length = args.length; if (length < 1 || length > 3) - error(new WrongNumberOfArgumentsException(this)); + error(new WrongNumberOfArgumentsException(this, 1, 3)); char c = LispCharacter.getValue(args[0]); Stream stream = length > 1 ? inSynonymOf(args[1]) : getStandardInput(); Modified: trunk/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java Thu Aug 11 08:44:29 2011 (r13460) +++ trunk/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java Thu Aug 11 10:01:41 2011 (r13461) @@ -38,22 +38,29 @@ public final class WrongNumberOfArgumentsException extends ProgramError { private Operator operator; - private int expectedArgs; + private int expectedMinArgs; + private int expectedMaxArgs; private String message; public WrongNumberOfArgumentsException(Operator operator) { this(operator, -1); } - public WrongNumberOfArgumentsException(Operator operator, int expectedArgs) { + public WrongNumberOfArgumentsException(Operator operator, int expectedMin, + int expectedMax) { // This is really just an ordinary PROGRAM-ERROR, broken out into its // own Java class as a convenience for the implementation. super(StandardClass.PROGRAM_ERROR); this.operator = operator; - this.expectedArgs = expectedArgs; + this.expectedMinArgs = expectedMinArgs; + this.expectedMaxArgs = expectedMaxArgs; setFormatControl(getMessage()); setFormatArguments(NIL); } + + public WrongNumberOfArgumentsException(Operator operator, int expectedArgs) { + this(operator, expectedArgs, expectedArgs); + } public WrongNumberOfArgumentsException(String message) { super(StandardClass.PROGRAM_ERROR); @@ -74,9 +81,22 @@ StringBuilder sb = new StringBuilder("Wrong number of arguments for " + operator.princToString()); - if(expectedArgs >= 0) { + if(expectedMinArgs >= 0 || expectedMaxArgs >= 0) { sb.append("; "); - sb.append(expectedArgs); + + if (expectedMinArgs == expectedMaxArgs) { + sb.append(expectedMinArgs); + } else if (expectedMaxArgs < 0) { + sb.append("at least "); + sb.append(expectedMinArgs); + } else if (expectedMinArgs < 0) { + sb.append("at most "); + sb.append(expectedMaxArgs); + } else { + sb.append("between ").append(expectedMinArgs); + sb.append(" and ").append(expectedMaxArgs); + } + sb.append(" expected"); } sb.append('.'); Modified: trunk/abcl/src/org/armedbear/lisp/adjust_array.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/adjust_array.java Thu Aug 11 08:44:29 2011 (r13460) +++ trunk/abcl/src/org/armedbear/lisp/adjust_array.java Thu Aug 11 10:01:41 2011 (r13461) @@ -49,7 +49,7 @@ public LispObject execute(LispObject[] args) { if (args.length != 10) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 10)); AbstractArray array = checkArray(args[0]); LispObject dimensions = args[1]; LispObject elementType = args[2]; Modified: trunk/abcl/src/org/armedbear/lisp/make_array.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/make_array.java Thu Aug 11 08:44:29 2011 (r13460) +++ trunk/abcl/src/org/armedbear/lisp/make_array.java Thu Aug 11 10:01:41 2011 (r13461) @@ -49,7 +49,7 @@ public LispObject execute(LispObject[] args) { if (args.length != 9) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 9)); LispObject dimensions = args[0]; LispObject elementType = args[1]; LispObject initialElement = args[2]; Modified: trunk/abcl/src/org/armedbear/lisp/peek_char.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/peek_char.java Thu Aug 11 08:44:29 2011 (r13460) +++ trunk/abcl/src/org/armedbear/lisp/peek_char.java Thu Aug 11 10:01:41 2011 (r13461) @@ -49,7 +49,7 @@ { int length = args.length; if (length > 5) - error(new WrongNumberOfArgumentsException(this)); + error(new WrongNumberOfArgumentsException(this, -1, 5)); LispObject peekType = length > 0 ? args[0] : NIL; Stream stream = length > 1 ? inSynonymOf(args[1]) : getStandardInput(); boolean eofError = length > 2 ? (args[2] != NIL) : true; Modified: trunk/abcl/src/org/armedbear/lisp/room.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/room.java Thu Aug 11 08:44:29 2011 (r13460) +++ trunk/abcl/src/org/armedbear/lisp/room.java Thu Aug 11 10:01:41 2011 (r13461) @@ -47,7 +47,7 @@ public LispObject execute(LispObject[] args) { if (args.length > 1) - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, -1, 1)); Runtime runtime = Runtime.getRuntime(); long total = runtime.totalMemory(); long free = runtime.freeMemory(); From ehuelsmann at common-lisp.net Thu Aug 11 17:04:30 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Thu, 11 Aug 2011 10:04:30 -0700 Subject: [armedbear-cvs] r13462 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Aug 11 10:04:30 2011 New Revision: 13462 Log: Prepare for more debugging support. (Unbreaks last commit.) Modified: trunk/abcl/src/org/armedbear/lisp/StackFrame.java Modified: trunk/abcl/src/org/armedbear/lisp/StackFrame.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StackFrame.java Thu Aug 11 10:01:41 2011 (r13461) +++ trunk/abcl/src/org/armedbear/lisp/StackFrame.java Thu Aug 11 10:04:30 2011 (r13462) @@ -50,14 +50,27 @@ } StackFrame next; - + Environment env = null; + void setNext(StackFrame nextFrame) { this.next = nextFrame; } StackFrame getNext() { return this.next; } - + + /** Sets the applicable environment for this stack frame to 'env', + * returning the last value. + */ + public Environment setEnv(Environment env) { + Environment e = this.env; + this.env = env; + return e; + } + /** Gets the current lexical environment of this stack frame. */ + public Environment getEnv() { + return env; + } public abstract LispObject toLispList(); public abstract SimpleString toLispString(); } From ehuelsmann at common-lisp.net Thu Aug 11 17:05:46 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Thu, 11 Aug 2011 10:05:46 -0700 Subject: [armedbear-cvs] r13463 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Aug 11 10:05:46 2011 New Revision: 13463 Log: Code generation efficiency: when the closure array is only read from: don't copy it - ever. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu Aug 11 10:04:30 2011 (r13462) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu Aug 11 10:05:46 2011 (r13463) @@ -2162,17 +2162,20 @@ (let* ((*register* *register*) (register (allocate-register nil))) (aload (compiland-closure-register compiland)) ;; src - (emit-push-constant-int 0) ;; srcPos - (emit-push-constant-int (length *closure-variables*)) - (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-system+ "arraycopy" - (list +java-object+ :int - +java-object+ :int :int) nil) - (aload register))) ;; reload dest value + (when (some #'(lambda (var) + (< 1 (variable-writes var))) + *closure-variables*) + (emit-push-constant-int 0) ;; srcPos + (emit-push-constant-int (length *closure-variables*)) + (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-system+ "arraycopy" + (list +java-object+ :int + +java-object+ :int :int) nil) + (aload register)))) ;; reload dest value From ehuelsmann at common-lisp.net Thu Aug 11 19:44:31 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Thu, 11 Aug 2011 12:44:31 -0700 Subject: [armedbear-cvs] r13464 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Aug 11 12:44:30 2011 New Revision: 13464 Log: On second thought: revert r13463, it's not about value assignment, but about binding establishment (ie assigning a new value to the closure array's slots). Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu Aug 11 10:05:46 2011 (r13463) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu Aug 11 12:44:30 2011 (r13464) @@ -2162,20 +2162,17 @@ (let* ((*register* *register*) (register (allocate-register nil))) (aload (compiland-closure-register compiland)) ;; src - (when (some #'(lambda (var) - (< 1 (variable-writes var))) - *closure-variables*) - (emit-push-constant-int 0) ;; srcPos - (emit-push-constant-int (length *closure-variables*)) - (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-system+ "arraycopy" - (list +java-object+ :int - +java-object+ :int :int) nil) - (aload register)))) ;; reload dest value + (emit-push-constant-int 0) ;; srcPos + (emit-push-constant-int (length *closure-variables*)) + (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-system+ "arraycopy" + (list +java-object+ :int + +java-object+ :int :int) nil) + (aload register))) ;; reload dest value From ehuelsmann at common-lisp.net Fri Aug 12 12:00:40 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 12 Aug 2011 05:00:40 -0700 Subject: [armedbear-cvs] r13465 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 12 05:00:39 2011 New Revision: 13465 Log: Delete commented out code which isn't returning any time soon. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Thu Aug 11 12:44:30 2011 (r13464) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Fri Aug 12 05:00:39 2011 (r13465) @@ -405,7 +405,6 @@ (cond (compiled-function (setf (getf tail key) `(sys::get-fasl-function *fasl-loader* ,saved-class-number))) -;; `(load-compiled-function ,(file-namestring classfile)))) (t ;; FIXME This should be a warning or error of some sort... (format *error-output* "; Unable to compile method~%"))))))))) From ehuelsmann at common-lisp.net Fri Aug 12 12:08:26 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 12 Aug 2011 05:08:26 -0700 Subject: [armedbear-cvs] r13466 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 12 05:08:25 2011 New Revision: 13466 Log: Reduce load time of nested functions and the number of class loader objects. This commit groups all nested function objects resulting from a COMPILE call into one class loader (instead of a class loader each). Additionally, nested function objects aren't instantiated using reflection anymore, instead, the 'new' instruction is used, winning a factor 100 per local function. Added: trunk/abcl/src/org/armedbear/lisp/MemoryClassLoader.java (contents, props changed) Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Autoload.java Fri Aug 12 05:00:39 2011 (r13465) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Fri Aug 12 05:08:25 2011 (r13466) @@ -706,6 +706,10 @@ autoload(PACKAGE_SYS, "make-fasl-class-loader", "FaslClassLoader", false); autoload(PACKAGE_SYS, "get-fasl-function", "FaslClassLoader", false); + autoload(PACKAGE_SYS, "make-memory-class-loader", "MemoryClassLoader", false); + autoload(PACKAGE_SYS, "put-memory-function", "MemoryClassLoader", false); + autoload(PACKAGE_SYS, "get-memory-function", "MemoryClassLoader", false); + autoload(Symbol.SET_CHAR, "StringFunctions"); autoload(Symbol.SET_SCHAR, "StringFunctions"); Added: trunk/abcl/src/org/armedbear/lisp/MemoryClassLoader.java ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/src/org/armedbear/lisp/MemoryClassLoader.java Fri Aug 12 05:08:25 2011 (r13466) @@ -0,0 +1,157 @@ +/* + * MemoryClassLoader.java + * + * Copyright (C) 2011 Erik Huelsmann + * Copyright (C) 2010 Alessio Stalla + * $Id$ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import static org.armedbear.lisp.Lisp.*; + +import java.util.*; + +public class MemoryClassLoader extends JavaClassLoader { + + private final HashMap hashtable = new HashMap(5, 0.81); + private final JavaObject boxedThis = new JavaObject(this); + + public MemoryClassLoader() { + } + + @Override + protected Class loadClass(String name, boolean resolve) + throws ClassNotFoundException { + /* First we check if we should load the class ourselves, + * allowing the default handlers to kick in if we don't... + * + * This strategy eliminates ClassNotFound exceptions inside + * the inherited loadClass() eliminated ~80k exceptions during + * Maxima compilation. Generally, creation of an exception object + * is a pretty heavy operation, because it processes the call stack, + * which - in ABCL - is pretty deep, most of the time. + */ + if (hashtable.containsKey(name)) { + String internalName = "org/armedbear/lisp/" + name; + Class c = this.findLoadedClass(internalName); + + if (c == null) { + c = findClass(name); + } + if (c != null) { + if (resolve) { + resolveClass(c); + } + return c; + } + } + + // Fall through to our super's default handling + return super.loadClass(name, resolve); + } + + @Override + protected Class findClass(String name) throws ClassNotFoundException { + try { + byte[] b = getFunctionClassBytes(name); + return defineClass(name, b, 0, b.length); + } catch(Throwable e) { //TODO handle this better, readFunctionBytes uses Debug.assert() but should return null + e.printStackTrace(); + if(e instanceof ControlTransfer) { throw (ControlTransfer) e; } + throw new ClassNotFoundException("Function class not found: " + name, e); + } + } + + public byte[] getFunctionClassBytes(String name) { + return (byte[])hashtable.get(name).javaInstance(); + } + + public byte[] getFunctionClassBytes(Class functionClass) { + return getFunctionClassBytes(functionClass.getName()); + } + + public byte[] getFunctionClassBytes(Function f) { + byte[] b = getFunctionClassBytes(f.getClass()); + f.setClassBytes(b); + return b; + } + + public LispObject loadFunction(String name) { + try { + Function f = (Function) loadClass(name).newInstance(); + f.setClassBytes(getFunctionClassBytes(name)); + return f; + } catch(Throwable e) { + if(e instanceof ControlTransfer) { throw (ControlTransfer) e; } + Debug.trace(e); + return error(new LispError("Compiled function can't be loaded: " + name + " from memory")); + } + } + + private static final Primitive MAKE_MEMORY_CLASS_LOADER = new pf_make_memory_class_loader(); + private static final class pf_make_memory_class_loader extends Primitive { + pf_make_memory_class_loader() { + super("make-memory-class-loader", PACKAGE_SYS, false); + } + + @Override + public LispObject execute() { + return new MemoryClassLoader().boxedThis; + } + }; + + private static final Primitive PUT_MEMORY_FUNCTION = new pf_put_memory_function(); + private static final class pf_put_memory_function extends Primitive { + pf_put_memory_function() { + super("put-memory-function", PACKAGE_SYS, false, "loader class-name class-bytes"); + } + + @Override + public LispObject execute(LispObject loader, LispObject className, LispObject classBytes) { + MemoryClassLoader l = (MemoryClassLoader) loader.javaInstance(MemoryClassLoader.class); + return (LispObject)l.hashtable.put(className.getStringValue(), (JavaObject)classBytes); + } + }; + + private static final Primitive GET_MEMORY_FUNCTION = new pf_get_memory_function(); + private static final class pf_get_memory_function extends Primitive { + pf_get_memory_function() { + super("get-memory-function", PACKAGE_SYS, false, "loader class-name"); + } + + @Override + public LispObject execute(LispObject loader, LispObject name) { + MemoryClassLoader l = (MemoryClassLoader) loader.javaInstance(MemoryClassLoader.class); + return l.loadFunction(name.getStringValue()); + } + }; + + +} \ No newline at end of file Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri Aug 12 05:00:39 2011 (r13465) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri Aug 12 05:08:25 2011 (r13466) @@ -49,6 +49,8 @@ pool-class pool-field pool-method pool-int pool-float pool-long pool-double)) +(declaim (special *memory-class-loader*)) + (defun pool-name (name) (pool-add-utf8 *pool* name)) @@ -2206,10 +2208,7 @@ +lisp-object+)) (t (dformat t "compile-local-function-call default case~%") - (let* ((g (if *file-compilation* - (declare-local-function local-function) - (declare-object - (local-function-function local-function))))) + (let* ((g (declare-local-function local-function))) (emit-getstatic *this-class* g +lisp-object+) ; Stack: template-function (when *closure-variables* @@ -4063,9 +4062,12 @@ (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)))))))) + (let ((bytes (sys::%get-output-stream-bytes stream))) + (sys::put-memory-function *memory-class-loader* + (class-name-internal + (abcl-class-file-class-name + (compiland-class-file compiland))) + bytes))))))) (defun emit-make-compiled-closure-for-labels (local-function compiland declaration) @@ -4096,11 +4098,16 @@ (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))))) + (let* ((bytes (sys::%get-output-stream-bytes stream)) + (g (declare-local-function local-function))) + (sys::put-memory-function *memory-class-loader* + (class-name-internal + (abcl-class-file-class-name + (compiland-class-file compiland))) + bytes) (emit-make-compiled-closure-for-labels - local-function compiland g))))))) + local-function compiland g) + )))))) (defknown p2-flet-node (t t t) t) (defun p2-flet-node (block target representation) @@ -4152,8 +4159,17 @@ (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)))))) + (let ((bytes (sys::%get-output-stream-bytes stream))) + (sys::put-memory-function *memory-class-loader* + (class-name-internal + (abcl-class-file-class-name + (compiland-class-file compiland))) + bytes) + (emit-getstatic *this-class* + (declare-local-function + (make-local-function + :class-file (compiland-class-file compiland))) + +lisp-object+))))) (cond ((null *closure-variables*)) ; Nothing to do. ((compiland-closure-register *current-compiland*) (duplicate-closure-array *current-compiland*) @@ -4185,10 +4201,7 @@ (local-function-variable local-function)) 'stack nil)) (t - (let ((g (if *file-compilation* - (declare-local-function local-function) - (declare-object - (local-function-function local-function))))) + (let ((g (declare-local-function local-function))) (emit-getstatic *this-class* g +lisp-object+) ; Stack: template-function @@ -4226,10 +4239,7 @@ (local-function-variable local-function)) 'stack nil)) (t - (let ((g (if *file-compilation* - (declare-local-function local-function) - (declare-object - (local-function-function local-function))))) + (let ((g (declare-local-function local-function))) (emit-getstatic *this-class* g +lisp-object+))))) ; Stack: template-function ((and (member name *functions-defined-in-current-file* :test #'equal) @@ -7380,7 +7390,10 @@ (defun compile-defun (name form environment filespec stream *declare-inline*) "Compiles a lambda expression `form'. If `filespec' is NIL, a random Java class name is generated, if it is non-NIL, it's used -to derive a Java class name from." +to derive a Java class name from. + +Returns the a abcl-class-file structure containing the description of the +generated class." (aver (eq (car form) 'LAMBDA)) (catch 'compile-defun-abort (let* ((class-file (make-abcl-class-file :pathname filespec @@ -7402,7 +7415,8 @@ (precompiler:precompile-form form t environment) :class-file class-file) - stream)))) + stream) + class-file))) (defvar *catch-errors* t) @@ -7496,15 +7510,22 @@ (defun %jvm-compile (name definition expr env) ;; This function is part of the call chain from COMPILE, but ;; not COMPILE-FILE - (let* (compiled-function) + (let* (compiled-function + (*memory-class-loader* (sys::make-memory-class-loader))) (with-compilation-unit () (with-saved-compiler-policy (setf compiled-function - (load-compiled-function - (with-open-stream (s (sys::%make-byte-array-output-stream)) - (compile-defun name expr env nil s nil) - (finish-output s) - (sys::%get-output-stream-bytes s)))))) + (with-open-stream (s (sys::%make-byte-array-output-stream)) + (let* ((class-file (compile-defun name expr env nil s nil)) + (bytes (progn + (finish-output s) + (sys::%get-output-stream-bytes s))) + (class-name (class-name-internal + (abcl-class-file-class-name class-file)))) + (sys::put-memory-function *memory-class-loader* + class-name bytes) + (sys::get-memory-function *memory-class-loader* + class-name)))))) (when (and name (functionp compiled-function)) (sys::set-function-definition name compiled-function definition)) (or name compiled-function))) Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp Fri Aug 12 05:00:39 2011 (r13465) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Fri Aug 12 05:08:25 2011 (r13466) @@ -380,7 +380,6 @@ definition compiland inline-expansion - function ;; the function loaded through load-compiled-function class-file ;; the class file structure for this function variable ;; the variable which contains the loaded compiled function ;; or compiled closure From ehuelsmann at common-lisp.net Fri Aug 12 12:27:14 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 12 Aug 2011 05:27:14 -0700 Subject: [armedbear-cvs] r13467 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 12 05:27:14 2011 New Revision: 13467 Log: Repair incorrect last minute (uncompiled) change. Modified: trunk/abcl/src/org/armedbear/lisp/MemoryClassLoader.java Modified: trunk/abcl/src/org/armedbear/lisp/MemoryClassLoader.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/MemoryClassLoader.java Fri Aug 12 05:08:25 2011 (r13466) +++ trunk/abcl/src/org/armedbear/lisp/MemoryClassLoader.java Fri Aug 12 05:27:14 2011 (r13467) @@ -40,7 +40,7 @@ public class MemoryClassLoader extends JavaClassLoader { - private final HashMap hashtable = new HashMap(5, 0.81); + private final HashMap hashtable = new HashMap(); private final JavaObject boxedThis = new JavaObject(this); public MemoryClassLoader() { From ehuelsmann at common-lisp.net Fri Aug 12 18:53:47 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 12 Aug 2011 11:53:47 -0700 Subject: [armedbear-cvs] r13468 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 12 11:53:46 2011 New Revision: 13468 Log: Move variable-updating form to ditch PROGN form (and locally untabify). Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Fri Aug 12 05:27:14 2011 (r13467) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Fri Aug 12 11:53:46 2011 (r13468) @@ -724,27 +724,27 @@ (defmacro with-local-functions-for-flet/labels (form local-functions-var lambda-list-var name-var body-var body1 body2) - `(progn (incf (compiland-children *current-compiland*) (length (cadr ,form))) - (let ((*visible-variables* *visible-variables*) - (*local-functions* *local-functions*) - (*current-compiland* *current-compiland*) - (,local-functions-var '())) - (dolist (definition (cadr ,form)) - (let ((,name-var (car definition)) - (,lambda-list-var (cadr definition))) - (validate-function-name ,name-var) - (let* ((,body-var (cddr definition)) - (compiland (make-compiland :name ,name-var - :parent *current-compiland*))) - , at body1))) - (setf ,local-functions-var (nreverse ,local-functions-var)) - ;; Make the local functions visible. - (dolist (local-function ,local-functions-var) - (push local-function *local-functions*) - (let ((variable (local-function-variable local-function))) - (when variable - (push variable *visible-variables*)))) - , at body2))) + `(let ((*visible-variables* *visible-variables*) + (*local-functions* *local-functions*) + (*current-compiland* *current-compiland*) + (,local-functions-var '())) + (incf (compiland-children *current-compiland*) (length (cadr ,form))) + (dolist (definition (cadr ,form)) + (let ((,name-var (car definition)) + (,lambda-list-var (cadr definition))) + (validate-function-name ,name-var) + (let* ((,body-var (cddr definition)) + (compiland (make-compiland :name ,name-var + :parent *current-compiland*))) + , at body1))) + (setf ,local-functions-var (nreverse ,local-functions-var)) + ;; Make the local functions visible. + (dolist (local-function ,local-functions-var) + (push local-function *local-functions*) + (let ((variable (local-function-variable local-function))) + (when variable + (push variable *visible-variables*)))) + , at body2)) (defun split-decls (forms specific-vars) (let ((other-decls nil) From ehuelsmann at common-lisp.net Fri Aug 12 19:12:25 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 12 Aug 2011 12:12:25 -0700 Subject: [armedbear-cvs] r13469 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 12 12:12:24 2011 New Revision: 13469 Log: Remove duplicate information and the need to keep it up to date. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri Aug 12 11:53:46 2011 (r13468) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri Aug 12 12:12:24 2011 (r13469) @@ -1347,7 +1347,8 @@ local-function *declared-functions* ht g (setf g (symbol-name (gensym "LFUN"))) (let ((class-name (abcl-class-file-class-name - (local-function-class-file local-function)))) + (compiland-class-file + (local-function-compiland local-function))))) (with-code-to-method (*class-file* (abcl-class-file-constructor *class-file*)) ;; fixme *declare-inline* @@ -4054,14 +4055,10 @@ (defun p2-flet-process-compiland (local-function) (let* ((compiland (local-function-compiland local-function))) (cond (*file-compilation* - (compile-and-write-to-stream compiland) - (setf (local-function-class-file local-function) - (compiland-class-file compiland))) + (compile-and-write-to-stream compiland)) (t (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 ((bytes (sys::%get-output-stream-bytes stream))) (sys::put-memory-function *memory-class-loader* (class-name-internal @@ -4088,16 +4085,12 @@ (let* ((compiland (local-function-compiland local-function))) (cond (*file-compilation* (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 (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* ((bytes (sys::%get-output-stream-bytes stream)) (g (declare-local-function local-function))) (sys::put-memory-function *memory-class-loader* @@ -4153,8 +4146,7 @@ (compile-and-write-to-stream compiland) (emit-getstatic *this-class* (declare-local-function - (make-local-function - :class-file (compiland-class-file compiland))) + (make-local-function :compiland compiland)) +lisp-object+)) (t (with-open-stream (stream (sys::%make-byte-array-output-stream)) Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp Fri Aug 12 11:53:46 2011 (r13468) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Fri Aug 12 12:12:24 2011 (r13469) @@ -380,7 +380,6 @@ definition compiland inline-expansion - class-file ;; the class file structure for this function variable ;; the variable which contains the loaded compiled function ;; or compiled closure environment ;; the environment in which the function is stored in From ehuelsmann at common-lisp.net Fri Aug 12 19:43:38 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 12 Aug 2011 12:43:38 -0700 Subject: [armedbear-cvs] r13470 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 12 12:43:37 2011 New Revision: 13470 Log: Explicitly record the children of a compiland for later use, instead of counting them, even though we only needed a HAS-CHILDREN boolean. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Fri Aug 12 12:12:24 2011 (r13469) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Fri Aug 12 12:43:37 2011 (r13470) @@ -726,16 +726,16 @@ (form local-functions-var lambda-list-var name-var body-var body1 body2) `(let ((*visible-variables* *visible-variables*) (*local-functions* *local-functions*) - (*current-compiland* *current-compiland*) + (parent-compiland *current-compiland*) (,local-functions-var '())) - (incf (compiland-children *current-compiland*) (length (cadr ,form))) (dolist (definition (cadr ,form)) (let ((,name-var (car definition)) (,lambda-list-var (cadr definition))) (validate-function-name ,name-var) (let* ((,body-var (cddr definition)) (compiland (make-compiland :name ,name-var - :parent *current-compiland*))) + :parent parent-compiland))) + (push compiland (compiland-children parent-compiland)) , at body1))) (setf ,local-functions-var (nreverse ,local-functions-var)) ;; Make the local functions visible. @@ -1021,8 +1021,7 @@ name (gensym "ANONYMOUS-LAMBDA-")) :lambda-expression lambda-form :parent *current-compiland*))) - (when *current-compiland* - (incf (compiland-children *current-compiland*))) + (push compiland (compiland-children *current-compiland*)) (multiple-value-bind (body decls) (parse-body body) (setf (compiland-lambda-expression compiland) Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri Aug 12 12:12:24 2011 (r13469) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri Aug 12 12:43:37 2011 (r13470) @@ -7088,7 +7088,7 @@ (when (and register (not (variable-special-p variable)) (not (variable-used-non-locally-p variable)) - (zerop (compiland-children *current-compiland*))) + (null (compiland-children *current-compiland*))) (when (memq (type-representation (variable-declared-type variable)) '(:int :long)) (emit-push-variable variable) Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp Fri Aug 12 12:12:24 2011 (r13469) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Fri Aug 12 12:43:37 2011 (r13470) @@ -199,8 +199,8 @@ arity ; number of args, or NIL if the number of args can vary. p1-result ; the parse tree as created in pass 1 parent ; the parent for compilands which defined within another - (children 0 ; Number of local functions - :type fixnum) ; defined with FLET, LABELS or LAMBDA + children ; List of local compilands + ; defined with FLET, LABELS or LAMBDA blocks ; TAGBODY, PROGV, BLOCK, etc. blocks argument-register closure-register From ehuelsmann at common-lisp.net Fri Aug 12 20:07:02 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 12 Aug 2011 13:07:02 -0700 Subject: [armedbear-cvs] r13471 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 12 13:07:01 2011 New Revision: 13471 Log: LOCAL-FUNCTION has a 'compiland' field now, no CLASS-FILE anymore. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri Aug 12 12:43:37 2011 (r13470) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri Aug 12 13:07:01 2011 (r13471) @@ -4160,7 +4160,7 @@ (emit-getstatic *this-class* (declare-local-function (make-local-function - :class-file (compiland-class-file compiland))) + :compiland compiland)) +lisp-object+))))) (cond ((null *closure-variables*)) ; Nothing to do. ((compiland-closure-register *current-compiland*) From ehuelsmann at common-lisp.net Fri Aug 12 20:39:58 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 12 Aug 2011 13:39:58 -0700 Subject: [armedbear-cvs] r13472 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 12 13:39:58 2011 New Revision: 13472 Log: Miscelaneous improvements, mostly by moving code around. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Fri Aug 12 13:07:01 2011 (r13471) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Fri Aug 12 13:39:58 2011 (r13472) @@ -718,34 +718,6 @@ non-local-p t))) (make-jump-node form non-local-p tag-block tag)))) -(defun validate-function-name (name) - (unless (or (symbolp name) (setf-function-name-p name)) - (compiler-error "~S is not a valid function name." name))) - -(defmacro with-local-functions-for-flet/labels - (form local-functions-var lambda-list-var name-var body-var body1 body2) - `(let ((*visible-variables* *visible-variables*) - (*local-functions* *local-functions*) - (parent-compiland *current-compiland*) - (,local-functions-var '())) - (dolist (definition (cadr ,form)) - (let ((,name-var (car definition)) - (,lambda-list-var (cadr definition))) - (validate-function-name ,name-var) - (let* ((,body-var (cddr definition)) - (compiland (make-compiland :name ,name-var - :parent parent-compiland))) - (push compiland (compiland-children parent-compiland)) - , at body1))) - (setf ,local-functions-var (nreverse ,local-functions-var)) - ;; Make the local functions visible. - (dolist (local-function ,local-functions-var) - (push local-function *local-functions*) - (let ((variable (local-function-variable local-function))) - (when variable - (push variable *visible-variables*)))) - , at body2)) - (defun split-decls (forms specific-vars) (let ((other-decls nil) (specific-decls nil)) @@ -901,6 +873,34 @@ , at decls , at body)))) rv))))))) +(defun validate-function-name (name) + (unless (or (symbolp name) (setf-function-name-p name)) + (compiler-error "~S is not a valid function name." name))) + +(defmacro with-local-functions-for-flet/labels + (form local-functions-var lambda-list-var name-var body-var body1 body2) + `(let ((*visible-variables* *visible-variables*) + (*local-functions* *local-functions*) + (parent-compiland *current-compiland*) + (,local-functions-var '())) + (dolist (definition (cadr ,form)) + (let ((,name-var (car definition)) + (,lambda-list-var (cadr definition))) + (validate-function-name ,name-var) + (let* ((,body-var (cddr definition)) + (compiland (make-compiland :name ,name-var + :parent parent-compiland))) + (push compiland (compiland-children parent-compiland)) + , at body1))) + (setf ,local-functions-var (nreverse ,local-functions-var)) + ;; Make the local functions visible. + (dolist (local-function ,local-functions-var) + (push local-function *local-functions*) + (let ((variable (local-function-variable local-function))) + (when variable + (push variable *visible-variables*)))) + , at body2)) + (defun p1-flet (form) (with-local-functions-for-flet/labels form local-functions lambda-list name body @@ -910,15 +910,12 @@ (multiple-value-bind (body decls) (parse-body body) (let* ((block-name (fdefinition-block-name name)) (lambda-expression - (rewrite-lambda `(lambda ,lambda-list , at decls (block ,block-name , at body)))) - (*visible-variables* *visible-variables*) - (*local-functions* *local-functions*) - (*current-compiland* compiland)) + (rewrite-lambda `(lambda ,lambda-list + , at decls + (block ,block-name , at body))))) (setf (compiland-lambda-expression compiland) lambda-expression) (setf (local-function-definition local-function) (copy-tree definition)) - ;(setf (local-function-inline-expansion local-function) - ;(generate-inline-expansion block-name lambda-list body)) (p1-compiland compiland))) (push local-function local-functions))) ((with-saved-compiler-policy @@ -960,8 +957,7 @@ (push variable *all-variables*) (push local-function local-functions))) ((dolist (local-function local-functions) - (let ((*visible-variables* *visible-variables*) - (*current-compiland* (local-function-compiland local-function))) + (let ((*visible-variables* *visible-variables*)) (p1-compiland (local-function-compiland local-function)))) (let* ((block (make-labels-node)) (*block* block) @@ -1328,34 +1324,37 @@ (defun p1-compiland (compiland) ;; (format t "p1-compiland name = ~S~%" (compiland-name compiland)) - (let ((form (compiland-lambda-expression compiland))) + (let ((*current-compiland* compiland) + (*local-functions* *local-functions*) + (*visible-variables* *visible-variables*) + (form (compiland-lambda-expression compiland))) (aver (eq (car form) 'LAMBDA)) (setf form (rewrite-lambda form)) - (process-optimization-declarations (cddr form)) + (with-saved-compiler-policy + (process-optimization-declarations (cddr form)) - (let* ((lambda-list (cadr form)) - (body (cddr form)) - (*visible-variables* *visible-variables*) - (closure (make-closure `(lambda ,lambda-list nil) nil)) - (syms (sys::varlist closure)) - (vars nil) - compiland-result) - (dolist (sym syms) - (let ((var (make-variable :name sym - :special-p (special-variable-p sym)))) - (push var vars) - (push var *all-variables*) - (push var *visible-variables*))) - (setf (compiland-arg-vars compiland) (nreverse vars)) - (let ((free-specials (process-declarations-for-vars body vars nil))) - (setf (compiland-free-specials compiland) free-specials) - (dolist (var free-specials) - (push var *visible-variables*))) - (setf compiland-result - (list* 'LAMBDA lambda-list (p1-body body))) - (setf (compiland-%single-valued-p compiland) - (single-valued-p compiland-result)) - (setf (compiland-p1-result compiland) - compiland-result)))) + (let* ((lambda-list (cadr form)) + (body (cddr form)) + (closure (make-closure `(lambda ,lambda-list nil) nil)) + (syms (sys::varlist closure)) + (vars nil) + compiland-result) + (dolist (sym syms) + (let ((var (make-variable :name sym + :special-p (special-variable-p sym)))) + (push var vars) + (push var *all-variables*) + (push var *visible-variables*))) + (setf (compiland-arg-vars compiland) (nreverse vars)) + (let ((free-specials (process-declarations-for-vars body vars nil))) + (setf (compiland-free-specials compiland) free-specials) + (dolist (var free-specials) + (push var *visible-variables*))) + (setf compiland-result + (list* 'LAMBDA lambda-list (p1-body body))) + (setf (compiland-%single-valued-p compiland) + (single-valued-p compiland-result)) + (setf (compiland-p1-result compiland) + compiland-result))))) (provide "COMPILER-PASS1") From ehuelsmann at common-lisp.net Fri Aug 12 22:31:54 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 12 Aug 2011 15:31:54 -0700 Subject: [armedbear-cvs] r13473 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 12 15:31:54 2011 New Revision: 13473 Log: Finally clean up the mess that made up p1-flet and p1-labels, at the same time speeding up compilation. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Fri Aug 12 13:39:58 2011 (r13472) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Fri Aug 12 15:31:54 2011 (r13473) @@ -875,102 +875,89 @@ (defun validate-function-name (name) (unless (or (symbolp name) (setf-function-name-p name)) - (compiler-error "~S is not a valid function name." name))) + (compiler-error "~S is not a valid function name." name)) + name) -(defmacro with-local-functions-for-flet/labels - (form local-functions-var lambda-list-var name-var body-var body1 body2) - `(let ((*visible-variables* *visible-variables*) - (*local-functions* *local-functions*) - (parent-compiland *current-compiland*) - (,local-functions-var '())) - (dolist (definition (cadr ,form)) - (let ((,name-var (car definition)) - (,lambda-list-var (cadr definition))) - (validate-function-name ,name-var) - (let* ((,body-var (cddr definition)) - (compiland (make-compiland :name ,name-var - :parent parent-compiland))) - (push compiland (compiland-children parent-compiland)) - , at body1))) - (setf ,local-functions-var (nreverse ,local-functions-var)) - ;; Make the local functions visible. - (dolist (local-function ,local-functions-var) - (push local-function *local-functions*) - (let ((variable (local-function-variable local-function))) - (when variable - (push variable *visible-variables*)))) - , at body2)) +(defun construct-flet/labels-function (definition variable-name) + (let* ((name (car definition)) + (block-name (fdefinition-block-name (validate-function-name name))) + (lambda-list (cadr definition)) + (compiland (make-compiland :name name :parent *current-compiland*)) + (local-function (make-local-function :name name :compiland compiland))) + (push compiland (compiland-children *current-compiland*)) + (when variable-name + (setf (local-function-variable local-function) + (make-variable :name variable-name))) + (multiple-value-bind + (body decls) + (parse-body (cddr definition)) + (setf (local-function-definition local-function) + (copy-tree (cdr definition))) + (setf (compiland-lambda-expression compiland) + (rewrite-lambda `(lambda ,lambda-list + , at decls + (block ,block-name + , at body))))) + local-function)) (defun p1-flet (form) - (with-local-functions-for-flet/labels - form local-functions lambda-list name body - ((let ((local-function (make-local-function :name name - :compiland compiland)) - (definition (cons lambda-list body))) - (multiple-value-bind (body decls) (parse-body body) - (let* ((block-name (fdefinition-block-name name)) - (lambda-expression - (rewrite-lambda `(lambda ,lambda-list - , at decls - (block ,block-name , at body))))) - (setf (compiland-lambda-expression compiland) lambda-expression) - (setf (local-function-definition local-function) - (copy-tree definition)) - (p1-compiland compiland))) - (push local-function local-functions))) - ((with-saved-compiler-policy - (process-optimization-declarations (cddr form)) - (let* ((block (make-flet-node)) - (*block* block) - (*blocks* (cons block *blocks*)) - (body (cddr form)) - (*visible-variables* *visible-variables*)) - (setf (flet-free-specials block) - (process-declarations-for-vars body nil block)) - (dolist (special (flet-free-specials block)) - (push special *visible-variables*)) - (let ((body (p1-body (cddr form)))) - (setf (flet-form block) - (list* (car form) - (remove-if (lambda (fn) - (and (inline-p (local-function-name fn)) - (not (local-function-references-needed-p fn)))) - local-functions) - body))) - block))))) + (let* ((local-functions + (mapcar #'(lambda (definition) + (construct-flet/labels-function definition nil)) + (cadr form))) + (*local-functions* *local-functions*)) + (dolist (local-function local-functions) + (p1-compiland (local-function-compiland local-function))) + (dolist (local-function local-functions) + (push local-function *local-functions*)) + (with-saved-compiler-policy + (process-optimization-declarations (cddr form)) + (let* ((block (make-flet-node)) + (*block* block) + (*blocks* (cons block *blocks*)) + (body (cddr form)) + (*visible-variables* *visible-variables*)) + (setf (flet-free-specials block) + (process-declarations-for-vars body nil block)) + (dolist (special (flet-free-specials block)) + (push special *visible-variables*)) + (setf body (p1-body body) ;; affects the outcome of references-needed-p + (flet-form block) + (list* (car form) + (remove-if #'(lambda (fn) + (and (inline-p (local-function-name fn)) + (not (local-function-references-needed-p fn)))) + local-functions) + body)) + block)))) (defun p1-labels (form) - (with-local-functions-for-flet/labels - form local-functions lambda-list name body - ((let* ((variable (make-variable :name (gensym))) - (local-function (make-local-function :name name - :compiland compiland - :variable variable)) - (block-name (fdefinition-block-name name))) - (setf (local-function-definition local-function) - (copy-tree (cons lambda-list body))) - (multiple-value-bind (body decls) (parse-body body) - (setf (compiland-lambda-expression compiland) - (rewrite-lambda - `(lambda ,lambda-list , at decls (block ,block-name , at body))))) - (push variable *all-variables*) - (push local-function local-functions))) - ((dolist (local-function local-functions) - (let ((*visible-variables* *visible-variables*)) - (p1-compiland (local-function-compiland local-function)))) - (let* ((block (make-labels-node)) - (*block* block) - (*blocks* (cons block *blocks*)) - (body (cddr form)) - (*visible-variables* *visible-variables*)) - (setf (labels-free-specials block) - (process-declarations-for-vars body nil block)) - (dolist (special (labels-free-specials block)) - (push special *visible-variables*)) - (setf (labels-form block) - (list* (car form) local-functions (p1-body (cddr form)))) - block)))) + (let* ((local-functions + (mapcar #'(lambda (definition) + (construct-flet/labels-function definition (gensym))) + (cadr form))) + (*local-functions* *local-functions*) + (*visible-variables* *visible-variables*)) + (dolist (local-function local-functions) + (push local-function *local-functions*) + (let ((variable (local-function-variable local-function))) + (push variable *all-variables*) + (push variable *visible-variables*))) + (dolist (local-function local-functions) + (p1-compiland (local-function-compiland local-function))) + (let* ((block (make-labels-node)) + (*block* block) + (*blocks* (cons block *blocks*)) + (body (cddr form)) + (*visible-variables* *visible-variables*)) + (setf (labels-free-specials block) + (process-declarations-for-vars body nil block)) + (dolist (special (labels-free-specials block)) + (push special *visible-variables*)) + (setf (labels-form block) + (list* (car form) local-functions (p1-body (cddr form)))) + block))) (defknown p1-funcall (t) t) (defun p1-funcall (form) From mevenson at common-lisp.net Sat Aug 13 05:08:51 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 12 Aug 2011 22:08:51 -0700 Subject: [armedbear-cvs] r13474 - branches/0.26.x/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri Aug 12 22:08:51 2011 New Revision: 13474 Log: Backport r13460: Fix loading from fasls under Windows with whitespace in pathname. Modified: branches/0.26.x/abcl/src/org/armedbear/lisp/Load.java branches/0.26.x/abcl/src/org/armedbear/lisp/Pathname.java Modified: branches/0.26.x/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- branches/0.26.x/abcl/src/org/armedbear/lisp/Load.java Fri Aug 12 15:31:54 2011 (r13473) +++ branches/0.26.x/abcl/src/org/armedbear/lisp/Load.java Fri Aug 12 22:08:51 2011 (r13474) @@ -158,7 +158,7 @@ n = "jar:" + n + "!/" + name + "." + COMPILE_FILE_INIT_FASL_TYPE; } else { - n = "jar:file:" + n + "!/" + name + "." + n = "jar:file:" + Pathname.uriEncode(n) + "!/" + name + "." + COMPILE_FILE_INIT_FASL_TYPE; } mergedPathname = new Pathname(n); Modified: branches/0.26.x/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- branches/0.26.x/abcl/src/org/armedbear/lisp/Pathname.java Fri Aug 12 15:31:54 2011 (r13473) +++ branches/0.26.x/abcl/src/org/armedbear/lisp/Pathname.java Fri Aug 12 22:08:51 2011 (r13474) @@ -373,9 +373,13 @@ + "'" + url.toString() + "'" + ": " + ex.toString())); } - final String uriPath = uri.getPath(); + String uriPath = uri.getPath(); if (null == uriPath) { - error(new LispError("The URI has no path: " + uri)); + // We make an exception for forms like "file:z:/foo/path" + uriPath = uri.getSchemeSpecificPart(); + if (uriPath == null || uriPath.equals("")) { + error(new LispError("The URI has no path: " + uri)); + } } final File file = new File(uriPath); final Pathname p = new Pathname(file.getPath()); From mevenson at common-lisp.net Sat Aug 13 05:31:01 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 12 Aug 2011 22:31:01 -0700 Subject: [armedbear-cvs] r13475 - branches/0.26.x/abcl Message-ID: Author: mevenson Date: Fri Aug 12 22:31:01 2011 New Revision: 13475 Log: Backport r13456: Include ASDF definition in source release. Modified: branches/0.26.x/abcl/build.xml Modified: branches/0.26.x/abcl/build.xml ============================================================================== --- branches/0.26.x/abcl/build.xml Fri Aug 12 22:08:51 2011 (r13474) +++ branches/0.26.x/abcl/build.xml Fri Aug 12 22:31:01 2011 (r13475) @@ -579,6 +579,8 @@ + + From mevenson at common-lisp.net Sat Aug 13 05:32:53 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 12 Aug 2011 22:32:53 -0700 Subject: [armedbear-cvs] r13476 - branches/0.26.x/abcl Message-ID: Author: mevenson Date: Fri Aug 12 22:32:52 2011 New Revision: 13476 Log: Backport r13458: Include the test source in the release. Modified: branches/0.26.x/abcl/build.xml Modified: branches/0.26.x/abcl/build.xml ============================================================================== --- branches/0.26.x/abcl/build.xml Fri Aug 12 22:31:01 2011 (r13475) +++ branches/0.26.x/abcl/build.xml Fri Aug 12 22:32:52 2011 (r13476) @@ -585,6 +585,8 @@ + + @@ -594,8 +596,6 @@ - - From mevenson at common-lisp.net Sat Aug 13 05:34:03 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 12 Aug 2011 22:34:03 -0700 Subject: [armedbear-cvs] r13477 - branches/0.26.x/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri Aug 12 22:34:02 2011 New Revision: 13477 Log: Backport r13452: Include filename in the error string being reported. Modified: branches/0.26.x/abcl/src/org/armedbear/lisp/Load.java Modified: branches/0.26.x/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- branches/0.26.x/abcl/src/org/armedbear/lisp/Load.java Fri Aug 12 22:32:52 2011 (r13476) +++ branches/0.26.x/abcl/src/org/armedbear/lisp/Load.java Fri Aug 12 22:34:02 2011 (r13477) @@ -144,7 +144,7 @@ if (truename == null || truename.equals(NIL)) { if (ifDoesNotExist) { - return error(new FileError("File not found.", pathname)); + return error(new FileError("File not found: " + pathname.princToString(), pathname)); } else { Debug.warn("Failed to load " + pathname.getNamestring()); return NIL; From mevenson at common-lisp.net Sat Aug 13 05:35:08 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 12 Aug 2011 22:35:08 -0700 Subject: [armedbear-cvs] r13478 - branches/0.26.x/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri Aug 12 22:35:07 2011 New Revision: 13478 Log: Backport r13450: Fix #141 (SETF of APPLY not working with arbitrary function) Modified: branches/0.26.x/abcl/src/org/armedbear/lisp/late-setf.lisp Modified: branches/0.26.x/abcl/src/org/armedbear/lisp/late-setf.lisp ============================================================================== --- branches/0.26.x/abcl/src/org/armedbear/lisp/late-setf.lisp Fri Aug 12 22:34:02 2011 (r13477) +++ branches/0.26.x/abcl/src/org/armedbear/lisp/late-setf.lisp Fri Aug 12 22:35:07 2011 (r13478) @@ -88,11 +88,6 @@ `(getf ,get ,ptemp ,@(if default `(,def-temp))))))) (define-setf-expander apply (functionoid &rest args) - (unless (and (listp functionoid) - (= (length functionoid) 2) - (eq (first functionoid) 'function) - (memq (second functionoid) '(aref bit sbit))) - (error "SETF of APPLY is only defined for #'AREF, #'BIT and #'SBIT.")) (let ((function (second functionoid)) (new-var (gensym)) (vars (make-gensym-list (length args)))) From mevenson at common-lisp.net Sat Aug 13 05:36:30 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 12 Aug 2011 22:36:30 -0700 Subject: [armedbear-cvs] r13479 - branches/0.26.x/abcl Message-ID: Author: mevenson Date: Fri Aug 12 22:36:29 2011 New Revision: 13479 Log: Backport r13439: Fix #131: Don't include ':' in the version string. Modified: branches/0.26.x/abcl/build.xml Modified: branches/0.26.x/abcl/build.xml ============================================================================== --- branches/0.26.x/abcl/build.xml Fri Aug 12 22:35:07 2011 (r13478) +++ branches/0.26.x/abcl/build.xml Fri Aug 12 22:36:29 2011 (r13479) @@ -296,7 +296,7 @@ @@ -304,7 +304,7 @@ @@ -312,6 +312,16 @@ + + + + + + + + abcl.version.svn: ${abcl.version.svn} From mevenson at common-lisp.net Sat Aug 13 05:38:26 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 12 Aug 2011 22:38:26 -0700 Subject: [armedbear-cvs] r13480 - branches/0.26.x/abcl Message-ID: Author: mevenson Date: Fri Aug 12 22:38:26 2011 New Revision: 13480 Log: Backport r13428: Enable compilation with Java 7. Modified: branches/0.26.x/abcl/build.xml Modified: branches/0.26.x/abcl/build.xml ============================================================================== --- branches/0.26.x/abcl/build.xml Fri Aug 12 22:36:29 2011 (r13479) +++ branches/0.26.x/abcl/build.xml Fri Aug 12 22:38:26 2011 (r13480) @@ -174,6 +174,7 @@ From mevenson at common-lisp.net Sat Aug 13 05:43:37 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 12 Aug 2011 22:43:37 -0700 Subject: [armedbear-cvs] r13481 - branches/0.26.x/abcl Message-ID: Author: mevenson Date: Fri Aug 12 22:43:37 2011 New Revision: 13481 Log: Update CHANGES to reflect backports. Modified: branches/0.26.x/abcl/CHANGES Modified: branches/0.26.x/abcl/CHANGES ============================================================================== --- branches/0.26.x/abcl/CHANGES Fri Aug 12 22:38:26 2011 (r13480) +++ branches/0.26.x/abcl/CHANGES Fri Aug 12 22:43:37 2011 (r13481) @@ -1,6 +1,30 @@ +Version 0.26.2 +============== +svn://common-lisp.net/project/armedbear/svn/tags/0.26.2/abcl +(Unreleased) + +Features +-------- + * Enable compilation with Java 7 + +Fixes +----- + * Fix loading from fasls under Windows with whitespace in pathname. + + * Fix #131: Don't include ':' in the version string. + + * Fix #141: SETF of APPLY not working with arbitrary function. + + * Include filename in the error string being reported. + + * Include the test source in the release. + + * Include ASDF definition in source release. + Version 0.26.1 ============== svn://common-lisp.net/project/armedbear/svn/tags/0.26.1/abcl +(27 July 2011) Features -------- From mevenson at common-lisp.net Sat Aug 13 05:48:48 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 12 Aug 2011 22:48:48 -0700 Subject: [armedbear-cvs] r13482 - branches/0.26.x/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri Aug 12 22:48:48 2011 New Revision: 13482 Log: Adjust r13452 to absence of princToString() in abcl-0.26.x. Modified: branches/0.26.x/abcl/src/org/armedbear/lisp/Load.java Modified: branches/0.26.x/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- branches/0.26.x/abcl/src/org/armedbear/lisp/Load.java Fri Aug 12 22:43:37 2011 (r13481) +++ branches/0.26.x/abcl/src/org/armedbear/lisp/Load.java Fri Aug 12 22:48:48 2011 (r13482) @@ -144,7 +144,7 @@ if (truename == null || truename.equals(NIL)) { if (ifDoesNotExist) { - return error(new FileError("File not found: " + pathname.princToString(), pathname)); + return error(new FileError("File not found: " + pathname.toString(), pathname)); } else { Debug.warn("Failed to load " + pathname.getNamestring()); return NIL; From mevenson at common-lisp.net Sat Aug 13 06:46:16 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 12 Aug 2011 23:46:16 -0700 Subject: [armedbear-cvs] r13483 - public_html Message-ID: Author: mevenson Date: Fri Aug 12 23:46:15 2011 New Revision: 13483 Log: FAQ improvements. Explain how to avoid recompilation. Remove claim that Gray streams are broken due to improvements made to get Huchentoot working. Rephrase the issue reporting procedure, note #abcl as a resource. State goal for Quicklisp compatiblity. Update failing test number for abcl-0.26.1. Mention HTTP SVN repository. Modified: public_html/faq.shtml Modified: public_html/faq.shtml ============================================================================== --- public_html/faq.shtml Fri Aug 12 22:48:48 2011 (r13482) +++ public_html/faq.shtml Fri Aug 12 23:46:15 2011 (r13483) @@ -29,6 +29,13 @@
  • Where is ABCL's documentation?
    • + +
  • Building +
      +
    1. The Ant build process seems to recompile from scratch each time. How do I avoid this?
      2. +
    +
    • + @@ -41,15 +48,13 @@ the exception of the implementation of the long form of DEFINE-METHOD-COMBINATION.

    -

    Unfortunately, the CLOS implementation is not accessible through -a MOP (MetaObject Protocol). Any contributions in this area would -be greatly appreciated, ofcourse.

    - -

    One thing which is considered almost standard lisp - because all -implementations deliver it - is "Gray streams". Unfortunately ABCLs -version is broken [as per 05/2009]. It should be noted this is by no -means the final state of affairs, though, merely a warning that one -can't depend on this feature at the moment.

    +

    +Unfortunately, the CLOS implementation is not fully completely through +a MOP (MetaObject Protocol). Perhaps roughly a third of the +functionality defined by AMOP is present. Any +contributions in this area would be greatly appreciated, of course. +

    @@ -69,13 +74,13 @@ In general, such usage means that whenever you keep ABCL as a separate jar file, you won't have licensing problems. The combining in the Classpath exception means that you can - +

    1. Extend ABCL java classes in your program
    2. Use ABCL java classes in your program
    3. Invoke ABCL lisp functions in your program
    - +

    without having to worry about the licensing. You do have to distribute the source code of ABCL (including modifications) if you distribute ABCL, but otherwise the license of ABCL is not viral. @@ -86,16 +91,30 @@

    How/Where should I report bugs?

    -

    There is a list of currently known problems (bugs) in our -bug tracker. -Unfortunately, due to spamming problems, administration of bugs has been -closed for anybody but common-lisp.net members.

    - -

    If you found a bug which is not on the list, or you want to stress -the importance of one that is, please mail our mailing list about it.

    -
    +

    + +The current state of issues can be found in the ABCL issue +tracker. Unfortunately, due to spamming problems, administration +of bugs has been closed for anybody but common-lisp.net members.

    + +

    +To report a bug, please mail a description of the problem, the version +of ABCL you are using, and if possible a set of steps to reproduce the +problem to the armedbear-devel +mailing list. We try to respond within a day at most to messages. +A convenient way to browse the mailing list archives can be found by +the gmane +loom interface to the NNTP group gmane.lisp.armedbear.devel. +

    + +

    +Developers can also usually be found on the #abcl +irc channel. +

    Is ABCL faster or slower than implementation XYZ?

    @@ -133,8 +152,11 @@ to run existing Lisp code -

    The plan is to add to the list above software from Edi Weitz, who - wrote some great libraries.

    +

    +The plan is to ensure that ABCL runs with the software provided by +Quicklisp. For many packages available from Quicklisp, +this is already the case. +

    The first item is being measured by running the ANSI test suite compliance tests. The second item is measured by compiling and running the test suite @@ -142,9 +164,10 @@ Additionally, compilation of AP5 is used to improve this measure too.

    -

    ABCL 0.23.0 fails 31 out of 21702 tests in the ANSI test suite - in interpreted and compiled modes, a constant number over the past - releases. Most failures relate to pretty printing.

    +

    ABCL 0.26.1 fails roughly 20 out of 21702 tests in the ANSI test +suite in interpreted and compiled modes, a constant number over the +past releases. Most failures relate to pretty printing.

    +

    As a measure of 'improvement achieved', the development team refers to the number of failing tests in the Maxima test suite too. ABCL 0.23.0 is able to run the test suite without failures, coming from @@ -160,6 +183,12 @@ you can check out through svn://common-lisp.net/project/armedbear/svn/trunk/abcl.

    +

    +This repository is also exported read-only via HTTP at +http://svn.common-lisp.net/armedbear/trunk/abcl +

    + +
    @@ -177,8 +206,26 @@
    + + +
    +

    Building

    + +
    +

    The Ant build process seems to recompile from scratch each time. How do I avoid this?

    + +

    +If the JVM system property abcl.build.incremental is set, +the Ant build process will attempt to build ABCL incrementally +by not removing any intermediate results. The easiest way to enable +this property is to copy the 'abcl.properties.in' file to +'abcl.properties', then uncomment the line referencing the setting of +the abcl.build.incremental property. +

    +
    +
    From ehuelsmann at common-lisp.net Sat Aug 13 08:29:09 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 13 Aug 2011 01:29:09 -0700 Subject: [armedbear-cvs] r13484 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 13 01:29:08 2011 New Revision: 13484 Log: Store local functions in the parent compiland, since you can't reach the function from the compiland, but the other way around works. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Fri Aug 12 23:46:15 2011 (r13483) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sat Aug 13 01:29:08 2011 (r13484) @@ -884,7 +884,7 @@ (lambda-list (cadr definition)) (compiland (make-compiland :name name :parent *current-compiland*)) (local-function (make-local-function :name name :compiland compiland))) - (push compiland (compiland-children *current-compiland*)) + (push local-function (compiland-children *current-compiland*)) (when variable-name (setf (local-function-variable local-function) (make-variable :name variable-name))) @@ -1003,8 +1003,9 @@ (compiland (make-compiland :name (if named-lambda-p name (gensym "ANONYMOUS-LAMBDA-")) :lambda-expression lambda-form - :parent *current-compiland*))) - (push compiland (compiland-children *current-compiland*)) + :parent *current-compiland*)) + (local-function (make-local-function :compiland compiland))) + (push local-function (compiland-children *current-compiland*)) (multiple-value-bind (body decls) (parse-body body) (setf (compiland-lambda-expression compiland) @@ -1014,7 +1015,7 @@ (let ((*visible-variables* *visible-variables*) (*current-compiland* compiland)) (p1-compiland compiland))) - (list 'FUNCTION compiland))) + (list 'FUNCTION local-function))) ((setf local-function (find-local-function (cadr form))) (dformat "p1-function local function ~S~%" (cadr form)) ;;we found out that the function needs a reference Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri Aug 12 23:46:15 2011 (r13483) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Aug 13 01:29:08 2011 (r13484) @@ -4140,37 +4140,35 @@ (let ((*blocks* (cons block *blocks*))) (compile-progn-body body target representation)))) -(defun p2-lambda (compiland target) - (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 :compiland compiland)) - +lisp-object+)) - (t - (with-open-stream (stream (sys::%make-byte-array-output-stream)) - (compile-and-write-to-stream compiland stream) - (let ((bytes (sys::%get-output-stream-bytes stream))) - (sys::put-memory-function *memory-class-loader* - (class-name-internal - (abcl-class-file-class-name - (compiland-class-file compiland))) - bytes) - (emit-getstatic *this-class* - (declare-local-function - (make-local-function - :compiland compiland)) - +lisp-object+))))) - (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+)) +(defun p2-lambda (local-function target) + (let ((compiland (local-function-compiland local-function))) + (aver (null (compiland-class-file compiland))) + (cond (*file-compilation* + (compile-and-write-to-stream compiland) + (emit-getstatic *this-class* + (declare-local-function local-function) + +lisp-object+)) + (t + (with-open-stream (stream (sys::%make-byte-array-output-stream)) + (compile-and-write-to-stream compiland stream) + (let ((bytes (sys::%get-output-stream-bytes stream))) + (sys::put-memory-function *memory-class-loader* + (class-name-internal + (abcl-class-file-class-name + (compiland-class-file compiland))) + bytes) + (emit-getstatic *this-class* + (declare-local-function local-function) + +lisp-object+))))) + (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. + (t + (aver nil)))) ;; Shouldn't happen. (emit-move-from-stack target)) @@ -4250,7 +4248,7 @@ "getSymbolSetfFunctionOrDie" nil +lisp-object+) (emit-move-from-stack target)))) - ((compiland-p name) + ((local-function-p name) (dformat t "p2-function case 3~%") (p2-lambda name target)) (t Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp Fri Aug 12 23:46:15 2011 (r13483) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Sat Aug 13 01:29:08 2011 (r13484) @@ -199,7 +199,7 @@ arity ; number of args, or NIL if the number of args can vary. p1-result ; the parse tree as created in pass 1 parent ; the parent for compilands which defined within another - children ; List of local compilands + children ; List of local functions ; defined with FLET, LABELS or LAMBDA blocks ; TAGBODY, PROGV, BLOCK, etc. blocks argument-register From ehuelsmann at common-lisp.net Sat Aug 13 09:13:54 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 13 Aug 2011 02:13:54 -0700 Subject: [armedbear-cvs] r13485 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 13 02:13:53 2011 New Revision: 13485 Log: Remove two structure slots which are read only once, in favor of passing in the right values to the reading function. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Aug 13 01:29:08 2011 (r13484) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Aug 13 02:13:53 2011 (r13485) @@ -937,14 +937,12 @@ (defun emit-read-from-string (object) (emit-constructor-lambda-list object)) -(defun make-constructor (class) +(defun make-constructor (class lambda-name args) (let* ((*compiler-debug* nil) (method (make-jvm-method :constructor :void nil :flags '(:public))) ;; We don't normally need to see debugging output for constructors. (super (class-file-superclass class)) - (lambda-name (abcl-class-file-lambda-name class)) - (args (abcl-class-file-lambda-list class)) req-params-register opt-params-register key-params-register @@ -4036,9 +4034,7 @@ 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))))) + :pathname pathname))) (setf (compiland-class-file compiland) class-file) (with-open-stream (f (or stream (open pathname :direction :output @@ -7124,14 +7120,14 @@ (class-add-method class-file method) - (setf (abcl-class-file-lambda-list class-file) args) (setf (abcl-class-file-superclass class-file) (if (or *hairy-arglist-p* (and *child-p* *closure-variables*)) +lisp-compiled-closure+ +lisp-compiled-primitive+)) - (let ((constructor (make-constructor class-file))) + (let ((constructor + (make-constructor class-file (compiland-name compiland) args))) (setf (abcl-class-file-constructor class-file) constructor) (class-add-method class-file constructor)) #+enable-when-generating-clinit @@ -7386,18 +7382,14 @@ generated class." (aver (eq (car form) 'LAMBDA)) (catch 'compile-defun-abort - (let* ((class-file (make-abcl-class-file :pathname filespec - :lambda-name name - :lambda-list (cadr form))) + (let* ((class-file (make-abcl-class-file :pathname filespec)) (*compiler-error-bailout* `(lambda () (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))) + (make-abcl-class-file :pathname ,filespec)) ,stream))) (*compile-file-environment* environment)) (compile-1 (make-compiland :name name Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp Sat Aug 13 01:29:08 2011 (r13484) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Sat Aug 13 02:13:53 2011 (r13485) @@ -130,8 +130,6 @@ (:constructor %make-abcl-class-file)) pathname ; pathname of output file class-name - lambda-name - lambda-list ; as advertised static-initializer constructor objects ;; an alist of externalized objects and their field names @@ -160,7 +158,7 @@ (java:jstatic "randomUUID" "java.util.UUID")))))) -(defun make-abcl-class-file (&key pathname lambda-name lambda-list) +(defun make-abcl-class-file (&key pathname) "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'." @@ -170,8 +168,6 @@ (class-file (%make-abcl-class-file :pathname pathname :class class-name ; to be finalized :class-name class-name - :lambda-name lambda-name - :lambda-list lambda-list :access-flags '(:public :final)))) (when *file-compilation* (let ((source-attribute From ehuelsmann at common-lisp.net Sat Aug 13 10:30:16 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 13 Aug 2011 03:30:16 -0700 Subject: [armedbear-cvs] r13486 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 13 03:30:16 2011 New Revision: 13486 Log: Assign all local functions a field in the immediate parent; also make sure all compiland children have known class names before processing the body of the compiland. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Aug 13 02:13:53 2011 (r13485) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Aug 13 03:30:16 2011 (r13486) @@ -4032,10 +4032,8 @@ (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))) - (setf (compiland-class-file compiland) class-file) + (let* ((class-file (compiland-class-file compiland)) + (pathname (abcl-class-file-pathname class-file))) (with-open-stream (f (or stream (open pathname :direction :output :element-type '(unsigned-byte 8) @@ -4044,7 +4042,6 @@ (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) @@ -4138,7 +4135,7 @@ (defun p2-lambda (local-function target) (let ((compiland (local-function-compiland local-function))) - (aver (null (compiland-class-file compiland))) + (aver (not (null (compiland-class-file compiland)))) (cond (*file-compilation* (compile-and-write-to-stream compiland) (emit-getstatic *this-class* @@ -7093,6 +7090,15 @@ (emit-move-to-variable variable)))) t) + +(defun assign-field-and-class-name (local-function) + (let* ((pathname (funcall *pathnames-generator*)) + (class-file (make-abcl-class-file :pathname pathname)) + (compiland (local-function-compiland local-function))) + (setf (compiland-class-file compiland) class-file)) + (setf (local-function-field local-function) + (declare-local-function local-function))) + (defknown p2-compiland (t) t) (defun p2-compiland (compiland) (let* ((p1-result (compiland-p1-result compiland)) @@ -7144,6 +7150,9 @@ (code-add-attribute *current-code-attribute* table) (line-numbers-add-line table 0 *source-line-number*))) + (dolist (local-function (compiland-children compiland)) + (assign-field-and-class-name local-function)) + (dolist (var (compiland-arg-vars compiland)) (push var *visible-variables*)) (dolist (var (compiland-free-specials compiland)) Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp Sat Aug 13 02:13:53 2011 (r13485) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Sat Aug 13 03:30:16 2011 (r13486) @@ -375,6 +375,7 @@ name definition compiland + field inline-expansion variable ;; the variable which contains the loaded compiled function ;; or compiled closure From ehuelsmann at common-lisp.net Sat Aug 13 14:25:49 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 13 Aug 2011 07:25:49 -0700 Subject: [armedbear-cvs] r13487 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 13 07:25:49 2011 New Revision: 13487 Log: Store instances of local functions in their parent compiland. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Aug 13 03:30:16 2011 (r13486) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Aug 13 07:25:49 2011 (r13487) @@ -1339,6 +1339,13 @@ (declare-function (cadr name) t)) +(defun local-function-class-and-field (local-function) + (let ((local-function-parent-compiland + (compiland-parent (local-function-compiland local-function)))) + (values (abcl-class-file-class-name + (compiland-class-file local-function-parent-compiland)) + (local-function-field local-function)))) + (defknown declare-local-function (local-function) string) (defun declare-local-function (local-function) (declare-with-hashtable @@ -2207,15 +2214,16 @@ +lisp-object+)) (t (dformat t "compile-local-function-call default case~%") - (let* ((g (declare-local-function local-function))) - (emit-getstatic *this-class* g +lisp-object+) - ; Stack: template-function - (when *closure-variables* - (emit-checkcast +lisp-compiled-closure+) - (duplicate-closure-array compiland) - (emit-invokestatic +lisp+ "makeCompiledClosure" - (list +lisp-object+ +closure-binding-array+) - +lisp-object+))))) + (multiple-value-bind + (class field) + (local-function-class-and-field local-function) + (emit-getstatic class field +lisp-object+)) + (when *closure-variables* + (emit-checkcast +lisp-compiled-closure+) + (duplicate-closure-array compiland) + (emit-invokestatic +lisp+ "makeCompiledClosure" + (list +lisp-object+ +closure-binding-array+) + +lisp-object+)))) (process-args args '(nil)) (emit-call-execute (length args)) (fix-boxing representation nil) @@ -4059,10 +4067,12 @@ (compiland-class-file compiland))) bytes))))))) -(defun emit-make-compiled-closure-for-labels - (local-function compiland declaration) - (emit-getstatic *this-class* declaration +lisp-object+) - (let ((parent (compiland-parent compiland))) +(defun emit-make-compiled-closure-for-labels (local-function) + (let ((parent (compiland-parent (local-function-compiland local-function)))) + (multiple-value-bind + (class field) + (local-function-class-and-field local-function) + (emit-getstatic class field +lisp-object+)) (when (compiland-closure-register parent) (dformat t "(compiland-closure-register parent) = ~S~%" (compiland-closure-register parent)) @@ -4076,24 +4086,20 @@ (defknown p2-labels-process-compiland (t) t) (defun p2-labels-process-compiland (local-function) (let* ((compiland (local-function-compiland local-function))) - (cond (*file-compilation* - (compile-and-write-to-stream compiland) - (let ((g (declare-local-function local-function))) - (emit-make-compiled-closure-for-labels - local-function compiland g))) - (t - (with-open-stream (stream (sys::%make-byte-array-output-stream)) - (compile-and-write-to-stream compiland stream) - (let* ((bytes (sys::%get-output-stream-bytes stream)) - (g (declare-local-function local-function))) - (sys::put-memory-function *memory-class-loader* - (class-name-internal - (abcl-class-file-class-name - (compiland-class-file compiland))) - bytes) - (emit-make-compiled-closure-for-labels - local-function compiland g) - )))))) + (cond + (*file-compilation* + (compile-and-write-to-stream compiland) + (emit-make-compiled-closure-for-labels local-function)) + (t + (with-open-stream (stream (sys::%make-byte-array-output-stream)) + (compile-and-write-to-stream compiland stream) + (let* ((bytes (sys::%get-output-stream-bytes stream))) + (sys::put-memory-function *memory-class-loader* + (class-name-internal + (abcl-class-file-class-name + (compiland-class-file compiland))) + bytes) + (emit-make-compiled-closure-for-labels local-function))))))) (defknown p2-flet-node (t t t) t) (defun p2-flet-node (block target representation) @@ -4138,9 +4144,10 @@ (aver (not (null (compiland-class-file compiland)))) (cond (*file-compilation* (compile-and-write-to-stream compiland) - (emit-getstatic *this-class* - (declare-local-function local-function) - +lisp-object+)) + (multiple-value-bind + (class field) + (local-function-class-and-field local-function) + (emit-getstatic class field +lisp-object+))) (t (with-open-stream (stream (sys::%make-byte-array-output-stream)) (compile-and-write-to-stream compiland stream) @@ -4150,9 +4157,10 @@ (abcl-class-file-class-name (compiland-class-file compiland))) bytes) - (emit-getstatic *this-class* - (declare-local-function local-function) - +lisp-object+))))) + (multiple-value-bind + (class field) + (local-function-class-and-field local-function) + (emit-getstatic class field +lisp-object+)))))) (cond ((null *closure-variables*)) ; Nothing to do. ((compiland-closure-register *current-compiland*) (duplicate-closure-array *current-compiland*) @@ -4184,16 +4192,16 @@ (local-function-variable local-function)) 'stack nil)) (t - (let ((g (declare-local-function local-function))) - (emit-getstatic *this-class* g +lisp-object+) - ; Stack: template-function - - (when (compiland-closure-register *current-compiland*) - (emit-checkcast +lisp-compiled-closure+) - (duplicate-closure-array *current-compiland*) - (emit-invokestatic +lisp+ "makeCompiledClosure" - (list +lisp-object+ +closure-binding-array+) - +lisp-object+))))) + (multiple-value-bind + (class field) + (local-function-class-and-field local-function) + (emit-getstatic class field +lisp-object+)) + (when (compiland-closure-register *current-compiland*) + (emit-checkcast +lisp-compiled-closure+) + (duplicate-closure-array *current-compiland*) + (emit-invokestatic +lisp+ "makeCompiledClosure" + (list +lisp-object+ +closure-binding-array+) + +lisp-object+)))) (emit-move-from-stack target)) ((inline-ok name) (emit-getstatic *this-class* @@ -4222,9 +4230,11 @@ (local-function-variable local-function)) 'stack nil)) (t - (let ((g (declare-local-function local-function))) - (emit-getstatic *this-class* - g +lisp-object+))))) ; Stack: template-function + (multiple-value-bind + (class field) + (local-function-class-and-field) + ; Stack: template-function + (emit-getstatic class field +lisp-object+))))) ((and (member name *functions-defined-in-current-file* :test #'equal) (not (notinline-p name))) (emit-getstatic *this-class* From ehuelsmann at common-lisp.net Sat Aug 13 20:26:03 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 13 Aug 2011 13:26:03 -0700 Subject: [armedbear-cvs] r13488 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 13 13:26:01 2011 New Revision: 13488 Log: Eliminate the need for functions defined using LABELS to be stored in closures. Code elimination! Yay! Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sat Aug 13 07:25:49 2011 (r13487) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sat Aug 13 13:26:01 2011 (r13488) @@ -878,16 +878,13 @@ (compiler-error "~S is not a valid function name." name)) name) -(defun construct-flet/labels-function (definition variable-name) +(defun construct-flet/labels-function (definition) (let* ((name (car definition)) (block-name (fdefinition-block-name (validate-function-name name))) (lambda-list (cadr definition)) (compiland (make-compiland :name name :parent *current-compiland*)) (local-function (make-local-function :name name :compiland compiland))) (push local-function (compiland-children *current-compiland*)) - (when variable-name - (setf (local-function-variable local-function) - (make-variable :name variable-name))) (multiple-value-bind (body decls) (parse-body (cddr definition)) @@ -903,7 +900,7 @@ (defun p1-flet (form) (let* ((local-functions (mapcar #'(lambda (definition) - (construct-flet/labels-function definition nil)) + (construct-flet/labels-function definition)) (cadr form))) (*local-functions* *local-functions*)) (dolist (local-function local-functions) @@ -935,15 +932,12 @@ (defun p1-labels (form) (let* ((local-functions (mapcar #'(lambda (definition) - (construct-flet/labels-function definition (gensym))) + (construct-flet/labels-function definition)) (cadr form))) (*local-functions* *local-functions*) (*visible-variables* *visible-variables*)) (dolist (local-function local-functions) - (push local-function *local-functions*) - (let ((variable (local-function-variable local-function))) - (push variable *all-variables*) - (push variable *visible-variables*))) + (push local-function *local-functions*)) (dolist (local-function local-functions) (p1-compiland (local-function-compiland local-function))) (let* ((block (make-labels-node)) @@ -1020,11 +1014,6 @@ (dformat "p1-function local function ~S~%" (cadr form)) ;;we found out that the function needs a reference (setf (local-function-references-needed-p local-function) t) - (let ((variable (local-function-variable local-function))) - (when variable - (dformat t "p1-function ~S used non-locally~%" - (variable-name variable)) - (setf (variable-used-non-locally-p variable) t))) form) (t form)))) @@ -1177,12 +1166,7 @@ (return-from p1-function-call (let ((*inline-declarations* (remove op *inline-declarations* :key #'car :test #'equal))) - (p1 expansion)))))) - - (let ((variable (local-function-variable local-function))) - (when variable - (dformat t "p1 ~S used non-locally~%" (variable-name variable)) - (setf (variable-used-non-locally-p variable) t))))) + (p1 expansion)))))))) (p1-default form)) (defun %funcall (fn &rest args) Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Aug 13 07:25:49 2011 (r13487) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Aug 13 13:26:01 2011 (r13488) @@ -1075,8 +1075,7 @@ (defknown declare-field (t t t) t) (defun declare-field (name descriptor) - (let ((field (make-field name descriptor - :flags '(:final :static :private)))) + (let ((field (make-field name descriptor :flags '(:final :static)))) (class-add-field *class-file* field))) (defknown sanitize (symbol) string) @@ -1348,21 +1347,18 @@ (defknown declare-local-function (local-function) string) (defun declare-local-function (local-function) - (declare-with-hashtable - local-function *declared-functions* ht g - (setf g (symbol-name (gensym "LFUN"))) - (let ((class-name (abcl-class-file-class-name - (compiland-class-file - (local-function-compiland local-function))))) - (with-code-to-method - (*class-file* (abcl-class-file-constructor *class-file*)) - ;; fixme *declare-inline* - (declare-field g +lisp-object+) - (emit-new class-name) - (emit 'dup) - (emit-invokespecial-init class-name '()) - (emit-putstatic *this-class* g +lisp-object+) - (setf (gethash local-function ht) g))))) + (let ((class-name (abcl-class-file-class-name + (compiland-class-file + (local-function-compiland local-function)))) + (field-name (local-function-field local-function))) + (with-code-to-method + (*class-file* (abcl-class-file-constructor *class-file*)) + ;; fixme *declare-inline* + (declare-field field-name +lisp-object+) + (emit-new class-name) + (emit 'dup) + (emit-invokespecial-init class-name '()) + (emit-putstatic *this-class* field-name +lisp-object+)))) (defknown declare-object-as-string (t) string) @@ -2195,13 +2191,7 @@ (args (cdr form)) (local-function (find-local-function op)) (*register* *register*)) - (cond ((local-function-variable local-function) - ;; LABELS - (dformat t "compile-local-function-call LABELS case variable = ~S~%" - (variable-name (local-function-variable local-function))) - (compile-var-ref (make-var-ref - (local-function-variable local-function)) - 'stack nil)) + (cond ((local-function-environment local-function) (assert (local-function-references-allowed-p local-function)) (assert (not *file-compilation*)) @@ -4040,8 +4030,9 @@ (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* ((class-file (compiland-class-file compiland)) - (pathname (abcl-class-file-pathname class-file))) + (let* ((pathname (funcall *pathnames-generator*)) + (class-file (make-abcl-class-file :pathname pathname))) + (setf (compiland-class-file compiland) class-file) (with-open-stream (f (or stream (open pathname :direction :output :element-type '(unsigned-byte 8) @@ -4067,29 +4058,12 @@ (compiland-class-file compiland))) bytes))))))) -(defun emit-make-compiled-closure-for-labels (local-function) - (let ((parent (compiland-parent (local-function-compiland local-function)))) - (multiple-value-bind - (class field) - (local-function-class-and-field local-function) - (emit-getstatic class field +lisp-object+)) - (when (compiland-closure-register parent) - (dformat t "(compiland-closure-register parent) = ~S~%" - (compiland-closure-register parent)) - (emit-checkcast +lisp-compiled-closure+) - (duplicate-closure-array parent) - (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))) (cond (*file-compilation* - (compile-and-write-to-stream compiland) - (emit-make-compiled-closure-for-labels local-function)) + (compile-and-write-to-stream compiland)) (t (with-open-stream (stream (sys::%make-byte-array-output-stream)) (compile-and-write-to-stream compiland stream) @@ -4098,8 +4072,7 @@ (class-name-internal (abcl-class-file-class-name (compiland-class-file compiland))) - bytes) - (emit-make-compiled-closure-for-labels local-function))))))) + bytes))))))) (defknown p2-flet-node (t t t) t) (defun p2-flet-node (block target representation) @@ -4125,13 +4098,7 @@ (local-functions (cadr form)) (body (cddr form))) (dolist (local-function local-functions) - (push local-function *local-functions*) - (push (local-function-variable local-function) *visible-variables*)) - (dolist (local-function local-functions) - (let ((variable (local-function-variable local-function))) - (aver (null (variable-register variable))) - (unless (variable-closure-index variable) - (setf (variable-register variable) (allocate-register nil))))) + (push local-function *local-functions*)) (dolist (local-function local-functions) (p2-labels-process-compiland local-function)) (dolist (special (labels-free-specials block)) @@ -4141,7 +4108,6 @@ (defun p2-lambda (local-function target) (let ((compiland (local-function-compiland local-function))) - (aver (not (null (compiland-class-file compiland)))) (cond (*file-compilation* (compile-and-write-to-stream compiland) (multiple-value-bind @@ -4185,23 +4151,16 @@ (cond ((setf local-function (find-local-function name)) (dformat t "p2-function 1~%") - (cond - ((local-function-variable local-function) - (dformat t "p2-function 2 emitting var-ref~%") - (compile-var-ref (make-var-ref - (local-function-variable local-function)) - 'stack nil)) - (t - (multiple-value-bind - (class field) - (local-function-class-and-field local-function) - (emit-getstatic class field +lisp-object+)) - (when (compiland-closure-register *current-compiland*) - (emit-checkcast +lisp-compiled-closure+) - (duplicate-closure-array *current-compiland*) - (emit-invokestatic +lisp+ "makeCompiledClosure" - (list +lisp-object+ +closure-binding-array+) - +lisp-object+)))) + (multiple-value-bind + (class field) + (local-function-class-and-field local-function) + (emit-getstatic class field +lisp-object+)) + (when (compiland-closure-register *current-compiland*) + (emit-checkcast +lisp-compiled-closure+) + (duplicate-closure-array *current-compiland*) + (emit-invokestatic +lisp+ "makeCompiledClosure" + (list +lisp-object+ +closure-binding-array+) + +lisp-object+)) (emit-move-from-stack target)) ((inline-ok name) (emit-getstatic *this-class* @@ -4223,18 +4182,11 @@ (aload 0) ; this (emit-move-from-stack target) (return-from p2-function)) - (cond - ((local-function-variable local-function) - (dformat t "p2-function 2~%") - (compile-var-ref (make-var-ref - (local-function-variable local-function)) - 'stack nil)) - (t - (multiple-value-bind - (class field) - (local-function-class-and-field) - ; Stack: template-function - (emit-getstatic class field +lisp-object+))))) + (multiple-value-bind + (class field) + (local-function-class-and-field local-function) + ; Stack: template-function + (emit-getstatic class field +lisp-object+))) ((and (member name *functions-defined-in-current-file* :test #'equal) (not (notinline-p name))) (emit-getstatic *this-class* @@ -7101,13 +7053,9 @@ t) -(defun assign-field-and-class-name (local-function) - (let* ((pathname (funcall *pathnames-generator*)) - (class-file (make-abcl-class-file :pathname pathname)) - (compiland (local-function-compiland local-function))) - (setf (compiland-class-file compiland) class-file)) +(defun assign-field-name (local-function) (setf (local-function-field local-function) - (declare-local-function local-function))) + (symbol-name (gensym "LFUN")))) (defknown p2-compiland (t) t) (defun p2-compiland (compiland) @@ -7161,7 +7109,7 @@ (line-numbers-add-line table 0 *source-line-number*))) (dolist (local-function (compiland-children compiland)) - (assign-field-and-class-name local-function)) + (assign-field-name local-function)) (dolist (var (compiland-arg-vars compiland)) (push var *visible-variables*)) @@ -7308,6 +7256,10 @@ ;; Warn if any unused args. (Is this the right place?) (check-for-unused-variables (compiland-arg-vars compiland)) + (dolist (local-function (compiland-children compiland)) + (when (compiland-class-file (local-function-compiland local-function)) + (declare-local-function local-function))) + ;; Go back and fill in prologue. (let ((code *code*)) (setf *code* ()) Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp Sat Aug 13 07:25:49 2011 (r13487) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Sat Aug 13 13:26:01 2011 (r13488) @@ -377,8 +377,6 @@ compiland field inline-expansion - variable ;; the variable which contains the loaded compiled function - ;; or compiled closure environment ;; the environment in which the function is stored in ;; case of a function from an enclosing lexical environment ;; which itself isn't being compiled From ehuelsmann at common-lisp.net Sat Aug 13 21:08:30 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 13 Aug 2011 14:08:30 -0700 Subject: [armedbear-cvs] r13489 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 13 14:08:29 2011 New Revision: 13489 Log: Code duplication refactoring. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Aug 13 13:26:01 2011 (r13488) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Aug 13 14:08:29 2011 (r13489) @@ -4027,11 +4027,13 @@ (emit-push-nil) (emit-move-from-stack target))) -(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))) + +(defun compile-local-function (local-function) + (let* ((compiland (local-function-compiland local-function)) + (pathname (funcall *pathnames-generator*)) + (class-file (make-abcl-class-file :pathname pathname)) + (stream (unless *file-compilation* + (sys::%make-byte-array-output-stream)))) (setf (compiland-class-file compiland) class-file) (with-open-stream (f (or stream (open pathname :direction :output @@ -4041,38 +4043,14 @@ (let ((*current-compiland* compiland)) (with-saved-compiler-policy (p2-compiland 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))) - (cond (*file-compilation* - (compile-and-write-to-stream compiland)) - (t - (with-open-stream (stream (sys::%make-byte-array-output-stream)) - (compile-and-write-to-stream compiland stream) - (let ((bytes (sys::%get-output-stream-bytes stream))) - (sys::put-memory-function *memory-class-loader* - (class-name-internal - (abcl-class-file-class-name - (compiland-class-file compiland))) - bytes))))))) - -(defknown p2-labels-process-compiland (t) t) -(defun p2-labels-process-compiland (local-function) - (let* ((compiland (local-function-compiland local-function))) - (cond - (*file-compilation* - (compile-and-write-to-stream compiland)) - (t - (with-open-stream (stream (sys::%make-byte-array-output-stream)) - (compile-and-write-to-stream compiland stream) - (let* ((bytes (sys::%get-output-stream-bytes stream))) - (sys::put-memory-function *memory-class-loader* - (class-name-internal - (abcl-class-file-class-name - (compiland-class-file compiland))) - bytes))))))) + (finish-class (compiland-class-file compiland) f))))) + (when stream + (let ((bytes (sys::%get-output-stream-bytes stream))) + (sys::put-memory-function *memory-class-loader* + (class-name-internal + (abcl-class-file-class-name + (compiland-class-file compiland))) + bytes))))) (defknown p2-flet-node (t t t) t) (defun p2-flet-node (block target representation) @@ -4082,7 +4060,7 @@ (local-functions (cadr form)) (body (cddr form))) (dolist (local-function local-functions) - (p2-flet-process-compiland local-function)) + (compile-local-function local-function)) (dolist (local-function local-functions) (push local-function *local-functions*)) (dolist (special (flet-free-specials block)) @@ -4100,43 +4078,23 @@ (dolist (local-function local-functions) (push local-function *local-functions*)) (dolist (local-function local-functions) - (p2-labels-process-compiland local-function)) + (compile-local-function local-function)) (dolist (special (labels-free-specials block)) (push special *visible-variables*)) (let ((*blocks* (cons block *blocks*))) (compile-progn-body body target representation)))) (defun p2-lambda (local-function target) - (let ((compiland (local-function-compiland local-function))) - (cond (*file-compilation* - (compile-and-write-to-stream compiland) - (multiple-value-bind - (class field) - (local-function-class-and-field local-function) - (emit-getstatic class field +lisp-object+))) - (t - (with-open-stream (stream (sys::%make-byte-array-output-stream)) - (compile-and-write-to-stream compiland stream) - (let ((bytes (sys::%get-output-stream-bytes stream))) - (sys::put-memory-function *memory-class-loader* - (class-name-internal - (abcl-class-file-class-name - (compiland-class-file compiland))) - bytes) - (multiple-value-bind - (class field) - (local-function-class-and-field local-function) - (emit-getstatic class field +lisp-object+)))))) - (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. - + (compile-local-function local-function) + (multiple-value-bind + (class field) + (local-function-class-and-field local-function) + (emit-getstatic class field +lisp-object+)) + (when (compiland-closure-register *current-compiland*) + (duplicate-closure-array *current-compiland*) + (emit-invokestatic +lisp+ "makeCompiledClosure" + (list +lisp-object+ +closure-binding-array+) + +lisp-object+)) (emit-move-from-stack target)) (defknown p2-function (t t t) t) From ehuelsmann at common-lisp.net Sat Aug 13 21:54:55 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 13 Aug 2011 14:54:55 -0700 Subject: [armedbear-cvs] r13490 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 13 14:54:55 2011 New Revision: 13490 Log: More code duplication removal. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Aug 13 14:08:29 2011 (r13489) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Aug 13 14:54:55 2011 (r13490) @@ -467,6 +467,7 @@ (or (variable-register variable) ;; either register or index (variable-index variable))) ;; is non-nil for local variables + (defun emit-load-local-variable (variable) "Loads a local variable in the top stack position." (aver (variable-local-p variable)) @@ -2179,6 +2180,22 @@ (aload register))) ;; reload dest value +(defun emit-load-local-function (local-function) + (when (eq *current-compiland* (local-function-compiland local-function)) + (aload 0) + (return-from emit-load-local-function)) + (multiple-value-bind + (class field) + (local-function-class-and-field local-function) + (emit-getstatic class field +lisp-object+)) + (when *closure-variables* + (emit-checkcast +lisp-compiled-closure+) + (duplicate-closure-array *current-compiland*) + (emit-invokestatic +lisp+ "makeCompiledClosure" + (list +lisp-object+ +closure-binding-array+) + +lisp-object+))) + + (defknown compile-local-function-call (t t t) t) (defun compile-local-function-call (form target representation) @@ -2186,8 +2203,7 @@ Functions this applies to can be FLET, LABELS, LAMBDA or NAMED-LAMBDA. Note: DEFUN implies a named lambda." - (let* ((compiland *current-compiland*) - (op (car form)) + (let* ((op (car form)) (args (cdr form)) (local-function (find-local-function op)) (*register* *register*)) @@ -2204,16 +2220,7 @@ +lisp-object+)) (t (dformat t "compile-local-function-call default case~%") - (multiple-value-bind - (class field) - (local-function-class-and-field local-function) - (emit-getstatic class field +lisp-object+)) - (when *closure-variables* - (emit-checkcast +lisp-compiled-closure+) - (duplicate-closure-array compiland) - (emit-invokestatic +lisp+ "makeCompiledClosure" - (list +lisp-object+ +closure-binding-array+) - +lisp-object+)))) + (emit-load-local-function local-function))) (process-args args '(nil)) (emit-call-execute (length args)) (fix-boxing representation nil) @@ -4086,15 +4093,7 @@ (defun p2-lambda (local-function target) (compile-local-function local-function) - (multiple-value-bind - (class field) - (local-function-class-and-field local-function) - (emit-getstatic class field +lisp-object+)) - (when (compiland-closure-register *current-compiland*) - (duplicate-closure-array *current-compiland*) - (emit-invokestatic +lisp+ "makeCompiledClosure" - (list +lisp-object+ +closure-binding-array+) - +lisp-object+)) + (emit-load-local-function local-function) (emit-move-from-stack target)) (defknown p2-function (t t t) t) @@ -4109,16 +4108,7 @@ (cond ((setf local-function (find-local-function name)) (dformat t "p2-function 1~%") - (multiple-value-bind - (class field) - (local-function-class-and-field local-function) - (emit-getstatic class field +lisp-object+)) - (when (compiland-closure-register *current-compiland*) - (emit-checkcast +lisp-compiled-closure+) - (duplicate-closure-array *current-compiland*) - (emit-invokestatic +lisp+ "makeCompiledClosure" - (list +lisp-object+ +closure-binding-array+) - +lisp-object+)) + (emit-load-local-function local-function) (emit-move-from-stack target)) ((inline-ok name) (emit-getstatic *this-class* @@ -4135,16 +4125,7 @@ (cond ((setf local-function (find-local-function name)) (dformat t "p2-function 1~%") - (when (eq (local-function-compiland local-function) - *current-compiland*) - (aload 0) ; this - (emit-move-from-stack target) - (return-from p2-function)) - (multiple-value-bind - (class field) - (local-function-class-and-field local-function) - ; Stack: template-function - (emit-getstatic class field +lisp-object+))) + (emit-load-local-function local-function)) ((and (member name *functions-defined-in-current-file* :test #'equal) (not (notinline-p name))) (emit-getstatic *this-class* From ehuelsmann at common-lisp.net Sun Aug 14 10:18:26 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 14 Aug 2011 03:18:26 -0700 Subject: [armedbear-cvs] r13491 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 14 03:18:25 2011 New Revision: 13491 Log: Start cutting up the huge CASE statement that makes up our file compilation, in favor of using dispatch tables just like other parts of our compilation process (precompile, pass1, pass2). Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Sat Aug 13 14:54:55 2011 (r13490) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Sun Aug 14 03:18:25 2011 (r13491) @@ -94,18 +94,6 @@ (declare (ignore classfile)) t) -(declaim (ftype (function (t) t) process-defconstant)) -(defun process-defconstant (form) - ;; "If a DEFCONSTANT form appears as a top level form, the compiler - ;; must recognize that [the] name names a constant variable. An - ;; implementation may choose to evaluate the value-form at compile - ;; time, load time, or both. Therefore, users must ensure that the - ;; initial-value can be evaluated at compile time (regardless of - ;; whether or not references to name appear in the file) and that - ;; it always evaluates to the same value." - (eval form) - (output-form form)) - (declaim (ftype (function (t) t) note-toplevel-form)) (defun note-toplevel-form (form) (when *compile-print* @@ -117,232 +105,295 @@ (prin1 form)) (terpri))) + +(declaim (ftype (function (t t t) t) process-toplevel-defconstant)) +(defun process-toplevel-defconstant (form stream compile-time-too) + (declare (ignore stream compile-time-too)) + ;; "If a DEFCONSTANT form appears as a top level form, the compiler + ;; must recognize that [the] name names a constant variable. An + ;; implementation may choose to evaluate the value-form at compile + ;; time, load time, or both. Therefore, users must ensure that the + ;; initial-value can be evaluated at compile time (regardless of + ;; whether or not references to name appear in the file) and that + ;; it always evaluates to the same value." + (note-toplevel-form form) + (eval form) + form) + +(declaim (ftype (function (t t t) t) process-toplevel-defvar/defparameter)) +(defun process-toplevel-defvar/defparameter (form stream compile-time-too) + (declare (ignore stream)) + (note-toplevel-form form) + (if compile-time-too + (eval form) + ;; "If a DEFVAR or DEFPARAMETER form appears as a top level form, + ;; the compiler must recognize that the name has been proclaimed + ;; special. However, it must neither evaluate the initial-value + ;; form nor assign the dynamic variable named NAME at compile + ;; time." + (let ((name (second form))) + (%defvar name))) + form) + +(declaim (ftype (function (t t t) t) process-toplevel-defpackage/in-package)) +(defun process-toplevel-defpackage/in-package (form stream compile-time-too) + (declare (ignore stream compile-time-too)) + (note-toplevel-form form) + (setf form + (precompiler:precompile-form form nil *compile-file-environment*)) + (eval form) + ;; Force package prefix to be used when dumping form. + (let ((*package* +keyword-package+)) + (output-form form)) + nil) + +(declaim (ftype (function (t t t) t) process-toplevel-declare)) +(defun process-toplevel-declare (form stream compile-time-too) + (declare (ignore stream compile-time-too)) + (compiler-style-warn "Misplaced declaration: ~S" form) + nil) + +(declaim (ftype (function (t t t) t) process-toplevel-progn)) +(defun process-toplevel-progn (form stream compile-time-too) + (process-progn (cdr form) stream compile-time-too) + nil) + +(declaim (ftype (function (t t t) t) process-toplevel-deftype)) +(defun process-toplevel-deftype (form stream compile-time-too) + (declare (ignore stream compile-time-too)) + (note-toplevel-form form) + (eval form) + form) + +(declaim (ftype (function (t t t) t) process-toplevel-eval-when)) +(defun process-toplevel-eval-when (form stream compile-time-too) + (multiple-value-bind (ct lt e) + (parse-eval-when-situations (cadr form)) + (let ((new-compile-time-too (or ct (and compile-time-too e))) + (body (cddr form))) + (if lt + (process-progn body stream new-compile-time-too) + (when new-compile-time-too + (eval `(progn , at body)))))) + nil) + + +(declaim (ftype (function (t t t) t) process-toplevel-defmethod/defgeneric)) +(defun process-toplevel-defmethod/defgeneric (form stream compile-time-too) + (note-toplevel-form form) + (note-name-defined (second form)) + (let ((*compile-print* nil)) + (process-toplevel-form (macroexpand-1 form *compile-file-environment*) + stream compile-time-too)) + nil) + +(declaim (ftype (function (t t t) t) process-toplevel-locally)) +(defun process-toplevel-locally (form stream compile-time-too) + (jvm::with-saved-compiler-policy + (multiple-value-bind (forms decls) + (parse-body (cdr form) nil) + (process-optimization-declarations decls) + (let* ((jvm::*visible-variables* jvm::*visible-variables*) + (specials (jvm::process-declarations-for-vars (cdr form) + nil nil))) + (dolist (special specials) + (push special jvm::*visible-variables*)) + (process-progn forms stream compile-time-too)))) + nil) + +(declaim (ftype (function (t t t) t) process-toplevel-defmacro)) +(defun process-toplevel-defmacro (form stream compile-time-too) + (declare (ignore stream compile-time-too)) + (note-toplevel-form form) + (let ((name (second form))) + (eval form) + (let* ((expr (function-lambda-expression (macro-function name))) + (saved-class-number *class-number*) + (classfile (next-classfile-name))) + (with-open-file + (f classfile + :direction :output + :element-type '(unsigned-byte 8) + :if-exists :supersede) + (ignore-errors + (jvm:compile-defun nil expr *compile-file-environment* + classfile f nil))) + (when (null (verify-load classfile)) + ;; FIXME error or warning + (format *error-output* "; Unable to compile macro ~A~%" name) + (return-from process-toplevel-defmacro form)) + + (if (special-operator-p name) + `(put ',name 'macroexpand-macro + (make-macro ',name + (sys::get-fasl-function *fasl-loader* ,saved-class-number))) + `(fset ',name + (make-macro ',name + (sys::get-fasl-function *fasl-loader* ,saved-class-number)) + ,*source-position* + ',(third form)))))) + +(declaim (ftype (function (t t t) t) process-toplevel-defun)) +(defun process-toplevel-defun (form stream compile-time-too) + (declare (ignore stream)) + (note-toplevel-form form) + (let* ((name (second form)) + (block-name (fdefinition-block-name name)) + (lambda-list (third form)) + (body (nthcdr 3 form))) + (jvm::with-saved-compiler-policy + (multiple-value-bind (body decls doc) + (parse-body body) + (let* ((expr `(lambda ,lambda-list + , at decls (block ,block-name , at body))) + (saved-class-number *class-number*) + (classfile (next-classfile-name)) + (internal-compiler-errors nil) + (result (with-open-file + (f classfile + :direction :output + :element-type '(unsigned-byte 8) + :if-exists :supersede) + (handler-bind + ((internal-compiler-error + #'(lambda (e) + (push e internal-compiler-errors) + (continue)))) + (report-error + (jvm:compile-defun name expr *compile-file-environment* + classfile f nil))))) + (compiled-function (if (not internal-compiler-errors) + (verify-load classfile) + nil))) + (declare (ignore result)) + (cond + ((and (not internal-compiler-errors) + compiled-function) + (when compile-time-too + (eval form)) + (setf form + `(fset ',name + (sys::get-fasl-function *fasl-loader* + ,saved-class-number) + ,*source-position* + ',lambda-list + ,doc))) + (t + (compiler-warn "Unable to compile function ~A. Using interpreted form instead.~%" name) + (when internal-compiler-errors + (dolist (e internal-compiler-errors) + (format *error-output* + "; ~A~%" e))) + (let ((precompiled-function + (precompiler:precompile-form expr nil + *compile-file-environment*))) + (setf form + `(fset ',name + ,precompiled-function + ,*source-position* + ',lambda-list + ,doc))) + (when compile-time-too + (eval form))))) + (when (and (symbolp name) (eq (get name '%inline) 'INLINE)) + ;; FIXME Need to support SETF functions too! + (setf (inline-expansion name) + (jvm::generate-inline-expansion block-name + lambda-list body)) + (output-form `(setf (inline-expansion ',name) + ',(inline-expansion name)))))) + (push name jvm::*functions-defined-in-current-file*) + (note-name-defined name) + ;; If NAME is not fbound, provide a dummy definition so that + ;; getSymbolFunctionOrDie() will succeed when we try to verify that + ;; functions defined later in the same file can be loaded correctly. + (unless (fboundp name) + (setf (fdefinition name) #'dummy) + (push name *fbound-names*))) + form) + + +;; toplevel handlers +;; each toplevel handler takes a form and stream as input + +(defun install-toplevel-handler (symbol handler) + (setf (get symbol 'toplevel-handler) handler)) + +(dolist (pair '( + (DECLARE process-toplevel-declare) + (DEFCONSTANT process-toplevel-defconstant) + (DEFGENERIC process-toplevel-defmethod/defgeneric) + (DEFMACRO process-toplevel-defmacro) + (DEFMETHOD process-toplevel-defmethod/defgeneric) + (DEFPACKAGE process-toplevel-defpackage/in-package) + (DEFPARAMETER process-toplevel-defvar/defparameter) + (DEFTYPE process-toplevel-deftype) + (DEFUN process-toplevel-defun) + (DEFVAR process-toplevel-defvar/defparameter) + (EVAL-WHEN process-toplevel-eval-when) + (IN-PACKAGE process-toplevel-defpackage/in-package) + (LOCALLY process-toplevel-locally) + (MACROLET process-toplevel-macrolet) + (PROGN process-toplevel-progn) +)) + (install-toplevel-handler (car pair) (cadr pair))) + (declaim (ftype (function (t stream t) t) process-toplevel-form)) (defun process-toplevel-form (form stream compile-time-too) (if (atom form) (when compile-time-too (eval form)) (progn - (let ((operator (%car form))) - (case operator - (MACROLET - (process-toplevel-macrolet form stream compile-time-too) + (let* ((operator (%car form)) + (handler (get operator 'toplevel-handler))) + (when handler + (let ((out-form (funcall handler form stream compile-time-too))) + (when out-form + (output-form out-form))) + (return-from process-toplevel-form)) + (when (and (symbolp operator) + (macro-function operator *compile-file-environment*)) + (note-toplevel-form form) + ;; Note that we want MACROEXPAND-1 and not MACROEXPAND here, in + ;; case the form being expanded expands into something that needs + ;; special handling by PROCESS-TOPLEVEL-FORM (e.g. DEFMACRO). + (let ((*compile-print* nil)) + (process-toplevel-form (macroexpand-1 form *compile-file-environment*) + stream compile-time-too)) + (return-from process-toplevel-form)) + + (cond + ((eq operator 'QUOTE) +;;; (setf form (precompiler:precompile-form form nil +;;; *compile-file-environment*)) + (when compile-time-too + (eval form)) (return-from process-toplevel-form)) - ((IN-PACKAGE DEFPACKAGE) - (note-toplevel-form form) + ((eq operator 'PUT) + (setf form (precompiler:precompile-form form nil *compile-file-environment*))) + ((eq operator 'COMPILER-DEFSTRUCT) + (setf form (precompiler:precompile-form form nil *compile-file-environment*))) + ((eq operator 'PROCLAIM) + (setf form (precompiler:precompile-form form nil *compile-file-environment*))) + ((and (memq operator '(EXPORT REQUIRE PROVIDE SHADOW)) + (or (keywordp (second form)) + (and (listp (second form)) + (eq (first (second form)) 'QUOTE)))) + (setf form (precompiler:precompile-form form nil *compile-file-environment*))) + ((eq operator 'IMPORT) (setf form (precompiler:precompile-form form nil *compile-file-environment*)) - (eval form) - ;; Force package prefix to be used when dumping form. + ;; Make sure package prefix is printed when symbols are imported. (let ((*package* +keyword-package+)) (output-form form)) + (when compile-time-too + (eval form)) (return-from process-toplevel-form)) - ((DEFVAR DEFPARAMETER) - (note-toplevel-form form) - (if compile-time-too - (eval form) - ;; "If a DEFVAR or DEFPARAMETER form appears as a top level form, - ;; the compiler must recognize that the name has been proclaimed - ;; special. However, it must neither evaluate the initial-value - ;; form nor assign the dynamic variable named NAME at compile - ;; time." - (let ((name (second form))) - (%defvar name)))) - (DEFCONSTANT - (note-toplevel-form form) - (process-defconstant form) - (return-from process-toplevel-form)) - (DEFUN - (note-toplevel-form form) - (let* ((name (second form)) - (block-name (fdefinition-block-name name)) - (lambda-list (third form)) - (body (nthcdr 3 form))) - (jvm::with-saved-compiler-policy - (multiple-value-bind (body decls doc) - (parse-body body) - (let* ((expr `(lambda ,lambda-list - , at decls (block ,block-name , at body))) - (saved-class-number *class-number*) - (classfile (next-classfile-name)) - (internal-compiler-errors nil) - (result (with-open-file - (f classfile - :direction :output - :element-type '(unsigned-byte 8) - :if-exists :supersede) - (handler-bind - ((internal-compiler-error - #'(lambda (e) - (push e internal-compiler-errors) - (continue)))) - (report-error - (jvm:compile-defun name expr *compile-file-environment* - classfile f nil))))) - (compiled-function (if (not internal-compiler-errors) - (verify-load classfile) - nil))) - (declare (ignore result)) - (cond - ((and (not internal-compiler-errors) - compiled-function) - (setf form - `(fset ',name - (sys::get-fasl-function *fasl-loader* - ,saved-class-number) - ,*source-position* - ',lambda-list - ,doc)) - (when compile-time-too - (fset name compiled-function))) - (t - ;; Add this warning when the stock ABCL compiles - ;; again, as all warnings in COMPILE-SYSTEM - ;; produce a non-zero exit status that stops - ;; build.xml in its tracks. - #+nil - (compiler-warn "Unable to compile function ~A. Using interpreted form instead.~%" name) - (format *error-output* - "; Unable to compile function ~A. Using interpreted form instead.~%" name) - (when internal-compiler-errors - (dolist (e internal-compiler-errors) - (format *error-output* - "; ~A~%" e))) - (let ((precompiled-function - (precompiler:precompile-form expr nil - *compile-file-environment*))) - (setf form - `(fset ',name - ,precompiled-function - ,*source-position* - ',lambda-list - ,doc))) - (when compile-time-too - (eval form))))) - (when (and (symbolp name) (eq (get name '%inline) 'INLINE)) - ;; FIXME Need to support SETF functions too! - (setf (inline-expansion name) - (jvm::generate-inline-expansion block-name - lambda-list body)) - (output-form `(setf (inline-expansion ',name) - ',(inline-expansion name)))))) - (push name jvm::*functions-defined-in-current-file*) - (note-name-defined name) - ;; If NAME is not fbound, provide a dummy definition so that - ;; getSymbolFunctionOrDie() will succeed when we try to verify that - ;; functions defined later in the same file can be loaded correctly. - (unless (fboundp name) - (setf (fdefinition name) #'dummy) - (push name *fbound-names*)))) - ((DEFGENERIC DEFMETHOD) - (note-toplevel-form form) - (note-name-defined (second form)) - (let ((*compile-print* nil)) - (process-toplevel-form (macroexpand-1 form *compile-file-environment*) - stream compile-time-too)) - (return-from process-toplevel-form)) - (DEFMACRO - (note-toplevel-form form) - (let ((name (second form))) - (eval form) - (let* ((expr (function-lambda-expression (macro-function name))) - (saved-class-number *class-number*) - (classfile (next-classfile-name))) - (with-open-file - (f classfile - :direction :output - :element-type '(unsigned-byte 8) - :if-exists :supersede) - (ignore-errors - (jvm:compile-defun nil expr *compile-file-environment* - classfile f nil))) - (if (null (verify-load classfile)) - ;; FIXME error or warning - (format *error-output* "; Unable to compile macro ~A~%" name) - (progn - (setf form - (if (special-operator-p name) - `(put ',name 'macroexpand-macro - (make-macro ',name - (sys::get-fasl-function *fasl-loader* ,saved-class-number))) - `(fset ',name - (make-macro ',name - (sys::get-fasl-function *fasl-loader* ,saved-class-number)) - ,*source-position* - ',(third form))))))))) - (DEFTYPE - (note-toplevel-form form) - (eval form)) - (EVAL-WHEN - (multiple-value-bind (ct lt e) - (parse-eval-when-situations (cadr form)) - (let ((new-compile-time-too (or ct (and compile-time-too e))) - (body (cddr form))) - (if lt - (process-toplevel-progn body stream new-compile-time-too) - (when new-compile-time-too - (eval `(progn , at body))))) - (return-from process-toplevel-form))) - (LOCALLY - ;; FIXME Need to handle special declarations too! - (jvm::with-saved-compiler-policy - (multiple-value-bind (forms decls) - (parse-body (cdr form) nil) - (process-optimization-declarations decls) - (let* ((jvm::*visible-variables* jvm::*visible-variables*) - (specials (jvm::process-declarations-for-vars (cdr form) - nil nil))) - (dolist (special specials) - (push special jvm::*visible-variables*)) - (process-toplevel-progn forms stream compile-time-too)) - (return-from process-toplevel-form)))) - (PROGN - (process-toplevel-progn (cdr form) stream compile-time-too) - (return-from process-toplevel-form)) - (DECLARE - (compiler-style-warn "Misplaced declaration: ~S" form)) - (t - (when (and (symbolp operator) - (macro-function operator *compile-file-environment*)) - (note-toplevel-form form) - ;; Note that we want MACROEXPAND-1 and not MACROEXPAND here, in - ;; case the form being expanded expands into something that needs - ;; special handling by PROCESS-TOPLEVEL-FORM (e.g. DEFMACRO). - (let ((*compile-print* nil)) - (process-toplevel-form (macroexpand-1 form *compile-file-environment*) - stream compile-time-too)) - (return-from process-toplevel-form)) - - (cond ((eq operator 'QUOTE) -;;; (setf form (precompiler:precompile-form form nil -;;; *compile-file-environment*)) - (when compile-time-too - (eval form)) - (return-from process-toplevel-form)) - ((eq operator 'PUT) - (setf form (precompiler:precompile-form form nil *compile-file-environment*))) - ((eq operator 'COMPILER-DEFSTRUCT) - (setf form (precompiler:precompile-form form nil *compile-file-environment*))) - ((eq operator 'PROCLAIM) - (setf form (precompiler:precompile-form form nil *compile-file-environment*))) - ((and (memq operator '(EXPORT REQUIRE PROVIDE SHADOW)) - (or (keywordp (second form)) - (and (listp (second form)) - (eq (first (second form)) 'QUOTE)))) - (setf form (precompiler:precompile-form form nil *compile-file-environment*))) - ((eq operator 'IMPORT) - (setf form (precompiler:precompile-form form nil *compile-file-environment*)) - ;; Make sure package prefix is printed when symbols are imported. - (let ((*package* +keyword-package+)) - (output-form form)) - (when compile-time-too - (eval form)) - (return-from process-toplevel-form)) - ((and (eq operator '%SET-FDEFINITION) - (eq (car (second form)) 'QUOTE) - (consp (third form)) - (eq (%car (third form)) 'FUNCTION) - (symbolp (cadr (third form)))) - (setf form (precompiler:precompile-form form nil *compile-file-environment*))) + ((and (eq operator '%SET-FDEFINITION) + (eq (car (second form)) 'QUOTE) + (consp (third form)) + (eq (%car (third form)) 'FUNCTION) + (symbolp (cadr (third form)))) + (setf form (precompiler:precompile-form form nil *compile-file-environment*))) ;;; ((memq operator '(LET LET*)) ;;; (let ((body (cddr form))) ;;; (if (dolist (subform body nil) @@ -350,16 +401,16 @@ ;;; (return t))) ;;; (setf form (convert-toplevel-form form)) ;;; (setf form (precompiler:precompile-form form nil))))) - ((eq operator 'mop::ensure-method) - (setf form (convert-ensure-method form))) - ((and (symbolp operator) - (not (special-operator-p operator)) - (null (cdr form))) - (setf form (precompiler:precompile-form form nil *compile-file-environment*))) - (t + ((eq operator 'mop::ensure-method) + (setf form (convert-ensure-method form))) + ((and (symbolp operator) + (not (special-operator-p operator)) + (null (cdr form))) + (setf form (precompiler:precompile-form form nil *compile-file-environment*))) + (t ;;; (setf form (precompiler:precompile-form form nil)) - (note-toplevel-form form) - (setf form (convert-toplevel-form form nil))))))))) + (note-toplevel-form form) + (setf form (convert-toplevel-form form nil))))))) (when (consp form) (output-form form)) ;; Make sure the compiled-function loader knows where @@ -463,12 +514,14 @@ (make-macro (car definition) (make-expander-for-macrolet definition)))) (dolist (body-form (cddr form)) - (process-toplevel-form body-form stream compile-time-too)))) + (process-toplevel-form body-form stream compile-time-too))) + nil) ;; nothing to be sent to output -(declaim (ftype (function (t stream t) t) process-toplevel-progn)) -(defun process-toplevel-progn (forms stream compile-time-too) +(declaim (ftype (function (t stream t) t) process-progn)) +(defun process-progn (forms stream compile-time-too) (dolist (form forms) - (process-toplevel-form form stream compile-time-too))) + (process-toplevel-form form stream compile-time-too)) + nil) ;;; Adapted from SBCL. ;;; Parse an EVAL-WHEN situations list, returning three flags, From ehuelsmann at common-lisp.net Sun Aug 14 10:24:33 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 14 Aug 2011 03:24:33 -0700 Subject: [armedbear-cvs] r13492 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 14 03:24:32 2011 New Revision: 13492 Log: Reindenting and removal of code which was commented out for years now. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Sun Aug 14 03:18:25 2011 (r13491) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Sun Aug 14 03:24:32 2011 (r13492) @@ -364,24 +364,27 @@ (cond ((eq operator 'QUOTE) -;;; (setf form (precompiler:precompile-form form nil -;;; *compile-file-environment*)) (when compile-time-too (eval form)) (return-from process-toplevel-form)) ((eq operator 'PUT) - (setf form (precompiler:precompile-form form nil *compile-file-environment*))) + (setf form (precompiler:precompile-form form nil + *compile-file-environment*))) ((eq operator 'COMPILER-DEFSTRUCT) - (setf form (precompiler:precompile-form form nil *compile-file-environment*))) + (setf form (precompiler:precompile-form form nil + *compile-file-environment*))) ((eq operator 'PROCLAIM) - (setf form (precompiler:precompile-form form nil *compile-file-environment*))) + (setf form (precompiler:precompile-form form nil + *compile-file-environment*))) ((and (memq operator '(EXPORT REQUIRE PROVIDE SHADOW)) (or (keywordp (second form)) (and (listp (second form)) (eq (first (second form)) 'QUOTE)))) - (setf form (precompiler:precompile-form form nil *compile-file-environment*))) + (setf form (precompiler:precompile-form form nil + *compile-file-environment*))) ((eq operator 'IMPORT) - (setf form (precompiler:precompile-form form nil *compile-file-environment*)) + (setf form (precompiler:precompile-form form nil + *compile-file-environment*)) ;; Make sure package prefix is printed when symbols are imported. (let ((*package* +keyword-package+)) (output-form form)) @@ -393,22 +396,16 @@ (consp (third form)) (eq (%car (third form)) 'FUNCTION) (symbolp (cadr (third form)))) - (setf form (precompiler:precompile-form form nil *compile-file-environment*))) -;;; ((memq operator '(LET LET*)) -;;; (let ((body (cddr form))) -;;; (if (dolist (subform body nil) -;;; (when (and (consp subform) (eq (%car subform) 'DEFUN)) -;;; (return t))) -;;; (setf form (convert-toplevel-form form)) -;;; (setf form (precompiler:precompile-form form nil))))) + (setf form (precompiler:precompile-form form nil + *compile-file-environment*))) ((eq operator 'mop::ensure-method) (setf form (convert-ensure-method form))) ((and (symbolp operator) (not (special-operator-p operator)) (null (cdr form))) - (setf form (precompiler:precompile-form form nil *compile-file-environment*))) + (setf form (precompiler:precompile-form form nil + *compile-file-environment*))) (t -;;; (setf form (precompiler:precompile-form form nil)) (note-toplevel-form form) (setf form (convert-toplevel-form form nil))))))) (when (consp form) @@ -421,7 +418,8 @@ (let ((*load-truename* *output-file-pathname*) (*fasl-loader* (make-fasl-class-loader nil - (concatenate 'string "org.armedbear.lisp." (base-classname)) + (concatenate 'string + "org.armedbear.lisp." (base-classname)) nil))) (eval form)))) From ehuelsmann at common-lisp.net Sun Aug 14 11:27:55 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 14 Aug 2011 04:27:55 -0700 Subject: [armedbear-cvs] r13493 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 14 04:27:54 2011 New Revision: 13493 Log: More refactoring. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Sun Aug 14 03:24:32 2011 (r13492) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Sun Aug 14 04:27:54 2011 (r13493) @@ -106,6 +106,19 @@ (terpri))) +(declaim (ftype (function (t t t) t) process-toplevel-quote)) +(defun precompile-toplevel-form (form stream compile-time-too) + (declare (ignore stream)) + (let ((form (precompiler:precompile-form form nil + *compile-file-environment*))) + (when compile-time-too + (eval form)) + form)) + + + + + (declaim (ftype (function (t t t) t) process-toplevel-defconstant)) (defun process-toplevel-defconstant (form stream compile-time-too) (declare (ignore stream compile-time-too)) @@ -120,6 +133,33 @@ (eval form) form) +(declaim (ftype (function (t t t) t) process-toplevel-quote)) +(defun process-toplevel-quote (form stream compile-time-too) + (declare (ignore stream)) + (when compile-time-too + (eval form)) + nil) + + +(declaim (ftype (function (t t t) t) process-toplevel-import)) +(defun process-toplevel-import (form stream compile-time-too) + (declare (ignore stream)) + (let ((form (precompiler:precompile-form form nil + *compile-file-environment*))) + (let ((*package* +keyword-package+)) + (output-form form)) + (when compile-time-too + (eval form))) + nil) + +(declaim (ftype (function (t t t) t) process-toplevel-mop.ensure-method)) +(defun process-toplevel-mop.ensure-method (form stream compile-time-too) + (declare (ignore stream)) + (let ((form (convert-ensure-method form))) + (when compile-time-too + (eval form)) + form)) + (declaim (ftype (function (t t t) t) process-toplevel-defvar/defparameter)) (defun process-toplevel-defvar/defparameter (form stream compile-time-too) (declare (ignore stream)) @@ -319,7 +359,7 @@ (defun install-toplevel-handler (symbol handler) (setf (get symbol 'toplevel-handler) handler)) -(dolist (pair '( +(dolist (pair '((COMPILER-DEFSTRUCT precompile-toplevel-form) (DECLARE process-toplevel-declare) (DEFCONSTANT process-toplevel-defconstant) (DEFGENERIC process-toplevel-defmethod/defgeneric) @@ -331,10 +371,20 @@ (DEFUN process-toplevel-defun) (DEFVAR process-toplevel-defvar/defparameter) (EVAL-WHEN process-toplevel-eval-when) + (EXPORT precompile-toplevel-form) +;; (IMPORT precompile-toplevel-form) (IN-PACKAGE process-toplevel-defpackage/in-package) (LOCALLY process-toplevel-locally) (MACROLET process-toplevel-macrolet) + (PROCLAIM precompile-toplevel-form) (PROGN process-toplevel-progn) + (PROVIDE precompile-toplevel-form) + (PUT precompile-toplevel-form) + (QUOTE process-toplevel-quote) + (REQUIRE precompile-toplevel-form) + (SHADOW precompile-toplevel-form) + (%SET-FDEFINITION precompile-toplevel-form) + (MOP::ENSURE-METHOD process-toplevel-mop.ensure-method) )) (install-toplevel-handler (car pair) (cadr pair))) @@ -363,43 +413,6 @@ (return-from process-toplevel-form)) (cond - ((eq operator 'QUOTE) - (when compile-time-too - (eval form)) - (return-from process-toplevel-form)) - ((eq operator 'PUT) - (setf form (precompiler:precompile-form form nil - *compile-file-environment*))) - ((eq operator 'COMPILER-DEFSTRUCT) - (setf form (precompiler:precompile-form form nil - *compile-file-environment*))) - ((eq operator 'PROCLAIM) - (setf form (precompiler:precompile-form form nil - *compile-file-environment*))) - ((and (memq operator '(EXPORT REQUIRE PROVIDE SHADOW)) - (or (keywordp (second form)) - (and (listp (second form)) - (eq (first (second form)) 'QUOTE)))) - (setf form (precompiler:precompile-form form nil - *compile-file-environment*))) - ((eq operator 'IMPORT) - (setf form (precompiler:precompile-form form nil - *compile-file-environment*)) - ;; Make sure package prefix is printed when symbols are imported. - (let ((*package* +keyword-package+)) - (output-form form)) - (when compile-time-too - (eval form)) - (return-from process-toplevel-form)) - ((and (eq operator '%SET-FDEFINITION) - (eq (car (second form)) 'QUOTE) - (consp (third form)) - (eq (%car (third form)) 'FUNCTION) - (symbolp (cadr (third form)))) - (setf form (precompiler:precompile-form form nil - *compile-file-environment*))) - ((eq operator 'mop::ensure-method) - (setf form (convert-ensure-method form))) ((and (symbolp operator) (not (special-operator-p operator)) (null (cdr form))) @@ -463,12 +476,12 @@ "Returns NIL if the form is too complex to become an interpreted toplevel form, non-NIL if it is 'simple enough'." (and (consp form) - (every #'(lambda (arg) - (or (and (atom arg) - (not (and (symbolp arg) - (symbol-macro-p arg)))) - (and (consp arg) - (eq 'QUOTE (car arg))))) + (every #'(lambda (arg) + (or (and (atom arg) + (not (and (symbolp arg) + (symbol-macro-p arg)))) + (and (consp arg) + (eq 'QUOTE (car arg))))) (cdr form)))) (declaim (ftype (function (t t) t) convert-toplevel-form)) From ehuelsmann at common-lisp.net Sun Aug 14 13:19:33 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 14 Aug 2011 06:19:33 -0700 Subject: [armedbear-cvs] r13494 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 14 06:19:32 2011 New Revision: 13494 Log: Only evaluate atoms in the input stream once. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Sun Aug 14 04:27:54 2011 (r13493) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Sun Aug 14 06:19:32 2011 (r13494) @@ -390,39 +390,36 @@ (declaim (ftype (function (t stream t) t) process-toplevel-form)) (defun process-toplevel-form (form stream compile-time-too) - (if (atom form) - (when compile-time-too - (eval form)) - (progn - (let* ((operator (%car form)) - (handler (get operator 'toplevel-handler))) - (when handler - (let ((out-form (funcall handler form stream compile-time-too))) - (when out-form - (output-form out-form))) - (return-from process-toplevel-form)) - (when (and (symbolp operator) - (macro-function operator *compile-file-environment*)) - (note-toplevel-form form) - ;; Note that we want MACROEXPAND-1 and not MACROEXPAND here, in - ;; case the form being expanded expands into something that needs - ;; special handling by PROCESS-TOPLEVEL-FORM (e.g. DEFMACRO). - (let ((*compile-print* nil)) - (process-toplevel-form (macroexpand-1 form *compile-file-environment*) - stream compile-time-too)) - (return-from process-toplevel-form)) + (unless (atom form) + (let* ((operator (%car form)) + (handler (get operator 'toplevel-handler))) + (when handler + (let ((out-form (funcall handler form stream compile-time-too))) + (when out-form + (output-form out-form))) + (return-from process-toplevel-form)) + (when (and (symbolp operator) + (macro-function operator *compile-file-environment*)) + (note-toplevel-form form) + ;; Note that we want MACROEXPAND-1 and not MACROEXPAND here, in + ;; case the form being expanded expands into something that needs + ;; special handling by PROCESS-TOPLEVEL-FORM (e.g. DEFMACRO). + (let ((*compile-print* nil)) + (process-toplevel-form (macroexpand-1 form *compile-file-environment*) + stream compile-time-too)) + (return-from process-toplevel-form)) - (cond - ((and (symbolp operator) - (not (special-operator-p operator)) - (null (cdr form))) - (setf form (precompiler:precompile-form form nil - *compile-file-environment*))) - (t - (note-toplevel-form form) - (setf form (convert-toplevel-form form nil))))))) - (when (consp form) - (output-form form)) + (cond + ((and (symbolp operator) + (not (special-operator-p operator)) + (null (cdr form))) + (setf form (precompiler:precompile-form form nil + *compile-file-environment*))) + (t + (note-toplevel-form form) + (setf form (convert-toplevel-form form nil))))) + (when (consp form) + (output-form form))) ;; Make sure the compiled-function loader knows where ;; to load the compiled functions. Note that this trickery ;; was already used in verify-load before I used it, From ehuelsmann at common-lisp.net Sun Aug 14 15:09:46 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 14 Aug 2011 08:09:46 -0700 Subject: [armedbear-cvs] r13495 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 14 08:09:46 2011 New Revision: 13495 Log: Uncomment file-compilation of IMPORT forms. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Sun Aug 14 06:19:32 2011 (r13494) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Sun Aug 14 08:09:46 2011 (r13495) @@ -106,7 +106,7 @@ (terpri))) -(declaim (ftype (function (t t t) t) process-toplevel-quote)) +(declaim (ftype (function (t t t) t) process-toplevel-form)) (defun precompile-toplevel-form (form stream compile-time-too) (declare (ignore stream)) (let ((form (precompiler:precompile-form form nil @@ -372,7 +372,7 @@ (DEFVAR process-toplevel-defvar/defparameter) (EVAL-WHEN process-toplevel-eval-when) (EXPORT precompile-toplevel-form) -;; (IMPORT precompile-toplevel-form) + (IMPORT process-toplevel-import) (IN-PACKAGE process-toplevel-defpackage/in-package) (LOCALLY process-toplevel-locally) (MACROLET process-toplevel-macrolet) @@ -384,8 +384,7 @@ (REQUIRE precompile-toplevel-form) (SHADOW precompile-toplevel-form) (%SET-FDEFINITION precompile-toplevel-form) - (MOP::ENSURE-METHOD process-toplevel-mop.ensure-method) -)) + (MOP::ENSURE-METHOD process-toplevel-mop.ensure-method))) (install-toplevel-handler (car pair) (cadr pair))) (declaim (ftype (function (t stream t) t) process-toplevel-form)) From ehuelsmann at common-lisp.net Sun Aug 14 17:17:44 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 14 Aug 2011 10:17:44 -0700 Subject: [armedbear-cvs] r13496 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 14 10:17:44 2011 New Revision: 13496 Log: Move code around to benefit from performance advantages with backward referenced functions. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Sun Aug 14 08:09:46 2011 (r13495) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Sun Aug 14 10:17:44 2011 (r13496) @@ -105,6 +105,32 @@ (prin1 form)) (terpri))) +(defun output-form (form) + (if *binary-fasls* + (push form *forms-for-output*) + (progn + (dump-form form *fasl-stream*) + (%stream-terpri *fasl-stream*)))) + +(defun finalize-fasl-output () + (when *binary-fasls* + (let ((*package* (find-package :keyword)) + (*double-colon-package-separators* T)) + (dump-form (convert-toplevel-form (list* 'PROGN + (nreverse *forms-for-output*)) + t) + *fasl-stream*)) + (%stream-terpri *fasl-stream*))) + + + + +(declaim (ftype (function (t stream t) t) process-progn)) +(defun process-progn (forms stream compile-time-too) + (dolist (form forms) + (process-toplevel-form form stream compile-time-too)) + nil) + (declaim (ftype (function (t t t) t) process-toplevel-form)) (defun precompile-toplevel-form (form stream compile-time-too) @@ -117,7 +143,17 @@ - +(defun process-toplevel-macrolet (form stream compile-time-too) + (let ((*compile-file-environment* + (make-environment *compile-file-environment*))) + (dolist (definition (cadr form)) + (environment-add-macro-definition *compile-file-environment* + (car definition) + (make-macro (car definition) + (make-expander-for-macrolet definition)))) + (dolist (body-form (cddr form)) + (process-toplevel-form body-form stream compile-time-too))) + nil) (declaim (ftype (function (t t t) t) process-toplevel-defconstant)) (defun process-toplevel-defconstant (form stream compile-time-too) @@ -155,7 +191,41 @@ (declaim (ftype (function (t t t) t) process-toplevel-mop.ensure-method)) (defun process-toplevel-mop.ensure-method (form stream compile-time-too) (declare (ignore stream)) - (let ((form (convert-ensure-method form))) + (flet ((convert-ensure-method (form key) + (let* ((tail (cddr form)) + (function-form (getf tail key))) + (when (and function-form (consp function-form) + (eq (%car function-form) 'FUNCTION)) + (let ((lambda-expression (cadr function-form))) + (jvm::with-saved-compiler-policy + (let* ((saved-class-number *class-number*) + (classfile (next-classfile-name)) + (result + (with-open-file + (f classfile + :direction :output + :element-type '(unsigned-byte 8) + :if-exists :supersede) + (report-error + (jvm:compile-defun nil lambda-expression + *compile-file-environment* + classfile f nil)))) + (compiled-function (verify-load classfile))) + (declare (ignore result)) + (cond + (compiled-function + (setf (getf tail key) + `(sys::get-fasl-function *fasl-loader* + ,saved-class-number))) + (t + ;; FIXME This should be a warning or error of some sort... + (format *error-output* "; Unable to compile method~%")))))))))) + + + (convert-ensure-method form :function) + (convert-ensure-method form :fast-function)) + (let ((form (precompiler:precompile-form form nil + *compile-file-environment*))) (when compile-time-too (eval form)) form)) @@ -207,14 +277,31 @@ (declaim (ftype (function (t t t) t) process-toplevel-eval-when)) (defun process-toplevel-eval-when (form stream compile-time-too) - (multiple-value-bind (ct lt e) - (parse-eval-when-situations (cadr form)) - (let ((new-compile-time-too (or ct (and compile-time-too e))) - (body (cddr form))) - (if lt - (process-progn body stream new-compile-time-too) - (when new-compile-time-too - (eval `(progn , at body)))))) + (flet ((parse-eval-when-situations (situations) + "Parse an EVAL-WHEN situations list, returning three flags, + (VALUES COMPILE-TOPLEVEL LOAD-TOPLEVEL EXECUTE), indicating + the types of situations present in the list." + ; Adapted from SBCL. + (when (or (not (listp situations)) + (set-difference situations + '(:compile-toplevel + compile + :load-toplevel + load + :execute + eval))) + (error "Bad EVAL-WHEN situation list: ~S." situations)) + (values (intersection '(:compile-toplevel compile) situations) + (intersection '(:load-toplevel load) situations) + (intersection '(:execute eval) situations)))) + (multiple-value-bind (ct lt e) + (parse-eval-when-situations (cadr form)) + (let ((new-compile-time-too (or ct (and compile-time-too e))) + (body (cddr form))) + (if lt + (process-progn body stream new-compile-time-too) + (when new-compile-time-too + (eval `(progn , at body))))))) nil) @@ -432,40 +519,6 @@ nil))) (eval form)))) -(declaim (ftype (function (t) t) convert-ensure-method)) -(defun convert-ensure-method (form) - (c-e-m-1 form :function) - (c-e-m-1 form :fast-function) - (precompiler:precompile-form form nil *compile-file-environment*)) - -(declaim (ftype (function (t t) t) c-e-m-1)) -(defun c-e-m-1 (form key) - (let* ((tail (cddr form)) - (function-form (getf tail key))) - (when (and function-form (consp function-form) - (eq (%car function-form) 'FUNCTION)) - (let ((lambda-expression (cadr function-form))) - (jvm::with-saved-compiler-policy - (let* ((saved-class-number *class-number*) - (classfile (next-classfile-name)) - (result - (with-open-file - (f classfile - :direction :output - :element-type '(unsigned-byte 8) - :if-exists :supersede) - (report-error - (jvm:compile-defun nil lambda-expression - *compile-file-environment* - classfile f nil)))) - (compiled-function (verify-load classfile))) - (declare (ignore result)) - (cond (compiled-function - (setf (getf tail key) - `(sys::get-fasl-function *fasl-loader* ,saved-class-number))) - (t - ;; FIXME This should be a warning or error of some sort... - (format *error-output* "; Unable to compile method~%"))))))))) (declaim (ftype (function (t) t) simple-toplevel-form-p)) (defun simple-toplevel-form-p (form) @@ -513,63 +566,10 @@ (precompiler:precompile-form form nil *compile-file-environment*))))) -(defun process-toplevel-macrolet (form stream compile-time-too) - (let ((*compile-file-environment* (make-environment *compile-file-environment*))) - (dolist (definition (cadr form)) - (environment-add-macro-definition *compile-file-environment* - (car definition) - (make-macro (car definition) - (make-expander-for-macrolet definition)))) - (dolist (body-form (cddr form)) - (process-toplevel-form body-form stream compile-time-too))) - nil) ;; nothing to be sent to output - -(declaim (ftype (function (t stream t) t) process-progn)) -(defun process-progn (forms stream compile-time-too) - (dolist (form forms) - (process-toplevel-form form stream compile-time-too)) - nil) - -;;; Adapted from SBCL. -;;; Parse an EVAL-WHEN situations list, returning three flags, -;;; (VALUES COMPILE-TOPLEVEL LOAD-TOPLEVEL EXECUTE), indicating -;;; the types of situations present in the list. -(defun parse-eval-when-situations (situations) - (when (or (not (listp situations)) - (set-difference situations - '(:compile-toplevel - compile - :load-toplevel - load - :execute - eval))) - (error "Bad EVAL-WHEN situation list: ~S." situations)) - (values (intersection '(:compile-toplevel compile) situations) - (intersection '(:load-toplevel load) situations) - (intersection '(:execute eval) situations))) - - (defvar *binary-fasls* nil) (defvar *forms-for-output* nil) (defvar *fasl-stream* nil) -(defun output-form (form) - (if *binary-fasls* - (push form *forms-for-output*) - (progn - (dump-form form *fasl-stream*) - (%stream-terpri *fasl-stream*)))) - -(defun finalize-fasl-output () - (when *binary-fasls* - (let ((*package* (find-package :keyword)) - (*double-colon-package-separators* T)) - (dump-form (convert-toplevel-form (list* 'PROGN - (nreverse *forms-for-output*)) - t) - *fasl-stream*)) - (%stream-terpri *fasl-stream*))) - (defun compile-file (input-file &key output-file From ehuelsmann at common-lisp.net Sun Aug 14 19:55:18 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 14 Aug 2011 12:55:18 -0700 Subject: [armedbear-cvs] r13497 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 14 12:55:17 2011 New Revision: 13497 Log: More code shuffling. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Sun Aug 14 10:17:44 2011 (r13496) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Sun Aug 14 12:55:17 2011 (r13497) @@ -123,6 +123,55 @@ (%stream-terpri *fasl-stream*))) +(declaim (ftype (function (t) t) simple-toplevel-form-p)) +(defun simple-toplevel-form-p (form) + "Returns NIL if the form is too complex to become an +interpreted toplevel form, non-NIL if it is 'simple enough'." + (and (consp form) + (every #'(lambda (arg) + (or (and (atom arg) + (not (and (symbolp arg) + (symbol-macro-p arg)))) + (and (consp arg) + (eq 'QUOTE (car arg))))) + (cdr form)))) + +(declaim (ftype (function (t t) t) convert-toplevel-form)) +(defun convert-toplevel-form (form declare-inline) + (when (or (simple-toplevel-form-p form) + (and (eq (car form) 'SETQ) + ;; for SETQ, look at the evaluated part + (simple-toplevel-form-p (third form)))) + ;; single form with simple or constant arguments + ;; Without this exception, toplevel function calls + ;; will be compiled into lambdas which get compiled to + ;; compiled-functions. Those need to be loaded. + ;; Conclusion: Top level interpreting the function call + ;; and its arguments may be (and should be) more efficient. + (return-from convert-toplevel-form + (precompiler:precompile-form form nil *compile-file-environment*))) + (let* ((expr `(lambda () ,form)) + (saved-class-number *class-number*) + (classfile (next-classfile-name)) + (result + (with-open-file + (f classfile + :direction :output + :element-type '(unsigned-byte 8) + :if-exists :supersede) + (report-error (jvm:compile-defun nil + expr *compile-file-environment* + classfile f declare-inline)))) + (compiled-function (verify-load classfile))) + (declare (ignore result)) + (setf form + (if compiled-function + `(funcall (sys::get-fasl-function *fasl-loader* + ,saved-class-number)) + (precompiler:precompile-form form nil + *compile-file-environment*))))) + + (declaim (ftype (function (t stream t) t) process-progn)) @@ -353,10 +402,12 @@ (if (special-operator-p name) `(put ',name 'macroexpand-macro (make-macro ',name - (sys::get-fasl-function *fasl-loader* ,saved-class-number))) + (sys::get-fasl-function *fasl-loader* + ,saved-class-number))) `(fset ',name (make-macro ',name - (sys::get-fasl-function *fasl-loader* ,saved-class-number)) + (sys::get-fasl-function *fasl-loader* + ,saved-class-number)) ,*source-position* ',(third form)))))) @@ -520,51 +571,6 @@ (eval form)))) -(declaim (ftype (function (t) t) simple-toplevel-form-p)) -(defun simple-toplevel-form-p (form) - "Returns NIL if the form is too complex to become an -interpreted toplevel form, non-NIL if it is 'simple enough'." - (and (consp form) - (every #'(lambda (arg) - (or (and (atom arg) - (not (and (symbolp arg) - (symbol-macro-p arg)))) - (and (consp arg) - (eq 'QUOTE (car arg))))) - (cdr form)))) - -(declaim (ftype (function (t t) t) convert-toplevel-form)) -(defun convert-toplevel-form (form declare-inline) - (when (or (simple-toplevel-form-p form) - (and (eq (car form) 'SETQ) - ;; for SETQ, look at the evaluated part - (simple-toplevel-form-p (third form)))) - ;; single form with simple or constant arguments - ;; Without this exception, toplevel function calls - ;; will be compiled into lambdas which get compiled to - ;; compiled-functions. Those need to be loaded. - ;; Conclusion: Top level interpreting the function call - ;; and its arguments may be (and should be) more efficient. - (return-from convert-toplevel-form - (precompiler:precompile-form form nil *compile-file-environment*))) - (let* ((expr `(lambda () ,form)) - (saved-class-number *class-number*) - (classfile (next-classfile-name)) - (result - (with-open-file - (f classfile - :direction :output - :element-type '(unsigned-byte 8) - :if-exists :supersede) - (report-error (jvm:compile-defun nil expr *compile-file-environment* - classfile f declare-inline)))) - (compiled-function (verify-load classfile))) - (declare (ignore result)) - (setf form - (if compiled-function - `(funcall (sys::get-fasl-function *fasl-loader* ,saved-class-number)) - (precompiler:precompile-form form nil *compile-file-environment*))))) - (defvar *binary-fasls* nil) (defvar *forms-for-output* nil) From ehuelsmann at common-lisp.net Sun Aug 14 20:53:27 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 14 Aug 2011 13:53:27 -0700 Subject: [armedbear-cvs] r13498 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 14 13:53:26 2011 New Revision: 13498 Log: Start breaking up the beast function that COMPILE-FILE used to be. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Sun Aug 14 12:55:17 2011 (r13497) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Sun Aug 14 13:53:26 2011 (r13498) @@ -570,6 +570,60 @@ nil))) (eval form)))) +(defun populate-zip-fasl (output-file) + (let* ((type ;; Don't use ".zip", it'll result in an extension + ;; with a dot, which is rejected by NAMESTRING + (%format nil "~A~A" (pathname-type output-file) "-zip")) + (zipfile (namestring + (merge-pathnames (make-pathname :type type) + output-file))) + (pathnames nil) + (fasl-loader (namestring (merge-pathnames + (make-pathname :name (fasl-loader-classname) + :type "cls") + output-file)))) + (when (probe-file fasl-loader) + (push fasl-loader pathnames)) + (dotimes (i *class-number*) + (push (probe-file (compute-classfile-name (1+ i))) pathnames)) + (setf pathnames (nreverse (remove nil pathnames))) + (let ((load-file (merge-pathnames (make-pathname :type "_") + output-file))) + (rename-file output-file load-file) + (push load-file pathnames)) + (zip zipfile pathnames) + (dolist (pathname pathnames) + (ignore-errors (delete-file pathname))) + (rename-file zipfile output-file))) + +(defun write-fasl-prologue (stream) + (let ((out stream)) + ;; write header + (write "; -*- Mode: Lisp -*-" :escape nil :stream out) + (%stream-terpri out) + (write (list 'init-fasl :version *fasl-version*) :stream out) + (%stream-terpri out) + (write (list 'setq '*source* *compile-file-truename*) :stream out) + (%stream-terpri out) + + ;; Note: Beyond this point, you can't use DUMP-FORM, + ;; because the list of uninterned symbols has been fixed now. + (when *fasl-uninterned-symbols* + (write (list 'setq '*fasl-uninterned-symbols* + (coerce (mapcar #'car (nreverse *fasl-uninterned-symbols*)) + 'vector)) + :stream out :length nil)) + (%stream-terpri out) + + (when (> *class-number* 0) + (write (list 'setq '*fasl-loader* + `(sys::make-fasl-class-loader + nil + ,(concatenate 'string "org.armedbear.lisp." (base-classname)) + nil)) + :stream out)) + (%stream-terpri out))) + (defvar *binary-fasls* nil) @@ -611,7 +665,6 @@ (*class-number* 0) (namestring (namestring *compile-file-truename*)) (start (get-internal-real-time)) - elapsed *fasl-uninterned-symbols*) (when *compile-verbose* (format t "; Compiling ~A ...~%" namestring)) @@ -629,21 +682,21 @@ *forms-for-output*) (jvm::with-saved-compiler-policy (jvm::with-file-compilation - (handler-bind ((style-warning - #'(lambda (c) - (setf warnings-p t) - ;; let outer handlers do their thing - (signal c) - ;; prevent the next handler - ;; from running: we're a - ;; WARNING subclass - (continue))) - ((or warning - compiler-error) - #'(lambda (c) - (declare (ignore c)) - (setf warnings-p t - failure-p t)))) + (handler-bind + ((style-warning + #'(lambda (c) + (setf warnings-p t) + ;; let outer handlers do their thing + (signal c) + ;; prevent the next handler + ;; from running: we're a + ;; WARNING subclass + (continue))) + ((or warning compiler-error) + #'(lambda (c) + (declare (ignore c)) + (setf warnings-p t + failure-p t)))) (loop (let* ((*source-position* (file-position in)) (jvm::*source-line-number* (stream-line-number in)) @@ -659,9 +712,6 @@ (with-open-file (out temp-file2 :direction :output :if-does-not-exist :create :if-exists :supersede) - ;; write header - (write "; -*- Mode: Lisp -*-" :escape nil :stream out) - (%stream-terpri out) (let ((*package* (find-package '#:cl)) (*print-fasl* t) (*print-array* t) @@ -695,72 +745,22 @@ ;; (*read-default-float-format* 'single-float) ;; (*readtable* (copy-readtable nil)) - (write (list 'init-fasl :version *fasl-version*) - :stream out) - (%stream-terpri out) - (write (list 'setq '*source* *compile-file-truename*) - :stream out) - (%stream-terpri out) - ;; Note: Beyond this point, you can't use DUMP-FORM, - ;; because the list of uninterned symbols has been fixed now. - (when *fasl-uninterned-symbols* - (write (list 'setq '*fasl-uninterned-symbols* - (coerce (mapcar #'car - (nreverse *fasl-uninterned-symbols*)) - 'vector)) - :stream out - :length nil)) - (%stream-terpri out) - - (when (> *class-number* 0) - (write (list 'setq '*fasl-loader* - `(sys::make-fasl-class-loader - nil - ,(concatenate 'string "org.armedbear.lisp." (base-classname)) - nil)) :stream out)) - (%stream-terpri out)) - - - ;; copy remaining content - (loop for line = (read-line in nil :eof) - while (not (eq line :eof)) - do (write-line line out)))) + (write-fasl-prologue out) + ;; copy remaining content + (loop for line = (read-line in nil :eof) + while (not (eq line :eof)) + do (write-line line out))))) (delete-file temp-file) (remove-zip-cache-entry output-file) ;; Necessary under windows (rename-file temp-file2 output-file) (when *compile-file-zip* - (let* ((type ;; Don't use ".zip", it'll result in an extension - ;; with a dot, which is rejected by NAMESTRING - (%format nil "~A~A" (pathname-type output-file) "-zip")) - (zipfile (namestring - (merge-pathnames (make-pathname :type type) - output-file))) - (pathnames nil) - (fasl-loader (namestring (merge-pathnames (make-pathname :name (fasl-loader-classname) :type "cls") - output-file)))) - (when (probe-file fasl-loader) - (push fasl-loader pathnames)) - (dotimes (i *class-number*) - (let* ((pathname (compute-classfile-name (1+ i)))) - (when (probe-file pathname) - (push pathname pathnames)))) - (setf pathnames (nreverse pathnames)) - (let ((load-file (merge-pathnames (make-pathname :type "_") - output-file))) - (rename-file output-file load-file) - (push load-file pathnames)) - (zip zipfile pathnames) - (dolist (pathname pathnames) - (let ((truename (probe-file pathname))) - (when truename - (delete-file truename)))) - (rename-file zipfile output-file))) + (populate-zip-fasl output-file)) - (setf elapsed (/ (- (get-internal-real-time) start) 1000.0)) (when *compile-verbose* (format t "~&; Wrote ~A (~A seconds)~%" - (namestring output-file) elapsed)))) + (namestring output-file) + (/ (- (get-internal-real-time) start) 1000.0))))) (values (truename output-file) warnings-p failure-p))) (defun compile-file-if-needed (input-file &rest allargs &key force-compile From ehuelsmann at common-lisp.net Sun Aug 14 20:57:26 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 14 Aug 2011 13:57:26 -0700 Subject: [armedbear-cvs] r13499 - in tags/0.26.2: . abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 14 13:57:26 2011 New Revision: 13499 Log: Tag 0.26.2. Added: tags/0.26.2/ - copied from r13498, branches/0.26.x/ Modified: tags/0.26.2/abcl/src/org/armedbear/lisp/Version.java Modified: tags/0.26.2/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- branches/0.26.x/abcl/src/org/armedbear/lisp/Version.java Sun Aug 14 13:53:26 2011 (r13498) +++ tags/0.26.2/abcl/src/org/armedbear/lisp/Version.java Sun Aug 14 13:57:26 2011 (r13499) @@ -41,7 +41,7 @@ { private Version() {} - static final String baseVersion = "0.26.2-dev"; + static final String baseVersion = "0.26.2"; static void init() { try { From ehuelsmann at common-lisp.net Sun Aug 14 20:58:16 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 14 Aug 2011 13:58:16 -0700 Subject: [armedbear-cvs] r13500 - branches/0.26.x/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 14 13:58:15 2011 New Revision: 13500 Log: Update branch version number. Modified: branches/0.26.x/abcl/src/org/armedbear/lisp/Version.java Modified: branches/0.26.x/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- branches/0.26.x/abcl/src/org/armedbear/lisp/Version.java Sun Aug 14 13:57:26 2011 (r13499) +++ branches/0.26.x/abcl/src/org/armedbear/lisp/Version.java Sun Aug 14 13:58:15 2011 (r13500) @@ -41,7 +41,7 @@ { private Version() {} - static final String baseVersion = "0.26.2-dev"; + static final String baseVersion = "0.26.3-dev"; static void init() { try { From ehuelsmann at common-lisp.net Sun Aug 14 21:21:56 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 14 Aug 2011 14:21:56 -0700 Subject: [armedbear-cvs] r13501 - public_html/releases/0.26.2 Message-ID: Author: ehuelsmann Date: Sun Aug 14 14:21:54 2011 New Revision: 13501 Log: Publish 0.26.2 release. Sigs coming up. Added: public_html/releases/0.26.2/ (props changed) public_html/releases/0.26.2/abcl-bin-0.26.2.tar.gz (contents, props changed) public_html/releases/0.26.2/abcl-bin-0.26.2.zip (contents, props changed) public_html/releases/0.26.2/abcl-src-0.26.2.tar.gz (contents, props changed) public_html/releases/0.26.2/abcl-src-0.26.2.zip (contents, props changed) Added: public_html/releases/0.26.2/abcl-bin-0.26.2.tar.gz ============================================================================== Binary file. No diff available. Added: public_html/releases/0.26.2/abcl-bin-0.26.2.zip ============================================================================== Binary file. No diff available. Added: public_html/releases/0.26.2/abcl-src-0.26.2.tar.gz ============================================================================== Binary file. No diff available. Added: public_html/releases/0.26.2/abcl-src-0.26.2.zip ============================================================================== Binary file. No diff available. From ehuelsmann at common-lisp.net Sun Aug 14 21:32:49 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 14 Aug 2011 14:32:49 -0700 Subject: [armedbear-cvs] r13502 - public_html/releases/0.26.2 Message-ID: Author: ehuelsmann Date: Sun Aug 14 14:32:48 2011 New Revision: 13502 Log: Add 0.26.2 release signatures. Added: public_html/releases/0.26.2/abcl-bin-0.26.2.tar.gz.asc public_html/releases/0.26.2/abcl-bin-0.26.2.zip.asc public_html/releases/0.26.2/abcl-src-0.26.2.tar.gz.asc public_html/releases/0.26.2/abcl-src-0.26.2.zip.asc Added: public_html/releases/0.26.2/abcl-bin-0.26.2.tar.gz.asc ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ public_html/releases/0.26.2/abcl-bin-0.26.2.tar.gz.asc Sun Aug 14 14:32:48 2011 (r13502) @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEUEABECAAYFAk5IO88ACgkQi5O0Epaz9TnQwQCffLvxLLoQAxO+Mg3tB3NzvCCE ++CAAlin5thCe87xyEw10v5vb1u2ujt0= +=eBQs +-----END PGP SIGNATURE----- Added: public_html/releases/0.26.2/abcl-bin-0.26.2.zip.asc ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ public_html/releases/0.26.2/abcl-bin-0.26.2.zip.asc Sun Aug 14 14:32:48 2011 (r13502) @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAk5IO9QACgkQi5O0Epaz9TkxFgCeL51s+3BTA0aDqsoQgdZMDl8x +Ve0AnjNNvsPbMQoba8JGC2q56obCzD7W +=wFrE +-----END PGP SIGNATURE----- Added: public_html/releases/0.26.2/abcl-src-0.26.2.tar.gz.asc ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ public_html/releases/0.26.2/abcl-src-0.26.2.tar.gz.asc Sun Aug 14 14:32:48 2011 (r13502) @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAk5IO9kACgkQi5O0Epaz9Tl3MgCdEwG9FFJg1o2ZwcKe2QXD/XeJ +0FcAn18unQkgMJPkQpLYrLJS9ANTsJUU +=rC6j +-----END PGP SIGNATURE----- Added: public_html/releases/0.26.2/abcl-src-0.26.2.zip.asc ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ public_html/releases/0.26.2/abcl-src-0.26.2.zip.asc Sun Aug 14 14:32:48 2011 (r13502) @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAk5IO90ACgkQi5O0Epaz9TkMPgCeN1bKwcxbHk9Rce0YZuVZNDft +WwMAnR/G/49WHFLwln/Mml22266NvGMW +=qKTs +-----END PGP SIGNATURE----- From ehuelsmann at common-lisp.net Sun Aug 14 21:33:50 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 14 Aug 2011 14:33:50 -0700 Subject: [armedbear-cvs] r13503 - public_html Message-ID: Author: ehuelsmann Date: Sun Aug 14 14:33:49 2011 New Revision: 13503 Log: Update front page to point to 0.26.2 Modified: public_html/index.shtml Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml Sun Aug 14 14:32:48 2011 (r13502) +++ public_html/index.shtml Sun Aug 14 14:33:49 2011 (r13503) @@ -61,24 +61,24 @@ Binary - abcl-bin-0.26.1.tar.gz - (pgp) + abcl-bin-0.26.2.tar.gz + (pgp) - abcl-bin-0.26.1.zip - (pgp) + abcl-bin-0.26.2.zip + (pgp) Source - abcl-src-0.26.1.tar.gz - (pgp) + abcl-src-0.26.2.tar.gz + (pgp) - abcl-src-0.26.1.zip - (pgp) + abcl-src-0.26.2.zip + (pgp) From ehuelsmann at common-lisp.net Sun Aug 14 21:51:18 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 14 Aug 2011 14:51:18 -0700 Subject: [armedbear-cvs] r13504 - tags/0.26.2/abcl Message-ID: Author: ehuelsmann Date: Sun Aug 14 14:51:17 2011 New Revision: 13504 Log: Update release date for 0.26.2 in CHANGES. Modified: tags/0.26.2/abcl/CHANGES Modified: tags/0.26.2/abcl/CHANGES ============================================================================== --- tags/0.26.2/abcl/CHANGES Sun Aug 14 14:33:49 2011 (r13503) +++ tags/0.26.2/abcl/CHANGES Sun Aug 14 14:51:17 2011 (r13504) @@ -1,7 +1,7 @@ Version 0.26.2 ============== svn://common-lisp.net/project/armedbear/svn/tags/0.26.2/abcl -(Unreleased) +(14 August 2011) Features -------- From ehuelsmann at common-lisp.net Sun Aug 14 21:51:40 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 14 Aug 2011 14:51:40 -0700 Subject: [armedbear-cvs] r13505 - branches/0.26.x/abcl Message-ID: Author: ehuelsmann Date: Sun Aug 14 14:51:39 2011 New Revision: 13505 Log: Update release date for 0.26.2 in CHANGES. Modified: branches/0.26.x/abcl/CHANGES Modified: branches/0.26.x/abcl/CHANGES ============================================================================== --- branches/0.26.x/abcl/CHANGES Sun Aug 14 14:51:17 2011 (r13504) +++ branches/0.26.x/abcl/CHANGES Sun Aug 14 14:51:39 2011 (r13505) @@ -1,7 +1,7 @@ Version 0.26.2 ============== svn://common-lisp.net/project/armedbear/svn/tags/0.26.2/abcl -(Unreleased) +(14 August 2011) Features -------- From ehuelsmann at common-lisp.net Sun Aug 14 22:03:34 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 14 Aug 2011 15:03:34 -0700 Subject: [armedbear-cvs] r13506 - trunk/abcl Message-ID: Author: ehuelsmann Date: Sun Aug 14 15:03:33 2011 New Revision: 13506 Log: Merge CHANGES back to trunk from 0.26.x. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES Sun Aug 14 14:51:39 2011 (r13505) +++ trunk/abcl/CHANGES Sun Aug 14 15:03:33 2011 (r13506) @@ -1,6 +1,30 @@ +Version 0.26.2 +============== +svn://common-lisp.net/project/armedbear/svn/tags/0.26.2/abcl +(14 August 2011) + +Features +-------- + * Enable compilation with Java 7 + +Fixes +----- + * Fix loading from fasls under Windows with whitespace in pathname. + + * Fix #131: Don't include ':' in the version string. + + * Fix #141: SETF of APPLY not working with arbitrary function. + + * Include filename in the error string being reported. + + * Include the test source in the release. + + * Include ASDF definition in source release. + Version 0.26.1 ============== svn://common-lisp.net/project/armedbear/svn/tags/0.26.1/abcl +(27 July 2011) Features -------- From mevenson at common-lisp.net Tue Aug 16 08:43:25 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 16 Aug 2011 01:43:25 -0700 Subject: [armedbear-cvs] r13507 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue Aug 16 01:43:24 2011 New Revision: 13507 Log: Re-enable a default implementation for printing a LispObject. Otherwise something like (COPY-READTABLE) returns an illegal expression at the REPL, i.e. one that doesn't implement the Reader serialization protocol correctly. Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispObject.java Sun Aug 14 15:03:33 2011 (r13506) +++ trunk/abcl/src/org/armedbear/lisp/LispObject.java Tue Aug 16 01:43:24 2011 (r13507) @@ -751,7 +751,7 @@ public String printObject() { - return toString(); + return unreadableString(toString(), false); } /** Calls unreadableString(String s, boolean identity) with a default From mevenson at common-lisp.net Tue Aug 16 09:49:25 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 16 Aug 2011 02:49:25 -0700 Subject: [armedbear-cvs] r13508 - in trunk/abcl: src/org/armedbear/lisp test/lisp/abcl Message-ID: Author: mevenson Date: Tue Aug 16 02:49:25 2011 New Revision: 13508 Log: Fix #148: READTABLE-CASE :invert doesn't work for symbols. A slightly modified version of the patch provided by Ole Arnedt with a test. Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java trunk/abcl/test/lisp/abcl/bugs.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Stream.java Tue Aug 16 01:43:24 2011 (r13507) +++ trunk/abcl/src/org/armedbear/lisp/Stream.java Tue Aug 16 02:49:25 2011 (r13508) @@ -545,15 +545,15 @@ public LispObject readSymbol() { final Readtable rt = (Readtable) Symbol.CURRENT_READTABLE.symbolValue(LispThread.currentThread()); - StringBuilder sb = new StringBuilder(); - _readToken(sb, rt); - return new Symbol(sb.toString()); + return readSymbol(rt); } public LispObject readSymbol(Readtable rt) { - StringBuilder sb = new StringBuilder(); - _readToken(sb, rt); - return new Symbol(sb.toString()); + final StringBuilder sb = new StringBuilder(); + final BitSet flags = _readToken(sb, rt); + return new Symbol(rt.getReadtableCase() == Keyword.INVERT + ? invert(sb.toString(), flags) + : sb.toString()); } public LispObject readStructure(ReadtableAccessor rta) { Modified: trunk/abcl/test/lisp/abcl/bugs.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/bugs.lisp Tue Aug 16 01:43:24 2011 (r13507) +++ trunk/abcl/test/lisp/abcl/bugs.lisp Tue Aug 16 02:49:25 2011 (r13508) @@ -71,4 +71,15 @@ stream) - \ No newline at end of file + +(deftest bugs.readtable-case.1 + (let (original-case result) + (setf original-case (readtable-case *readtable*) + (readtable-case *readtable*) :invert + result (list (string (read-from-string "lower")) + (string (read-from-string "UPPER")) + (string (read-from-string "#:lower")) + (string (read-from-string "#:UPPER"))) + (readtable-case *readtable*) original-case) + (values-list result)) + "LOWER" "upper" "LOWER" "upper") \ No newline at end of file From mevenson at common-lisp.net Tue Aug 16 12:16:30 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 16 Aug 2011 05:16:30 -0700 Subject: [armedbear-cvs] r13509 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue Aug 16 05:16:29 2011 New Revision: 13509 Log: Provide a more useful implementation of LispObject.toString(). Since most JVM debuggers use the java.lang.Object.toString() contract to provide meaningful information for users, we have out default implementation call the princToString() implementation. Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispObject.java Tue Aug 16 02:49:25 2011 (r13508) +++ trunk/abcl/src/org/armedbear/lisp/LispObject.java Tue Aug 16 05:16:29 2011 (r13509) @@ -748,6 +748,11 @@ thread.resetSpecialBindings(mark); } } + + public String toString() + { + return princToString(); + } public String printObject() { From ehuelsmann at common-lisp.net Tue Aug 16 13:45:30 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 16 Aug 2011 06:45:30 -0700 Subject: [armedbear-cvs] r13510 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Aug 16 06:45:28 2011 New Revision: 13510 Log: Assign fields the value of the arguments, instead of the values of the fields themselves. Fixes Wrong number of arguments error message. Modified: trunk/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java Modified: trunk/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java Tue Aug 16 05:16:29 2011 (r13509) +++ trunk/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java Tue Aug 16 06:45:28 2011 (r13510) @@ -52,8 +52,8 @@ // own Java class as a convenience for the implementation. super(StandardClass.PROGRAM_ERROR); this.operator = operator; - this.expectedMinArgs = expectedMinArgs; - this.expectedMaxArgs = expectedMaxArgs; + this.expectedMinArgs = expectedMin; + this.expectedMaxArgs = expectedMax; setFormatControl(getMessage()); setFormatArguments(NIL); } From ehuelsmann at common-lisp.net Fri Aug 19 15:42:42 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 19 Aug 2011 08:42:42 -0700 Subject: [armedbear-cvs] r13511 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 19 08:42:38 2011 New Revision: 13511 Log: Re #116: while working to fix the issue, at least tell the user we're unable to generate a conforming class file. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Tue Aug 16 06:45:28 2011 (r13510) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri Aug 19 08:42:38 2011 (r13511) @@ -51,6 +51,10 @@ (declaim (special *memory-class-loader*)) + +(declaim (inline pool-name pool-name-and-type pool-string + pool-field pool-method pool-int pool-float pool-long + pool-double add-exception-handler)) (defun pool-name (name) (pool-add-utf8 *pool* name)) @@ -1177,14 +1181,33 @@ (emit-invokestatic +lisp+ "readObjectFromString" (list +java-string+) +lisp-object+)) +(defun external-constant-resource-name (class) + (declare (ignore class)) + ;; dummy implementation to suppress compiler warnings + ;; which break abcl compilation + ) + (defun serialize-object (object) "Generate code to restore a serialized object which is not of any of the other types." (let ((s (with-output-to-string (stream) (dump-form object stream)))) - (emit 'ldc (pool-string s)) - (emit-invokestatic +lisp+ "readObjectFromString" - (list +java-string+) +lisp-object+))) + (cond + ((< (length s) #xFFFF) ;; maximum string size in class file + (emit 'ldc (pool-string s)) + (emit-invokestatic +lisp+ "readObjectFromString" + (list +java-string+) +lisp-object+)) + (t + (assert (not "Serialized representation too long to be stored in a string")) + (aload 0) ;; this + (emit-invokevirtual +java-object+ "getClass" '() +java-class+) + (emit 'ldc (pool-string (external-constant-resource-name *this-class*))) + (emit-invokevirtual +java-class+ "getResourceAsStream" + (list +java-string+) + +java-io-input-stream+) + (emit-invokestatic +lisp+ "readObjectFromStream" + (list +java-io-input-stream+) + +lisp-object+))))) (defun serialize-symbol (symbol) "Generate code to restore a serialized symbol." Modified: trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Tue Aug 16 06:45:28 2011 (r13510) +++ trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Fri Aug 19 08:42:38 2011 (r13511) @@ -130,9 +130,11 @@ `(defconstant ,symbol (make-jvm-class-name ,java-dotted-name) ,documentation)) +(define-class-name +java-class+ "java.lang.Class") (define-class-name +java-object+ "java.lang.Object") (define-class-name +java-string+ "java.lang.String") (define-class-name +java-system+ "java.lang.System") +(define-class-name +java-io-input-stream+ "java.io.InputStream") (define-class-name +lisp-object+ "org.armedbear.lisp.LispObject") (defconstant +lisp-object-array+ (class-array +lisp-object+)) (define-class-name +lisp-simple-string+ "org.armedbear.lisp.SimpleString") From ehuelsmann at common-lisp.net Fri Aug 19 15:43:32 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 19 Aug 2011 08:43:32 -0700 Subject: [armedbear-cvs] r13512 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 19 08:43:32 2011 New Revision: 13512 Log: Re #116: Implement some infrastructure to load from other sources than plain java.lang.String-s. 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 Fri Aug 19 08:42:38 2011 (r13511) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Fri Aug 19 08:43:32 2011 (r13512) @@ -34,14 +34,14 @@ package org.armedbear.lisp; import java.io.File; -import java.io.FileInputStream; -import java.io.FileNotFoundException; import java.io.IOException; import java.io.InputStream; +import java.io.InputStreamReader; +import java.io.Reader; +import java.io.StringReader; import java.math.BigInteger; -import java.net.MalformedURLException; import java.net.URL; -import java.net.URLDecoder; +import java.nio.charset.Charset; import java.util.Hashtable; public final class Lisp @@ -1239,7 +1239,18 @@ } // Used by the compiler. - public static final LispObject readObjectFromString(String s) + public static LispObject readObjectFromString(String s) + { + return readObjectFromReader(new StringReader(s)); + } + + final static Charset UTF8CHARSET = Charset.forName("UTF-8"); + public static LispObject readObjectFromStream(InputStream s) + { + return readObjectFromReader(new InputStreamReader(s)); + } + + public static LispObject readObjectFromReader(Reader r) { LispThread thread = LispThread.currentThread(); SpecialBindingsMark mark = thread.markSpecialBindings(); @@ -1253,7 +1264,7 @@ // No need to bind the default read table, because the default fasl // read table is used below - return new StringInputStream(s).read(true, NIL, false, + return new Stream(Symbol.SYSTEM_STREAM, r).read(true, NIL, false, LispThread.currentThread(), Stream.faslReadtable); } @@ -1261,8 +1272,8 @@ thread.resetSpecialBindings(mark); } } - - @Deprecated + + @Deprecated public static final LispObject loadCompiledFunction(final String namestring) { Pathname name = new Pathname(namestring); From ehuelsmann at common-lisp.net Fri Aug 19 19:52:57 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 19 Aug 2011 12:52:57 -0700 Subject: [armedbear-cvs] r13513 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 19 12:52:56 2011 New Revision: 13513 Log: Remove meaningless 'final' classification on a method and an unused variable. 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 Fri Aug 19 08:43:32 2011 (r13512) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Fri Aug 19 12:52:56 2011 (r13513) @@ -1284,12 +1284,11 @@ return null; } - public static final byte[] readFunctionBytes(final Pathname name) { + public static byte[] readFunctionBytes(final Pathname name) { final LispThread thread = LispThread.currentThread(); Pathname load = null; LispObject truenameFasl = Symbol.LOAD_TRUENAME_FASL.symbolValue(thread); LispObject truename = Symbol.LOAD_TRUENAME.symbolValue(thread); - Pathname fasl = null; if (truenameFasl instanceof Pathname) { load = Pathname.mergePathnames(name, (Pathname)truenameFasl, Keyword.NEWEST); } else if (truename instanceof Pathname) { From ehuelsmann at common-lisp.net Fri Aug 19 20:43:01 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 19 Aug 2011 13:43:01 -0700 Subject: [armedbear-cvs] r13514 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 19 13:43:00 2011 New Revision: 13514 Log: Fix #116 (fail to load cl-unicode) by saving serialized resources with a size bigger that 64k in a separate file instead of within-classfile. Modified: trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java trunk/abcl/src/org/armedbear/lisp/compile-file.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java Fri Aug 19 12:52:56 2011 (r13513) +++ trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java Fri Aug 19 13:43:00 2011 (r13514) @@ -33,9 +33,9 @@ package org.armedbear.lisp; +import java.io.InputStream; import static org.armedbear.lisp.Lisp.*; -import java.util.*; public class FaslClassLoader extends JavaClassLoader { @@ -89,6 +89,27 @@ } } + @Override + public InputStream getResourceAsStream(String resourceName) { + final LispThread thread = LispThread.currentThread(); + + Pathname name = new Pathname(resourceName.substring("org/armedbear/lisp/".length())); + LispObject truenameFasl = Symbol.LOAD_TRUENAME_FASL.symbolValue(thread); + LispObject truename = Symbol.LOAD_TRUENAME.symbolValue(thread); + + if (truenameFasl instanceof Pathname) { + return Pathname.mergePathnames(name, (Pathname)truenameFasl, Keyword.NEWEST) + .getInputStream(); + } else if (truename instanceof Pathname) { + return Pathname.mergePathnames(name, (Pathname) truename, Keyword.NEWEST) + .getInputStream(); + } else if (!Pathname.truename(name).equals(NIL)) { + return name.getInputStream(); + } + + return null; + } + public byte[] getFunctionClassBytes(String name) { Pathname pathname = new Pathname(name.substring("org/armedbear/lisp/".length()) + ".cls"); return readFunctionBytes(pathname); Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Fri Aug 19 12:52:56 2011 (r13513) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Fri Aug 19 13:43:00 2011 (r13514) @@ -585,7 +585,15 @@ (when (probe-file fasl-loader) (push fasl-loader pathnames)) (dotimes (i *class-number*) - (push (probe-file (compute-classfile-name (1+ i))) pathnames)) + (let ((truename (probe-file (compute-classfile-name (1+ i))))) + (when truename + (push truename pathnames) + (dolist (resource (directory + (make-pathname :name (format nil "~A_*" + (pathname-name truename)) + :type "clc" + :defaults truename))) + (push resource pathnames))))) (setf pathnames (nreverse (remove nil pathnames))) (let ((load-file (merge-pathnames (make-pathname :type "_") output-file))) Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri Aug 19 12:52:56 2011 (r13513) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri Aug 19 13:43:00 2011 (r13514) @@ -1181,11 +1181,14 @@ (emit-invokestatic +lisp+ "readObjectFromString" (list +java-string+) +lisp-object+)) -(defun external-constant-resource-name (class) - (declare (ignore class)) - ;; dummy implementation to suppress compiler warnings - ;; which break abcl compilation - ) +(defun compiland-external-constant-resource-name (compiland) + (let ((resource-number (compiland-next-resource compiland)) + (pathname (abcl-class-file-pathname (compiland-class-file compiland)))) + (incf (compiland-next-resource compiland)) + (make-pathname :name (format nil "~A_~D" + (pathname-name pathname) resource-number) + :type "clc" + :defaults pathname))) (defun serialize-object (object) "Generate code to restore a serialized object which is not of any @@ -1198,10 +1201,19 @@ (emit-invokestatic +lisp+ "readObjectFromString" (list +java-string+) +lisp-object+)) (t - (assert (not "Serialized representation too long to be stored in a string")) (aload 0) ;; this (emit-invokevirtual +java-object+ "getClass" '() +java-class+) - (emit 'ldc (pool-string (external-constant-resource-name *this-class*))) + (let ((pathname + (compiland-external-constant-resource-name *current-compiland*))) + (with-open-file (f pathname + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (write-string s f)) + (emit 'ldc (pool-string + (namestring (make-pathname :name (pathname-name pathname) + :type (pathname-type pathname) + :version nil))))) (emit-invokevirtual +java-class+ "getResourceAsStream" (list +java-string+) +java-io-input-stream+) Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp Fri Aug 19 12:52:56 2011 (r13513) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Fri Aug 19 13:43:00 2011 (r13514) @@ -198,6 +198,7 @@ children ; List of local functions ; defined with FLET, LABELS or LAMBDA blocks ; TAGBODY, PROGV, BLOCK, etc. blocks + (next-resource 0) argument-register closure-register environment-register From ehuelsmann at common-lisp.net Fri Aug 19 21:47:22 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 19 Aug 2011 14:47:22 -0700 Subject: [armedbear-cvs] r13515 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Aug 19 14:47:21 2011 New Revision: 13515 Log: Extend overly long serialization strings storage mechanism to normal strings as well. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri Aug 19 13:43:00 2011 (r13514) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri Aug 19 14:47:21 2011 (r13515) @@ -1169,10 +1169,14 @@ (defun serialize-string (string) "Generate code to restore a serialized string." - (emit-new +lisp-simple-string+) - (emit 'dup) - (emit 'ldc (pool-string string)) - (emit-invokespecial-init +lisp-simple-string+ (list +java-string+))) + (cond + ((< (length string) #xFFFF) + (emit-new +lisp-simple-string+) + (emit 'dup) + (emit 'ldc (pool-string string)) + (emit-invokespecial-init +lisp-simple-string+ (list +java-string+))) + (t + (serialize-object string)))) (defun serialize-package (pkg) "Generate code to restore a serialized package." From ehuelsmann at common-lisp.net Sat Aug 20 10:03:53 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 20 Aug 2011 03:03:53 -0700 Subject: [armedbear-cvs] r13516 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 20 03:03:52 2011 New Revision: 13516 Log: Fix #161: READTABLE-CASE setting of *readtable* affects FASL content. Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java trunk/abcl/src/org/armedbear/lisp/dump-form.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java Fri Aug 19 14:47:21 2011 (r13515) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Sat Aug 20 03:03:52 2011 (r13516) @@ -5847,4 +5847,17 @@ } }; + private static final Primitive GET_FASL_READTABLE + = new pf_get_fasl_readtable(); + private static class pf_get_fasl_readtable extends Primitive { + pf_get_fasl_readtable() { + super("get-fasl-readtable", PACKAGE_SYS, false); + } + + @Override + public LispObject execute() { + return FaslReadtable.getInstance(); + } + } + } Modified: trunk/abcl/src/org/armedbear/lisp/dump-form.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/dump-form.lisp Fri Aug 19 14:47:21 2011 (r13515) +++ trunk/abcl/src/org/armedbear/lisp/dump-form.lisp Sat Aug 20 03:03:52 2011 (r13516) @@ -120,6 +120,12 @@ (t (%stream-output-object object stream)))) +(defvar *the-fasl-printer-readtable* + (copy-readtable (get-fasl-readtable)) + "This variable holds a copy of the FASL readtable which we need to bind +below, in order to prevent the current readtable from influencing the content +being written to the FASL: the READTABLE-CASE setting influences symbol printing.") + (declaim (ftype (function (t stream) t) dump-form)) (defun dump-form (form stream) (let ((*print-fasl* t) @@ -142,6 +148,7 @@ (*print-readably* t) (*print-right-margin* nil) (*print-structure* t) + (*readtable* *the-fasl-printer-readtable*) ;; make sure to write all floats with their exponent marker: ;; the dump-time default may not be the same at load-time From ehuelsmann at common-lisp.net Sat Aug 20 10:06:13 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 20 Aug 2011 03:06:13 -0700 Subject: [armedbear-cvs] r13516 - svn:log Message-ID: Author: ehuelsmann Revision: 13516 Property Name: svn:log Action: modified Property diff: --- old property value +++ new property value @@ -1 +1,3 @@ -Fix #161: READTABLE-CASE setting of *readtable* affects FASL content. \ No newline at end of file +Fix #161: READTABLE-CASE setting of *readtable* affects FASL content. + +Note: Fix based on research by Alessio Stalla. \ No newline at end of file From ehuelsmann at common-lisp.net Sat Aug 20 12:55:35 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 20 Aug 2011 05:55:35 -0700 Subject: [armedbear-cvs] r13517 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 20 05:55:31 2011 New Revision: 13517 Log: Fix #162: Non-symbol in variable position of SETQ form causes class verification problems of generated .cls file. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Aug 20 03:03:52 2011 (r13516) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Aug 20 05:55:31 2011 (r13517) @@ -6383,6 +6383,10 @@ (list +lisp-symbol+ +lisp-object+) +lisp-object+))) (t + (unless (symbolp name) + (error 'program-error + "First argument to SETQ is not a symbol in ~S" + form)) (with-operand-accumulation ((emit-thread-operand) (emit-load-externalized-object-operand name) From ehuelsmann at common-lisp.net Sat Aug 20 21:53:53 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 20 Aug 2011 14:53:53 -0700 Subject: [armedbear-cvs] r13518 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 20 14:53:51 2011 New Revision: 13518 Log: Replace the use of the (non-concurrent) Hashtable with the ConcurrentHashmap for the 'remember' hashtable, which is used concurrently from multiple threads, if they're all compiling. 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 Sat Aug 20 05:55:31 2011 (r13517) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Sat Aug 20 14:53:51 2011 (r13518) @@ -43,6 +43,7 @@ import java.net.URL; import java.nio.charset.Charset; import java.util.Hashtable; +import java.util.concurrent.ConcurrentHashMap; public final class Lisp { @@ -2113,15 +2114,15 @@ } // The compiler's object table. - static final Hashtable objectTable = - new Hashtable(); + static final ConcurrentHashMap objectTable = + new ConcurrentHashMap(); - public static final LispObject recall(String key) + public static LispObject recall(String key) { return objectTable.remove(key); } - public static final LispObject recall(SimpleString key) + public static LispObject recall(SimpleString key) { return objectTable.remove(key.getStringValue()); } From ehuelsmann at common-lisp.net Sat Aug 20 21:55:30 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 20 Aug 2011 14:55:30 -0700 Subject: [armedbear-cvs] r13519 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 20 14:55:30 2011 New Revision: 13519 Log: Generate () functions for the initialization of static variables. After this change, it should be possible to run the constructor of compiled functions more than once. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Aug 20 14:53:51 2011 (r13518) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Aug 20 14:55:30 2011 (r13519) @@ -1060,8 +1060,6 @@ :void nil :flags '(:public :static)))) ;; We don't normally need to see debugging output for . (with-code-to-method (class method) - (setf (code-max-locals *current-code-attribute*) 0) - (emit 'return) method))) (defvar *source-line-number* nil) @@ -1074,6 +1072,8 @@ extend the class any further." (with-code-to-method (class (abcl-class-file-constructor class)) (emit 'return)) + (with-code-to-method (class (abcl-class-file-static-initializer class)) + (emit 'return)) (finalize-class-file class) (write-class-file class stream)) @@ -1307,7 +1307,7 @@ (cond ((not *file-compilation*) (with-code-to-method - (*class-file* (abcl-class-file-constructor *class-file*)) + (*class-file* (abcl-class-file-static-initializer *class-file*)) (remember field-name object) (emit 'ldc (pool-string field-name)) (emit-invokestatic +lisp+ "recall" @@ -1320,7 +1320,7 @@ (emit-putstatic *this-class* field-name field-type)) (t (with-code-to-method - (*class-file* (abcl-class-file-constructor *class-file*)) + (*class-file* (abcl-class-file-static-initializer *class-file*)) (funcall dispatch-fn object) (emit-putstatic *this-class* field-name field-type)))) @@ -7076,7 +7076,6 @@ (make-constructor class-file (compiland-name compiland) args))) (setf (abcl-class-file-constructor class-file) constructor) (class-add-method class-file constructor)) - #+enable-when-generating-clinit (let ((clinit (make-static-initializer class-file))) (setf (abcl-class-file-static-initializer class-file) clinit) (class-add-method class-file clinit)) From ehuelsmann at common-lisp.net Sat Aug 20 22:01:18 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 20 Aug 2011 15:01:18 -0700 Subject: [armedbear-cvs] r13520 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 20 15:01:18 2011 New Revision: 13520 Log: Fix MULTIPLE-VALUE-PROG1.10 -- compiled mode. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Aug 20 14:55:30 2011 (r13519) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sat Aug 20 15:01:18 2011 (r13520) @@ -3005,6 +3005,14 @@ (emit-push-current-thread) (emit-getfield +lisp-thread+ "_values" +lisp-object-array+) (astore values-register) + + ;; we need to clear the values again: + ;; some parts will consider a non-null _values array + ;; by itself a legitimate return value (multiple values) + ;; however, if we have a non-local return after the previous form + ;; set the values array, other code may pick up the values instead + ;; of the actual return code. (Fixes MULTIPLE-VALUE-PROG1.10) + (emit-clear-values) (compile-progn-body subforms nil nil) ;; Restore multiple values returned by first subform. (emit-push-current-thread) From ehuelsmann at common-lisp.net Sat Aug 20 22:18:37 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 20 Aug 2011 15:18:37 -0700 Subject: [armedbear-cvs] r13521 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Aug 20 15:18:37 2011 New Revision: 13521 Log: Revert r13509 because it breaks cl-ppcre compilation and the ANSI tests. Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispObject.java Sat Aug 20 15:01:18 2011 (r13520) +++ trunk/abcl/src/org/armedbear/lisp/LispObject.java Sat Aug 20 15:18:37 2011 (r13521) @@ -749,11 +749,6 @@ } } - public String toString() - { - return princToString(); - } - public String printObject() { return unreadableString(toString(), false); From ehuelsmann at common-lisp.net Sun Aug 21 09:10:44 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 21 Aug 2011 02:10:44 -0700 Subject: [armedbear-cvs] r13522 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 21 02:10:43 2011 New Revision: 13522 Log: Change COND indenting to save left margin. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sat Aug 20 15:18:37 2011 (r13521) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sun Aug 21 02:10:43 2011 (r13522) @@ -1177,75 +1177,79 @@ (defun p1 (form) (cond ((symbolp form) (let (value) - (cond ((null form) - form) - ((eq form t) - form) - ((keywordp form) - form) - ((and (constantp form) - (progn - (setf value (symbol-value form)) - (or (numberp value) - (stringp value) - (pathnamep value)))) - (setf form value)) - (t - (let ((variable (find-visible-variable form))) - (when (null variable) - (unless (or (special-variable-p form) - (memq form *undefined-variables*)) - (compiler-style-warn - "Undefined variable ~S assumed special" form) - (push form *undefined-variables*)) - (setf variable (make-variable :name form :special-p t)) - (push variable *visible-variables*)) - (let ((ref (make-var-ref variable))) - (unless (variable-special-p variable) - (when (variable-ignore-p variable) - (compiler-style-warn - "Variable ~S is read even though it was declared to be ignored." - (variable-name variable))) - (push ref (variable-references variable)) - (incf (variable-reads variable)) - (cond ((eq (variable-compiland variable) *current-compiland*) - (dformat t "p1: read ~S~%" form)) - (t - (dformat t "p1: non-local read ~S variable-compiland = ~S current compiland = ~S~%" - form - (compiland-name (variable-compiland variable)) - (compiland-name *current-compiland*)) - (setf (variable-used-non-locally-p variable) t)))) - (setf form ref))) - form)))) + (cond + ((null form) + form) + ((eq form t) + form) + ((keywordp form) + form) + ((and (constantp form) + (progn + (setf value (symbol-value form)) + (or (numberp value) + (stringp value) + (pathnamep value)))) + (setf form value)) + (t + (let ((variable (find-visible-variable form))) + (when (null variable) + (unless (or (special-variable-p form) + (memq form *undefined-variables*)) + (compiler-style-warn + "Undefined variable ~S assumed special" form) + (push form *undefined-variables*)) + (setf variable (make-variable :name form :special-p t)) + (push variable *visible-variables*)) + (let ((ref (make-var-ref variable))) + (unless (variable-special-p variable) + (when (variable-ignore-p variable) + (compiler-style-warn + "Variable ~S is read even though it was declared to be ignored." + (variable-name variable))) + (push ref (variable-references variable)) + (incf (variable-reads variable)) + (cond + ((eq (variable-compiland variable) *current-compiland*) + (dformat t "p1: read ~S~%" form)) + (t + (dformat t "p1: non-local read ~S variable-compiland = ~S current compiland = ~S~%" + form + (compiland-name (variable-compiland variable)) + (compiland-name *current-compiland*)) + (setf (variable-used-non-locally-p variable) t)))) + (setf form ref))) + form)))) ((atom form) form) (t (let ((op (%car form)) handler) - (cond ((symbolp op) - (when (compiler-macro-function op) - (unless (notinline-p op) - (multiple-value-bind (expansion expanded-p) - (compiler-macroexpand form) - ;; Fall through if no change... - (when expanded-p - (return-from p1 (p1 expansion)))))) - (cond ((setf handler (get op 'p1-handler)) - (funcall handler form)) - ((macro-function op *compile-file-environment*) - (p1 (macroexpand form *compile-file-environment*))) - ((special-operator-p op) - (compiler-unsupported "P1: unsupported special operator ~S" op)) - (t - (p1-function-call form)))) - ((and (consp op) (eq (%car op) 'LAMBDA)) - (let ((maybe-optimized-call (rewrite-function-call form))) - (if (eq maybe-optimized-call form) - (p1 `(%funcall (function ,op) ,@(cdr form))) - (p1 maybe-optimized-call)))) - (t - form)))))) + (cond + ((symbolp op) + (when (compiler-macro-function op) + (unless (notinline-p op) + (multiple-value-bind (expansion expanded-p) + (compiler-macroexpand form) + ;; Fall through if no change... + (when expanded-p + (return-from p1 (p1 expansion)))))) + (cond + ((setf handler (get op 'p1-handler)) + (funcall handler form)) + ((macro-function op *compile-file-environment*) + (p1 (macroexpand form *compile-file-environment*))) + ((special-operator-p op) + (compiler-unsupported "P1: unsupported special operator ~S" op)) + (t + (p1-function-call form)))) + ((and (consp op) (eq (%car op) 'LAMBDA)) + (let ((maybe-optimized-call (rewrite-function-call form))) + (if (eq maybe-optimized-call form) + (p1 `(%funcall (function ,op) ,@(cdr form))) + (p1 maybe-optimized-call)))) + (t + form)))))) (defun install-p1-handler (symbol handler) (setf (get symbol 'p1-handler) handler)) From ehuelsmann at common-lisp.net Sun Aug 21 12:54:21 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 21 Aug 2011 05:54:21 -0700 Subject: [armedbear-cvs] r13523 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 21 05:54:20 2011 New Revision: 13523 Log: Reindenting to save left margin. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Aug 21 02:10:43 2011 (r13522) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Aug 21 05:54:20 2011 (r13523) @@ -6881,91 +6881,91 @@ (defknown compile-form (t t t) t) (defun compile-form (form target representation) - (cond ((consp form) - (let* ((op (%car form)) - (handler (and (symbolp op) (get op 'p2-handler)))) - (cond (handler - (funcall handler form target representation)) - ((symbolp op) - (cond ((macro-function op *compile-file-environment*) - (compile-form (macroexpand form *compile-file-environment*) - target representation)) - ((special-operator-p op) - (dformat t "form = ~S~%" form) - (compiler-unsupported - "COMPILE-FORM: unsupported special operator ~S" op)) - (t - (compile-function-call form target representation)))) - ((and (consp op) (eq (%car op) 'LAMBDA)) - (aver (progn 'unexpected-lambda nil)) - (let ((new-form (list* 'FUNCALL form))) - (compile-form new-form target representation))) - (t - (compiler-unsupported "COMPILE-FORM unhandled case ~S" form))))) - ((symbolp form) - (cond ((null form) - (emit-push-false representation) - (emit-move-from-stack target representation)) - ((eq form t) - (emit-push-true representation) - (emit-move-from-stack target representation)) - ((keywordp form) - (ecase representation - (:boolean - (emit 'iconst_1)) - ((nil) - (emit-load-externalized-object form))) - (emit-move-from-stack target representation)) - (t - ;; Shouldn't happen. - (aver nil)))) - ((var-ref-p form) - (compile-var-ref form target representation)) - ((node-p form) - (cond - ((jump-node-p form) - (let ((op (car (node-form form)))) - (cond - ((eq op 'go) - (p2-go form target representation)) - ((eq op 'return-from) - (p2-return-from form target representation)) - (t - (assert (not "jump-node: can't happen")))))) - ((block-node-p form) - (p2-block-node form target representation)) - ((let/let*-node-p form) - (p2-let/let*-node form target representation)) - ((tagbody-node-p form) - (p2-tagbody-node form target) - (fix-boxing representation nil)) - ((unwind-protect-node-p form) - (p2-unwind-protect-node form target) - (fix-boxing representation nil)) - ((m-v-b-node-p form) - (p2-m-v-b-node form target) - (fix-boxing representation nil)) - ((flet-node-p form) - (p2-flet-node form target representation)) - ((labels-node-p form) - (p2-labels-node form target representation)) - ((locally-node-p form) - (p2-locally-node form target representation)) - ((catch-node-p form) - (p2-catch-node form target) - (fix-boxing representation nil)) - ((progv-node-p form) - (p2-progv-node form target representation)) - ((synchronized-node-p form) - (p2-threads-synchronized-on form target) - (fix-boxing representation nil)) - (t - (aver (not "Can't happen"))) -)) - ((constantp form) - (compile-constant form target representation)) - (t - (compiler-unsupported "COMPILE-FORM unhandled case ~S" form))) + (cond + ((consp form) + (let* ((op (%car form)) + (handler (and (symbolp op) (get op 'p2-handler)))) + (cond + (handler + (funcall handler form target representation)) + ((symbolp op) + (cond + ((special-operator-p op) + (dformat t "form = ~S~%" form) + (compiler-unsupported + "COMPILE-FORM: unsupported special operator ~S" op)) + (t + (compile-function-call form target representation)))) + ((and (consp op) (eq (%car op) 'LAMBDA)) + (aver (progn 'unexpected-lambda nil)) + (let ((new-form (list* 'FUNCALL form))) + (compile-form new-form target representation))) + (t + (compiler-unsupported "COMPILE-FORM unhandled case ~S" form))))) + ((symbolp form) + (cond + ((null form) + (emit-push-false representation) + (emit-move-from-stack target representation)) + ((eq form t) + (emit-push-true representation) + (emit-move-from-stack target representation)) + ((keywordp form) + (ecase representation + (:boolean + (emit 'iconst_1)) + ((nil) + (emit-load-externalized-object form))) + (emit-move-from-stack target representation)) + (t + ;; Shouldn't happen. + (aver nil)))) + ((var-ref-p form) + (compile-var-ref form target representation)) + ((node-p form) + (cond + ((jump-node-p form) + (let ((op (car (node-form form)))) + (cond + ((eq op 'go) + (p2-go form target representation)) + ((eq op 'return-from) + (p2-return-from form target representation)) + (t + (assert (not "jump-node: can't happen")))))) + ((block-node-p form) + (p2-block-node form target representation)) + ((let/let*-node-p form) + (p2-let/let*-node form target representation)) + ((tagbody-node-p form) + (p2-tagbody-node form target) + (fix-boxing representation nil)) + ((unwind-protect-node-p form) + (p2-unwind-protect-node form target) + (fix-boxing representation nil)) + ((m-v-b-node-p form) + (p2-m-v-b-node form target) + (fix-boxing representation nil)) + ((flet-node-p form) + (p2-flet-node form target representation)) + ((labels-node-p form) + (p2-labels-node form target representation)) + ((locally-node-p form) + (p2-locally-node form target representation)) + ((catch-node-p form) + (p2-catch-node form target) + (fix-boxing representation nil)) + ((progv-node-p form) + (p2-progv-node form target representation)) + ((synchronized-node-p form) + (p2-threads-synchronized-on form target) + (fix-boxing representation nil)) + (t + (aver (not "Can't happen"))))) + ((constantp form) + (compile-constant form target representation)) + (t + (compiler-unsupported "COMPILE-FORM unhandled case ~S" form))) t) From ehuelsmann at common-lisp.net Sun Aug 21 12:58:50 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 21 Aug 2011 05:58:50 -0700 Subject: [armedbear-cvs] r13524 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 21 05:58:49 2011 New Revision: 13524 Log: Reindenting to save left margin. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sun Aug 21 05:54:20 2011 (r13523) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sun Aug 21 05:58:49 2011 (r13524) @@ -1175,81 +1175,82 @@ (defknown p1 (t) t) (defun p1 (form) - (cond ((symbolp form) - (let (value) - (cond - ((null form) - form) - ((eq form t) - form) - ((keywordp form) - form) - ((and (constantp form) - (progn - (setf value (symbol-value form)) - (or (numberp value) - (stringp value) - (pathnamep value)))) - (setf form value)) - (t - (let ((variable (find-visible-variable form))) - (when (null variable) - (unless (or (special-variable-p form) - (memq form *undefined-variables*)) - (compiler-style-warn - "Undefined variable ~S assumed special" form) - (push form *undefined-variables*)) - (setf variable (make-variable :name form :special-p t)) - (push variable *visible-variables*)) - (let ((ref (make-var-ref variable))) - (unless (variable-special-p variable) - (when (variable-ignore-p variable) - (compiler-style-warn - "Variable ~S is read even though it was declared to be ignored." - (variable-name variable))) - (push ref (variable-references variable)) - (incf (variable-reads variable)) - (cond - ((eq (variable-compiland variable) *current-compiland*) - (dformat t "p1: read ~S~%" form)) - (t - (dformat t "p1: non-local read ~S variable-compiland = ~S current compiland = ~S~%" - form - (compiland-name (variable-compiland variable)) - (compiland-name *current-compiland*)) - (setf (variable-used-non-locally-p variable) t)))) - (setf form ref))) - form)))) - ((atom form) - form) - (t - (let ((op (%car form)) - handler) - (cond - ((symbolp op) - (when (compiler-macro-function op) - (unless (notinline-p op) - (multiple-value-bind (expansion expanded-p) - (compiler-macroexpand form) - ;; Fall through if no change... - (when expanded-p - (return-from p1 (p1 expansion)))))) - (cond - ((setf handler (get op 'p1-handler)) - (funcall handler form)) - ((macro-function op *compile-file-environment*) - (p1 (macroexpand form *compile-file-environment*))) - ((special-operator-p op) - (compiler-unsupported "P1: unsupported special operator ~S" op)) - (t - (p1-function-call form)))) - ((and (consp op) (eq (%car op) 'LAMBDA)) - (let ((maybe-optimized-call (rewrite-function-call form))) - (if (eq maybe-optimized-call form) - (p1 `(%funcall (function ,op) ,@(cdr form))) - (p1 maybe-optimized-call)))) - (t - form)))))) + (cond + ((symbolp form) + (let (value) + (cond + ((null form) + form) + ((eq form t) + form) + ((keywordp form) + form) + ((and (constantp form) + (progn + (setf value (symbol-value form)) + (or (numberp value) + (stringp value) + (pathnamep value)))) + (setf form value)) + (t + (let ((variable (find-visible-variable form))) + (when (null variable) + (unless (or (special-variable-p form) + (memq form *undefined-variables*)) + (compiler-style-warn + "Undefined variable ~S assumed special" form) + (push form *undefined-variables*)) + (setf variable (make-variable :name form :special-p t)) + (push variable *visible-variables*)) + (let ((ref (make-var-ref variable))) + (unless (variable-special-p variable) + (when (variable-ignore-p variable) + (compiler-style-warn + "Variable ~S is read even though it was declared to be ignored." + (variable-name variable))) + (push ref (variable-references variable)) + (incf (variable-reads variable)) + (cond + ((eq (variable-compiland variable) *current-compiland*) + (dformat t "p1: read ~S~%" form)) + (t + (dformat t "p1: non-local read ~S variable-compiland = ~S current compiland = ~S~%" + form + (compiland-name (variable-compiland variable)) + (compiland-name *current-compiland*)) + (setf (variable-used-non-locally-p variable) t)))) + (setf form ref))) + form)))) + ((atom form) + form) + (t + (let ((op (%car form)) + handler) + (cond + ((symbolp op) + (when (compiler-macro-function op) + (unless (notinline-p op) + (multiple-value-bind (expansion expanded-p) + (compiler-macroexpand form) + ;; Fall through if no change... + (when expanded-p + (return-from p1 (p1 expansion)))))) + (cond + ((setf handler (get op 'p1-handler)) + (funcall handler form)) + ((macro-function op *compile-file-environment*) + (p1 (macroexpand form *compile-file-environment*))) + ((special-operator-p op) + (compiler-unsupported "P1: unsupported special operator ~S" op)) + (t + (p1-function-call form)))) + ((and (consp op) (eq (%car op) 'LAMBDA)) + (let ((maybe-optimized-call (rewrite-function-call form))) + (if (eq maybe-optimized-call form) + (p1 `(%funcall (function ,op) ,@(cdr form))) + (p1 maybe-optimized-call)))) + (t + form)))))) (defun install-p1-handler (symbol handler) (setf (get symbol 'p1-handler) handler)) From ehuelsmann at common-lisp.net Sun Aug 21 13:37:52 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 21 Aug 2011 06:37:52 -0700 Subject: [armedbear-cvs] r13523 - svn:log Message-ID: Author: ehuelsmann Revision: 13523 Property Name: svn:log Action: modified Property diff: --- old property value +++ new property value @@ -1 +1,4 @@ -Reindenting to save left margin. \ No newline at end of file +Re #163: Don't macroexpand anything in compiler pass 2; we're completely +macroexpanded by precompilation and pass 1. + +Also: Reindenting to save left margin. \ No newline at end of file From ehuelsmann at common-lisp.net Sun Aug 21 14:06:34 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 21 Aug 2011 07:06:34 -0700 Subject: [armedbear-cvs] r13525 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 21 07:06:31 2011 New Revision: 13525 Log: Fix #163: Local functions should shadow global macro and function bindings. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sun Aug 21 05:58:49 2011 (r13524) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sun Aug 21 07:06:31 2011 (r13525) @@ -1228,6 +1228,11 @@ handler) (cond ((symbolp op) + (when (find-local-function op) + ;; local functions shadow macros and functions in + ;; the global environment as well as compiler macros + (return-from p1 + (p1-function-call form))) (when (compiler-macro-function op) (unless (notinline-p op) (multiple-value-bind (expansion expanded-p) From ehuelsmann at common-lisp.net Sun Aug 21 18:46:24 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 21 Aug 2011 11:46:24 -0700 Subject: [armedbear-cvs] r13526 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 21 11:46:22 2011 New Revision: 13526 Log: Factor out a function. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sun Aug 21 07:06:31 2011 (r13525) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sun Aug 21 11:46:22 2011 (r13526) @@ -1173,6 +1173,35 @@ "Dummy FUNCALL wrapper to force p1 not to optimize the call." (apply fn args)) +(defun p1-variable-reference (var) + (let ((variable (find-visible-variable var))) + (when (null variable) + (unless (or (special-variable-p var) + (memq var *undefined-variables*)) + (compiler-style-warn + "Undefined variable ~S assumed special" var) + (push var *undefined-variables*)) + (setf variable (make-variable :name var :special-p t)) + (push variable *visible-variables*)) + (let ((ref (make-var-ref variable))) + (unless (variable-special-p variable) + (when (variable-ignore-p variable) + (compiler-style-warn + "Variable ~S is read even though it was declared to be ignored." + (variable-name variable))) + (push ref (variable-references variable)) + (incf (variable-reads variable)) + (cond + ((eq (variable-compiland variable) *current-compiland*) + (dformat t "p1: read ~S~%" var)) + (t + (dformat t "p1: non-local read ~S variable-compiland = ~S current compiland = ~S~%" + var + (compiland-name (variable-compiland variable)) + (compiland-name *current-compiland*)) + (setf (variable-used-non-locally-p variable) t)))) + ref))) + (defknown p1 (t) t) (defun p1 (form) (cond @@ -1193,34 +1222,7 @@ (pathnamep value)))) (setf form value)) (t - (let ((variable (find-visible-variable form))) - (when (null variable) - (unless (or (special-variable-p form) - (memq form *undefined-variables*)) - (compiler-style-warn - "Undefined variable ~S assumed special" form) - (push form *undefined-variables*)) - (setf variable (make-variable :name form :special-p t)) - (push variable *visible-variables*)) - (let ((ref (make-var-ref variable))) - (unless (variable-special-p variable) - (when (variable-ignore-p variable) - (compiler-style-warn - "Variable ~S is read even though it was declared to be ignored." - (variable-name variable))) - (push ref (variable-references variable)) - (incf (variable-reads variable)) - (cond - ((eq (variable-compiland variable) *current-compiland*) - (dformat t "p1: read ~S~%" form)) - (t - (dformat t "p1: non-local read ~S variable-compiland = ~S current compiland = ~S~%" - form - (compiland-name (variable-compiland variable)) - (compiland-name *current-compiland*)) - (setf (variable-used-non-locally-p variable) t)))) - (setf form ref))) - form)))) + (p1-variable-reference form))))) ((atom form) form) (t From ehuelsmann at common-lisp.net Sun Aug 21 18:58:08 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 21 Aug 2011 11:58:08 -0700 Subject: [armedbear-cvs] r13527 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 21 11:58:07 2011 New Revision: 13527 Log: Improved readability. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Aug 21 11:46:22 2011 (r13526) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Aug 21 11:58:07 2011 (r13527) @@ -3654,8 +3654,8 @@ (t (compile-form subform nil nil) (unless must-clear-values - (unless (single-valued-p subform) - (setf must-clear-values t)))))) + (setf must-clear-values + (single-valued-p subform)))))) (label END-BLOCK) (emit 'goto EXIT) (when (tagbody-non-local-go-p block) From ehuelsmann at common-lisp.net Sun Aug 21 20:03:45 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 21 Aug 2011 13:03:45 -0700 Subject: [armedbear-cvs] r13528 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 21 13:03:44 2011 New Revision: 13528 Log: Fix MULTIPLE-VALUE-PROG1.10 the right way. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Aug 21 11:58:07 2011 (r13527) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Aug 21 13:03:44 2011 (r13528) @@ -3005,14 +3005,6 @@ (emit-push-current-thread) (emit-getfield +lisp-thread+ "_values" +lisp-object-array+) (astore values-register) - - ;; we need to clear the values again: - ;; some parts will consider a non-null _values array - ;; by itself a legitimate return value (multiple values) - ;; however, if we have a non-local return after the previous form - ;; set the values array, other code may pick up the values instead - ;; of the actual return code. (Fixes MULTIPLE-VALUE-PROG1.10) - (emit-clear-values) (compile-progn-body subforms nil nil) ;; Restore multiple values returned by first subform. (emit-push-current-thread) @@ -3894,8 +3886,7 @@ ;; Local case. Is the RETURN nested inside an UNWIND-PROTECT which is ;; inside the block we're returning from? (unless (enclosed-by-protected-block-p block) - (unless (compiland-single-valued-p *current-compiland*) - (emit-clear-values)) + (emit-clear-values) (compile-form result-form (block-target block) nil) (when (and (block-needs-environment-restoration block) (enclosed-by-environment-setting-block-p block)) From ehuelsmann at common-lisp.net Sun Aug 21 20:12:11 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 21 Aug 2011 13:12:11 -0700 Subject: [armedbear-cvs] r13529 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Aug 21 13:12:11 2011 New Revision: 13529 Log: Aesthetics. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Aug 21 13:03:44 2011 (r13528) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Aug 21 13:12:11 2011 (r13529) @@ -3124,23 +3124,23 @@ (emit-push-nil) (emit-move-from-stack target))) (t - (let ((clear-values nil) - (tail body)) - (loop - (let ((form (car tail))) - (cond ((null (cdr tail)) - ;; Last form. - (when clear-values - (emit-clear-values)) - (compile-form form target representation) - (return)) - (t - ;; Not the last form. - (compile-form form nil nil) - (unless clear-values - (unless (single-valued-p form) - (setq clear-values t))))) - (setq tail (cdr tail))))))) + (loop + with clear-values = nil + for tail on body + for form = (car tail) + do (cond + ((null (cdr tail)) + ;; Last form. + (when clear-values + (emit-clear-values)) + (compile-form form target representation) + (return)) + (t + ;; Not the last form. + (compile-form form nil nil) + (unless clear-values + (unless (single-valued-p form) + (setq clear-values t)))))))) t) (defun restore-dynamic-environment (register) From mevenson at common-lisp.net Mon Aug 22 09:52:29 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 22 Aug 2011 02:52:29 -0700 Subject: [armedbear-cvs] r13530 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon Aug 22 02:52:28 2011 New Revision: 13530 Log: All LispThread objects can act on a ProcessingTerminated exception. Without this modifications, threads created with the THREADS:MAKE-THREADS cannot successfully call the EXT:QUIT or EXT:EXIT functions. This prevented the SLIME quit implementation from successfully quitting implementations. Note that all threads can always execute a form like (jstatic "exit" "java.lang.System" 0) to uncermoniously exit the JVM, so there is nothing gained security-wise by preventing threads from using the official Lisp interfaces. Modified: trunk/abcl/src/org/armedbear/lisp/LispThread.java Modified: trunk/abcl/src/org/armedbear/lisp/LispThread.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispThread.java Sun Aug 21 13:12:11 2011 (r13529) +++ trunk/abcl/src/org/armedbear/lisp/LispThread.java Mon Aug 22 02:52:28 2011 (r13530) @@ -41,6 +41,8 @@ import java.util.concurrent.ConcurrentLinkedQueue; import java.util.concurrent.atomic.AtomicInteger; +import java.text.MessageFormat; + public final class LispThread extends LispObject { static boolean use_fast_calls = false; @@ -98,10 +100,17 @@ catch (ThreadDestroyed ignored) { // Might happen. } + catch (ProcessingTerminated e) { + System.exit(e.getStatus()); + } catch (Throwable t) { // any error: process thread interrupts if (isInterrupted()) { processThreadInterrupts(); } + String msg + = MessageFormat.format("Ignoring uncaught exception {0}.", + t.toString()); + Debug.warn(msg); } finally { // make sure the thread is *always* removed from the hash again From mevenson at common-lisp.net Mon Aug 22 14:48:39 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 22 Aug 2011 07:48:39 -0700 Subject: [armedbear-cvs] r13531 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon Aug 22 07:48:39 2011 New Revision: 13531 Log: Optimize the compilation of files with a large number of compilands. Don't use DIRECTORY with a wildcard unless when compiling files unless we know of the presence of at least one class constant ".clc" via PROBE-FILE. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Mon Aug 22 02:52:28 2011 (r13530) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Mon Aug 22 07:48:39 2011 (r13531) @@ -588,12 +588,18 @@ (let ((truename (probe-file (compute-classfile-name (1+ i))))) (when truename (push truename pathnames) - (dolist (resource (directory - (make-pathname :name (format nil "~A_*" - (pathname-name truename)) - :type "clc" - :defaults truename))) - (push resource pathnames))))) + ;;; XXX it would be better to just use the recorded number + ;;; of class constants, but probing for the first at least + ;;; makes this subjectively bearable. + (when (probe-file (make-pathname :name (format nil "~A_1" (pathname-name truename)) + :type "clc" + :defaults truename)) + (dolist (resource (directory + (make-pathname :name (format nil "~A_*" + (pathname-name truename)) + :type "clc" + :defaults truename))) + (push resource pathnames)))))) (setf pathnames (nreverse (remove nil pathnames))) (let ((load-file (merge-pathnames (make-pathname :type "_") output-file))) From mevenson at common-lisp.net Tue Aug 23 10:43:05 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 23 Aug 2011 03:43:05 -0700 Subject: [armedbear-cvs] r13532 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue Aug 23 03:43:03 2011 New Revision: 13532 Log: Fix compiler for compile-time toplevel defstruct with print-object. Fixes some problems which arose in compiling SBCL. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Mon Aug 22 07:48:39 2011 (r13531) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Tue Aug 23 03:43:03 2011 (r13532) @@ -271,13 +271,17 @@ (format *error-output* "; Unable to compile method~%")))))))))) + (when compile-time-too + (let* ((copy-form (copy-tree form)) + ;; ### Ideally, the precompiler would leave the forms alone + ;; and copy them where required, instead of forcing us to + ;; do a deep copy in advance + (precompiled-form (precompiler:precompile-form copy-form nil + *compile-file-environment*))) + (eval precompiled-form))) (convert-ensure-method form :function) (convert-ensure-method form :fast-function)) - (let ((form (precompiler:precompile-form form nil - *compile-file-environment*))) - (when compile-time-too - (eval form)) - form)) + (precompiler:precompile-form form nil *compile-file-environment*)) (declaim (ftype (function (t t t) t) process-toplevel-defvar/defparameter)) (defun process-toplevel-defvar/defparameter (form stream compile-time-too) From ehuelsmann at common-lisp.net Tue Aug 23 12:48:25 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 23 Aug 2011 05:48:25 -0700 Subject: [armedbear-cvs] r13533 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Aug 23 05:48:24 2011 New Revision: 13533 Log: Remove two unnecessary EVAL-WHEN forms. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Tue Aug 23 03:43:03 2011 (r13532) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Tue Aug 23 05:48:24 2011 (r13533) @@ -31,37 +31,35 @@ (in-package "JVM") -(eval-when (:compile-toplevel :load-toplevel :execute) - (require "LOOP") - (require "FORMAT") - (require "CLOS") - (require "PRINT-OBJECT") - (require "COMPILER-TYPES") - (require "KNOWN-FUNCTIONS") - (require "KNOWN-SYMBOLS") - (require "DUMP-FORM") - (require "OPCODES") - (require "JAVA")) - - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun generate-inline-expansion (name lambda-list body - &optional (args nil args-p)) - "Generates code that can be used to expand a named local function inline. It can work either per-function (no args provided) or per-call." - (if args-p - (expand-function-call-inline - nil lambda-list - (copy-tree `((block ,name , at body))) - args) - (cond ((intersection lambda-list - '(&optional &rest &key &allow-other-keys &aux) - :test #'eq) - nil) - (t - (setf body (copy-tree body)) - (list 'LAMBDA lambda-list - (list* 'BLOCK name body)))))) - ) ; EVAL-WHEN +(require "LOOP") +(require "FORMAT") +(require "CLOS") +(require "PRINT-OBJECT") +(require "COMPILER-TYPES") +(require "KNOWN-FUNCTIONS") +(require "KNOWN-SYMBOLS") +(require "DUMP-FORM") +(require "OPCODES") +(require "JAVA") + + +(defun generate-inline-expansion (name lambda-list body + &optional (args nil args-p)) + "Generates code that can be used to expand a named local function inline. +It can work either per-function (no args provided) or per-call." + (if args-p + (expand-function-call-inline nil lambda-list + (copy-tree `((block ,name , at body))) + args) + (cond ((intersection lambda-list + '(&optional &rest &key &allow-other-keys &aux) + :test #'eq) + nil) + (t + (setf body (copy-tree body)) + (list 'LAMBDA lambda-list + (list* 'BLOCK name body)))))) + ;;; Pass 1. From ehuelsmann at common-lisp.net Tue Aug 23 20:31:03 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 23 Aug 2011 13:31:03 -0700 Subject: [armedbear-cvs] r13534 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Aug 23 13:31:01 2011 New Revision: 13534 Log: Follow-up to r13531: The first resource file is _0, not _1. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Tue Aug 23 05:48:24 2011 (r13533) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Tue Aug 23 13:31:01 2011 (r13534) @@ -595,9 +595,11 @@ ;;; XXX it would be better to just use the recorded number ;;; of class constants, but probing for the first at least ;;; makes this subjectively bearable. - (when (probe-file (make-pathname :name (format nil "~A_1" (pathname-name truename)) - :type "clc" - :defaults truename)) + (when (probe-file + (make-pathname :name (format nil "~A_0" + (pathname-name truename)) + :type "clc" + :defaults truename)) (dolist (resource (directory (make-pathname :name (format nil "~A_*" (pathname-name truename)) From ehuelsmann at common-lisp.net Tue Aug 23 20:35:33 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 23 Aug 2011 13:35:33 -0700 Subject: [armedbear-cvs] r13535 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Aug 23 13:35:32 2011 New Revision: 13535 Log: Moving huge object serialization from () to () broke the code generation for that special case -- there's no longer a 'this' variable to be loaded. Replace with .class. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/compiler-types.lisp trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Tue Aug 23 13:31:01 2011 (r13534) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Tue Aug 23 13:35:32 2011 (r13535) @@ -1057,7 +1057,7 @@ (defun make-static-initializer (class) (let ((*compiler-debug* nil) (method (make-jvm-method :static-initializer - :void nil :flags '(:public :static)))) + :void nil :flags '(:public :static)))) ;; We don't normally need to see debugging output for . (with-code-to-method (class method) method))) @@ -1205,8 +1205,8 @@ (emit-invokestatic +lisp+ "readObjectFromString" (list +java-string+) +lisp-object+)) (t - (aload 0) ;; this - (emit-invokevirtual +java-object+ "getClass" '() +java-class+) + ;; get a 'class literal' for this class + (emit 'ldc_w (pool-class *this-class*)) (let ((pathname (compiland-external-constant-resource-name *current-compiland*))) (with-open-file (f pathname Modified: trunk/abcl/src/org/armedbear/lisp/compiler-types.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-types.lisp Tue Aug 23 13:31:01 2011 (r13534) +++ trunk/abcl/src/org/armedbear/lisp/compiler-types.lisp Tue Aug 23 13:35:32 2011 (r13535) @@ -226,7 +226,7 @@ (values (subtypep compiler-type typespec))))) (declaim (type hash-table *function-result-types*)) -(defconst *function-result-types* (make-hash-table :test 'equal)) +(defvar *function-result-types* (make-hash-table :test 'equal)) (declaim (ftype (function (t) t) function-result-type)) (defun function-result-type (name) Modified: trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Tue Aug 23 13:31:01 2011 (r13534) +++ trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Tue Aug 23 13:35:32 2011 (r13535) @@ -698,8 +698,11 @@ ;; header (write-u4 #xCAFEBABE stream) - (write-u2 3 stream) - (write-u2 45 stream) + (write-u2 0 stream) + (write-u2 49 stream) ;; our methods use class literals + ;; which require a high enough class file format + ;; we used to have 45, but the LDC instruction doesn't support + ;; class literals in that version... (49 == Java 1.5) ;; constants pool (write-constants (class-file-constants class) stream) @@ -714,7 +717,7 @@ ;; interfaces (if (class-file-interfaces class) - (progn + (progn (write-u2 (length (class-file-interfaces class)) stream) (dolist (interface-ref (class-file-interfaces class)) (write-u2 interface-ref stream))) Modified: trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Tue Aug 23 13:31:01 2011 (r13534) +++ trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Tue Aug 23 13:35:32 2011 (r13535) @@ -660,6 +660,13 @@ (inst 19 (u2 (car args))) ; LDC_W (inst 18 args)))) +;; ldc_w +(define-resolver 19 (instruction) + (let* ((args (instruction-args instruction))) + (unless (= (length args) 1) + (error "Wrong number of args for LDC_W.")) + (inst 19 (u2 (car args))))) + ;; ldc2_w (define-resolver 20 (instruction) (let* ((args (instruction-args instruction))) From ehuelsmann at common-lisp.net Tue Aug 23 21:34:33 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 23 Aug 2011 14:34:33 -0700 Subject: [armedbear-cvs] r13536 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Aug 23 14:34:33 2011 New Revision: 13536 Log: Move more static field initialization to the static class initializer () code. Additionally, place some remarks where I expect issues once I start compiling forward references the same way as backward references. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Tue Aug 23 13:35:32 2011 (r13535) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Tue Aug 23 14:34:33 2011 (r13536) @@ -1392,7 +1392,7 @@ (local-function-compiland local-function)))) (field-name (local-function-field local-function))) (with-code-to-method - (*class-file* (abcl-class-file-constructor *class-file*)) + (*class-file* (abcl-class-file-static-initializer *class-file*)) ;; fixme *declare-inline* (declare-field field-name +lisp-object+) (emit-new class-name) @@ -1416,7 +1416,7 @@ (with-code-to-method (*class-file* (if *declare-inline* *method* - (abcl-class-file-constructor *class-file*))) + (abcl-class-file-static-initializer *class-file*))) ;; strings may contain evaluated bits which may depend on ;; previous statements (declare-field g +lisp-object+) @@ -1432,7 +1432,7 @@ (with-code-to-method (*class-file* (if *declare-inline* *method* - (abcl-class-file-constructor *class-file*))) + (abcl-class-file-static-initializer *class-file*))) ;; 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 @@ -1455,7 +1455,7 @@ ;; fixme *declare-inline*? (remember g obj) (with-code-to-method - (*class-file* (abcl-class-file-constructor *class-file*)) + (*class-file* (abcl-class-file-static-initializer *class-file*)) (declare-field g +lisp-object+) (emit 'ldc (pool-string g)) (emit-invokestatic +lisp+ "recall" @@ -4149,6 +4149,11 @@ (emit-load-local-function local-function) (emit-move-from-stack target)) ((inline-ok name) + ;; ### FASLATONCE: when compiling fasl functions after the + ;; full fasl has been processed, forward referenced functions + ;; may not be available during the load process + ;; This case is particularly triggered with circular referencing + ;; functions, both marked as 'notinline' (emit-getstatic *this-class* (declare-function name) +lisp-object+) (emit-move-from-stack target)) @@ -4166,6 +4171,11 @@ (emit-load-local-function local-function)) ((and (member name *functions-defined-in-current-file* :test #'equal) (not (notinline-p name))) + ;; ### FASLATONCE: when compiling fasl functions after the + ;; full fasl has been processed, forward referenced functions + ;; may not be available during the load process + ;; This case is particularly triggered with circular referencing + ;; functions, both marked as 'notinline' (emit-getstatic *this-class* (declare-setf-function name) +lisp-object+) (emit-move-from-stack target)) From ehuelsmann at common-lisp.net Wed Aug 24 08:49:57 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Wed, 24 Aug 2011 01:49:57 -0700 Subject: [armedbear-cvs] r13537 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Aug 24 01:49:56 2011 New Revision: 13537 Log: Follow up to r13527 fixes TAGBODY.3 and TAGBODY.4 regressions. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Tue Aug 23 14:34:33 2011 (r13536) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Wed Aug 24 01:49:56 2011 (r13537) @@ -3647,7 +3647,7 @@ (compile-form subform nil nil) (unless must-clear-values (setf must-clear-values - (single-valued-p subform)))))) + (not (single-valued-p subform))))))) (label END-BLOCK) (emit 'goto EXIT) (when (tagbody-non-local-go-p block) From mevenson at common-lisp.net Thu Aug 25 09:24:02 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 25 Aug 2011 02:24:02 -0700 Subject: [armedbear-cvs] r13538 - in trunk/abcl: src/org/armedbear/lisp test/lisp/abcl Message-ID: Author: mevenson Date: Thu Aug 25 02:24:01 2011 New Revision: 13538 Log: (partially) address ticket #165. sbcl-buildhost gets much further, and the ANSI tests show no additional failures, but still something is not quite right here. N.B. The test still doesn't succeed. Modified: trunk/abcl/src/org/armedbear/lisp/format.lisp trunk/abcl/test/lisp/abcl/bugs.lisp Modified: trunk/abcl/src/org/armedbear/lisp/format.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/format.lisp Wed Aug 24 01:49:56 2011 (r13537) +++ trunk/abcl/src/org/armedbear/lisp/format.lisp Thu Aug 25 02:24:01 2011 (r13538) @@ -1073,7 +1073,9 @@ (after (nthcdr (1+ posn) directives))) (values (expand-bind-defaults () params - `(let ((stream (sys::make-case-frob-stream stream + `(let ((stream (sys::make-case-frob-stream (if (typep stream 'xp::xp-structure) + (xp::base-stream stream) + stream) ,(if colonp (if atsignp :upcase @@ -2578,14 +2580,17 @@ (let* ((posn (position close directives)) (before (subseq directives 0 posn)) (after (nthcdr (1+ posn) directives)) - (stream (sys::make-case-frob-stream stream - (if colonp - (if atsignp - :upcase - :capitalize) - (if atsignp - :capitalize-first - :downcase))))) + (stream (sys::make-case-frob-stream + (if (typep stream 'xp::xp-structure) + (xp::base-stream stream) + stream) + (if colonp + (if atsignp + :upcase + :capitalize) + (if atsignp + :capitalize-first + :downcase))))) (setf args (interpret-directive-list stream before orig-args args)) after)))) Modified: trunk/abcl/test/lisp/abcl/bugs.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/bugs.lisp Wed Aug 24 01:49:56 2011 (r13537) +++ trunk/abcl/test/lisp/abcl/bugs.lisp Thu Aug 25 02:24:01 2011 (r13538) @@ -82,4 +82,13 @@ (string (read-from-string "#:UPPER"))) (readtable-case *readtable*) original-case) (values-list result)) - "LOWER" "upper" "LOWER" "upper") \ No newline at end of file + "LOWER" "upper" "LOWER" "upper") + +;;; http://trac.common-lisp.net/armedbear/ticket/165 +(deftest bugs.pprint.1 + (let ((result (make-array '(0) :element-type 'base-char :fill-pointer t))) + (with-output-to-string (s result) + (pprint-logical-block (s nil :per-line-prefix "---") + (format s "~(~A~)" '(1 2 3 4)))) + result) + "---(1 2 3 4)") From mevenson at common-lisp.net Thu Aug 25 09:24:13 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 25 Aug 2011 02:24:13 -0700 Subject: [armedbear-cvs] r13539 - trunk/abcl/test/lisp/abcl Message-ID: Author: mevenson Date: Thu Aug 25 02:24:13 2011 New Revision: 13539 Log: Make compiler-tests.lisp safe for non-ABCL implementations again. Modified: trunk/abcl/test/lisp/abcl/compiler-tests.lisp Modified: trunk/abcl/test/lisp/abcl/compiler-tests.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/compiler-tests.lisp Thu Aug 25 02:24:01 2011 (r13538) +++ trunk/abcl/test/lisp/abcl/compiler-tests.lisp Thu Aug 25 02:24:13 2011 (r13539) @@ -444,6 +444,7 @@ :results #.most-positive-java-long) ;;; ticket #147 +#+abcl (deftest compiler.1 (let ((tmpfile (ext::make-temp-file)) (forms `((in-package :cl-user) @@ -459,6 +460,7 @@ t) ;;; ticket #156 +#+abcl (deftest compiler.2 (let ((tmpfile (ext::make-temp-file)) (line "(defconstant a #.(make-array '(8 256) From mevenson at common-lisp.net Sat Aug 27 23:23:07 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 27 Aug 2011 16:23:07 -0700 Subject: [armedbear-cvs] r13540 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sat Aug 27 16:23:05 2011 New Revision: 13540 Log: Pass wrapped error message to IllegalMonitorException. Modified: trunk/abcl/src/org/armedbear/lisp/IllegalMonitorState.java trunk/abcl/src/org/armedbear/lisp/LispThread.java Modified: trunk/abcl/src/org/armedbear/lisp/IllegalMonitorState.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/IllegalMonitorState.java Thu Aug 25 02:24:13 2011 (r13539) +++ trunk/abcl/src/org/armedbear/lisp/IllegalMonitorState.java Sat Aug 27 16:23:05 2011 (r13540) @@ -47,9 +47,23 @@ setFormatArguments(NIL); } + public IllegalMonitorState(String message) + { + // This is really just an ordinary PROGRAM-ERROR, broken out into its + // own Java class as a convenience for the implementation. + super(StandardClass.PROGRAM_ERROR); + if (message != null) { + this.message = message; + } + setFormatControl(getMessage()); + setFormatArguments(NIL); + } + + String message = "Illegal monitor state."; + @Override public String getMessage() { - return "Illegal monitor state."; + return message; } } Modified: trunk/abcl/src/org/armedbear/lisp/LispThread.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispThread.java Thu Aug 25 02:24:13 2011 (r13539) +++ trunk/abcl/src/org/armedbear/lisp/LispThread.java Sat Aug 27 16:23:05 2011 (r13540) @@ -1249,7 +1249,7 @@ currentThread().processThreadInterrupts(); } catch (IllegalMonitorStateException e) { - return error(new IllegalMonitorState()); + return error(new IllegalMonitorState(e.getMessage())); } return NIL; } @@ -1265,7 +1265,7 @@ currentThread().processThreadInterrupts(); } catch (IllegalMonitorStateException e) { - return error(new IllegalMonitorState()); + return error(new IllegalMonitorState(e.getMessage())); } return NIL; } @@ -1284,7 +1284,7 @@ object.lockableInstance().notify(); } catch (IllegalMonitorStateException e) { - return error(new IllegalMonitorState()); + return error(new IllegalMonitorState(e.getMessage())); } return NIL; } @@ -1302,7 +1302,7 @@ object.lockableInstance().notifyAll(); } catch (IllegalMonitorStateException e) { - return error(new IllegalMonitorState()); + return error(new IllegalMonitorState(e.getMessage())); } return NIL; } From mevenson at common-lisp.net Sat Aug 27 23:23:25 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 27 Aug 2011 16:23:25 -0700 Subject: [armedbear-cvs] r13541 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sat Aug 27 16:23:24 2011 New Revision: 13541 Log: Convert docstrings and primitives to standard conventions. Modified: trunk/abcl/src/org/armedbear/lisp/SlotClass.java trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java trunk/abcl/src/org/armedbear/lisp/StandardMethod.java trunk/abcl/src/org/armedbear/lisp/StandardObject.java trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java trunk/abcl/src/org/armedbear/lisp/StandardReaderMethod.java trunk/abcl/src/org/armedbear/lisp/StructureObject.java trunk/abcl/src/org/armedbear/lisp/mop.lisp Modified: trunk/abcl/src/org/armedbear/lisp/SlotClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SlotClass.java Sat Aug 27 16:23:05 2011 (r13540) +++ trunk/abcl/src/org/armedbear/lisp/SlotClass.java Sat Aug 27 16:23:24 2011 (r13541) @@ -176,10 +176,15 @@ setFinalized(true); } - // ### class-direct-slots - private static final Primitive CLASS_DIRECT_SLOTS = - new Primitive("%class-direct-slots", PACKAGE_SYS, true) + @DocString(name="%class-direct-slots") + private static final Primitive CLASS_DIRECT_SLOTS + = new pf__class_direct_slots(); + private static final class pf__class_direct_slots extends Primitive { + pf__class_direct_slots() + { + super("%class-direct-slots", PACKAGE_SYS, true); + } @Override public LispObject execute(LispObject arg) @@ -192,31 +197,41 @@ } }; - // ### %set-class-direct-slots - private static final Primitive _SET_CLASS_DIRECT_SLOTS = - new Primitive("%set-class-direct-slots", PACKAGE_SYS, true) + @DocString(name="%set-class-direct-slots") + private static final Primitive _SET_CLASS_DIRECT_SLOT + = new pf__set_class_direct_slots(); + private static final class pf__set_class_direct_slots extends Primitive { + pf__set_class_direct_slots() + { + super("%set-class-direct-slots", PACKAGE_SYS, true); + } + @Override public LispObject execute(LispObject first, LispObject second) - { - if (second instanceof SlotClass) { + if (second instanceof SlotClass) { ((SlotClass)second).setDirectSlotDefinitions(first); return first; - } - else { + } else { return type_error(second, Symbol.STANDARD_CLASS); } } }; - // ### %class-slots - private static final Primitive _CLASS_SLOTS = - new Primitive(Symbol._CLASS_SLOTS, "class") + @DocString(name="%class-slots", + args="class") + private static final Primitive _CLASS_SLOTS + = new pf__class_slots(); + private static final class pf__class_slots extends Primitive { + pf__class_slots() + { + super(Symbol._CLASS_SLOTS, "class"); + } + @Override public LispObject execute(LispObject arg) - { if (arg instanceof SlotClass) return ((SlotClass)arg).getSlotDefinitions(); @@ -226,31 +241,39 @@ } }; - // ### set-class-slots - private static final Primitive _SET_CLASS_SLOTS = - new Primitive(Symbol._SET_CLASS_SLOTS, "class slot-definitions") + @DocString(name="%set-class-slots", + args="class slot-definitions") + private static final Primitive _SET_CLASS_SLOTS + = new pf__set_class_slots(); + private static final class pf__set_class_slots extends Primitive { + pf__set_class_slots() + { + super(Symbol._SET_CLASS_SLOTS, "class slot-definitions"); + } @Override public LispObject execute(LispObject first, LispObject second) - { if (second instanceof SlotClass) { ((SlotClass)second).setSlotDefinitions(first); return first; - } - else { + } else { return type_error(second, Symbol.STANDARD_CLASS); } } }; - // ### class-direct-default-initargs - private static final Primitive CLASS_DIRECT_DEFAULT_INITARGS = - new Primitive("%class-direct-default-initargs", PACKAGE_SYS, true) + @DocString(name="%class-direct-default-initargs") + private static final Primitive CLASS_DIRECT_DEFAULT_INITARGS + = new pf__class_direct_default_initargs(); + private static final class pf__class_direct_default_initargs extends Primitive { + pf__class_direct_default_initargs() + { + super("%class-direct-default-initargs", PACKAGE_SYS, true); + } @Override public LispObject execute(LispObject arg) - { if (arg instanceof SlotClass) return ((SlotClass)arg).getDirectDefaultInitargs(); @@ -260,29 +283,37 @@ } }; - // ### %set-class-direct-default-initargs - private static final Primitive _SET_CLASS_DIRECT_DEFAULT_INITARGS = - new Primitive("%set-class-direct-default-initargs", PACKAGE_SYS, true) + @DocString(name="%set-class-direct-default-initargs") + private static final Primitive _SET_CLASS_DIRECT_DEFAULT_INITARGS + = new pf__set_class_direct_default_initargs(); + private static final class pf__set_class_direct_default_initargs extends Primitive { + pf__set_class_direct_default_initargs() + { + super("%set-class-direct-default-initargs", PACKAGE_SYS, true); + } @Override public LispObject execute(LispObject first, LispObject second) - { if (second instanceof SlotClass) { - ((SlotClass)second).setDirectDefaultInitargs(first); - return first; + ((SlotClass)second).setDirectDefaultInitargs(first); + return first; } return type_error(second, Symbol.STANDARD_CLASS); } }; - // ### class-default-initargs - private static final Primitive CLASS_DEFAULT_INITARGS = - new Primitive("%class-default-initargs", PACKAGE_SYS, true) + @DocString(name="%class-default-initargs") + private static final Primitive CLASS_DEFAULT_INITARGS + = new pf__class_default_initargs(); + private static final class pf__class_default_initargs extends Primitive { + pf__class_default_initargs() + { + super("%class-default-initargs", PACKAGE_SYS, true); + } @Override public LispObject execute(LispObject arg) - { if (arg instanceof SlotClass) return ((SlotClass)arg).getDefaultInitargs(); @@ -292,13 +323,18 @@ } }; - // ### %set-class-default-initargs - private static final Primitive _SET_CLASS_DEFAULT_INITARGS = - new Primitive("%set-class-default-initargs", PACKAGE_SYS, true) + @DocString(name="%set-class-default-initargs") + private static final Primitive _SET_CLASS_DEFAULT_INITARGS + = new pf__set_class_default_initargs(); + + private static final class pf__set_class_default_initargs extends Primitive { + pf__set_class_default_initargs() + { + super("%set-class-default-initargs", PACKAGE_SYS, true); + } @Override public LispObject execute(LispObject first, LispObject second) - { if (second instanceof SlotClass) { ((SlotClass)second).setDefaultInitargs(first); @@ -307,5 +343,4 @@ return type_error(second, Symbol.STANDARD_CLASS); } }; - } Modified: trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java Sat Aug 27 16:23:05 2011 (r13540) +++ trunk/abcl/src/org/armedbear/lisp/SlotDefinition.java Sat Aug 27 16:23:24 2011 (r13541) @@ -129,248 +129,349 @@ return unreadableString(sb.toString()); } - // ### make-slot-definition &optional class - private static final Primitive MAKE_SLOT_DEFINITION = - new Primitive("make-slot-definition", PACKAGE_SYS, true, "&optional class") - { - @Override - public LispObject execute() - { - return new SlotDefinition(); - } - @Override - public LispObject execute(LispObject slotDefinitionClass) - { - return new SlotDefinition((StandardClass) slotDefinitionClass); - } - }; - - // ### %slot-definition-name - private static final Primitive _SLOT_DEFINITION_NAME = - new Primitive(Symbol._SLOT_DEFINITION_NAME, "slot-definition") - { - @Override - public LispObject execute(LispObject arg) - { - return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_NAME]; - } - }; - - // ### set-slot-definition-name - private static final Primitive SET_SLOT_DEFINITION_NAME = - new Primitive("set-slot-definition-name", PACKAGE_SYS, true, - "slot-definition name") - { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_NAME] = second; - return second; - } - }; - - // ### %slot-definition-initfunction - private static final Primitive _SLOT_DEFINITION_INITFUNCTION = - new Primitive(Symbol._SLOT_DEFINITION_INITFUNCTION, "slot-definition") - { - @Override - public LispObject execute(LispObject arg) - { - return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION]; - } - }; - - // ### set-slot-definition-initfunction - static final Primitive SET_SLOT_DEFINITION_INITFUNCTION = - new Primitive("set-slot-definition-initfunction", PACKAGE_SYS, true, - "slot-definition initfunction") - { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION] = second; - return second; - } - }; - - // ### %slot-definition-initform - private static final Primitive _SLOT_DEFINITION_INITFORM = - new Primitive("%slot-definition-initform", PACKAGE_SYS, true, - "slot-definition") - { - @Override - public LispObject execute(LispObject arg) - { - return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITFORM]; - } - }; - - // ### set-slot-definition-initform - static final Primitive SET_SLOT_DEFINITION_INITFORM = - new Primitive("set-slot-definition-initform", PACKAGE_SYS, true, - "slot-definition initform") - { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_INITFORM] = second; - return second; - } - }; - - // ### %slot-definition-initargs - private static final Primitive _SLOT_DEFINITION_INITARGS = - new Primitive(Symbol._SLOT_DEFINITION_INITARGS, "slot-definition") - { - @Override - public LispObject execute(LispObject arg) - { - return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITARGS]; - } - }; - - // ### set-slot-definition-initargs - private static final Primitive SET_SLOT_DEFINITION_INITARGS = - new Primitive("set-slot-definition-initargs", PACKAGE_SYS, true, - "slot-definition initargs") - { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_INITARGS] = second; - return second; - } - }; - - // ### %slot-definition-readers - private static final Primitive _SLOT_DEFINITION_READERS = - new Primitive("%slot-definition-readers", PACKAGE_SYS, true, - "slot-definition") - { - @Override - public LispObject execute(LispObject arg) - { - return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_READERS]; - } - }; - - // ### set-slot-definition-readers - private static final Primitive SET_SLOT_DEFINITION_READERS = - new Primitive("set-slot-definition-readers", PACKAGE_SYS, true, - "slot-definition readers") - { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_READERS] = second; - return second; - } - }; - - // ### %slot-definition-writers - private static final Primitive _SLOT_DEFINITION_WRITERS = - new Primitive("%slot-definition-writers", PACKAGE_SYS, true, - "slot-definition") - { - @Override - public LispObject execute(LispObject arg) - { - return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_WRITERS]; - } - }; - - // ### set-slot-definition-writers - private static final Primitive SET_SLOT_DEFINITION_WRITERS = - new Primitive("set-slot-definition-writers", PACKAGE_SYS, true, - "slot-definition writers") - { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_WRITERS] = second; - return second; - } - }; - - // ### %slot-definition-allocation - private static final Primitive _SLOT_DEFINITION_ALLOCATION = - new Primitive("%slot-definition-allocation", PACKAGE_SYS, true, - "slot-definition") - { - @Override - public LispObject execute(LispObject arg) - { - return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION]; - } - }; - - // ### set-slot-definition-allocation - private static final Primitive SET_SLOT_DEFINITION_ALLOCATION = - new Primitive("set-slot-definition-allocation", PACKAGE_SYS, true, - "slot-definition allocation") - { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = second; - return second; - } - }; - - // ### %slot-definition-allocation-class - private static final Primitive _SLOT_DEFINITION_ALLOCATION_CLASS = - new Primitive("%slot-definition-allocation-class", PACKAGE_SYS, true, - "slot-definition") - { - @Override - public LispObject execute(LispObject arg) - { - return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION_CLASS]; - } - }; - - // ### set-slot-definition-allocation-class - private static final Primitive SET_SLOT_DEFINITION_ALLOCATION_CLASS = - new Primitive("set-slot-definition-allocation-class", PACKAGE_SYS, true, - "slot-definition allocation-class") - { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION_CLASS] = second; - return second; - } - }; - - // ### %slot-definition-location - private static final Primitive _SLOT_DEFINITION_LOCATION = - new Primitive("%slot-definition-location", PACKAGE_SYS, true, "slot-definition") - { - @Override - public LispObject execute(LispObject arg) - { - return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_LOCATION]; - } - }; - - // ### set-slot-definition-location - private static final Primitive SET_SLOT_DEFINITION_LOCATION = - new Primitive("set-slot-definition-location", PACKAGE_SYS, true, "slot-definition location") - { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = second; - return second; - } - }; + private static final Primitive MAKE_SLOT_DEFINITION + = new pf_make_slot_definition(); + @DocString(name="make-slot-definition", + args="&optional class") + private static final class pf_make_slot_definition extends Primitive + { + pf_make_slot_definition() + { + super("make-slot-definition", PACKAGE_SYS, true, "&optional class"); + } + @Override + public LispObject execute() + { + return new SlotDefinition(); + } + @Override + public LispObject execute(LispObject slotDefinitionClass) + { + return new SlotDefinition((StandardClass) slotDefinitionClass); + } + }; + + private static final Primitive _SLOT_DEFINITION_NAME + = new pf__slot_definition_name(); + @DocString(name="%slot-definition-name") + private static final class pf__slot_definition_name extends Primitive + { + pf__slot_definition_name() + { + super(Symbol._SLOT_DEFINITION_NAME, "slot-definition"); + } + @Override + public LispObject execute(LispObject arg) + { + return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_NAME]; + } + }; + + private static final Primitive SET_SLOT_DEFINITION_NAME + = new pf_set_slot_definition_name(); + @DocString(name="set-slot-definition-name", + args="slot-definition name") + private static final class pf_set_slot_definition_name extends Primitive + { + pf_set_slot_definition_name() + { + super("set-slot-definition-name", PACKAGE_SYS, true, + "slot-definition name"); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_NAME] = second; + return second; + } + }; + + private static final Primitive _SLOT_DEFINITION_INITFUNCTION + = new pf__slot_definition_initfunction(); + @DocString(name="%slot-definition-initfunction") + private static final class pf__slot_definition_initfunction extends Primitive + { + pf__slot_definition_initfunction() + { + super(Symbol._SLOT_DEFINITION_INITFUNCTION, "slot-definition"); + } + @Override + public LispObject execute(LispObject arg) + { + return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION]; + } + }; + + static final Primitive SET_SLOT_DEFINITION_INITFUNCTION + = new pf_set_slot_definition_initfunction(); + @DocString(name="set-slot-definition-initfunction", + args="slot-definition initfunction") + static final class pf_set_slot_definition_initfunction extends Primitive + { + pf_set_slot_definition_initfunction() + { + super("set-slot-definition-initfunction", PACKAGE_SYS, true, + "slot-definition initfunction"); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION] = second; + return second; + } + }; + + private static final Primitive _SLOT_DEFINITION_INITFORM + = new pf__slot_definition_initform(); + @DocString(name="%slot-definition-initform", + args="slot-definition") + private static final class pf__slot_definition_initform extends Primitive + { + pf__slot_definition_initform() + { + super("%slot-definition-initform", PACKAGE_SYS, true, + "slot-definition"); + } + @Override + public LispObject execute(LispObject arg) + { + return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITFORM]; + } + }; + + static final Primitive SET_SLOT_DEFINITION_INITFORM + = new pf_set_slot_definition_initform(); + @DocString(name="set-slot-definition-initform", + args="slot-definition initform") + static final class pf_set_slot_definition_initform extends Primitive + { + pf_set_slot_definition_initform() + { + super("set-slot-definition-initform", PACKAGE_SYS, true, + "slot-definition initform"); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_INITFORM] = second; + return second; + } + }; + + private static final Primitive _SLOT_DEFINITION_INITARGS + = new pf__slot_definition_initargs(); + @DocString(name="%slot-definition-initargs") + private static final class pf__slot_definition_initargs extends Primitive + { + pf__slot_definition_initargs() + { + super(Symbol._SLOT_DEFINITION_INITARGS, "slot-definition"); + } + @Override + public LispObject execute(LispObject arg) + { + return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_INITARGS]; + } + }; + + private static final Primitive SET_SLOT_DEFINITION_INITARGS + = new pf_set_slot_definition_initargs(); + @DocString(name="set-slot-definition-initargs", + args="slot-definition initargs") + private static final class pf_set_slot_definition_initargs extends Primitive + { + pf_set_slot_definition_initargs() + { + super("set-slot-definition-initargs", PACKAGE_SYS, true, + "slot-definition initargs"); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_INITARGS] = second; + return second; + } + }; + + private static final Primitive _SLOT_DEFINITION_READERS + = new pf__slot_definition_readers(); + @DocString(name="%slot-definition-readers", + args="slot-definition") + private static final class pf__slot_definition_readers extends Primitive { + pf__slot_definition_readers() + { + super("%slot-definition-readers", PACKAGE_SYS, true, + "slot-definition"); + } + @Override + public LispObject execute(LispObject arg) + { + return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_READERS]; + } + }; + + private static final Primitive SET_SLOT_DEFINITION_READERS + = new pf_set_slot_definition_readers(); + @DocString(name="set-slot-definition-readers", + args="slot-definition readers") + private static final class pf_set_slot_definition_readers extends Primitive + { + pf_set_slot_definition_readers() + { + super("set-slot-definition-readers", PACKAGE_SYS, true, + "slot-definition readers"); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_READERS] = second; + return second; + } + }; + + private static final Primitive _SLOT_DEFINITION_WRITERS + = new pf__slot_definition_writers(); + @DocString(name="%slot-definition-writers", + args="slot-definition") + private static final class pf__slot_definition_writers extends Primitive + { + pf__slot_definition_writers() + { + super("%slot-definition-writers", PACKAGE_SYS, true, + "slot-definition"); + } + @Override + public LispObject execute(LispObject arg) + { + return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_WRITERS]; + } + }; + + private static final Primitive SET_SLOT_DEFINITION_WRITERS + = new pf_set_slot_definition_writers(); + @DocString(name="set-slot-definition-writers", + args="slot-definition writers") + private static final class pf_set_slot_definition_writers extends Primitive + { + pf_set_slot_definition_writers() + { + super("set-slot-definition-writers", PACKAGE_SYS, true, + "slot-definition writers"); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_WRITERS] = second; + return second; + } + }; + + private static final Primitive _SLOT_DEFINITION_ALLOCATION + = new pf__slot_definition_allocation(); + @DocString(name="%slot-definition-allocation", + args="slot-definition") + private static final class pf__slot_definition_allocation extends Primitive + { + pf__slot_definition_allocation() + { + super("%slot-definition-allocation", PACKAGE_SYS, true, + "slot-definition"); + } + @Override + public LispObject execute(LispObject arg) + { + return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION]; + } + }; + + private static final Primitive SET_SLOT_DEFINITION_ALLOCATION + = new pf_set_slot_definition_allocation(); + @DocString(name="set-slot-definition-allocation", + args="slot-definition allocation") + private static final class pf_set_slot_definition_allocation extends Primitive + { + pf_set_slot_definition_allocation() + { + super("set-slot-definition-allocation", PACKAGE_SYS, true, + "slot-definition allocation"); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = second; + return second; + } + }; + + private static final Primitive _SLOT_DEFINITION_ALLOCATION_CLASS + = new pf__slot_definition_allocation_class(); + @DocString(name="%slot-definition-allocation-class", + args="slot-definition") + private static final class pf__slot_definition_allocation_class extends Primitive + { + pf__slot_definition_allocation_class() + { + super("%slot-definition-allocation-class", PACKAGE_SYS, true, + "slot-definition"); + } + @Override + public LispObject execute(LispObject arg) + { + return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION_CLASS]; + } + }; + + private static final Primitive SET_SLOT_DEFINITION_ALLOCATION_CLASS + = new pf_set_slot_definition_allocation_class(); + @DocString(name="set-slot-definition-allocation-class", + args="slot-definition allocation-class") + private static final class pf_set_slot_definition_allocation_class extends Primitive + { + pf_set_slot_definition_allocation_class() + { + super("set-slot-definition-allocation-class", PACKAGE_SYS, true, + "slot-definition allocation-class"); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION_CLASS] = second; + return second; + } + }; + + private static final Primitive _SLOT_DEFINITION_LOCATION + = new pf__slot_definition_location(); + @DocString(name="%slot-definition-location") + private static final class pf__slot_definition_location extends Primitive + { + pf__slot_definition_location() + { + super("%slot-definition-location", PACKAGE_SYS, true, "slot-definition"); + } + @Override + public LispObject execute(LispObject arg) + { + return checkSlotDefinition(arg).slots[SlotDefinitionClass.SLOT_INDEX_LOCATION]; + } + }; + + private static final Primitive SET_SLOT_DEFINITION_LOCATION + = new pf_set_slot_definition_location(); + @DocString(name="set-slot-definition-location", + args="slot-definition location") + private static final class pf_set_slot_definition_location extends Primitive + { + pf_set_slot_definition_location() + { + super("set-slot-definition-location", PACKAGE_SYS, true, + "slot-definition location"); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + checkSlotDefinition(first).slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = second; + return second; + } + }; } Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Sat Aug 27 16:23:05 2011 (r13540) +++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Sat Aug 27 16:23:24 2011 (r13541) @@ -246,25 +246,25 @@ ++callCount; } - @Override - public final int getHotCount() - { - return hotCount; - } + @Override + public final int getHotCount() + { + return hotCount; + } - @Override - public void setHotCount(int n) - { - hotCount = n; - } + @Override + public void setHotCount(int n) + { + hotCount = n; + } - @Override - public final void incrementHotCount() - { - ++hotCount; - } + @Override + public final void incrementHotCount() + { + ++hotCount; + } - // AMOP (p. 216) specifies the following readers as generic functions: + // AMOP (p. 216) specifies the following readers as generic functions: // generic-function-argument-precedence-order // generic-function-declarations // generic-function-lambda-list @@ -273,346 +273,462 @@ // generic-function-methods // generic-function-name - // ### %generic-function-name - private static final Primitive _GENERIC_FUNCTION_NAME = - new Primitive("%generic-function-name", PACKAGE_SYS, true) + private static final Primitive _GENERIC_FUNCTION_NAME + = new pf__generic_function_name(); + @DocString(name="%generic-function-name") + private static final class pf__generic_function_name extends Primitive + { + pf__generic_function_name() { - @Override - public LispObject execute(LispObject arg) - { - return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_NAME]; - } - }; - - // ### %set-generic-function-name - private static final Primitive _SET_GENERIC_FUNCTION_NAME = - new Primitive("%set-generic-function-name", PACKAGE_SYS, true) + super("%generic-function-name", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject arg) { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_NAME] = second; - return second; - } - }; + return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_NAME]; + } + }; - // ### %generic-function-lambda-list - private static final Primitive _GENERIC_FUNCTION_LAMBDA_LIST = - new Primitive("%generic-function-lambda-list", PACKAGE_SYS, true) + private static final Primitive _SET_GENERIC_FUNCTION_NAME + = new pf__set_generic_function_name(); + @DocString(name="%set-generic-function-name") + private static final class pf__set_generic_function_name extends Primitive + { + pf__set_generic_function_name() { - @Override - public LispObject execute(LispObject arg) - { - return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_LAMBDA_LIST]; - } - }; - - // ### %set-generic-function-lambdaList - private static final Primitive _SET_GENERIC_FUNCTION_LAMBDA_LIST = - new Primitive("%set-generic-function-lambda-list", PACKAGE_SYS, true) + super ("%set-generic-function-name", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject first, LispObject second) { - @Override - public LispObject execute(LispObject first, LispObject second) + checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_NAME] = second; + return second; + } + }; - { - checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_LAMBDA_LIST] = second; - return second; - } - }; + private static final Primitive _GENERIC_FUNCTION_LAMBDA_LIST + = new pf__generic_function_lambda_list(); + @DocString(name ="%generic-function-lambda-list") + private static final class pf__generic_function_lambda_list extends Primitive { + pf__generic_function_lambda_list() + { + super("%generic-function-lambda-list", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject arg) + { + return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_LAMBDA_LIST]; + } + }; - // ### funcallable-instance-function funcallable-instance => function - private static final Primitive FUNCALLABLE_INSTANCE_FUNCTION = - new Primitive("funcallable-instance-function", PACKAGE_MOP, false, - "funcallable-instance") + private static final Primitive _SET_GENERIC_FUNCTION_LAMBDA_LIST + = new pf__set_generic_function_lambda_list(); + @DocString(name="%set-generic-function-lambdalist") + private static final class pf__set_generic_function_lambda_list extends Primitive + { + pf__set_generic_function_lambda_list() { - @Override - public LispObject execute(LispObject arg) + super("%set-generic-function-lambda-list", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_LAMBDA_LIST] = second; + return second; + } + }; - { - return checkStandardGenericFunction(arg).function; - } - }; + private static final Primitive FUNCALLABLE_INSTANCE_FUNCTION + = new pf_funcallable_instance_function(); + @DocString(name="funcallable-instance-function", + args="funcallable-instance", + returns="function") + private static final class pf_funcallable_instance_function extends Primitive + { + pf_funcallable_instance_function() + { + super("funcallable-instance-function", PACKAGE_MOP, false, + "funcallable-instance"); + } + @Override + public LispObject execute(LispObject arg) + { + return checkStandardGenericFunction(arg).function; + } + }; - // ### set-funcallable-instance-function funcallable-instance function => unspecified // AMOP p. 230 - private static final Primitive SET_FUNCALLABLE_INSTANCE_FUNCTION = - new Primitive("set-funcallable-instance-function", PACKAGE_MOP, true, - "funcallable-instance function") + private static final Primitive SET_FUNCALLABLE_INSTANCE_FUNCTION + = new pf_set_funcallable_instance_function(); + @DocString(name="set-funcallable-instance-function", + args="funcallable-instance function", + returns="unspecified") + private static final class pf_set_funcallable_instance_function extends Primitive + { + pf_set_funcallable_instance_function() { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - checkStandardGenericFunction(first).function = second; - return second; - } - }; - - // ### gf-required-args - private static final Primitive GF_REQUIRED_ARGS = - new Primitive("gf-required-args", PACKAGE_SYS, true) + super("set-funcallable-instance-function", PACKAGE_MOP, true, + "funcallable-instance function"); + } + @Override + public LispObject execute(LispObject first, LispObject second) { - @Override - public LispObject execute(LispObject arg) - { - return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_REQUIRED_ARGS]; - } - }; + checkStandardGenericFunction(first).function = second; + return second; + } + }; - // ### %set-gf-required-args - private static final Primitive _SET_GF_REQUIRED_ARGS = - new Primitive("%set-gf-required-args", PACKAGE_SYS, true) + private static final Primitive GF_REQUIRED_ARGS + = new pf_gf_required_args(); + @DocString(name="gf-required-args") + private static final class pf_gf_required_args extends Primitive + { + pf_gf_required_args() { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - final StandardGenericFunction gf = checkStandardGenericFunction(first); - gf.slots[StandardGenericFunctionClass.SLOT_INDEX_REQUIRED_ARGS] = second; - gf.numberOfRequiredArgs = second.length(); - return second; - } - }; - - // ### generic-function-initial-methods - private static final Primitive GENERIC_FUNCTION_INITIAL_METHODS = - new Primitive("generic-function-initial-methods", PACKAGE_SYS, true) + super("gf-required-args", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject arg) { - @Override - public LispObject execute(LispObject arg) - { - return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_INITIAL_METHODS]; - } - }; + return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_REQUIRED_ARGS]; + } + }; - // ### set-generic-function-initial-methods - private static final Primitive SET_GENERIC_FUNCTION_INITIAL_METHODS = - new Primitive("set-generic-function-initial-methods", PACKAGE_SYS, true) + private static final Primitive _SET_GF_REQUIRED_ARGS + = new pf__set_gf_required_args(); + @DocString(name="%set-gf-required-args") + private static final class pf__set_gf_required_args extends Primitive + { + pf__set_gf_required_args() { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_INITIAL_METHODS] = second; - return second; - } - }; - - // ### generic-function-methods - private static final Primitive GENERIC_FUNCTION_METHODS = - new Primitive("generic-function-methods", PACKAGE_SYS, true) + super("%set-gf-required-args", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject first, LispObject second) { - @Override - public LispObject execute(LispObject arg) - { - return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_METHODS]; - } - }; + final StandardGenericFunction gf = checkStandardGenericFunction(first); + gf.slots[StandardGenericFunctionClass.SLOT_INDEX_REQUIRED_ARGS] = second; + gf.numberOfRequiredArgs = second.length(); + return second; + } + }; - // ### set-generic-function-methods - private static final Primitive SET_GENERIC_FUNCTION_METHODS = - new Primitive("set-generic-function-methods", PACKAGE_SYS, true) + private static final Primitive GENERIC_FUNCTION_INITIAL_METHODS + = new pf_generic_function_initial_methods(); + @DocString(name="generic-function-initial-methods") + private static final class pf_generic_function_initial_methods extends Primitive + { + pf_generic_function_initial_methods() { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_METHODS] = second; - return second; - } - }; - - // ### generic-function-method-class - private static final Primitive GENERIC_FUNCTION_METHOD_CLASS = - new Primitive("generic-function-method-class", PACKAGE_SYS, true) + super("generic-function-initial-methods", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject arg) { - @Override - public LispObject execute(LispObject arg) - { - return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_CLASS]; - } - }; + return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_INITIAL_METHODS]; + } + }; - // ### set-generic-function-method-class - private static final Primitive SET_GENERIC_FUNCTION_METHOD_CLASS = - new Primitive("set-generic-function-method-class", PACKAGE_SYS, true) + private static final Primitive SET_GENERIC_FUNCTION_INITIAL_METHODS + = new pf_set_generic_function_initial_methods(); + @DocString(name="set-generic-function-initial-methods") + private static final class pf_set_generic_function_initial_methods extends Primitive + { + pf_set_generic_function_initial_methods() { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_CLASS] = second; - return second; - } - }; - - // ### generic-function-method-combination - private static final Primitive GENERIC_FUNCTION_METHOD_COMBINATION = - new Primitive("generic-function-method-combination", PACKAGE_SYS, true) + super("set-generic-function-initial-methods", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject first, LispObject second) { - @Override - public LispObject execute(LispObject arg) - { - return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_COMBINATION]; - } - }; + checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_INITIAL_METHODS] = second; + return second; + } + }; - // ### set-generic-function-method-combination - private static final Primitive SET_GENERIC_FUNCTION_METHOD_COMBINATION = - new Primitive("set-generic-function-method-combination", PACKAGE_SYS, true) + private static final Primitive GENERIC_FUNCTION_METHODS + = new pf_generic_function_methods(); + @DocString(name="generic-function-methods") + private static final class pf_generic_function_methods extends Primitive + { + pf_generic_function_methods() { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_COMBINATION] - = second; - return second; - } - }; + super("generic-function-methods", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject arg) + { + return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_METHODS]; + } + }; - // ### generic-function-argument-precedence-order - private static final Primitive GENERIC_FUNCTION_ARGUMENT_PRECEDENCE_ORDER = - new Primitive("generic-function-argument-precedence-order", PACKAGE_SYS, true) + private static final Primitive SET_GENERIC_FUNCTION_METHODS + = new pf_set_generic_function_methods(); + @DocString(name="set-generic-function-methods") + private static final class pf_set_generic_function_methods extends Primitive + { + pf_set_generic_function_methods() { - @Override - public LispObject execute(LispObject arg) - { - return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass - .SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER]; - } - }; + super("set-generic-function-methods", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_METHODS] = second; + return second; + } + }; - // ### set-generic-function-argument-precedence-order - private static final Primitive SET_GENERIC_FUNCTION_ARGUMENT_PRECEDENCE_ORDER = - new Primitive("set-generic-function-argument-precedence-order", PACKAGE_SYS, true) + private static final Primitive GENERIC_FUNCTION_METHOD_CLASS + = new pf_generic_function_method_class(); + @DocString(name="generic-function-method-class") + private static final class pf_generic_function_method_class extends Primitive + { + pf_generic_function_method_class() { - @Override - public LispObject execute(LispObject first, LispObject second) + super("generic-function-method-class", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject arg) + { + return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_CLASS]; + } + }; - { - checkStandardGenericFunction(first) - .slots[StandardGenericFunctionClass.SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER] = second; - return second; - } - }; + private static final Primitive SET_GENERIC_FUNCTION_METHOD_CLASS + = new pf_set_generic_function_method_class(); + @DocString(name="set-generic-function-method-class") + private static final class pf_set_generic_function_method_class extends Primitive + { + pf_set_generic_function_method_class() + { + super("set-generic-function-method-class", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_CLASS] = second; + return second; + } + }; - // ### generic-function-classes-to-emf-table - private static final Primitive GENERIC_FUNCTION_CLASSES_TO_EMF_TABLE = - new Primitive("generic-function-classes-to-emf-table", PACKAGE_SYS, true) + private static final Primitive GENERIC_FUNCTION_METHOD_COMBINATION + = new pf_generic_function_method_combination(); + @DocString(name="generic-function-method-combination") + private static final class pf_generic_function_method_combination extends Primitive + { + pf_generic_function_method_combination() { - @Override - public LispObject execute(LispObject arg) - { - return checkStandardGenericFunction(arg) - .slots[StandardGenericFunctionClass.SLOT_INDEX_CLASSES_TO_EMF_TABLE]; - } - }; + super("generic-function-method-combination", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject arg) + { + return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_COMBINATION]; + } + }; - // ### set-generic-function-classes-to-emf-table - private static final Primitive SET_GENERIC_FUNCTION_CLASSES_TO_EMF_TABLE = - new Primitive("set-generic-function-classes-to-emf-table", PACKAGE_SYS, true) + private static final Primitive SET_GENERIC_FUNCTION_METHOD_COMBINATION + = new pf_set_generic_function_method_combination(); + @DocString(name="set-generic-function-method-combination") + private static final class pf_set_generic_function_method_combination extends Primitive + { + pf_set_generic_function_method_combination() + { + super("set-generic-function-method-combination", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject first, LispObject second) { - @Override - public LispObject execute(LispObject first, LispObject second) + checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_COMBINATION] + = second; + return second; + } + }; - { - checkStandardGenericFunction(first) - .slots[StandardGenericFunctionClass.SLOT_INDEX_CLASSES_TO_EMF_TABLE] = second; - return second; - } - }; + private static final Primitive GENERIC_FUNCTION_ARGUMENT_PRECEDENCE_ORDER + = new pf_generic_function_argument_precedence_order(); + @DocString(name="generic-function-argument-precedence-order") + private static final class pf_generic_function_argument_precedence_order extends Primitive + { + pf_generic_function_argument_precedence_order() + { + super("generic-function-argument-precedence-order", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject arg) + { + return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass + .SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER]; + } + }; - // ### generic-function-documentation - private static final Primitive GENERIC_FUNCTION_DOCUMENTATION = - new Primitive("generic-function-documentation", PACKAGE_SYS, true) + private static final Primitive SET_GENERIC_FUNCTION_ARGUMENT_PRECEDENCE_ORDER + = new pf_set_generic_function_argument_precedence_order(); + @DocString(name="set-generic-function-argument-precedence-order") + private static final class pf_set_generic_function_argument_precedence_order extends Primitive + { + pf_set_generic_function_argument_precedence_order() { - @Override - public LispObject execute(LispObject arg) - { - return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_DOCUMENTATION]; - } - }; + super("set-generic-function-argument-precedence-order", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + checkStandardGenericFunction(first) + .slots[StandardGenericFunctionClass.SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER] = second; + return second; + } + }; - // ### set-generic-function-documentation - private static final Primitive SET_GENERIC_FUNCTION_DOCUMENTATION = - new Primitive("set-generic-function-documentation", PACKAGE_SYS, true) + private static final Primitive GENERIC_FUNCTION_CLASSES_TO_EMF_TABLE + = new pf_generic_function_classes_to_emf_table(); + @DocString(name="generic-function-classes-to-emf-table") + private static final class pf_generic_function_classes_to_emf_table extends Primitive + { + pf_generic_function_classes_to_emf_table() + { + super("generic-function-classes-to-emf-table", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject arg) { - @Override - public LispObject execute(LispObject first, LispObject second) + return checkStandardGenericFunction(arg) + .slots[StandardGenericFunctionClass.SLOT_INDEX_CLASSES_TO_EMF_TABLE]; + } + }; - { - checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_DOCUMENTATION] - = second; - return second; - } - }; + private static final Primitive SET_GENERIC_FUNCTION_CLASSES_TO_EMF_TABLE + = new pf_set_generic_function_classes_to_emf_table(); + @DocString(name="set-generic-function-classes-to-emf-table") + private static final class pf_set_generic_function_classes_to_emf_table extends Primitive + { + pf_set_generic_function_classes_to_emf_table() + { + super("set-generic-function-classes-to-emf-table", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + checkStandardGenericFunction(first) + .slots[StandardGenericFunctionClass.SLOT_INDEX_CLASSES_TO_EMF_TABLE] = second; + return second; + } + }; - // ### %finalize-generic-function - private static final Primitive _FINALIZE_GENERIC_FUNCTION = - new Primitive("%finalize-generic-function", PACKAGE_SYS, true, - "generic-function") + private static final Primitive GENERIC_FUNCTION_DOCUMENTATION + = new pf_generic_function_documentation(); + @DocString(name="generic-function-documentation") + private static final class pf_generic_function_documentation extends Primitive + { + pf_generic_function_documentation() { - @Override - public LispObject execute(LispObject arg) - { - final StandardGenericFunction gf = checkStandardGenericFunction(arg); - gf.finalizeInternal(); - return T; - } - }; + super("generic-function-documentation", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject arg) + { + return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_DOCUMENTATION]; + } + }; - // ### cache-emf - private static final Primitive CACHE_EMF = - new Primitive("cache-emf", PACKAGE_SYS, true, "generic-function args emf") + private static final Primitive SET_GENERIC_FUNCTION_DOCUMENTATION + = new pf_set_generic_function_documentation(); + @DocString(name="set-generic-function-documentation") + private static final class pf_set_generic_function_documentation extends Primitive + { + pf_set_generic_function_documentation() { - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) + super("set-generic-function-documentation", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + checkStandardGenericFunction(first).slots[StandardGenericFunctionClass.SLOT_INDEX_DOCUMENTATION] + = second; + return second; + } + }; - { - final StandardGenericFunction gf = checkStandardGenericFunction(first); - LispObject args = second; - LispObject[] array = new LispObject[gf.numberOfRequiredArgs]; - for (int i = gf.numberOfRequiredArgs; i-- > 0;) - { - array[i] = gf.getArgSpecialization(args.car()); - args = args.cdr(); - } - CacheEntry specializations = new CacheEntry(array); - ConcurrentHashMap ht = gf.cache; - if (ht == null) - ht = gf.cache = new ConcurrentHashMap(); - ht.put(specializations, third); - return third; - } - }; + private static final Primitive _FINALIZE_GENERIC_FUNCTION + = new pf__finalize_generic_function(); + @DocString(name="%finalize-generic-function", + args="generic-function") + private static final class pf__finalize_generic_function extends Primitive + { + pf__finalize_generic_function() + { + super("%finalize-generic-function", PACKAGE_SYS, true, + "generic-function"); + } + @Override + public LispObject execute(LispObject arg) + { + final StandardGenericFunction gf = checkStandardGenericFunction(arg); + gf.finalizeInternal(); + return T; + } + }; - // ### get-cached-emf - private static final Primitive GET_CACHED_EMF = - new Primitive("get-cached-emf", PACKAGE_SYS, true, "generic-function args") + private static final Primitive CACHE_EMF + = new pf_cache_emf(); + @DocString(name="cache-emf", + args="generic-function args emf") + private static final class pf_cache_emf extends Primitive + { + pf_cache_emf() + { + super("cache-emf", PACKAGE_SYS, true, "generic-function args emf"); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) { - @Override - public LispObject execute(LispObject first, LispObject second) + final StandardGenericFunction gf = checkStandardGenericFunction(first); + LispObject args = second; + LispObject[] array = new LispObject[gf.numberOfRequiredArgs]; + for (int i = gf.numberOfRequiredArgs; i-- > 0;) + { + array[i] = gf.getArgSpecialization(args.car()); + args = args.cdr(); + } + CacheEntry specializations = new CacheEntry(array); + ConcurrentHashMap ht = gf.cache; + if (ht == null) + ht = gf.cache = new ConcurrentHashMap(); + ht.put(specializations, third); + return third; + } + }; - { - final StandardGenericFunction gf = checkStandardGenericFunction(first); - LispObject args = second; - LispObject[] array = new LispObject[gf.numberOfRequiredArgs]; - for (int i = gf.numberOfRequiredArgs; i-- > 0;) - { - array[i] = gf.getArgSpecialization(args.car()); - args = args.cdr(); - } - CacheEntry specializations = new CacheEntry(array); - ConcurrentHashMap ht = gf.cache; - if (ht == null) - return NIL; - LispObject emf = (LispObject) ht.get(specializations); - return emf != null ? emf : NIL; - } - }; + private static final Primitive GET_CACHED_EMF + = new pf_get_cached_emf(); + @DocString(name="get-cached-emf", + args="generic-function args") + private static final class pf_get_cached_emf extends Primitive + { + pf_get_cached_emf() { + super("get-cached-emf", PACKAGE_SYS, true, "generic-function args"); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + final StandardGenericFunction gf = checkStandardGenericFunction(first); + LispObject args = second; + LispObject[] array = new LispObject[gf.numberOfRequiredArgs]; + for (int i = gf.numberOfRequiredArgs; i-- > 0;) + { + array[i] = gf.getArgSpecialization(args.car()); + args = args.cdr(); + } + CacheEntry specializations = new CacheEntry(array); + ConcurrentHashMap ht = gf.cache; + if (ht == null) + return NIL; + LispObject emf = (LispObject) ht.get(specializations); + return emf != null ? emf : NIL; + } + }; /** * Returns an object representing generic function @@ -680,56 +796,70 @@ return arg.classOf(); } - // ### %get-arg-specialization - private static final Primitive _GET_ARG_SPECIALIZATION = - new Primitive("%get-arg-specialization", PACKAGE_SYS, true, "generic-function arg") + private static final Primitive _GET_ARG_SPECIALIZATION + = new pf__get_arg_specialization(); + @DocString(name="%get-arg-specialization", + args="generic-function arg") + private static final class pf__get_arg_specialization extends Primitive + { + pf__get_arg_specialization() { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - final StandardGenericFunction gf = checkStandardGenericFunction(first); - return gf.getArgSpecialization(second); - } - }; + super("%get-arg-specialization", PACKAGE_SYS, true, "generic-function arg"); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + final StandardGenericFunction gf = checkStandardGenericFunction(first); + return gf.getArgSpecialization(second); + } + }; - // ### cache-slot-location - private static final Primitive CACHE_SLOT_LOCATION = - new Primitive("cache-slot-location", PACKAGE_SYS, true, "generic-function layout location") + private static final Primitive CACHE_SLOT_LOCATION + = new pf_cache_slot_location(); + @DocString(name="cache-slot-location", + args="generic-function layout location") + private static final class pf_cache_slot_location extends Primitive + { + pf_cache_slot_location() { - @Override - public LispObject execute(LispObject first, LispObject second, + super("cache-slot-location", PACKAGE_SYS, true, "generic-function layout location"); + } + @Override + public LispObject execute(LispObject first, LispObject second, LispObject third) - - { - final StandardGenericFunction gf = checkStandardGenericFunction(first); - LispObject layout = second; - LispObject location = third; - ConcurrentHashMap ht = gf.slotCache; - if (ht == null) - ht = gf.slotCache = new ConcurrentHashMap(); - ht.put(layout, location); - return third; - } - }; - - // ### get-cached-slot-location - private static final Primitive GET_CACHED_SLOT_LOCATION = - new Primitive("get-cached-slot-location", PACKAGE_SYS, true, "generic-function layout") { - @Override - public LispObject execute(LispObject first, LispObject second) + final StandardGenericFunction gf = checkStandardGenericFunction(first); + LispObject layout = second; + LispObject location = third; + ConcurrentHashMap ht = gf.slotCache; + if (ht == null) + ht = gf.slotCache = new ConcurrentHashMap(); + ht.put(layout, location); + return third; + } + }; - { - final StandardGenericFunction gf = checkStandardGenericFunction(first); - LispObject layout = second; - ConcurrentHashMap ht = gf.slotCache; - if (ht == null) - return NIL; - LispObject location = (LispObject) ht.get(layout); - return location != null ? location : NIL; - } - }; + private static final Primitive GET_CACHED_SLOT_LOCATION + = new pf_get_cached_slot_location(); + @DocString(name="get-cached-slot-location") + private static final class pf_get_cached_slot_location extends Primitive + { + pf_get_cached_slot_location() + { + super("get-cached-slot-location", PACKAGE_SYS, true, "generic-function layout"); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + final StandardGenericFunction gf = checkStandardGenericFunction(first); + LispObject layout = second; + ConcurrentHashMap ht = gf.slotCache; + if (ht == null) + return NIL; + LispObject location = (LispObject) ht.get(layout); + return location != null ? location : NIL; + } + }; private static final StandardGenericFunction GENERIC_FUNCTION_NAME = new StandardGenericFunction("generic-function-name", @@ -775,25 +905,30 @@ EqlSpecialization eqlSpecializations[] = new EqlSpecialization[0]; - // ### %init-eql-specializations - private static final Primitive _INIT_EQL_SPECIALIZATIONS - = new Primitive("%init-eql-specializations", PACKAGE_SYS, true, - "generic-function eql-specilizer-objects-list") - { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - final StandardGenericFunction gf = checkStandardGenericFunction(first); - LispObject eqlSpecializerObjects = second; - gf.eqlSpecializations = new EqlSpecialization[eqlSpecializerObjects.length()]; - for (int i = 0; i < gf.eqlSpecializations.length; i++) { - gf.eqlSpecializations[i] = new EqlSpecialization(eqlSpecializerObjects.car()); - eqlSpecializerObjects = eqlSpecializerObjects.cdr(); - } - return NIL; - } - }; + private static final Primitive _INIT_EQL_SPECIALIZATIONS + = new pf__init_eql_specializations(); + @DocString(name="%init-eql-specializations", + args="generic-function eql-specilizer-objects-list") + private static final class pf__init_eql_specializations extends Primitive + { + pf__init_eql_specializations() + { + super("%init-eql-specializations", PACKAGE_SYS, true, + "generic-function eql-specilizer-objects-list"); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + final StandardGenericFunction gf = checkStandardGenericFunction(first); + LispObject eqlSpecializerObjects = second; + gf.eqlSpecializations = new EqlSpecialization[eqlSpecializerObjects.length()]; + for (int i = 0; i < gf.eqlSpecializations.length; i++) { + gf.eqlSpecializations[i] = new EqlSpecialization(eqlSpecializerObjects.car()); + eqlSpecializerObjects = eqlSpecializerObjects.cdr(); + } + return NIL; + } + }; private static class EqlSpecialization extends LispObject { @@ -806,7 +941,6 @@ } public static final StandardGenericFunction checkStandardGenericFunction(LispObject obj) - { if (obj instanceof StandardGenericFunction) return (StandardGenericFunction) obj; Modified: trunk/abcl/src/org/armedbear/lisp/StandardMethod.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardMethod.java Sat Aug 27 16:23:05 2011 (r13540) +++ trunk/abcl/src/org/armedbear/lisp/StandardMethod.java Sat Aug 27 16:23:24 2011 (r13541) @@ -63,81 +63,114 @@ slots[StandardMethodClass.SLOT_INDEX_DOCUMENTATION] = NIL; } - // ### method-lambda-list - // generic function - private static final Primitive METHOD_LAMBDA_LIST = - new Primitive("method-lambda-list", PACKAGE_SYS, true, "method") + private static final Primitive METHOD_LAMBDA_LIST + = new pf_method_lambda_list(); + @DocString(name="method-lambda-list", + args="generic-method") + private static final class pf_method_lambda_list extends Primitive + { + pf_method_lambda_list() { - @Override - public LispObject execute(LispObject arg) - { - return checkStandardMethod(arg).slots[StandardMethodClass.SLOT_INDEX_LAMBDA_LIST]; - } - }; - - // ### set-method-lambda-list - private static final Primitive SET_METHOD_LAMBDA_LIST = - new Primitive("set-method-lambda-list", PACKAGE_SYS, true, - "method lambda-list") + super("method-lambda-list", PACKAGE_SYS, true, "generic-method"); + } + @Override + public LispObject execute(LispObject arg) + { + return checkStandardMethod(arg).slots[StandardMethodClass.SLOT_INDEX_LAMBDA_LIST]; + } + }; + + private static final Primitive SET_METHOD_LAMBDA_LIST + = new pf_set_method_lambda_list(); + @DocString(name="set-method-lambda-list", + args="method lambda-list") + private static final class pf_set_method_lambda_list extends Primitive + { + pf_set_method_lambda_list() { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - checkStandardMethod(first).slots[StandardMethodClass.SLOT_INDEX_LAMBDA_LIST] = second; - return second; - } - }; - - // ### method-qualifiers - private static final Primitive _METHOD_QUALIFIERS = - new Primitive("%method-qualifiers", PACKAGE_SYS, true, "method") + super("set-method-lambda-list", PACKAGE_SYS, true, + "method lambda-list"); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + checkStandardMethod(first).slots[StandardMethodClass.SLOT_INDEX_LAMBDA_LIST] = second; + return second; + } + }; + + + private static final Primitive _METHOD_QUALIFIERS + = new gf__method_qualifiers(); + @DocString(name="%method-qualifiers", + args="method") + private static final class gf__method_qualifiers extends Primitive + { + gf__method_qualifiers() { - @Override - public LispObject execute(LispObject arg) - { - return checkStandardMethod(arg).slots[StandardMethodClass.SLOT_INDEX_QUALIFIERS]; - } - }; - - // ### set-method-qualifiers - private static final Primitive SET_METHOD_QUALIFIERS = - new Primitive("set-method-qualifiers", PACKAGE_SYS, true, - "method qualifiers") - { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - checkStandardMethod(first).slots[StandardMethodClass.SLOT_INDEX_QUALIFIERS] = second; - return second; - } - }; - - // ### method-documentation - private static final Primitive METHOD_DOCUMENTATION = - new Primitive("method-documentation", PACKAGE_SYS, true, "method") + super("%method-qualifiers", PACKAGE_SYS, true, "method"); + } + @Override + public LispObject execute(LispObject arg) + { + return checkStandardMethod(arg).slots[StandardMethodClass.SLOT_INDEX_QUALIFIERS]; + } + }; + + private static final Primitive SET_METHOD_QUALIFIERS + = new pf_set_method_qualifiers(); + @DocString(name="set-method-qualifiers", + args="method qualifiers") + private static final class pf_set_method_qualifiers extends Primitive + { + pf_set_method_qualifiers() { - @Override - public LispObject execute(LispObject arg) - { - return checkStandardMethod(arg).slots[StandardMethodClass.SLOT_INDEX_DOCUMENTATION]; - } - }; - - // ### set-method-documentation - private static final Primitive SET_METHOD_DOCUMENTATION = - new Primitive("set-method-documentation", PACKAGE_SYS, true, - "method documentation") + super("set-method-qualifiers", PACKAGE_SYS, true, + "method qualifiers"); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + checkStandardMethod(first).slots[StandardMethodClass.SLOT_INDEX_QUALIFIERS] = second; + return second; + } + }; + + private static final Primitive METHOD_DOCUMENTATION + = new pf_method_documentation(); + @DocString(name="method-documentation", + args="method") + private static final class pf_method_documentation extends Primitive + { + pf_method_documentation() { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - checkStandardMethod(first).slots[StandardMethodClass.SLOT_INDEX_DOCUMENTATION] = second; - return second; - } - }; + super("method-documentation", PACKAGE_SYS, true, "method"); + } + @Override + public LispObject execute(LispObject arg) + { + return checkStandardMethod(arg).slots[StandardMethodClass.SLOT_INDEX_DOCUMENTATION]; + } + }; + + private static final Primitive SET_METHOD_DOCUMENTATION + = new pf_set_method_documentation(); + @DocString(name="set-method-documentation", + args="method documentation") + private static final class pf_set_method_documentation extends Primitive + { + pf_set_method_documentation() + { + super("set-method-documentation", PACKAGE_SYS, true, + "method documentation"); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + checkStandardMethod(first).slots[StandardMethodClass.SLOT_INDEX_DOCUMENTATION] = second; + return second; + } + }; public LispObject getFunction() { @@ -190,104 +223,144 @@ return super.printObject(); } - // ### %method-generic-function - private static final Primitive _METHOD_GENERIC_FUNCTION = - new Primitive("%method-generic-function", PACKAGE_SYS, true) + private static final Primitive _METHOD_GENERIC_FUNCTION + = new pf__method_generic_function(); + @DocString(name="%method-generic-function") + private static final class pf__method_generic_function extends Primitive + { + pf__method_generic_function() { - @Override - public LispObject execute(LispObject arg) - { - return checkStandardMethod(arg).slots[StandardMethodClass.SLOT_INDEX_GENERIC_FUNCTION]; - } - }; - - // ### %set-method-generic-function - private static final Primitive _SET_METHOD_GENERICFUNCTION = - new Primitive("%set-method-generic-function", PACKAGE_SYS, true) + super("%method-generic-function", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject arg) + { + return checkStandardMethod(arg).slots[StandardMethodClass.SLOT_INDEX_GENERIC_FUNCTION]; + } + }; + + private static final Primitive _SET_METHOD_GENERICFUNCTION + = new pf__set_method_genericfunction(); + @DocString(name="%set-method-generic-function") + private static final class pf__set_method_genericfunction extends Primitive + { + pf__set_method_genericfunction() { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - checkStandardMethod(first).slots[StandardMethodClass.SLOT_INDEX_GENERIC_FUNCTION] = second; - return second; - } - }; - - // ### %method-function - private static final Primitive _METHOD_FUNCTION = - new Primitive("%method-function", PACKAGE_SYS, true, "method") + super("%set-method-generic-function", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + checkStandardMethod(first).slots[StandardMethodClass.SLOT_INDEX_GENERIC_FUNCTION] = second; + return second; + } + }; + + private static final Primitive _METHOD_FUNCTION + = new pf__method_function(); + @DocString(name="%method-function") + private static final class pf__method_function extends Primitive + { + pf__method_function() + { + super("%method-function", PACKAGE_SYS, true, "method"); + } + @Override + public LispObject execute(LispObject arg) { - @Override - public LispObject execute(LispObject arg) - { return checkStandardMethod(arg).slots[StandardMethodClass.SLOT_INDEX_FUNCTION]; - } - }; + } + }; - // ### %set-method-function - private static final Primitive _SET_METHOD_FUNCTION = - new Primitive("%set-method-function", PACKAGE_SYS, true, - "method function") + private static final Primitive _SET_METHOD_FUNCTION + = new pf__set_method_function(); + @DocString(name="%set-method-function", + args="method function") + private static final class pf__set_method_function extends Primitive + { + pf__set_method_function() { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - checkStandardMethod(first).slots[StandardMethodClass.SLOT_INDEX_FUNCTION] = second; - return second; - } - }; - - // ### %method-fast-function - private static final Primitive _METHOD_FAST_FUNCTION = - new Primitive("%method-fast-function", PACKAGE_SYS, true, "method") + super("%set-method-function", PACKAGE_SYS, true, + "method function"); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + checkStandardMethod(first).slots[StandardMethodClass.SLOT_INDEX_FUNCTION] = second; + return second; + } + }; + + private static final Primitive _METHOD_FAST_FUNCTION + = new pf__method_fast_function(); + @DocString(name="%method-fast-function", + args="method") + private static final class pf__method_fast_function extends Primitive + { + pf__method_fast_function() { - @Override - public LispObject execute(LispObject arg) - { - return checkStandardMethod(arg).slots[StandardMethodClass.SLOT_INDEX_FAST_FUNCTION]; - } - }; - - // ### %set-method-fast-function - private static final Primitive _SET_METHOD_FAST_FUNCTION = - new Primitive("%set-method-fast-function", PACKAGE_SYS, true, - "method fast-function") + super("%method-fast-function", PACKAGE_SYS, true, "method"); + } + @Override + public LispObject execute(LispObject arg) + { + return checkStandardMethod(arg).slots[StandardMethodClass.SLOT_INDEX_FAST_FUNCTION]; + } + }; + + private static final Primitive _SET_METHOD_FAST_FUNCTION + = new pf__set_method_fast_function(); + @DocString(name="%set-method-fast-function", + args="method fast-function") + private static final class pf__set_method_fast_function extends Primitive + { + pf__set_method_fast_function() { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - checkStandardMethod(first).slots[StandardMethodClass.SLOT_INDEX_FAST_FUNCTION] = second; - return second; - } - }; - - // ### %method-specializers - private static final Primitive _METHOD_SPECIALIZERS = - new Primitive("%method-specializers", PACKAGE_SYS, true, "method") + super("%set-method-fast-function", PACKAGE_SYS, true, + "method fast-function"); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + checkStandardMethod(first).slots[StandardMethodClass.SLOT_INDEX_FAST_FUNCTION] = second; + return second; + } + }; + + private static final Primitive _METHOD_SPECIALIZERS + = new pf__method_specializers(); + @DocString(name="%method-specializers") + private static final class pf__method_specializers extends Primitive + { + pf__method_specializers() { - @Override - public LispObject execute(LispObject arg) - { - return checkStandardMethod(arg).slots[StandardMethodClass.SLOT_INDEX_SPECIALIZERS]; - } - }; - - // ### %set-method-specializers - private static final Primitive _SET_METHOD_SPECIALIZERS = - new Primitive("%set-method-specializers", PACKAGE_SYS, true, - "method specializers") + super("%method-specializers", PACKAGE_SYS, true, "method"); + } + @Override + public LispObject execute(LispObject arg) + { + return checkStandardMethod(arg).slots[StandardMethodClass.SLOT_INDEX_SPECIALIZERS]; + } + }; + + private static final Primitive _SET_METHOD_SPECIALIZERS + = new pf__set_method_specializers(); + @DocString(name="%set-method-specializers", + args="method specializers") + private static final class pf__set_method_specializers extends Primitive + { + pf__set_method_specializers() { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - checkStandardMethod(first).slots[StandardMethodClass.SLOT_INDEX_SPECIALIZERS] = second; - return second; - } - }; + super("%set-method-specializers", PACKAGE_SYS, true, + "method specializers"); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + checkStandardMethod(first).slots[StandardMethodClass.SLOT_INDEX_SPECIALIZERS] = second; + return second; + } + }; private static final StandardGenericFunction METHOD_SPECIALIZERS = new StandardGenericFunction("method-specializers", @@ -305,11 +378,10 @@ list(Symbol.METHOD), list(StandardClass.STANDARD_METHOD)); - final public static StandardMethod checkStandardMethod(LispObject first) - { - if (first instanceof StandardMethod) - return (StandardMethod) first; - return (StandardMethod) type_error(first, Symbol.METHOD); - } - + final public static StandardMethod checkStandardMethod(LispObject first) + { + if (first instanceof StandardMethod) + return (StandardMethod) first; + return (StandardMethod) type_error(first, Symbol.METHOD); + } } Modified: trunk/abcl/src/org/armedbear/lisp/StandardObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardObject.java Sat Aug 27 16:23:05 2011 (r13540) +++ trunk/abcl/src/org/armedbear/lisp/StandardObject.java Sat Aug 27 16:23:24 2011 (r13541) @@ -320,171 +320,207 @@ } Debug.assertTrue(layout != null); int index = layout.getSlotIndex(slotName); - //### FIXME: should call SLOT-MISSING (clhs) + // FIXME: should call SLOT-MISSING (clhs) if (index < 0) error(new LispError("Missing slot " + slotName.princToString())); slots[index] = newValue; } - - final public static StandardObject checkStandardObject(LispObject first) + + final public static StandardObject checkStandardObject(LispObject first) + { + if (first instanceof StandardObject) + return (StandardObject) first; + return (StandardObject) type_error(first, Symbol.STANDARD_OBJECT); + } + + private static final Primitive SWAP_SLOTS + = new pf_swap_slots(); + @DocString(name="swap-slots", + args="instance-1 instance-2", + returns="nil") + private static final class pf_swap_slots extends Primitive + { + pf_swap_slots() + { + super("swap-slots", PACKAGE_SYS, true, "instance-1 instance-2"); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + final StandardObject obj1 = checkStandardObject(first); + final StandardObject obj2 = checkStandardObject(second); + LispObject[] temp = obj1.slots; + obj1.slots = obj2.slots; + obj2.slots = temp; + return NIL; + } + }; + + private static final Primitive STD_INSTANCE_LAYOUT + = new pf_std_instance_layout(); + @DocString(name="std-instance-layout") + private static final class pf_std_instance_layout extends Primitive + { + pf_std_instance_layout() + { + super("std-instance-layout", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject arg) + { + final StandardObject instance = checkStandardObject(arg); + Layout layout = instance.layout; + if (layout.isInvalid()) { - if (first instanceof StandardObject) - return (StandardObject) first; - return (StandardObject) type_error(first, Symbol.STANDARD_OBJECT); + // Update instance. + layout = instance.updateLayout(); } - - // ### swap-slots instance-1 instance-2 => nil - private static final Primitive SWAP_SLOTS = - new Primitive("swap-slots", PACKAGE_SYS, true, "instance-1 instance-2") + return layout; + } + }; + + private static final Primitive _SET_STD_INSTANCE_LAYOUT + = new pf__set_std_instance_layout(); + @DocString(name="%set-std-instance-layout") + private static final class pf__set_std_instance_layout extends Primitive + { + pf__set_std_instance_layout() { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - final StandardObject obj1 = checkStandardObject(first); - final StandardObject obj2 = checkStandardObject(second); - LispObject[] temp = obj1.slots; - obj1.slots = obj2.slots; - obj2.slots = temp; - return NIL; - } - }; - - // ### std-instance-layout - private static final Primitive STD_INSTANCE_LAYOUT = - new Primitive("std-instance-layout", PACKAGE_SYS, true) + super("%set-std-instance-layout", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject first, LispObject second) { - @Override - public LispObject execute(LispObject arg) - { - final StandardObject instance = checkStandardObject(arg); - Layout layout = instance.layout; - if (layout.isInvalid()) - { - // Update instance. - layout = instance.updateLayout(); - } - return layout; - } - }; - - // ### %set-std-instance-layout - private static final Primitive _SET_STD_INSTANCE_LAYOUT = - new Primitive("%set-std-instance-layout", PACKAGE_SYS, true) + checkStandardObject(first).layout = checkLayout(second); + return second; + } + }; + + private static final Primitive STD_INSTANCE_CLASS + = new pf_std_instance_class(); + @DocString(name="std-instance-class") + private static final class pf_std_instance_class extends Primitive + { + pf_std_instance_class() { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - checkStandardObject(first).layout = checkLayout(second); - return second; - } - }; - - // ### std-instance-class - private static final Primitive STD_INSTANCE_CLASS = - new Primitive("std-instance-class", PACKAGE_SYS, true) + super("std-instance-class", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject arg) { - @Override - public LispObject execute(LispObject arg) - { - return checkStandardObject(arg).layout.getLispClass(); - } - }; - - // ### standard-instance-access instance location => value - private static final Primitive STANDARD_INSTANCE_ACCESS = - new Primitive("standard-instance-access", PACKAGE_SYS, true, - "instance location") + return checkStandardObject(arg).layout.getLispClass(); + } + }; + + private static final Primitive STANDARD_INSTANCE_ACCESS + = new pf_standard_instance_access(); + @DocString(name="standard-instance-access", + args="instance location", + returns="value") + private static final class pf_standard_instance_access extends Primitive + { + pf_standard_instance_access() { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - final StandardObject instance = checkStandardObject(first); - final int index; - if (second instanceof Fixnum) - { - index = ((Fixnum)second).value; - } - else - { - return type_error(second, - list(Symbol.INTEGER, Fixnum.ZERO, - Fixnum.getInstance(instance.slots.length))); - } - LispObject value; - try - { - value = instance.slots[index]; - } - catch (ArrayIndexOutOfBoundsException e) - { - return type_error(second, - list(Symbol.INTEGER, Fixnum.ZERO, - Fixnum.getInstance(instance.slots.length))); - } - if (value == UNBOUND_VALUE) - { - LispObject slotName = instance.layout.getSlotNames()[index]; - value = Symbol.SLOT_UNBOUND.execute(instance.getLispClass(), - instance, slotName); - LispThread.currentThread()._values = null; - } - return value; - } - }; - - // ### %set-standard-instance-access instance location new-value => new-value - private static final Primitive _SET_STANDARD_INSTANCE_ACCESS = - new Primitive("%set-standard-instance-access", PACKAGE_SYS, true) - { - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) - - { - checkStandardObject(first).slots[Fixnum.getValue(second)] = third; // FIXME - return third; - } - }; - - // ### std-slot-boundp - private static final Primitive STD_SLOT_BOUNDP = - new Primitive(Symbol.STD_SLOT_BOUNDP, "instance slot-name") + super("standard-instance-access", PACKAGE_SYS, true, + "instance location"); + } + @Override + public LispObject execute(LispObject first, LispObject second) { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - final StandardObject instance = checkStandardObject(first); - Layout layout = instance.layout; - if (layout.isInvalid()) - { - // Update instance. - layout = instance.updateLayout(); - } - final LispObject index = layout.slotTable.get(second); - if (index != null) - { - // Found instance slot. - return instance.slots[((Fixnum)index).value] != UNBOUND_VALUE ? T : NIL; - } - // Check for shared slot. - final LispObject location = layout.getSharedSlotLocation(second); - if (location != null) - return location.cdr() != UNBOUND_VALUE ? T : NIL; - // Not found. - final LispThread thread = LispThread.currentThread(); - LispObject value = - thread.execute(Symbol.SLOT_MISSING, instance.getLispClass(), - instance, second, Symbol.SLOT_BOUNDP); - // "If SLOT-MISSING is invoked and returns a value, a boolean - // equivalent to its primary value is returned by SLOT-BOUNDP." - thread._values = null; - return value != NIL ? T : NIL; - } - }; + final StandardObject instance = checkStandardObject(first); + final int index; + if (second instanceof Fixnum) + { + index = ((Fixnum)second).value; + } + else + { + return type_error(second, + list(Symbol.INTEGER, Fixnum.ZERO, + Fixnum.getInstance(instance.slots.length))); + } + LispObject value; + try + { + value = instance.slots[index]; + } + catch (ArrayIndexOutOfBoundsException e) + { + return type_error(second, + list(Symbol.INTEGER, Fixnum.ZERO, + Fixnum.getInstance(instance.slots.length))); + } + if (value == UNBOUND_VALUE) + { + LispObject slotName = instance.layout.getSlotNames()[index]; + value = Symbol.SLOT_UNBOUND.execute(instance.getLispClass(), + instance, slotName); + LispThread.currentThread()._values = null; + } + return value; + } + }; + + private static final Primitive _SET_STANDARD_INSTANCE_ACCESS + = new pf__set_standard_instance_access(); + @DocString(name="%set-standard-instance-access", + args="instance location new-value", + returns="new-value") + private static final class pf__set_standard_instance_access extends Primitive + { + pf__set_standard_instance_access() + { + super("%set-standard-instance-access", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + { + checkStandardObject(first).slots[Fixnum.getValue(second)] = third; // FIXME + return third; + } + }; + + private static final Primitive STD_SLOT_BOUNDP + = new pf_std_slot_boundp(); + @DocString(name="std-slot-boundp") + private static final class pf_std_slot_boundp extends Primitive + { + pf_std_slot_boundp() + { + super(Symbol.STD_SLOT_BOUNDP, "instance slot-name"); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + final StandardObject instance = checkStandardObject(first); + Layout layout = instance.layout; + if (layout.isInvalid()) + { + // Update instance. + layout = instance.updateLayout(); + } + final LispObject index = layout.slotTable.get(second); + if (index != null) + { + // Found instance slot. + return instance.slots[((Fixnum)index).value] != UNBOUND_VALUE ? T : NIL; + } + // Check for shared slot. + final LispObject location = layout.getSharedSlotLocation(second); + if (location != null) + return location.cdr() != UNBOUND_VALUE ? T : NIL; + // Not found. + final LispThread thread = LispThread.currentThread(); + LispObject value = + thread.execute(Symbol.SLOT_MISSING, instance.getLispClass(), + instance, second, Symbol.SLOT_BOUNDP); + // "If SLOT-MISSING is invoked and returns a value, a boolean + // equivalent to its primary value is returned by SLOT-BOUNDP." + thread._values = null; + return value != NIL ? T : NIL; + } + }; @Override public LispObject SLOT_VALUE(LispObject slotName) @@ -518,21 +554,24 @@ return value; } - // ### std-slot-value - private static final Primitive STD_SLOT_VALUE = - new Primitive(Symbol.STD_SLOT_VALUE, "instance slot-name") + private static final Primitive STD_SLOT_VALUE + = new pf_std_slot_value(); + @DocString(name="std-slot-value") + private static final class pf_std_slot_value extends Primitive + { + pf_std_slot_value() { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - return first.SLOT_VALUE(second); - } - }; + super(Symbol.STD_SLOT_VALUE, "instance slot-name"); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + return first.SLOT_VALUE(second); + } + }; @Override public void setSlotValue(LispObject slotName, LispObject newValue) - { if (layout.isInvalid()) { @@ -562,17 +601,21 @@ Symbol.SLOT_MISSING.execute(args); } - // ### set-std-slot-value - private static final Primitive SET_STD_SLOT_VALUE = - new Primitive(Symbol.SET_STD_SLOT_VALUE, "instance slot-name new-value") - { - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) - - { - first.setSlotValue(second, third); - return third; - } - }; + private static final Primitive SET_STD_SLOT_VALUE + = new pf_set_std_slot_value(); + @DocString(name="set-std-slot-value") + private static final class pf_set_std_slot_value extends Primitive + { + pf_set_std_slot_value() + { + super(Symbol.SET_STD_SLOT_VALUE, "instance slot-name new-value"); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + { + first.setSlotValue(second, third); + return third; + } + }; } Modified: trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java Sat Aug 27 16:23:05 2011 (r13540) +++ trunk/abcl/src/org/armedbear/lisp/StandardObjectFunctions.java Sat Aug 27 16:23:24 2011 (r13541) @@ -37,25 +37,32 @@ public class StandardObjectFunctions { - // ### %std-allocate-instance class => instance - private static final Primitive _STD_ALLOCATE_INSTANCE = - new Primitive("%std-allocate-instance", PACKAGE_SYS, true, "class") + private static final Primitive _STD_ALLOCATE_INSTANCE + = new pf__std_allocate_instance(); + @DocString(name="%std-allocate-instance", + args="class", + returns="instance") + private static final class pf__std_allocate_instance extends Primitive + { + pf__std_allocate_instance() { - @Override - public LispObject execute(LispObject arg) - { - if (arg == StandardClass.STANDARD_CLASS) - return new StandardClass(); - if (arg instanceof StandardClass) - return ((StandardClass)arg).allocateInstance(); - if (arg.typep(StandardClass.STANDARD_CLASS) != NIL) { - LispObject l = Symbol.CLASS_LAYOUT.execute(arg); - if (! (l instanceof Layout)) - return error(new ProgramError("Invalid standard class layout for: " + arg.princToString())); - - return new StandardObject((Layout)l); - } - return type_error(arg, Symbol.STANDARD_CLASS); + super("%std-allocate-instance", PACKAGE_SYS, true, "class"); + } + @Override + public LispObject execute(LispObject arg) + { + if (arg == StandardClass.STANDARD_CLASS) + return new StandardClass(); + if (arg instanceof StandardClass) + return ((StandardClass)arg).allocateInstance(); + if (arg.typep(StandardClass.STANDARD_CLASS) != NIL) { + LispObject l = Symbol.CLASS_LAYOUT.execute(arg); + if (! (l instanceof Layout)) + return error(new ProgramError("Invalid standard class layout for: " + arg.princToString())); + + return new StandardObject((Layout)l); } - }; + return type_error(arg, Symbol.STANDARD_CLASS); + } + }; } Modified: trunk/abcl/src/org/armedbear/lisp/StandardReaderMethod.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardReaderMethod.java Sat Aug 27 16:23:05 2011 (r13540) +++ trunk/abcl/src/org/armedbear/lisp/StandardReaderMethod.java Sat Aug 27 16:23:24 2011 (r13541) @@ -43,10 +43,16 @@ StandardClass.STANDARD_READER_METHOD.getClassLayout().getLength()); } - // ### reader-method-slot-name - private static final Primitive READER_METHOD_SLOT_NAME = - new Primitive("reader-method-slot-name", PACKAGE_MOP, false, "reader-method") + private static final Primitive READER_METHOD_SLOT_NAME + = new pf_reader_method_slot_name(); + @DocString(name="reader-method-slot-name", + args="reader-method") + private static final class pf_reader_method_slot_name extends Primitive { + pf_reader_method_slot_name() + { + super("reader-method-slot-name", PACKAGE_MOP, false, "reader-method"); + } @Override public LispObject execute(LispObject arg) { @@ -56,11 +62,17 @@ } }; - // ### set-reader-method-slot-name - private static final Primitive SET_READER_METHOD_SLOT_NAME = - new Primitive("set-reader-method-slot-name", PACKAGE_MOP, false, - "reader-method slot-name") + private static final Primitive SET_READER_METHOD_SLOT_NAME + = new pf_set_reader_method_slot_name(); + @DocString(name="set-reader-method-slot-name", + args="reader-method slot-name") + private static final class pf_set_reader_method_slot_name extends Primitive { + pf_set_reader_method_slot_name() + { + super("set-reader-method-slot-name", PACKAGE_MOP, false, + "reader-method slot-name"); + } @Override public LispObject execute(LispObject first, LispObject second) Modified: trunk/abcl/src/org/armedbear/lisp/StructureObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StructureObject.java Sat Aug 27 16:23:05 2011 (r13540) +++ trunk/abcl/src/org/armedbear/lisp/StructureObject.java Sat Aug 27 16:23:24 2011 (r13541) @@ -522,39 +522,59 @@ } } - // ### structure-object-p object => generalized-boolean - private static final Primitive STRUCTURE_OBJECT_P = - new Primitive("structure-object-p", PACKAGE_SYS, true, "object") - { - @Override - public LispObject execute(LispObject arg) - { - return arg instanceof StructureObject ? T : NIL; - } - }; - - // ### structure-length instance => length - private static final Primitive STRUCTURE_LENGTH = - new Primitive("structure-length", PACKAGE_SYS, true, "instance") - { - @Override - public LispObject execute(LispObject arg) - { - if (arg instanceof StructureObject) - return Fixnum.getInstance(((StructureObject)arg).slots.length); - return type_error(arg, Symbol.STRUCTURE_OBJECT); - } - }; - - // ### structure-ref instance index => value - private static final Primitive STRUCTURE_REF = - new Primitive("structure-ref", PACKAGE_SYS, true) + private static final Primitive STRUCTURE_OBJECT_P + = new pf_structure_object_p(); + @DocString(name="structure-object-p", + args="object", + returns="generalized-boolean") + private static final class pf_structure_object_p extends Primitive + { + pf_structure_object_p() + { + super("structure-object-p", PACKAGE_SYS, true, "object"); + } + @Override + public LispObject execute(LispObject arg) + { + return arg instanceof StructureObject ? T : NIL; + } + }; + + private static final Primitive STRUCTURE_LENGTH + = new pf_structure_length(); + @DocString(name="structure-length", + args="instance", + returns="length") + private static final class pf_structure_length extends Primitive + { + pf_structure_length() + { + super("structure-length", PACKAGE_SYS, true, "instance"); + } + @Override + public LispObject execute(LispObject arg) + { + if (arg instanceof StructureObject) + return Fixnum.getInstance(((StructureObject)arg).slots.length); + return type_error(arg, Symbol.STRUCTURE_OBJECT); + } + }; + + private static final Primitive STRUCTURE_REF + = new pf_structure_ref(); + @DocString(name="structure-ref", + args="instance index", + returns="value") + private static final class pf_structure_ref extends Primitive + { + pf_structure_ref() + { + super("structure-ref", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject first, LispObject second) { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - if (first instanceof StructureObject) + if (first instanceof StructureObject) try { return ((StructureObject)first).slots[Fixnum.getValue(second)]; @@ -565,110 +585,129 @@ return error(new LispError("Internal error.")); } return type_error(first, Symbol.STRUCTURE_OBJECT); - } - }; + } + }; - // ### structure-set instance index new-value => new-value - private static final Primitive STRUCTURE_SET = - new Primitive("structure-set", PACKAGE_SYS, true) - { - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) - - { - - if (first instanceof StructureObject) - try - { - ((StructureObject)first).slots[Fixnum.getValue(second)] = third; - return third; - } - catch (ArrayIndexOutOfBoundsException e) - { - // Shouldn't happen. - return error(new LispError("Internal error.")); - } - return type_error(first, Symbol.STRUCTURE_OBJECT); - } - }; - - // ### make-structure - private static final Primitive MAKE_STRUCTURE = - new Primitive("make-structure", PACKAGE_SYS, true) + private static final Primitive STRUCTURE_SET + = new pf_structure_set(); + @DocString(name="structure-set", + args="instance index new-value", + returns="new-value") + private static final class pf_structure_set extends Primitive + { + pf_structure_set() + { + super("structure-set", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - return new StructureObject(checkSymbol(first), second); - } - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) - - { - return new StructureObject(checkSymbol(first), second, third); - } - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth) - - { - return new StructureObject(checkSymbol(first), second, third, fourth); - } - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth) - - { - return new StructureObject(checkSymbol(first), second, third, fourth, - fifth); - } - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth) - - { - return new StructureObject(checkSymbol(first), second, third, fourth, - fifth, sixth); - } - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth, - LispObject seventh) - - { - return new StructureObject(checkSymbol(first), second, third, fourth, - fifth, sixth, seventh); - } - }; - - // ### %make-structure name slot-values => object - private static final Primitive _MAKE_STRUCTURE = - new Primitive("%make-structure", PACKAGE_SYS, true) - { - @Override - public LispObject execute(LispObject first, LispObject second) - - { - return new StructureObject(checkSymbol(first), second.copyToArray()); - } - }; + if (first instanceof StructureObject) + try + { + ((StructureObject)first).slots[Fixnum.getValue(second)] = third; + return third; + } + catch (ArrayIndexOutOfBoundsException e) + { + // Shouldn't happen. + return error(new LispError("Internal error.")); + } + return type_error(first, Symbol.STRUCTURE_OBJECT); + } + }; - // ### copy-structure structure => copy - private static final Primitive COPY_STRUCTURE = - new Primitive(Symbol.COPY_STRUCTURE, "structure") - { - @Override - public LispObject execute(LispObject arg) - { - if (arg instanceof StructureObject) - return new StructureObject((StructureObject)arg); - return type_error(arg, Symbol.STRUCTURE_OBJECT); - } - }; + private static final Primitive MAKE_STRUCTURE + = new pf_make_structure(); + @DocString(name="make-structure") + private static final class pf_make_structure extends Primitive + { + pf_make_structure() + { + super("make-structure", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + return new StructureObject(checkSymbol(first), second); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + + { + return new StructureObject(checkSymbol(first), second, third); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + + { + return new StructureObject(checkSymbol(first), second, third, fourth); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth) + { + return new StructureObject(checkSymbol(first), second, third, fourth, + fifth); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) + { + return new StructureObject(checkSymbol(first), second, third, fourth, + fifth, sixth); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh) + { + return new StructureObject(checkSymbol(first), second, third, fourth, + fifth, sixth, seventh); + } + }; + + private static final Primitive _MAKE_STRUCTURE + = new pf__make_structure(); + @DocString(name="%make-structure", + args="name slot-values", + returns="object") + private static final class pf__make_structure extends Primitive + { + pf__make_structure() + { + super("%make-structure", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + return new StructureObject(checkSymbol(first), second.copyToArray()); + } + }; + + private static final Primitive COPY_STRUCTURE + = new pf_copy_structure(); + @DocString(name="copy-structure", + args="structure", + returns="copy") + private static final class pf_copy_structure extends Primitive + { + pf_copy_structure() + { + super(Symbol.COPY_STRUCTURE, "structure"); + } + @Override + public LispObject execute(LispObject arg) + { + if (arg instanceof StructureObject) + return new StructureObject((StructureObject)arg); + return type_error(arg, Symbol.STRUCTURE_OBJECT); + } + }; } Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/mop.lisp Sat Aug 27 16:23:05 2011 (r13540) +++ trunk/abcl/src/org/armedbear/lisp/mop.lisp Sat Aug 27 16:23:24 2011 (r13541) @@ -23,6 +23,8 @@ "This generic function is called to determine whether the class superclass is suitable for use as a superclass of class.")) +;;; TODO Hook VALIDATE-SUPERCLASS into during class metaobject +;;; initialization and reinitialization. (AMOP p.240-1) (defmethod validate-superclass ((class class) (superclass class)) (or (eql (class-name superclass) t) (eql (class-name class) (class-name superclass)) From mevenson at common-lisp.net Sun Aug 28 07:46:17 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sun, 28 Aug 2011 00:46:17 -0700 Subject: [armedbear-cvs] r13542 - public_html Message-ID: Author: mevenson Date: Sun Aug 28 00:46:16 2011 New Revision: 13542 Log: Include instructions for what to do about PermGen memory errors. Note that bugs may now be submitted via OpenID authentication to the common-lisp.net infrastructure. Modified: public_html/faq.shtml Modified: public_html/faq.shtml ============================================================================== --- public_html/faq.shtml Sat Aug 27 16:23:24 2011 (r13541) +++ public_html/faq.shtml Sun Aug 28 00:46:16 2011 (r13542) @@ -36,6 +36,11 @@ +
  • Running +
      +
    1. Java is running out of memory an error reporting something about "java.lang.OutOfMemoryError: PermGen space". What can I do?
      2. +
    +
    • @@ -55,7 +60,6 @@ href="http://www.lisp.org/mop/index.html">AMOP is present. Any contributions in this area would be greatly appreciated, of course.

    -
    @@ -85,24 +89,24 @@ distribute the source code of ABCL (including modifications) if you distribute ABCL, but otherwise the license of ABCL is not viral.

    -

    How/Where should I report bugs?

    - The current state of issues can be found in the ABCL issue -tracker. Unfortunately, due to spamming problems, administration -of bugs has been closed for anybody but common-lisp.net members.

    +tracker. Individuals with an OpenID such as a Google +ID may enter information directly in the bug tracker after +authenticating by your provider.

    -To report a bug, please mail a description of the problem, the version -of ABCL you are using, and if possible a set of steps to reproduce the -problem to the armedbear-devel mailing list. We try to respond within a day at most to messages. A convenient way to browse the mailing list archives can be found by @@ -138,7 +142,6 @@

    Given ABCL's age - a young project by Lisp standards - there is also plenty of room for improvement in the area of execution speed and optimization. The project welcomes initiatives to improve performance.

    -
    @@ -164,16 +167,15 @@ Additionally, compilation of AP5 is used to improve this measure too.

    -

    ABCL 0.26.1 fails roughly 20 out of 21702 tests in the ANSI test +

    ABCL 0.26.2 fails roughly 20 out of 21702 tests in the ANSI test suite in interpreted and compiled modes, a constant number over the -past releases. Most failures relate to pretty printing.

    +past releases.

    As a measure of 'improvement achieved', the development team refers to the number of failing tests in the Maxima test suite too. ABCL 0.23.0 is able to run the test suite without failures, coming from 'only' ca 75 failing tests at the time of 0.15.0, and even 1400 failures around October 2008.

    -
    @@ -187,8 +189,6 @@ This repository is also exported read-only via HTTP at http://svn.common-lisp.net/armedbear/trunk/abcl

    - -
    @@ -204,8 +204,8 @@
  • Specific examples
    • -
    +
    @@ -222,9 +222,48 @@ 'abcl.properties', then uncomment the line referencing the setting of the abcl.build.incremental property.

    +
    + + + +
    +

    Running

    + +
    +

    Java is running out of memory an error reporting something about "java.lang.OutOfMemoryError: PermGen space". What can I do?

    + +

    + You need to increase the memory which the Java allocates for + permanent generation ("PermGen)" objects by using the appropiate + switch on command line which invokes the JVM hosting ABCL. When the + implementation compiles or loads Lisp code, it creates a separate + JVM class for each top-level form. With large workloads, this can + overrun the part of memory which Java reserves for storing the class + definition which results in the error you are seeing. +

    +

    + The exact manner of configuring this option which unfortunately + varies by implementation. For the Oracle HotSpot 64bit JVM, + something like "-d64 -Xmx4g -XX:MaxPermSize=1g + -XX:+CMSClassUnloadingEnabled" will not only increse the + PermGen space, but will ensure you always invoke the 64bit JVM, + increase the maximum memory space available to the JVM to 4Gib, and + allow the JVM to garbage collect class definitions which its deems + to be unused. +

    + +

    + If you are compiling ABCL from source, a handy way to have the build + process incorporate such runtime flags in the JVM invocation would + be to copy the 'abcl.properties.in' file to 'abcl.properties', and + then ensure that the 'java.options' variable is set to the desired + options. +

    +
    +
    From mevenson at common-lisp.net Sun Aug 28 08:25:33 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sun, 28 Aug 2011 01:25:33 -0700 Subject: [armedbear-cvs] r13543 - public_html Message-ID: Author: mevenson Date: Sun Aug 28 01:25:32 2011 New Revision: 13543 Log: Number the FAQ questions and answers via CSS. Added: public_html/faq-style.css Modified: public_html/faq.shtml public_html/style.css Added: public_html/faq-style.css ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ public_html/faq-style.css Sun Aug 28 01:25:32 2011 (r13543) @@ -0,0 +1,20 @@ +/* Use CSS2 to automatically number the FAQ questions and answer */ +ol#toc { + counter-reset: question; +} +ol#toc li { + list-style: none; +} +ol#toc > li li:before { + content: counter(question) ". "; + counter-increment: question; +} + +div#general { + counter-reset: answer; +} +div#general h3:before { + content: counter(answer) ". "; + counter-increment: answer +} + Modified: public_html/faq.shtml ============================================================================== --- public_html/faq.shtml Sun Aug 28 00:46:16 2011 (r13542) +++ public_html/faq.shtml Sun Aug 28 01:25:32 2011 (r13543) @@ -5,6 +5,7 @@ FAQ: ABCL - Common Lisp on the JVM + Modified: public_html/style.css ============================================================================== --- public_html/style.css Sun Aug 28 00:46:16 2011 (r13542) +++ public_html/style.css Sun Aug 28 01:25:32 2011 (r13543) @@ -84,3 +84,4 @@ color: #fff; padding-left: 2ex; } + From mevenson at common-lisp.net Sun Aug 28 08:39:42 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sun, 28 Aug 2011 01:39:42 -0700 Subject: [armedbear-cvs] r13544 - public_html Message-ID: Author: mevenson Date: Sun Aug 28 01:39:42 2011 New Revision: 13544 Log: Spellchecking and proofreading. Modified: public_html/faq-style.css public_html/faq.shtml Modified: public_html/faq-style.css ============================================================================== --- public_html/faq-style.css Sun Aug 28 01:25:32 2011 (r13543) +++ public_html/faq-style.css Sun Aug 28 01:39:42 2011 (r13544) @@ -18,3 +18,6 @@ counter-increment: answer } +ol#toc li li { + margin-left: 1em; +} \ No newline at end of file Modified: public_html/faq.shtml ============================================================================== --- public_html/faq.shtml Sun Aug 28 01:25:32 2011 (r13543) +++ public_html/faq.shtml Sun Aug 28 01:39:42 2011 (r13544) @@ -39,7 +39,10 @@
  • Running
      -
    1. Java is running out of memory an error reporting something about "java.lang.OutOfMemoryError: PermGen space". What can I do?
      2. +
    2. Java is running out of memory + with an error reporting something about + "java.lang.OutOfMemoryError: PermGen space". What can I + do?
    • @@ -149,10 +152,10 @@

    What is the quality of the implementation? How can you tell?

    -

    The project recognises there are several dimensions to quality:

    +

    The project recognizes there are several dimensions to quality:

    1. The level of compliance to the standard
      2. -
    2. The level of 'useability': whether (or not) the application is able +
    3. The level of 'usability': whether (or not) the application is able to run existing Lisp code
    @@ -231,11 +234,13 @@

    Running

    -

    Java is running out of memory an error reporting something about "java.lang.OutOfMemoryError: PermGen space". What can I do?

    +

    Java is running out of memory with an error reporting something +about "java.lang.OutOfMemoryError: PermGen space". What can I +do?

    You need to increase the memory which the Java allocates for - permanent generation ("PermGen)" objects by using the appropiate + permanent generation ("PermGen)" objects by using the appropriate switch on command line which invokes the JVM hosting ABCL. When the implementation compiles or loads Lisp code, it creates a separate JVM class for each top-level form. With large workloads, this can @@ -244,22 +249,22 @@

    - The exact manner of configuring this option which unfortunately - varies by implementation. For the Oracle HotSpot 64bit JVM, - something like "-d64 -Xmx4g -XX:MaxPermSize=1g - -XX:+CMSClassUnloadingEnabled" will not only increse the + The exact manner of configuring this option unfortunately varies by + Java implementation. For the Oracle HotSpot 64bit JVM, something + like "-d64 -Xmx4g -XX:MaxPermSize=1g + -XX:+CMSClassUnloadingEnabled" will not only increase the PermGen space, but will ensure you always invoke the 64bit JVM, - increase the maximum memory space available to the JVM to 4Gib, and - allow the JVM to garbage collect class definitions which its deems + increase the maximum memory space available to the Java to 4GiB, and + allow the garbage collection of class definitions which are deemed to be unused.

    If you are compiling ABCL from source, a handy way to have the build process incorporate such runtime flags in the JVM invocation would - be to copy the 'abcl.properties.in' file to 'abcl.properties', and - then ensure that the 'java.options' variable is set to the desired - options. + be to copy the 'abcl.properties.in' file to + 'abcl.properties', and then ensure that the + 'java.options' variable is set to the desired options.

    From ehuelsmann at common-lisp.net Sun Aug 28 20:11:42 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 28 Aug 2011 13:11:42 -0700 Subject: [armedbear-cvs] r13545 - trunk/abcl Message-ID: Author: ehuelsmann Date: Sun Aug 28 13:11:41 2011 New Revision: 13545 Log: Update CHANGES with development so far. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES Sun Aug 28 01:39:42 2011 (r13544) +++ trunk/abcl/CHANGES Sun Aug 28 13:11:41 2011 (r13545) @@ -1,3 +1,45 @@ +Version 0.27.0 +============== +(untagged) + + +Features +-------- + + * ABCL works as an SBCL build host + + * Huge (> 64k) literal object support (fixes CL-UNICODE support) + + +Changes +------- + + * Static initializers moved to () (java: static { }) to + prevent repeated execution when invoking the constructor multiple times + + * Compiler clean-ups + + * Changed implementation of LABELS to eliminate the need + to *always* create a closure + + * File compiler (COMPILE-FILE) clean-ups + +Fixes +----- + + * MULTIPLE-VALUE-PROG1.10 (ansi test) fixed + + * [ticket #148] READTABLE-CASE :INVERT doesn't work for uninterned symbols + + * [ticket #161] READTABLE-CASE of current readtable affects FASL content + + * [ticket #162] Non-symbol in variable position of SETQ form causes + class verification failure + + * [ticket #163] Local functions shadow global macro and function bindings + (fixes PARENSCRIPT support) + + Version 0.26.2 ============== svn://common-lisp.net/project/armedbear/svn/tags/0.26.2/abcl @@ -10,15 +52,15 @@ Fixes ----- * Fix loading from fasls under Windows with whitespace in pathname. - + * Fix #131: Don't include ':' in the version string. * Fix #141: SETF of APPLY not working with arbitrary function. - + * Include filename in the error string being reported. * Include the test source in the release. - + * Include ASDF definition in source release. Version 0.26.1 From ehuelsmann at common-lisp.net Sun Aug 28 20:36:34 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 28 Aug 2011 13:36:34 -0700 Subject: [armedbear-cvs] r13546 - trunk/abcl Message-ID: Author: ehuelsmann Date: Sun Aug 28 13:36:34 2011 New Revision: 13546 Log: More CHANGES updates. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES Sun Aug 28 13:11:41 2011 (r13545) +++ trunk/abcl/CHANGES Sun Aug 28 13:36:34 2011 (r13546) @@ -14,6 +14,13 @@ Changes ------- + * Renamed LispObject.writeToString() method to (more lispy) printObject() + + * New LispObject.princToString() for user readable output + + * Changed behaviour of LispObject.unreadableString() to signal + errors when *PRINT-READABLY* is non-NIL + * Static initializers moved to () (java: static { }) to prevent repeated execution when invoking the constructor multiple times @@ -24,6 +31,11 @@ * File compiler (COMPILE-FILE) clean-ups + * When calling a function with the wrong number of arguments, + report the expected (range) of arguments + + * Upgraded ASDF to 2.017 + Fixes ----- @@ -39,6 +51,15 @@ * [ticket #163] Local functions shadow global macro and function bindings (fixes PARENSCRIPT support) + * [ticket 158] Readable printing of the string "#" does not signal + a PRINT-NOT-READABLE error anymore + + * Fixed SYNTAX.SHARP-BACKSLASH.6 and SYNTAX.SHARP-BACKSLASH.7 + + * Fixed many PPRINT.* test suite failures + + * [ticket #151] LOAD fails for whitespace in JAR-PATHNAME + Version 0.26.2 ============== From mevenson at common-lisp.net Mon Aug 29 14:03:41 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 29 Aug 2011 07:03:41 -0700 Subject: [armedbear-cvs] r13547 - trunk/abcl Message-ID: Author: mevenson Date: Mon Aug 29 07:03:39 2011 New Revision: 13547 Log: Noted CHANGES for contrib since abcl-0.26.2. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES Sun Aug 28 13:36:34 2011 (r13546) +++ trunk/abcl/CHANGES Mon Aug 29 07:03:39 2011 (r13547) @@ -14,7 +14,7 @@ Changes ------- - * Renamed LispObject.writeToString() method to (more lispy) printObject() + * Renamed LispObject.writeToString() method to (more Lispy) printObject() * New LispObject.princToString() for user readable output @@ -36,6 +36,19 @@ * Upgraded ASDF to 2.017 + * JSS:JLIST-TO-LIST now converts any java.list.List to a Lisp list. + + * The ASDF extensions from JSS for the "jar-directory", "jar-file", + and "class-file-directory" types have been refactored into the + ABCL-ASDF contrib as well as the *ADDED-TO-CLASSPATH* variable + which records dynamically added dependencies. Use the + JSS:ENSURE-COMPATIBILITY function to have JSS include these + dependencies. + + * Threads spawned by THREADS:MAKE-THREAD can terminate the Lisp image + via the EXT:QUIT and EXT:EXIT functions. + + Fixes ----- @@ -83,6 +96,7 @@ * Include the test source in the release. * Include ASDF definition in source release. + Version 0.26.1 ============== From mevenson at common-lisp.net Tue Aug 30 13:58:56 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 30 Aug 2011 06:58:56 -0700 Subject: [armedbear-cvs] r13548 - trunk/abcl/tools/jar-size Message-ID: Author: mevenson Date: Tue Aug 30 06:58:55 2011 New Revision: 13548 Log: Tools for processing the progressive build size and times of abcl.jar. Added: trunk/abcl/tools/jar-size/ trunk/abcl/tools/jar-size/build-metrics.gnuplot trunk/abcl/tools/jar-size/build-metrics.lisp trunk/abcl/tools/jar-size/build-metrics.out Added: trunk/abcl/tools/jar-size/build-metrics.gnuplot ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/tools/jar-size/build-metrics.gnuplot Tue Aug 30 06:58:55 2011 (r13548) @@ -0,0 +1,124 @@ +1271 13105 2010-12-27 8300202 264.16 +1261 13095 2010-12-15 8295975 262.58 +1251 13078 2010-12-01 8292504 265.34 +1241 13058 2010-11-27 8277895 262.19 +1231 13039 2010-11-20 8281919 258.58 +1221 13024 2010-11-15 8279701 256.70 +1211 13011 2010-11-07 8284885 264.55 +1201 12998 2010-11-04 8284571 269.44 +1191 12987 2010-10-31 8278780 265.71 +1181 12973 2010-10-14 8151120 261.78 +1171 12963 2010-10-09 8160741 260.59 +1161 12952 2010-10-04 8149414 261.22 +1151 12941 2010-10-03 8147622 261.87 +1141 12931 2010-09-30 8105012 262.18 +1131 12912 2010-09-24 7538165 177.00 +1121 12888 2010-08-12 7538151 176.32 +1111 12828 2010-07-26 7458606 175.71 +1101 12811 2010-07-17 7454306 176.18 +1091 12799 2010-07-10 7453556 175.53 +1081 12765 2010-06-25 7449371 175.39 +1071 12752 2010-06-13 7382845 172.23 +1061 12733 2010-05-25 7187378 157.02 +1051 12721 2010-05-23 7200304 155.69 +1041 12711 2010-05-19 7194703 156.24 +1031 12699 2010-05-17 7007573 152.07 +1021 12682 2010-05-15 7131003 151.21 +1011 12668 2010-05-11 7084459 149.27 +1001 12658 2010-05-07 7077270 150.75 +991 12648 2010-05-02 7053689 149.16 +981 12637 2010-04-27 7050804 151.19 +971 12622 2010-04-18 7049819 150.48 +961 12612 2010-04-15 6774409 143.87 +951 12602 2010-04-10 6767443 141.22 +941 12592 2010-04-10 6767289 140.53 +931 12582 2010-04-08 6764168 139.09 +921 12563 2010-03-20 6610611 137.29 +911 12550 2010-03-16 6620840 137.87 +901 12535 2010-03-14 6620618 138.61 +891 12518 2010-03-04 6619955 136.81 +881 12508 2010-02-27 6327015 131.92 +871 12498 2010-02-22 6320542 130.44 +861 12488 2010-02-20 6323021 129.80 +851 12471 2010-02-14 6319550 131.24 +841 12451 2010-02-12 6312015 130.31 +831 12439 2010-02-10 6295349 131.79 +821 12429 2010-02-08 6295385 127.48 +811 12419 2010-02-05 6278274 127.65 +801 12409 2010-01-30 6266032 131.39 +791 12399 2010-01-24 6244825 136.14 +781 12383 2010-01-17 6145770 134.04 +771 12362 2010-01-11 6160836 134.07 +761 12352 2010-01-08 6160005 133.70 +751 12338 2010-01-06 6155301 134.78 +741 12328 2010-01-02 6152422 132.50 +731 12318 2010-01-01 5868984 131.64 +721 12307 2009-12-25 5835506 131.25 +711 12294 2009-12-07 5796377 131.99 +701 12284 2009-11-26 5791996 124.62 +691 12274 2009-11-10 5790578 123.81 +681 12253 2009-11-05 5817625 123.14 +671 12236 2009-10-31 5816901 125.46 +651 12216 2009-10-23 5816825 115.42 +641 12202 2009-10-17 6325293 120.53 +631 12187 2009-10-10 6324908 123.43 +621 12177 2009-10-06 6324388 126.84 +611 12167 2009-09-29 6311657 122.87 +601 12157 2009-09-20 6307000 123.03 +591 12145 2009-09-14 6298706 117.76 +581 12128 2009-09-01 6287438 116.54 +571 12118 2009-08-26 6303287 117.09 +561 12108 2009-08-19 6214409 116.66 +551 12098 2009-08-13 6244475 94.44 +541 12088 2009-08-08 5914620 89.09 +531 12078 2009-07-30 5898032 94.14 +521 12068 2009-07-27 5898083 94.31 +511 12058 2009-07-24 5891741 93.95 +501 12048 2009-07-15 5900204 92.78 +491 12038 2009-07-11 5889859 93.25 +481 12027 2009-07-02 5884369 90.21 +471 12017 2009-06-14 5864231 93.27 +461 11992 2009-06-06 5859093 96.35 +451 11982 2009-06-01 5856862 95.39 +441 11972 2009-05-31 5857111 95.13 +431 11958 2009-05-27 5856917 102.41 +421 11924 2009-05-22 5845501 100.51 +411 11914 2009-05-21 5834530 99.00 +391 11891 2009-05-17 5859453 101.44 +381 11880 2009-05-16 5886008 101.95 +371 11870 2009-05-15 5891748 105.41 +361 11853 2009-05-10 5867734 102.89 +351 11843 2009-05-08 5869102 102.17 +341 11833 2009-05-05 5870038 103.10 +331 11823 2009-05-03 5856090 103.40 +321 11813 2009-05-02 5846149 100.97 +311 11803 2009-04-29 5846363 104.55 +291 11783 2009-04-25 5831615 100.27 +281 11773 2009-04-21 5843369 102.65 +271 11763 2009-04-18 5843436 102.13 +261 11748 2009-04-08 5858380 99.80 +251 11730 2009-04-04 5858963 100.30 +241 11720 2009-03-29 5859754 100.90 +231 11710 2009-03-15 5855641 99.91 +221 11698 2009-03-05 5845637 100.08 +211 11684 2009-02-22 5848243 101.90 +201 11674 2009-02-20 5846923 102.64 +191 11654 2009-02-10 5847162 102.65 +181 11644 2009-02-08 5813728 102.47 +171 11634 2009-02-06 5807475 100.62 +161 11624 2009-02-04 5808991 99.81 +151 11614 2009-01-31 5794954 94.05 +141 11604 2009-01-30 5797070 95.51 +131 11594 2009-01-26 5788173 94.72 +121 11584 2009-01-24 5748957 93.39 +111 11574 2009-01-21 5730633 92.03 +101 11564 2009-01-18 5709163 103.95 +91 11551 2009-01-08 5784174 102.22 +81 11541 2009-01-04 5767140 92.16 +61 11521 2009-01-02 5763052 91.62 +51 11511 2008-12-30 5762217 82.54 +41 11501 2008-12-28 5760471 81.81 +31 11491 2008-12-27 5758450 82.55 +21 11481 2008-12-26 5758394 82.15 +11 11470 2008-12-22 5758285 80.47 +1 11459 2008-12-20 5675929 78.63 Added: trunk/abcl/tools/jar-size/build-metrics.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/tools/jar-size/build-metrics.lisp Tue Aug 30 06:58:55 2011 (r13548) @@ -0,0 +1,55 @@ +(defun write () + (with-open-file (s "build-metrics.gnuplot" :direction :output :if-exists :supersede) + (dolist (line (parse)) + (format s "~A~%" line)))) + +(defun parse () + (let (result) + (with-open-file (s "build-metrics.out") + (loop + (unless (equal (peek-char nil s nil #\-) #\-) + (return result)) + (let ((record (read-record s))) + (when (null record) + (return result)) + (flet ((get-value (key) + (cdr (assoc key record :test 'equal)))) + (unless (string-equal (get-value "BUILD") + "FAILED") + (let ((changeset (get-value "changeset")) + (date (get-value "date")) + (svn (get-value "svn"))) + ;;; Just include the part before the colon + (setf changeset (subseq changeset + 0 (search ":" changeset))) + ;;; Just include the day + (setf date (subseq date + 0 (search " " date))) + ;;; String the preceeding "r" + (setf svn (subseq svn 1)) + (push (format nil "~A ~A ~A ~A ~A" + changeset + svn + date + (get-value "abcl.jar-size") + (get-value "user")) + result))))))))) + +(defun read-record (s) + (let ((begin (read-line s)) + result) + (unless (string-equal begin "-----") + (error "Stream ~a not at beginning of record: ~a" s begin)) + (loop + (when (equal (peek-char nil s nil #\-) #\-) (return result)) + (let* ((line (read-line s)) + (space (search " " line))) + (when (numberp space) + (let ((key (subseq line 0 space)) + (value (subseq line (1+ space)))) + (when (equal #\: (char key (1- (length key)))) + (setf key (subseq key 0 (1- (length key))))) + (push (cons key value) result))))) + result)) + + \ No newline at end of file Added: trunk/abcl/tools/jar-size/build-metrics.out ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/tools/jar-size/build-metrics.out Tue Aug 30 06:58:55 2011 (r13548) @@ -0,0 +1,1157 @@ +----- +real 59.80 +user 78.63 +sys 12.92 +changeset: 1:dffaddf964c374ef02be2eb85ecd45c6b3a7031d +date: 2008-12-20 19:44 +0000 +svn: r11459 +description: Remove (most of) J from ABCL. +abcl.jar-size: 5675929 +----- +real 62.12 +user 80.47 +sys 13.51 +changeset: 11:608630b7d8b404d38910f40520acbefaf8c9d71e +date: 2008-12-22 13:50 +0000 +svn: r11470 +description: Remove unnecessary backquote-comma from emit-ifne-for-eql. +abcl.jar-size: 5758285 +----- +real 63.63 +user 82.15 +sys 14.00 +changeset: 21:21f7426e1f1b7d1dc2ee6d87987076655dc9a618 +date: 2008-12-26 13:53 +0000 +svn: r11481 +description: Change FASL version number because of changes to the object structure (_execute() instead of execute()). +abcl.jar-size: 5758394 +----- +real 63.95 +user 82.55 +sys 13.96 +changeset: 31:ced3881bbfdc8ed6c66f2f2229c56a868eb63efa +date: 2008-12-27 15:28 +0000 +svn: r11491 +description: Cleanup: Add a way to add and initialize a special all at once. +abcl.jar-size: 5758450 +----- +real 62.78 +user 81.81 +sys 14.02 +changeset: 41:6106ae3483622d35a937833cd629e62b04206f95 +date: 2008-12-28 22:36 +0000 +svn: r11501 +description: Efficiency/correctness of generated code: choose opcodes based on operand value, +abcl.jar-size: 5760471 +----- +real 63.81 +user 82.54 +sys 13.94 +changeset: 51:6cde781e3f5bcf226fae162b952ddd6d7985ef23 +date: 2008-12-30 12:15 +0000 +svn: r11511 +description: Use replacement characters for unmappable and malformed +abcl.jar-size: 5762217 +----- +real 71.48 +user 91.62 +sys 15.81 +changeset: 61:71750c7d903491d86ad9adf0a34acdab3e85ef1b +date: 2009-01-02 15:23 +0000 +svn: r11521 +description: Helper macro for derive-compiler type, when checking +abcl.jar-size: 5763052 +----- +BUILD FAILED +/export/home/evenson/work/abcl.jar-size/build.xml:468: Duplicate target 'abcl.test.ansi.interpreted' + +Total time: 0 seconds + +real 0.46 +user 0.50 +sys 0.08 +changeset 71 failed to build. +----- +real 71.04 +user 92.16 +sys 15.19 +changeset: 81:14fb6458112e4569bbcd86bd86e933533ad9388d +date: 2009-01-04 17:29 +0000 +svn: r11541 +description: Look, I can do conditionals in the middle of a +abcl.jar-size: 5767140 +----- +real 81.29 +user 102.22 +sys 15.37 +changeset: 91:e6bcf9828c18722435685a1bc22eae30fe9efd70 +date: 2009-01-08 20:24 +0000 +svn: r11551 +description: Change the return value of Environment.isDeclaredSpecial() to include the +abcl.jar-size: 5784174 +----- +real 77.82 +user 103.95 +sys 15.56 +changeset: 101:06d8209461c5dffbf0645033783465fdbefd0bf4 +date: 2009-01-18 18:34 +0000 +svn: r11564 +description: Fix compiler issue found by compiling AP5: Instead of calculating the true upper bound +abcl.jar-size: 5709163 +----- +real 69.04 +user 92.03 +sys 14.10 +changeset: 111:b3d8f28e6d1398aa5e420bab052095ea0b9bb3fe +date: 2009-01-21 22:35 +0000 +svn: r11574 +description: Introduce LispInteger super-type to Bignum and Fixnum: +abcl.jar-size: 5730633 +----- +real 69.04 +user 93.39 +sys 13.78 +changeset: 121:91c3660fc2f328328f42e4861bd30e34f10d6d87 +date: 2009-01-24 18:33 +0000 +svn: r11584 +description: Handle both 'long' as well as 'double' argument and return types as types of size 2 +abcl.jar-size: 5748957 +----- +real 69.79 +user 94.72 +sys 14.10 +changeset: 131:aed68fd76940b9cdc3a557b646e82b122485aa31 +date: 2009-01-26 21:54 +0000 +svn: r11594 +description: Make DERIVE-TYPE support SINGLE-FLOAT and DOUBLE-FLOAT. +abcl.jar-size: 5788173 +----- +real 69.84 +user 95.51 +sys 13.99 +changeset: 141:e8e6e10042450de77939d8998d6cd26fd89080c4 +date: 2009-01-30 06:16 +0000 +svn: r11604 +description: Smarter type derivation: start *using* the float and double storage types +abcl.jar-size: 5797070 +----- +real 68.48 +user 94.05 +sys 13.58 +changeset: 151:8877c4247489dd98ed97991fcbaaa8302c0560f6 +date: 2009-01-31 22:43 +0000 +svn: r11614 +description: Inline all compiled subtractions instead of only the 2 and 3 argument cases. +abcl.jar-size: 5794954 +----- +real 72.25 +user 99.81 +sys 14.00 +changeset: 161:8dfcb9f5d7ba243e1088e56ff1bf83e2c178eec2 +date: 2009-02-04 22:22 +0000 +svn: r11624 +description: Wider use of CONVERT-REPRESENTATION shows an issue: LispInteger.getInstance() returns a LispInteger. +abcl.jar-size: 5808991 +----- +real 72.42 +user 100.62 +sys 14.13 +changeset: 171:1198e18431d636ad3484ad90ac1005814b8f1921 +date: 2009-02-06 21:00 +0000 +svn: r11634 +description: Better in-lining compilation of MIN and MAX. +abcl.jar-size: 5807475 +----- +real 72.98 +user 102.47 +sys 14.10 +changeset: 181:e6d7112485ef04e871f714cc25cded4774382c5c +date: 2009-02-08 14:00 +0000 +svn: r11644 +description: Further cleanup for p1-flet/labels. +abcl.jar-size: 5813728 +----- +real 72.80 +user 102.65 +sys 14.24 +changeset: 191:133c76a526a0ea177039364ca15ed551e5aa46be +date: 2009-02-10 15:47 +0000 +svn: r11654 +description: Add a stock copy of the GPLv2 that ABCL licensing is based. +abcl.jar-size: 5847162 +----- +real 72.76 +user 102.64 +sys 14.24 +changeset: 201:a664349b15f083b406e0f3115e76e3a8c96ed7ce +date: 2009-02-20 20:17 +0000 +svn: r11674 +description: More lispy MAKE-CLASSES. +abcl.jar-size: 5846923 +----- +real 72.62 +user 101.90 +sys 14.11 +changeset: 211:02f980133461d06b9018d148666e9f181f956b83 +date: 2009-02-22 23:17 +0000 +svn: r11684 +description: Since 0.13 was branched, trunk/ now is 0.14... +abcl.jar-size: 5848243 +----- +real 72.20 +user 100.08 +sys 14.09 +changeset: 221:3dae0988bd0374aeceb63064b0e3f74ede260713 +date: 2009-03-05 23:20 +0000 +svn: r11698 +description: reverted wrong commit. +abcl.jar-size: 5845637 +----- +real 72.81 +user 99.91 +sys 14.11 +changeset: 231:d01ab5844fa5d0da49632bd38c5046d8668a4d87 +date: 2009-03-15 15:08 +0000 +svn: r11710 +description: Implement a generic 'list()' function instead of 9 ones. +abcl.jar-size: 5855641 +----- +real 74.19 +user 100.90 +sys 14.28 +changeset: 241:ae75f230e46103adfcfc6c6bc07718ab199bd5fd +date: 2009-03-29 09:52 +0000 +svn: r11720 +description: Fix unbound variable error. +abcl.jar-size: 5859754 +----- +real 73.92 +user 100.30 +sys 14.38 +changeset: 251:acb8a04a32f2152a6fe84970ca8388b5a3afc50d +date: 2009-04-04 22:16 +0000 +svn: r11730 +description: No longer work around absense of Math.{sinh(),cosh(),tanh()}; +abcl.jar-size: 5858963 +----- +real 72.54 +user 99.80 +sys 13.90 +changeset: 261:2fa39c3401c16db2ea83bb62c073185d15df87bd +date: 2009-04-08 06:04 +0000 +svn: r11748 +description: Revert r11746. It turns out to break the ANSI test suite and I don't know why. +abcl.jar-size: 5858380 +----- +real 73.99 +user 102.13 +sys 14.17 +changeset: 271:f6ee87cb6154c75efede03f535a80ad407501a1f +date: 2009-04-18 19:08 +0000 +svn: r11763 +description: Fix COMPILE and COMPILE-FILE secondary and tertiary return values +abcl.jar-size: 5843436 +----- +real 73.28 +user 102.65 +sys 14.35 +changeset: 281:318ebfdf27c97e69d5a23e108ed626c13c1b04f6 +date: 2009-04-21 17:26 +0000 +svn: r11773 +description: Fix MULTIPLE-VALUE-SETQ and (SETF (VALUES ...) ...) when +abcl.jar-size: 5843369 +----- +real 72.37 +user 100.27 +sys 14.39 +changeset: 291:a684a800b37dce3f836e06ab44b8d348771edeb6 +date: 2009-04-25 14:19 +0000 +svn: r11783 +description: Fix fasl reader special bindings leak. +abcl.jar-size: 5831615 +----- +BUILD FAILED +/export/home/evenson/work/abcl.jar-size/build.xml:209: Java returned: 255 + +Total time: 1 minute 3 seconds + +real 64.53 +user 88.23 +sys 10.70 +changeset 301 failed to build. +----- +real 74.73 +user 104.55 +sys 14.58 +changeset: 311:e239ff54d3f16bd78523c4f34fc29f3366aa3810 +date: 2009-04-29 21:57 +0000 +svn: r11803 +description: Always rewrite &aux vars, even if there are no +abcl.jar-size: 5846363 +----- +real 73.12 +user 100.97 +sys 14.25 +changeset: 321:2138011d88fc85e76657468128d59d80d90bea19 +date: 2009-05-02 19:36 +0000 +svn: r11813 +description: Fix building in a path with spaces. +abcl.jar-size: 5846149 +----- +real 75.14 +user 103.40 +sys 14.69 +changeset: 331:facdd7a670d4329e9db772c342f382a79274f001 +date: 2009-05-03 19:01 +0000 +svn: r11823 +description: Revert r11814 (fix for stack inconsistencies), +abcl.jar-size: 5856090 +----- +real 82.18 +user 103.10 +sys 14.86 +changeset: 341:49feb338de4fe5be78c7255985c64f6b72f55060 +date: 2009-05-05 21:42 +0000 +svn: r11833 +description: Special bindings fixes: +abcl.jar-size: 5870038 +----- +real 79.68 +user 102.17 +sys 15.23 +changeset: 351:6d096621144fc778ce53bb9352c8261419d9d8c2 +date: 2009-05-08 21:09 +0000 +svn: r11843 +description: Reflow PROCESS-TOPLEVEL-FORM in order to make +abcl.jar-size: 5869102 +----- +real 78.74 +user 102.89 +sys 14.66 +changeset: 361:99cd5390c621432571aa31286d2d57c88ada46b5 +date: 2009-05-10 21:21 +0000 +svn: r11853 +description: Restore closure variables from their saved values, +abcl.jar-size: 5867734 +----- +real 82.69 +user 105.41 +sys 15.43 +changeset: 371:575eff937b363adb121d3386723944dc6e49e44d +date: 2009-05-15 17:19 +0000 +svn: r11870 +description: Remove the TEMP-REGISTER slot from the +abcl.jar-size: 5891748 +----- +real 81.78 +user 101.95 +sys 15.06 +changeset: 381:b9520e20686e0fdbddc1634d3ddad59777f657f0 +date: 2009-05-16 09:02 +0000 +svn: r11880 +description: Remove the KIND slot from the COMPILAND structure: +abcl.jar-size: 5886008 +----- +real 80.93 +user 101.44 +sys 15.04 +changeset: 391:7ffc1656b1ea78a09360ab82e84120e8c7ab1997 +date: 2009-05-17 13:17 +0000 +svn: r11891 +description: Add docstring and reindent DECLARE-OBJECT. +abcl.jar-size: 5859453 +----- +BUILD FAILED +/export/home/evenson/work/abcl.jar-size/build.xml:209: Java returned: 1 + +Total time: 9 seconds + +real 11.92 +user 20.40 +sys 2.25 +changeset 401 failed to build. +----- +real 75.95 +user 99.00 +sys 13.96 +changeset: 411:c7adfdebead8e2b44c1b023506eaeff06ebc2796 +date: 2009-05-21 14:05 +0000 +svn: r11914 +description: Remove trailing spaces. +abcl.jar-size: 5834530 +----- +real 76.34 +user 100.51 +sys 14.62 +changeset: 421:d7f05f09ba0b44bebab3f1a2c8b126cd177724d9 +date: 2009-05-22 08:37 +0000 +svn: r11924 +description: Implement compilation of closures with non-empty +abcl.jar-size: 5845501 +----- +real 77.63 +user 102.41 +sys 14.61 +changeset: 431:b448fd84e25f237bda83d51f296796c1c0d218c6 +date: 2009-05-27 06:12 +0000 +svn: r11958 +description: Redoing my math homework: +abcl.jar-size: 5856917 +----- +real 68.14 +user 95.13 +sys 10.97 +changeset: 441:ef24ee7f7da0b69a76354d435f5aae9b6aeaea43 +date: 2009-05-31 22:12 +0000 +svn: r11972 +description: Factor out bbuf-updating from read(byte[]) and read(char[]) +abcl.jar-size: 5857111 +----- +real 66.06 +user 95.39 +sys 10.21 +changeset: 451:af728c14f09b9f2f5bc283c2731e796cf74cc2bb +date: 2009-06-01 19:18 +0000 +svn: r11982 +description: Don't use exceptions to find out the reader is null; +abcl.jar-size: 5856862 +----- +real 64.98 +user 96.35 +sys 10.21 +changeset: 461:526c4e8d4a99f00843d22f26b3e1d90a68c0ed7d +date: 2009-06-06 08:58 +0000 +svn: r11992 +description: Exported MOP functions class-slots and slot-definition-name. +abcl.jar-size: 5859093 +----- +real 61.31 +user 93.27 +sys 9.56 +changeset: 471:380fa2b9b2dd52fc5c97e7ea581b92158f86b7a8 +date: 2009-06-14 15:32 +0000 +svn: r12017 +description: Performance improvement for non-recursive #= and ##: +abcl.jar-size: 5864231 +----- +real 60.39 +user 90.21 +sys 9.54 +changeset: 481:930b5756ff295e760ce82495ac448a6ff1485480 +date: 2009-07-02 13:56 +0000 +svn: r12027 +description: Set the name of associated the java.lang.Thread if specified. +abcl.jar-size: 5884369 +----- +real 60.64 +user 93.25 +sys 9.60 +changeset: 491:b98a4abb5ad903471972f38392962fb924ba6442 +date: 2009-07-11 20:53 +0000 +svn: r12038 +description: Enable monitorenter and monitorexit opcodes. +abcl.jar-size: 5889859 +----- +real 60.80 +user 92.78 +sys 9.77 +changeset: 501:e781e186be6fa14f51421076175197806908787c +date: 2009-07-15 14:28 +0000 +svn: r12048 +description: Remove obsolete build artifacts. Are these getting added by merges or something somehow? +abcl.jar-size: 5900204 +----- +real 61.49 +user 93.95 +sys 9.75 +changeset: 511:96f1ebf851ea17c70426d2afaa00a58700ee6469 +date: 2009-07-24 21:39 +0000 +svn: r12058 +description: Make pushStackFrame final. +abcl.jar-size: 5891741 +----- +real 61.45 +user 94.31 +sys 9.93 +changeset: 521:8e52b407c11b44a24a23c334c356148b2ef717b5 +date: 2009-07-27 20:11 +0000 +svn: r12068 +description: Record the latest changes to clos and StackFrame. +abcl.jar-size: 5898083 +----- +real 61.14 +user 94.14 +sys 9.84 +changeset: 531:f8384d632ba6d0eec8f3acedfa54fe6ba506fc76 +date: 2009-07-30 22:49 +0000 +svn: r12078 +description: Greatly increase performance with VECTOR structures by +abcl.jar-size: 5898032 +----- +real 59.83 +user 89.09 +sys 9.62 +changeset: 541:3e24e2040eeb188e9eac5744609cb16e79283d16 +date: 2009-08-08 19:18 +0000 +svn: r12088 +description: Register blocks with their compiland; +abcl.jar-size: 5914620 +----- +real 63.56 +user 94.44 +sys 10.40 +changeset: 551:7e93228f7568d76c7305af9f6a3ee7bddd53143c +date: 2009-08-13 13:14 +0000 +svn: r12098 +description: Structure access referential integrity checks. +abcl.jar-size: 6244475 +----- +real 86.10 +user 116.66 +sys 10.25 +changeset: 561:beba24988f5d4d999ad4b42bf90ea42ccd655486 +date: 2009-08-19 22:09 +0000 +svn: r12108 +description: r12104 followup: forgotten M-V-B-NODE accessor. +abcl.jar-size: 6214409 +----- +real 87.08 +user 117.09 +sys 10.19 +changeset: 571:a666438121b2c31627b02e75892ba3f6619e3abc +date: 2009-08-26 21:26 +0000 +svn: r12118 +description: Adjust BLOCK-NODE dispatch routine. +abcl.jar-size: 6303287 +----- +real 85.51 +user 116.54 +sys 10.23 +changeset: 581:713101a79e098ae007c1dd54719766e6b2a6cd79 +date: 2009-09-01 09:53 +0000 +svn: r12128 +description: Fix typo from last commit. +abcl.jar-size: 6287438 +----- +real 87.96 +user 117.76 +sys 10.50 +changeset: 591:2e0cdfbc7a2e28f904caed18eec8105c89617846 +date: 2009-09-14 15:26 +0000 +svn: r12145 +description: Don't traverse the lambda list twice when checking +abcl.jar-size: 6298706 +----- +real 90.12 +user 123.03 +sys 10.36 +changeset: 601:7f84a58d069b558dc72999e8201213aa86976450 +date: 2009-09-20 08:57 +0000 +svn: r12157 +description: *INVOKE-DEBUGGER-HOOK* now called before *DEBUGGER-HOOK* (Tobias Rittweiler) +abcl.jar-size: 6307000 +----- +real 89.97 +user 122.87 +sys 10.54 +changeset: 611:113dbc49329d139229e8c5bf24177c93b414e433 +date: 2009-09-29 21:18 +0000 +svn: r12167 +description: Reorder statements to make sure the implicit block includes the evaluation +abcl.jar-size: 6311657 +----- +real 91.65 +user 126.84 +sys 10.53 +changeset: 621:9c100afb1db481df75a82cbd80adb9b8ced5f5f2 +date: 2009-10-06 08:56 +0000 +svn: r12177 +description: Revert r12153 behavior to rethrow org.armedbear.lisp.Go out of INTERACTIVE-EVAL. +abcl.jar-size: 6324388 +----- +real 91.51 +user 123.43 +sys 10.96 +changeset: 631:eaf277bef295f49a2ff8eaf783b1e5fdd079d3ca +date: 2009-10-10 14:02 +0000 +svn: r12187 +description: Reinstate two-way-stream functionality with Gray streams. +abcl.jar-size: 6324908 +----- +real 90.81 +user 120.53 +sys 10.26 +changeset: 641:2ee4090a19ec4844820cc6c3a6cf57861294287d +date: 2009-10-17 19:35 +0000 +svn: r12202 +description: Fix ABCL as a build-host for SBCL: +abcl.jar-size: 6325293 +----- +real 86.66 +user 115.42 +sys 9.69 +changeset: 651:85a4fb4e4284b7848a133b902665849c1f31a8c3 +date: 2009-10-23 21:33 +0000 +svn: r12216 +description: Make sure the #n= and #n# reader functionality gets compiled. +abcl.jar-size: 5816825 +----- +BUILD FAILED +/export/home/evenson/work/abcl.jar-size/build.xml:211: Java returned: 2 + +Total time: 14 seconds + +real 15.38 +user 29.12 +sys 3.06 +changeset 661 failed to build. +----- +real 93.09 +user 125.46 +sys 9.33 +changeset: 671:c119e8710f36e383a1e711380ae2b009270cac2d +date: 2009-10-31 10:51 +0000 +svn: r12236 +description: Update CHANGES. +abcl.jar-size: 5816901 +----- +real 92.61 +user 123.14 +sys 9.64 +changeset: 681:72f3b925addf55db0bbaeed4ec150e5677c7fbc0 +date: 2009-11-05 22:45 +0000 +svn: r12253 +description: Make ConditionThrowable abstract: it's the parent of +abcl.jar-size: 5817625 +----- +real 93.12 +user 123.81 +sys 9.45 +changeset: 691:5645e0cb067dda7c27e8def951303b11b3cc7b72 +date: 2009-11-10 19:34 +0000 +svn: r12274 +description: Convert some uses of LispObject to Symbol. +abcl.jar-size: 5790578 +----- +real 91.26 +user 124.62 +sys 9.74 +changeset: 701:bc35fc7967805954e0550587253046f17e1b2ef6 +date: 2009-11-26 15:10 +0000 +svn: r12284 +description: Delete unused function (split-directory-components). +abcl.jar-size: 5791996 +----- +real 95.03 +user 131.99 +sys 10.53 +changeset: 711:8b2bf9ebd3af0d18ebc0955fc94d4a2e0aab4ad6 +date: 2009-12-07 11:56 +0000 +svn: r12294 +description: Fix abcl.compile.lisp under Windows. +abcl.jar-size: 5796377 +----- +real 95.10 +user 131.25 +sys 10.18 +changeset: 721:909d43397afa5fb367c76c5be1322da3e7e9a12b +date: 2009-12-25 21:54 +0000 +svn: r12307 +description: Complete "catch (Throwable" review by reviewing ../examples. +abcl.jar-size: 5835506 +----- +real 96.25 +user 131.64 +sys 10.19 +changeset: 731:662c3323f0348bed7a4069131c61017261519575 +date: 2010-01-01 10:42 +0000 +svn: r12318 +description: Remove trailing spaces/tabs which light my editing buffers red. +abcl.jar-size: 5868984 +----- +real 96.39 +user 132.50 +sys 10.26 +changeset: 741:a31fa6554ade90233805cabd34606a465dabe64a +date: 2010-01-02 23:22 +0000 +svn: r12328 +description: Note a few codepoint to char conversions which are potential bugs. +abcl.jar-size: 6152422 +----- +real 97.43 +user 134.78 +sys 10.18 +changeset: 751:92c258aa5654875862a2d17bda46f46eb5056e47 +date: 2010-01-06 15:52 +0000 +svn: r12338 +description: Reworked test infrastructure. +abcl.jar-size: 6155301 +----- +real 96.66 +user 133.70 +sys 10.29 +changeset: 761:7d33c53e40b59ca6c06b639bc2205be8ee96d40e +date: 2010-01-08 21:32 +0000 +svn: r12352 +description: Have JavaObject.javaInstance(c) complain if the wrapped object is null and c is a primitive type. +abcl.jar-size: 6160005 +----- +real 96.74 +user 134.07 +sys 10.21 +changeset: 771:843b4ff790a48ac3e01cdddb0cfaf57a1be64ff3 +date: 2010-01-11 20:03 +0000 +svn: r12362 +description: Make Stream extend StructureObject, modify Stream derivatives +abcl.jar-size: 6160836 +----- +real 96.94 +user 134.04 +sys 10.45 +changeset: 781:2c61205a821037f778be30318b59dd7d7103bef4 +date: 2010-01-17 21:04 +0000 +svn: r12383 +description: Changelogs for the newest releases. +abcl.jar-size: 6145770 +----- +real 107.86 +user 136.14 +sys 10.51 +changeset: 791:35a1807274fdb5bfe5025c402c046c83e1eae385 +date: 2010-01-24 22:26 +0000 +svn: r12399 +description: Remove debugging cruft. +abcl.jar-size: 6244825 +----- +real 102.13 +user 131.39 +sys 10.40 +changeset: 801:54b94d82a0987785576f82bd0ba07b73117a99db +date: 2010-01-30 23:08 +0000 +svn: r12409 +description: Rewriting of function calls with (lambda ...) as the operator to let* forms. +abcl.jar-size: 6266032 +----- +real 101.36 +user 127.65 +sys 9.75 +changeset: 811:de0e5f4a36124220cf28750e3e4c57aa904e5199 +date: 2010-02-05 15:52 +0000 +svn: r12419 +description: 'abcl.release' target now drives the release process. +abcl.jar-size: 6278274 +----- +real 102.46 +user 127.48 +sys 10.03 +changeset: 821:cae97e51f20054a335c1b5522faf08a3f25678cd +date: 2010-02-08 07:43 +0000 +svn: r12429 +description: Correct svn:eol-style and svn:keywords. +abcl.jar-size: 6295385 +----- +real 107.19 +user 131.79 +sys 10.59 +changeset: 831:a241b1f7bc65fb18ff366bc4cac9c21606d0cee4 +date: 2010-02-10 16:13 +0000 +svn: r12439 +description: Remove duplication of java options. +abcl.jar-size: 6295349 +----- +real 103.30 +user 130.31 +sys 10.65 +changeset: 841:d989f8e8c1936f90146d448ab26624c60fa7acc0 +date: 2010-02-12 11:08 +0000 +svn: r12451 +description: Fix for ZipException under interpreted ANSI tests. +abcl.jar-size: 6312015 +----- +real 99.37 +user 131.24 +sys 10.48 +changeset: 851:c24162c3e18738010d2fc2df1af78aa01674c679 +date: 2010-02-14 13:18 +0000 +svn: r12471 +description: Stack friendliness. +abcl.jar-size: 6319550 +----- +real 100.83 +user 129.80 +sys 10.33 +changeset: 861:a4c063f71bdea94fd2b1c8f1fdf44f3d4f20b44c +date: 2010-02-20 17:28 +0000 +svn: r12488 +description: 1) remove copy-paste code, consolidate index and char array extraction +abcl.jar-size: 6323021 +----- +real 96.80 +user 130.44 +sys 10.00 +changeset: 871:af94163220bc230e3cad932e68c1cf28c570a98d +date: 2010-02-22 07:16 +0000 +svn: r12498 +description: Start noting changes for upcoming release. +abcl.jar-size: 6320542 +----- +real 97.73 +user 131.92 +sys 10.21 +changeset: 881:fd172545f76de2ca38d536c6b14fb437d207419b +date: 2010-02-27 06:59 +0000 +svn: r12508 +description: Code for parsing ANSI errors database. +abcl.jar-size: 6327015 +----- +real 101.25 +user 136.81 +sys 10.26 +changeset: 891:b1a937425c54633df31576805970ff4966e5497b +date: 2010-03-04 14:52 +0000 +svn: r12518 +description: *DISASSEMBLER* may now contain a function to return the disassembler command. +abcl.jar-size: 6619955 +----- +real 102.34 +user 138.61 +sys 10.39 +changeset: 901:1bde39e6a410ef36106a5f15f739ff48f82d12b4 +date: 2010-03-14 19:17 +0000 +svn: r12535 +description: Fix returned values from SingleFloat.getInstance() and +abcl.jar-size: 6620618 +----- +real 101.95 +user 137.87 +sys 10.57 +changeset: 911:6cbc0a916cd2281a75feae699202633d94815958 +date: 2010-03-16 15:20 +0000 +svn: r12550 +description: Fix loading of packed FASLs which have been renamed. +abcl.jar-size: 6620840 +----- +real 101.80 +user 137.29 +sys 10.28 +changeset: 921:b1563df70d4cd5b11c58ace5a652fd500d2d116f +date: 2010-03-20 19:34 +0000 +svn: r12563 +description: Update README for release 0.19.1. +abcl.jar-size: 6610611 +----- +real 104.21 +user 139.09 +sys 10.41 +changeset: 931:8b97f6a62862a51c42f3c741af14abc115655acd +date: 2010-04-08 19:38 +0000 +svn: r12582 +description: Re #38: Make Cells compile with our metaclass support by +abcl.jar-size: 6764168 +----- +real 105.75 +user 140.53 +sys 10.52 +changeset: 941:adbbd83ee1efa981e37e81a336ad68e74353ca31 +date: 2010-04-10 19:55 +0000 +svn: r12592 +description: Consolidate the functionality of faslReadStructure and readStructure +abcl.jar-size: 6767289 +----- +real 104.96 +user 141.22 +sys 10.46 +changeset: 951:75202da6397ff9a9aef14ac02715a130eba48ab5 +date: 2010-04-10 21:36 +0000 +svn: r12602 +description: Un-duplicate string reading between FaslReader and LispReader. +abcl.jar-size: 6767443 +----- +real 108.82 +user 143.87 +sys 10.66 +changeset: 961:798a2725e441e85466a0b406f40bdfabac36db62 +date: 2010-04-15 14:50 +0000 +svn: r12612 +description: Incremental checkpoint on making JAR pathnames use the new URL pathname. +abcl.jar-size: 6774409 +----- +real 114.89 +user 150.48 +sys 10.88 +changeset: 971:85b341f3bf976945a5134773a616a133e0cf2031 +date: 2010-04-18 09:26 +0000 +svn: r12622 +description: Restore buildable trunk arising from ASDF2 compilation. +abcl.jar-size: 7049819 +----- +real 116.47 +user 151.19 +sys 10.88 +changeset: 981:4d4a48f067bb3bea530a6465d79a766dc74c7214 +date: 2010-04-27 20:30 +0000 +svn: r12637 +description: Make unreadableString() variants in LispObject final. +abcl.jar-size: 7050804 +----- +real 114.74 +user 149.16 +sys 10.79 +changeset: 991:d4c554443176990cc763e3d8f485b8a128444c0b +date: 2010-05-02 18:30 +0000 +svn: r12648 +description: Add (and use) more wrappers for the lisp ERROR function, using +abcl.jar-size: 7053689 +----- +real 115.28 +user 150.75 +sys 10.78 +changeset: 1001:424ef7735074dd4e94cb80b5da0468d607e4f8a8 +date: 2010-05-07 21:08 +0000 +svn: r12658 +description: Close #38: Add some metaclass tests - to be expanded +abcl.jar-size: 7077270 +----- +real 114.57 +user 149.27 +sys 10.73 +changeset: 1011:7412dbb81387f47e66442f9bd2f3b786dc7bca3b +date: 2010-05-11 18:17 +0000 +svn: r12668 +description: Updated CHANGES for the 0.20 release +abcl.jar-size: 7084459 +----- +real 116.07 +user 151.21 +sys 10.88 +changeset: 1021:13c0de379d9a5376ded3ca551e17c2a7d4d2e604 +date: 2010-05-15 10:20 +0000 +svn: r12682 +description: Add APIs to access data gathered in the profiler +abcl.jar-size: 7131003 +----- +real 116.53 +user 152.07 +sys 10.81 +changeset: 1031:e69dc63605163908806fbd9236ebaf1fdc3cfef6 +date: 2010-05-17 20:33 +0000 +svn: r12699 +description: Refactor EXTERNALIZE-OBJECT into EMIT-LOAD-EXTERNALIZED-OBJECT. +abcl.jar-size: 7007573 +----- +real 119.23 +user 156.24 +sys 10.97 +changeset: 1041:bad35afcb02438a62d78e63d79b91a41bd8970b2 +date: 2010-05-19 22:29 +0000 +svn: r12711 +description: No longer use the reader to load "stand alone" uninterned symbols, +abcl.jar-size: 7194703 +----- +real 120.14 +user 155.69 +sys 11.18 +changeset: 1051:8c0f3b6383fee2cfb5bd43f29e3993fd703eb673 +date: 2010-05-23 06:06 +0000 +svn: r12721 +description: Examples reorganization: move snippets to misc, adjust local READMEs. +abcl.jar-size: 7200304 +----- +real 120.58 +user 157.02 +sys 11.03 +changeset: 1061:7d01da825fa17056ebb77e63d779ad56b127e4c4 +date: 2010-05-25 13:03 +0000 +svn: r12733 +description: Mention gui subdirectory in README. +abcl.jar-size: 7187378 +----- +real 134.35 +user 172.23 +sys 10.39 +changeset: 1071:d6362675448798decdb5499bb692edb998ce25e3 +date: 2010-06-13 21:33 +0000 +svn: r12752 +description: Progress towards custom slot definition support: use of generic slot-definition-* +abcl.jar-size: 7382845 +----- +real 136.86 +user 175.39 +sys 10.60 +changeset: 1081:2b8058d2015208393f0ef9a07f94983bf4bea2e6 +date: 2010-06-25 10:46 +0000 +svn: r12765 +description: Update to ASDF-2.003 with local patches. +abcl.jar-size: 7449371 +----- +real 137.02 +user 175.53 +sys 10.65 +changeset: 1091:d1ef3b36f880086baaec8d9612413f5539bf2d97 +date: 2010-07-10 20:37 +0000 +svn: r12799 +description: Backout partial bad merge. +abcl.jar-size: 7453556 +----- +real 137.41 +user 176.18 +sys 10.73 +changeset: 1101:60a37240f5b04eb159efa7325e94e51632b0c0e2 +date: 2010-07-17 12:03 +0000 +svn: r12811 +description: Re-implement clean for ANSI tests in Lisp to work under Windows. +abcl.jar-size: 7454306 +----- +real 145.60 +user 175.71 +sys 11.22 +changeset: 1111:ff20f1bc2337755269887f5cb38ee2a6d79feac3 +date: 2010-07-26 22:26 +0000 +svn: r12828 +description: Updated changelog for new release. +abcl.jar-size: 7458606 +----- +real 142.65 +user 176.32 +sys 10.91 +changeset: 1121:44ab21bdeb95ccf8cb95bec2099d106ac341f00e +date: 2010-08-12 08:50 +0000 +svn: r12888 +description: Fix typo. +abcl.jar-size: 7538151 +----- +real 147.91 +user 177.00 +sys 11.23 +changeset: 1131:d7b3ef7e68cb3b4a521935786b86fa249fa74689 +date: 2010-09-24 07:15 +0000 +svn: r12912 +description: Update CHANGES for the upcoming release. +abcl.jar-size: 7538165 +----- +real 230.61 +user 262.18 +sys 12.80 +changeset: 1141:9e4b5b9417d63f8c3d689e3e470bea75ab8169e2 +date: 2010-09-30 19:37 +0000 +svn: r12931 +description: Add fixes on trunk to be released with 0.23. +abcl.jar-size: 8105012 +----- +real 226.45 +user 261.87 +sys 12.40 +changeset: 1151:5c68031a144ef501d7d36a85c7322231cf4896d4 +date: 2010-10-03 08:47 +0000 +svn: r12941 +description: Add ANALYZE-LOCALS, which should have been on the +abcl.jar-size: 8147622 +----- +real 223.90 +user 261.22 +sys 12.22 +changeset: 1161:456b1f8c52988a5b879dc56eb7f5d4352211fb06 +date: 2010-10-04 14:31 +0000 +svn: r12952 +description: Maxima disables underflow signals itself now. We default back +abcl.jar-size: 8149414 +----- +real 222.71 +user 260.59 +sys 12.16 +changeset: 1171:2eb1777d7f8ef1f657b6bbb962b27748b48c0130 +date: 2010-10-09 19:28 +0000 +svn: r12963 +description: Remove unused constructors. +abcl.jar-size: 8160741 +----- +real 223.07 +user 261.78 +sys 12.16 +changeset: 1181:e36dec1ba1e4c2729594a709a3389f9d19bbfea5 +date: 2010-10-14 11:47 +0000 +svn: r12973 +description: Fix an issue with running ABCL on Oracle JRockit JVM! +abcl.jar-size: 8151120 +----- +real 226.12 +user 265.71 +sys 12.32 +changeset: 1191:d1614b2f0757fe770044c216ffb8de7db0ff2f4e +date: 2010-10-31 08:48 +0000 +svn: r12987 +description: Use a lexical variable rather than SETQ for backtrace +abcl.jar-size: 8278780 +----- +real 229.07 +user 269.44 +sys 12.61 +changeset: 1201:9978c4558ffe6d166c38f958dba7c9d9823bc060 +date: 2010-11-04 19:35 +0000 +svn: r12998 +description: Update CHANGES. +abcl.jar-size: 8284571 +----- +real 226.01 +user 264.55 +sys 12.44 +changeset: 1211:294e145e3595fb7c0071f0c465e3ba83c20d6f99 +date: 2010-11-07 12:10 +0000 +svn: r13011 +description: Test that MAKE-PATHNAME checks its arguments +abcl.jar-size: 8284885 +----- +real 217.87 +user 256.70 +sys 12.19 +changeset: 1221:2784ee7f28fc25da2cd2c260f6a65b9f7edff130 +date: 2010-11-15 15:05 +0000 +svn: r13024 +description: Fix loading from pathnames with '+' in directory pathname re #110. +abcl.jar-size: 8279701 +----- +real 220.03 +user 258.58 +sys 12.58 +changeset: 1231:9bbdc7765393fb34f1214577898503e57b7b195f +date: 2010-11-20 16:38 +0000 +svn: r13039 +description: Fix Lisp-based build (reported by Pascal J. Bourguignon). +abcl.jar-size: 8281919 +----- +real 223.13 +user 262.19 +sys 12.63 +changeset: 1241:f9fde9bffad86aa58abfafa1d358b8b6f01a9dc8 +date: 2010-11-27 11:04 +0000 +svn: r13058 +description: Documentation for the URI encoding changes. +abcl.jar-size: 8277895 +----- +real 226.04 +user 265.34 +sys 12.90 +changeset: 1251:592e83a09637f58aa8a1ae7bc685cc7ae9e5219d +date: 2010-12-01 22:44 +0000 +svn: r13078 +description: The classfile writer now handles the creation of interfaces. +abcl.jar-size: 8292504 +----- +real 222.28 +user 262.58 +sys 12.45 +changeset: 1261:27f1abc5234364edc72f7109a7187ac3ef9f9798 +date: 2010-12-15 21:43 +0000 +svn: r13095 +description: Remove unused packages. +abcl.jar-size: 8295975 +----- +real 224.77 +user 264.16 +sys 12.46 +changeset: 1271:31a28c7a6a627399b1be459cac8389f2f3aaa69e +date: 2010-12-27 22:06 +0000 +svn: r13105 +description: Fix Pathname.java failing to find boot.lisp in an "unpacked JAR" situation +abcl.jar-size: 8300202 +----- \ No newline at end of file From mevenson at common-lisp.net Tue Aug 30 14:03:30 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 30 Aug 2011 07:03:30 -0700 Subject: [armedbear-cvs] r13549 - trunk/abcl/tools/jar-size Message-ID: Author: mevenson Date: Tue Aug 30 07:03:29 2011 New Revision: 13549 Log: Builds successive versions from a Mercurial repository. Added: trunk/abcl/tools/jar-size/build-metrics.ksh (contents, props changed) Added: trunk/abcl/tools/jar-size/build-metrics.ksh ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/tools/jar-size/build-metrics.ksh Tue Aug 30 07:03:29 2011 (r13549) @@ -0,0 +1,26 @@ +#!/bin/ksh -x + +results=build-metrics.out + +ANT=/usr/bin/ant + +build () { + cmd="$ANT abcl.clean abcl.jar" + /usr/bin/time -p $cmd 2>>$results +} + +for (( rev=1 ; $rev<1635 ; rev+=10 )) ; do + hg update -C -r $rev + printf "-----" >> $results + rm -f dist/abcl.jar + if build ; then + hg log --template 'changeset: {rev}:{node}\ndate: {date|isodate}\nsvn: r{svnrev}\ndescription: {desc|firstline}\n' -r $rev >> $results + size=`/usr/gnu/bin/du --bytes dist/abcl.jar | awk '{ print $1 }'` + echo "abcl.jar-size: $size" >> $results + else + echo "changeset $rev failed to build." >> $results + fi +done + + + \ No newline at end of file From mevenson at common-lisp.net Tue Aug 30 15:41:05 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 30 Aug 2011 08:41:05 -0700 Subject: [armedbear-cvs] r13550 - in trunk/abcl/contrib/abcl-asdf: . tests Message-ID: Author: mevenson Date: Tue Aug 30 08:41:04 2011 New Revision: 13550 Log: Maven dependencies loaded via ASDF defintions. If a Maven3 installation can be found via FIND-MVN, ASDF definitions of the form (:mvn "GROUP-ID/ARTIFACT-ID" :version "VERSION") will be resolved at the ASDF system load time via the Maven Aether resolution mechanism. The log4j example wrapping now works. N.b. this code seriously distorts some of the notions of ASDF which really seems to depend on its components actually being resident on the filesystem. This needs to be adressed ("blessed") via consultation with ASDF developers to ensure that the path we are choosing is reasonably future-proof. Added: trunk/abcl/contrib/abcl-asdf/packages.lisp Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp trunk/abcl/contrib/abcl-asdf/tests/example.lisp trunk/abcl/contrib/abcl-asdf/tests/log4j.asd Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd ============================================================================== --- trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd Tue Aug 30 07:03:29 2011 (r13549) +++ trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd Tue Aug 30 08:41:04 2011 (r13550) @@ -3,12 +3,17 @@ (defsystem :abcl-asdf :author "Mark Evenson" - :version "0.3.2" - :depends-on ("jss") + :version "0.4.0" + :depends-on (jss) :components - ((:module base :pathname "" :components - ((:file "abcl-asdf") + ((:module packages :pathname "" + :components + ((:file "packages"))) + (:module base :pathname "" + :components + ((:file "abcl-asdf") (:file "asdf-jar" :depends-on ("abcl-asdf")) (:file "maven-embedder" - :depends-on ("abcl-asdf" "asdf-jar")))))) + :depends-on ("abcl-asdf" "asdf-jar"))) + :depends-on (packages)))) Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Tue Aug 30 07:03:29 2011 (r13549) +++ trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Tue Aug 30 08:41:04 2011 (r13550) @@ -1,43 +1,60 @@ -(defpackage #:abcl-asdf - (:use :cl) - (:export - #:satisfy - #:as-classpath - - #:resolve-artifact - #:resolve-dependencies - - #:add-directory-jars-to-class-path - #:need-to-add-directory-jar? - - #:*added-to-classpath* - #:*inhibit-add-to-classpath*)) - (in-package :asdf) -(defclass iri (static-class) - (schema authority path query fragment)) - -(defclass mvn (iri) ()) +(defclass iri (component) + ((schema :initform nil) + (authority :initform nil) + (path :initform nil) + (query :initform nil) + (fragment :initform nil))) + +(defclass mvn (iri) + ((group-id :initform nil) + (artifact-id :initform nil))) + +#+nil +(defmethod find-component ((component iri) path) + component) ;;; We interpret compilation to ensure that load-op will succeed (defmethod perform ((op compile-op) (c mvn)) - (let ((version (component-version c))) - (abcl-asdf:satisfy (component-name c) - :version (if version version :latest)))) - + (maybe-parse-mvn c) + (abcl-asdf:satisfy c)) + (defmethod perform ((operation load-op) (c mvn)) - (let ((version (component-version c))) - (java:add-to-classpath - (abcl-asdf:as-classpath - (abcl-asdf:satisfy (component-name c) - :version (if version version :latest)))))) + (maybe-parse-mvn c) + (java:add-to-classpath + (abcl-asdf:as-classpath + (abcl-asdf:satisfy c))))) + +;;; A Maven URI has the form "mvn:group-id/artifact-id/version" +;;; +;;; Currently we "stuff" the group-id/artifact-id into the 'name' and +;;; use the component 'version' for the version string. +(defun maybe-parse-mvn (component) + (with-slots (asdf::name asdf::group-id asdf::artifact-id + asdf::version asdf::schema asdf::path) component + (when (null asdf::artifact-id) + (let ((slash (search "/" name))) + (unless (and (integerp slash) + asdf::version) + (error "Failed to construct a mvn reference from name '~A' and version '~A'" + asdf::name asdf::version)) + (setf asdf::group-id (subseq asdf::name 0 slash) + asdf::artifact-id (subseq asdf::name (1+ slash)) + asdf::schema "mvn" + asdf::path (format nil "~A/~A" asdf::name asdf::version)))))) + +(defmethod source-file-type ((component iri) (system system)) + nil) + +(defmethod component-relative-pathname ((component iri)) + nil) (in-package #:abcl-asdf) -(defun satisfy (name &key (version :latest)) - (declare (ignore version)) - (resolve-dependencies name)) - +(defun satisfy (mvn-component) + (with-slots (asdf::group-id asdf::artifact-id asdf::version) mvn-component + (resolve-dependencies asdf::group-id asdf::artifact-id asdf::version))) + (defun as-classpath (classpath) "For a given MVN entry, return a list of loadable archives suitable for addition to the classpath." Added: trunk/abcl/contrib/abcl-asdf/packages.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/contrib/abcl-asdf/packages.lisp Tue Aug 30 08:41:04 2011 (r13550) @@ -0,0 +1,15 @@ +(defpackage #:abcl-asdf + (:use :cl) + (:export + #:satisfy + #:as-classpath + + #:resolve-artifact + #:resolve-dependencies + + #:add-directory-jars-to-class-path + #:need-to-add-directory-jar? + + #:*added-to-classpath* + #:*inhibit-add-to-classpath*)) + Modified: trunk/abcl/contrib/abcl-asdf/tests/example.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/tests/example.lisp Tue Aug 30 07:03:29 2011 (r13549) +++ trunk/abcl/contrib/abcl-asdf/tests/example.lisp Tue Aug 30 08:41:04 2011 (r13550) @@ -1,5 +1,5 @@ (require :jss) -(let ((logger (#"getLogger" 'Logger (symbol-name (gensym))))) - (#"log" logger "Kilroy wuz here.")) +(let ((logger (#"getLogger" 'log4j.Logger (symbol-name (gensym))))) + (#"trace" logger "Kilroy wuz here.")) Modified: trunk/abcl/contrib/abcl-asdf/tests/log4j.asd ============================================================================== --- trunk/abcl/contrib/abcl-asdf/tests/log4j.asd Tue Aug 30 07:03:29 2011 (r13549) +++ trunk/abcl/contrib/abcl-asdf/tests/log4j.asd Tue Aug 30 08:41:04 2011 (r13550) @@ -3,8 +3,10 @@ (defsystem :log4j :components - ((:mvn "log4j/log4j" :version "1.4.9") - (:module src :pathname "") - ((:file "example")))) + ((:module log4j.jar :components + ((:mvn "log4j/log4j" :version "1.2.15"))) + (:module source :pathname "" :components + ((:file "example")) + :depends-on (log4j.jar)))) From mevenson at common-lisp.net Tue Aug 30 15:42:19 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 30 Aug 2011 08:42:19 -0700 Subject: [armedbear-cvs] r13551 - trunk/abcl/tools/jar-size Message-ID: Author: mevenson Date: Tue Aug 30 08:42:19 2011 New Revision: 13551 Log: Additional results from the build-metrics run for jar-size and compile time. Modified: trunk/abcl/tools/jar-size/build-metrics.out Modified: trunk/abcl/tools/jar-size/build-metrics.out ============================================================================== --- trunk/abcl/tools/jar-size/build-metrics.out Tue Aug 30 08:41:04 2011 (r13550) +++ trunk/abcl/tools/jar-size/build-metrics.out Tue Aug 30 08:42:19 2011 (r13551) @@ -1154,4 +1154,275 @@ svn: r13105 description: Fix Pathname.java failing to find boot.lisp in an "unpacked JAR" situation abcl.jar-size: 8300202 +----- +real 236.10 +user 269.68 +sys 12.62 +changeset: 1281:8deeda16ab780c2c44b866e0a79efe121564be28 +date: 2011-01-01 12:07 +0000 +svn: r13115 +description: Add SOME-NESTED-BLOCK function to work with hierarchical block structures. +abcl.jar-size: 8384671 +----- +real 240.94 +user 269.77 +sys 12.80 +changeset: 1291:db2b516f427af273e0d68fe5ec4463862a77d47d +date: 2011-01-10 21:26 +0000 +svn: r13132 +description: Fix: When deleting a package it remains on the usedByList of +abcl.jar-size: 8414233 +----- +real 213.95 +user 254.40 +sys 12.14 +changeset: 1301:e5d9ee75d0bc822717e1d46085b2fb55a6748006 +date: 2011-01-13 22:49 +0000 +svn: r13143 +description: Add IntegrityError and ProcessingTerminated error classes +abcl.jar-size: 8180273 +----- +real 210.15 +user 254.40 +sys 12.28 +changeset: 1311:ead57eb200c46b825fbdf29f56759e3c4cf33d44 +date: 2011-01-21 14:13 +0000 +svn: r13166 +description: Smooth over more nits in the README. +abcl.jar-size: 8179908 +----- +real 207.93 +user 249.24 +sys 12.59 +changeset: 1321:bb54951c4b6780e23101c9b7a93ab05b9a6dc22d +date: 2011-01-26 08:39 +0000 +svn: r13185 +description: Fix #119: Incorrect dynamic environment for evaluation of :CLASS +abcl.jar-size: 8180818 +----- +real 206.48 +user 254.51 +sys 12.16 +changeset: 1331:626fdbed0544bfbfeafb4f9f6faae06ff6ba3b04 +date: 2011-01-30 20:52 +0000 +svn: r13195 +description: Finalize CLASS and STANDARD-OBJECT, just like most (all?) others +abcl.jar-size: 8181117 +----- +real 209.55 +user 255.94 +sys 12.31 +changeset: 1341:966522088cbbd7690d5382e02d4c773b9fc22c64 +date: 2011-02-06 16:26 +0000 +svn: r13205 +description: Upon defining a forward referenced class, assign the CLASS-DIRECT-SUBCLASSES +abcl.jar-size: 8247327 +----- +real 212.00 +user 258.26 +sys 12.26 +changeset: 1351:601637006b1e2511ae2dc6481ee19605a25a7460 +date: 2011-02-12 18:36 +0000 +svn: r13215 +description: Untabify. +abcl.jar-size: 8250104 +----- +real 210.43 +user 257.65 +sys 12.17 +changeset: 1361:681cc6e0e224748807435ee2fab976dfeb3a5573 +date: 2011-02-20 20:02 +0000 +svn: r13226 +description: Fix ticket #128. This patch enables the use of -- as a parameter, +abcl.jar-size: 8305847 +----- +real 209.69 +user 255.63 +sys 12.66 +changeset: 1371:4c86e50b8cf81674ab7d8fc05f6d0f839263bb74 +date: 2011-03-10 20:30 +0000 +svn: r13241 +description: Reduce the amount of code in our compiler by changing the way +abcl.jar-size: 8296393 +----- +real 205.11 +user 252.94 +sys 12.52 +changeset: 1381:5bd4f7987e0e9da2541559f01fd3d016470ca40d +date: 2011-03-16 18:36 +0000 +svn: r13252 +description: Revert the fix attempt for files with names like File::Foo::Bar. +abcl.jar-size: 8304436 +----- +real 207.24 +user 255.71 +sys 12.63 +changeset: 1391:7a6a723d8ca89fcb48e6395afa2bac1066cfe22a +date: 2011-04-04 12:30 +0000 +svn: r13262 +description: Fix UNUSED.2 for ABCL. +abcl.jar-size: 8262019 +----- +real 209.48 +user 257.70 +sys 12.54 +changeset: 1401:dd3acec71fbde8b55b85a754b2b5e84898b31db7 +date: 2011-04-27 20:30 +0000 +svn: r13272 +description: Fix pprint routines using SYS:OUTPUT-OBJECT to a GRAY-STREAM. +abcl.jar-size: 8307606 +----- +real 205.64 +user 251.55 +sys 12.70 +changeset: 1411:56072f909988ffd6e8c9b162e22bcba12fb2f405 +date: 2011-05-21 12:40 +0000 +svn: r13282 +description: Make JAVA:JRESOLVE-METHOD try harder to resolve a JAVA-OBJECT instance. +abcl.jar-size: 8306789 +----- +real 207.98 +user 256.02 +sys 12.32 +changeset: 1421:ba42c165b3d84d6ffd03d0ff7ef227867ce078b0 +date: 2011-05-24 12:25 +0000 +svn: r13292 +description: Untabify. +abcl.jar-size: 8307056 +----- +real 206.80 +user 255.30 +sys 12.39 +changeset: 1431:011be6c7179b144a330e1f141bc511e8028149bb +date: 2011-05-27 13:06 +0000 +svn: r13302 +description: Include the version in the internal PATHNAME copy contructor. +abcl.jar-size: 8307269 +----- +real 208.28 +user 255.14 +sys 12.64 +changeset: 1441:de1b02d56a295c7dee20443316f85c3e279dcb04 +date: 2011-06-08 15:28 +0000 +svn: r13312 +description: Renam RUN-MATCHING to DO-MATCHING improving output. +abcl.jar-size: 8357651 +----- +real 215.35 +user 255.16 +sys 12.49 +changeset: 1451:011466ba4d9c3c76816eef446374365e5a1f98ee +date: 2011-06-10 10:15 +0000 +svn: r13322 +description: Make asdf-install version compatible with ASDF2 requirements. +abcl.jar-size: 8360405 +----- +real 223.44 +user 257.21 +sys 13.31 +changeset: 1461:ecc013bfb2a2f2cdf5a6c1b947d5ca98087e661d +date: 2011-06-16 05:25 +0000 +svn: r13332 +description: Expand the Java docstring annotation to include a separate field for return values. +abcl.jar-size: 8362496 +----- +real 217.78 +user 253.51 +sys 13.04 +changeset: 1471:4e3b842dd9bef8331fc0a3087b64ff1cd83188e8 +date: 2011-06-17 10:11 +0000 +svn: r13342 +description: Implementation strategy: use the Maven Ant tasks to drive via build.xml. +abcl.jar-size: 8366111 +----- +BUILD FAILED +/export/home/evenson/work/abcl.jar-size/build.xml:360: /export/home/evenson/work/abcl.jar-size/build/classes/org/armedbear/lisp/version doesn't exist + +Total time: 3 minutes 21 seconds + +real 202.08 +user 250.45 +sys 8.64 +changeset 1481 failed to build. +----- +real 209.36 +user 257.04 +sys 12.79 +changeset: 1491:60387ebcac26a0e821f71b576a917119c17a3070 +date: 2011-06-22 14:33 +0000 +svn: r13362 +description: Dynamically find location of mvn libraries based on 'mvn' in PATH. +abcl.jar-size: 8369879 +----- +real 207.53 +user 255.90 +sys 12.46 +changeset: 1501:8ff114576c16975ba4290fd3be7dd624cedd2149 +date: 2011-07-04 09:02 +0000 +svn: r13372 +description: Document the extension to CLOS specialization for Java objects. +abcl.jar-size: 8374815 +----- +real 207.79 +user 255.88 +sys 12.36 +changeset: 1511:b023035086e9029afe5ef197e33e3ca007f6940a +date: 2011-07-09 22:57 +0000 +svn: r13383 +description: Increase trunk version number. +abcl.jar-size: 8381822 +----- +real 210.11 +user 258.38 +sys 12.62 +changeset: 1521:4946da84d4a8f1f168ab9661e8455a22ed56fb01 +date: 2011-07-14 14:10 +0000 +svn: r13401 +description: ANSI-TESTS:FULL-REPORT provides a clearer reports of test failures. +abcl.jar-size: 8382748 +----- +real 209.70 +user 259.09 +sys 12.77 +changeset: 1531:92f2082e09d4f1cf4f056ec60e122f3c3634a5cb +date: 2011-07-26 18:50 +0000 +svn: r13415 +description: Don't print the #\Uxxxx representation for character codes greater than 0xff. +abcl.jar-size: 8384053 +----- +real 205.30 +user 251.51 +sys 12.71 +changeset: 1541:e51d4e4d8db14e024e502015d4f21d8ac523024f +date: 2011-08-02 20:57 +0000 +svn: r13434 +description: Correct stream being modified to be *DEBUG-IO* bound streams. +abcl.jar-size: 8383152 +----- +real 209.54 +user 257.85 +sys 12.58 +changeset: 1551:000ed07ff41f6451b157d97d2aa21d008660587e +date: 2011-08-06 13:51 +0000 +svn: r13444 +description: Reduce the number of required unreadableString() methods by removing +abcl.jar-size: 8389139 +----- +real 197.17 +user 245.62 +sys 12.13 +changeset: 1561:a33c4807329f59e98616fef16599c49e1ef7cffe +date: 2011-08-11 09:45 +0000 +svn: r13454 +description: Tweak appearance and contents of help message. +abcl.jar-size: 8154597 +----- +real 197.19 +user 243.52 +sys 12.26 +changeset: 1571:9e340ac12149b1cb26fb36b06da8fc0dfb279db3 +date: 2011-08-11 19:44 +0000 +svn: r13464 +description: On second thought: revert r13463, it's not about value assignment, +abcl.jar-size: 8155389 ----- \ No newline at end of file From mevenson at common-lisp.net Tue Aug 30 15:48:27 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 30 Aug 2011 08:48:27 -0700 Subject: [armedbear-cvs] r13552 - trunk/abcl/tools/jar-size Message-ID: Author: mevenson Date: Tue Aug 30 08:48:27 2011 New Revision: 13552 Log: Update gnuplot from new data. Be a little bit more verbose in our output. Modified: trunk/abcl/tools/jar-size/build-metrics.gnuplot trunk/abcl/tools/jar-size/build-metrics.lisp Modified: trunk/abcl/tools/jar-size/build-metrics.gnuplot ============================================================================== --- trunk/abcl/tools/jar-size/build-metrics.gnuplot Tue Aug 30 08:42:19 2011 (r13551) +++ trunk/abcl/tools/jar-size/build-metrics.gnuplot Tue Aug 30 08:48:27 2011 (r13552) @@ -1,124 +1,154 @@ -1271 13105 2010-12-27 8300202 264.16 -1261 13095 2010-12-15 8295975 262.58 -1251 13078 2010-12-01 8292504 265.34 -1241 13058 2010-11-27 8277895 262.19 -1231 13039 2010-11-20 8281919 258.58 -1221 13024 2010-11-15 8279701 256.70 -1211 13011 2010-11-07 8284885 264.55 -1201 12998 2010-11-04 8284571 269.44 -1191 12987 2010-10-31 8278780 265.71 -1181 12973 2010-10-14 8151120 261.78 -1171 12963 2010-10-09 8160741 260.59 -1161 12952 2010-10-04 8149414 261.22 -1151 12941 2010-10-03 8147622 261.87 -1141 12931 2010-09-30 8105012 262.18 -1131 12912 2010-09-24 7538165 177.00 -1121 12888 2010-08-12 7538151 176.32 -1111 12828 2010-07-26 7458606 175.71 -1101 12811 2010-07-17 7454306 176.18 -1091 12799 2010-07-10 7453556 175.53 -1081 12765 2010-06-25 7449371 175.39 -1071 12752 2010-06-13 7382845 172.23 -1061 12733 2010-05-25 7187378 157.02 -1051 12721 2010-05-23 7200304 155.69 -1041 12711 2010-05-19 7194703 156.24 -1031 12699 2010-05-17 7007573 152.07 -1021 12682 2010-05-15 7131003 151.21 -1011 12668 2010-05-11 7084459 149.27 -1001 12658 2010-05-07 7077270 150.75 -991 12648 2010-05-02 7053689 149.16 -981 12637 2010-04-27 7050804 151.19 -971 12622 2010-04-18 7049819 150.48 -961 12612 2010-04-15 6774409 143.87 -951 12602 2010-04-10 6767443 141.22 -941 12592 2010-04-10 6767289 140.53 -931 12582 2010-04-08 6764168 139.09 -921 12563 2010-03-20 6610611 137.29 -911 12550 2010-03-16 6620840 137.87 -901 12535 2010-03-14 6620618 138.61 -891 12518 2010-03-04 6619955 136.81 -881 12508 2010-02-27 6327015 131.92 -871 12498 2010-02-22 6320542 130.44 -861 12488 2010-02-20 6323021 129.80 -851 12471 2010-02-14 6319550 131.24 -841 12451 2010-02-12 6312015 130.31 -831 12439 2010-02-10 6295349 131.79 -821 12429 2010-02-08 6295385 127.48 -811 12419 2010-02-05 6278274 127.65 -801 12409 2010-01-30 6266032 131.39 -791 12399 2010-01-24 6244825 136.14 -781 12383 2010-01-17 6145770 134.04 -771 12362 2010-01-11 6160836 134.07 -761 12352 2010-01-08 6160005 133.70 -751 12338 2010-01-06 6155301 134.78 -741 12328 2010-01-02 6152422 132.50 -731 12318 2010-01-01 5868984 131.64 -721 12307 2009-12-25 5835506 131.25 -711 12294 2009-12-07 5796377 131.99 -701 12284 2009-11-26 5791996 124.62 -691 12274 2009-11-10 5790578 123.81 -681 12253 2009-11-05 5817625 123.14 -671 12236 2009-10-31 5816901 125.46 -651 12216 2009-10-23 5816825 115.42 -641 12202 2009-10-17 6325293 120.53 -631 12187 2009-10-10 6324908 123.43 -621 12177 2009-10-06 6324388 126.84 -611 12167 2009-09-29 6311657 122.87 -601 12157 2009-09-20 6307000 123.03 -591 12145 2009-09-14 6298706 117.76 -581 12128 2009-09-01 6287438 116.54 -571 12118 2009-08-26 6303287 117.09 -561 12108 2009-08-19 6214409 116.66 -551 12098 2009-08-13 6244475 94.44 -541 12088 2009-08-08 5914620 89.09 -531 12078 2009-07-30 5898032 94.14 -521 12068 2009-07-27 5898083 94.31 -511 12058 2009-07-24 5891741 93.95 -501 12048 2009-07-15 5900204 92.78 -491 12038 2009-07-11 5889859 93.25 -481 12027 2009-07-02 5884369 90.21 -471 12017 2009-06-14 5864231 93.27 -461 11992 2009-06-06 5859093 96.35 -451 11982 2009-06-01 5856862 95.39 -441 11972 2009-05-31 5857111 95.13 -431 11958 2009-05-27 5856917 102.41 -421 11924 2009-05-22 5845501 100.51 -411 11914 2009-05-21 5834530 99.00 -391 11891 2009-05-17 5859453 101.44 -381 11880 2009-05-16 5886008 101.95 -371 11870 2009-05-15 5891748 105.41 -361 11853 2009-05-10 5867734 102.89 -351 11843 2009-05-08 5869102 102.17 -341 11833 2009-05-05 5870038 103.10 -331 11823 2009-05-03 5856090 103.40 -321 11813 2009-05-02 5846149 100.97 -311 11803 2009-04-29 5846363 104.55 -291 11783 2009-04-25 5831615 100.27 -281 11773 2009-04-21 5843369 102.65 -271 11763 2009-04-18 5843436 102.13 -261 11748 2009-04-08 5858380 99.80 -251 11730 2009-04-04 5858963 100.30 -241 11720 2009-03-29 5859754 100.90 -231 11710 2009-03-15 5855641 99.91 -221 11698 2009-03-05 5845637 100.08 -211 11684 2009-02-22 5848243 101.90 -201 11674 2009-02-20 5846923 102.64 -191 11654 2009-02-10 5847162 102.65 -181 11644 2009-02-08 5813728 102.47 -171 11634 2009-02-06 5807475 100.62 -161 11624 2009-02-04 5808991 99.81 -151 11614 2009-01-31 5794954 94.05 -141 11604 2009-01-30 5797070 95.51 -131 11594 2009-01-26 5788173 94.72 -121 11584 2009-01-24 5748957 93.39 -111 11574 2009-01-21 5730633 92.03 -101 11564 2009-01-18 5709163 103.95 -91 11551 2009-01-08 5784174 102.22 -81 11541 2009-01-04 5767140 92.16 -61 11521 2009-01-02 5763052 91.62 -51 11511 2008-12-30 5762217 82.54 -41 11501 2008-12-28 5760471 81.81 -31 11491 2008-12-27 5758450 82.55 -21 11481 2008-12-26 5758394 82.15 -11 11470 2008-12-22 5758285 80.47 +# hg-changeset-number svn-revision date abcl.jar-size user-build-time 1 11459 2008-12-20 5675929 78.63 +11 11470 2008-12-22 5758285 80.47 +21 11481 2008-12-26 5758394 82.15 +31 11491 2008-12-27 5758450 82.55 +41 11501 2008-12-28 5760471 81.81 +51 11511 2008-12-30 5762217 82.54 +61 11521 2009-01-02 5763052 91.62 +81 11541 2009-01-04 5767140 92.16 +91 11551 2009-01-08 5784174 102.22 +101 11564 2009-01-18 5709163 103.95 +111 11574 2009-01-21 5730633 92.03 +121 11584 2009-01-24 5748957 93.39 +131 11594 2009-01-26 5788173 94.72 +141 11604 2009-01-30 5797070 95.51 +151 11614 2009-01-31 5794954 94.05 +161 11624 2009-02-04 5808991 99.81 +171 11634 2009-02-06 5807475 100.62 +181 11644 2009-02-08 5813728 102.47 +191 11654 2009-02-10 5847162 102.65 +201 11674 2009-02-20 5846923 102.64 +211 11684 2009-02-22 5848243 101.90 +221 11698 2009-03-05 5845637 100.08 +231 11710 2009-03-15 5855641 99.91 +241 11720 2009-03-29 5859754 100.90 +251 11730 2009-04-04 5858963 100.30 +261 11748 2009-04-08 5858380 99.80 +271 11763 2009-04-18 5843436 102.13 +281 11773 2009-04-21 5843369 102.65 +291 11783 2009-04-25 5831615 100.27 +311 11803 2009-04-29 5846363 104.55 +321 11813 2009-05-02 5846149 100.97 +331 11823 2009-05-03 5856090 103.40 +341 11833 2009-05-05 5870038 103.10 +351 11843 2009-05-08 5869102 102.17 +361 11853 2009-05-10 5867734 102.89 +371 11870 2009-05-15 5891748 105.41 +381 11880 2009-05-16 5886008 101.95 +391 11891 2009-05-17 5859453 101.44 +411 11914 2009-05-21 5834530 99.00 +421 11924 2009-05-22 5845501 100.51 +431 11958 2009-05-27 5856917 102.41 +441 11972 2009-05-31 5857111 95.13 +451 11982 2009-06-01 5856862 95.39 +461 11992 2009-06-06 5859093 96.35 +471 12017 2009-06-14 5864231 93.27 +481 12027 2009-07-02 5884369 90.21 +491 12038 2009-07-11 5889859 93.25 +501 12048 2009-07-15 5900204 92.78 +511 12058 2009-07-24 5891741 93.95 +521 12068 2009-07-27 5898083 94.31 +531 12078 2009-07-30 5898032 94.14 +541 12088 2009-08-08 5914620 89.09 +551 12098 2009-08-13 6244475 94.44 +561 12108 2009-08-19 6214409 116.66 +571 12118 2009-08-26 6303287 117.09 +581 12128 2009-09-01 6287438 116.54 +591 12145 2009-09-14 6298706 117.76 +601 12157 2009-09-20 6307000 123.03 +611 12167 2009-09-29 6311657 122.87 +621 12177 2009-10-06 6324388 126.84 +631 12187 2009-10-10 6324908 123.43 +641 12202 2009-10-17 6325293 120.53 +651 12216 2009-10-23 5816825 115.42 +671 12236 2009-10-31 5816901 125.46 +681 12253 2009-11-05 5817625 123.14 +691 12274 2009-11-10 5790578 123.81 +701 12284 2009-11-26 5791996 124.62 +711 12294 2009-12-07 5796377 131.99 +721 12307 2009-12-25 5835506 131.25 +731 12318 2010-01-01 5868984 131.64 +741 12328 2010-01-02 6152422 132.50 +751 12338 2010-01-06 6155301 134.78 +761 12352 2010-01-08 6160005 133.70 +771 12362 2010-01-11 6160836 134.07 +781 12383 2010-01-17 6145770 134.04 +791 12399 2010-01-24 6244825 136.14 +801 12409 2010-01-30 6266032 131.39 +811 12419 2010-02-05 6278274 127.65 +821 12429 2010-02-08 6295385 127.48 +831 12439 2010-02-10 6295349 131.79 +841 12451 2010-02-12 6312015 130.31 +851 12471 2010-02-14 6319550 131.24 +861 12488 2010-02-20 6323021 129.80 +871 12498 2010-02-22 6320542 130.44 +881 12508 2010-02-27 6327015 131.92 +891 12518 2010-03-04 6619955 136.81 +901 12535 2010-03-14 6620618 138.61 +911 12550 2010-03-16 6620840 137.87 +921 12563 2010-03-20 6610611 137.29 +931 12582 2010-04-08 6764168 139.09 +941 12592 2010-04-10 6767289 140.53 +951 12602 2010-04-10 6767443 141.22 +961 12612 2010-04-15 6774409 143.87 +971 12622 2010-04-18 7049819 150.48 +981 12637 2010-04-27 7050804 151.19 +991 12648 2010-05-02 7053689 149.16 +1001 12658 2010-05-07 7077270 150.75 +1011 12668 2010-05-11 7084459 149.27 +1021 12682 2010-05-15 7131003 151.21 +1031 12699 2010-05-17 7007573 152.07 +1041 12711 2010-05-19 7194703 156.24 +1051 12721 2010-05-23 7200304 155.69 +1061 12733 2010-05-25 7187378 157.02 +1071 12752 2010-06-13 7382845 172.23 +1081 12765 2010-06-25 7449371 175.39 +1091 12799 2010-07-10 7453556 175.53 +1101 12811 2010-07-17 7454306 176.18 +1111 12828 2010-07-26 7458606 175.71 +1121 12888 2010-08-12 7538151 176.32 +1131 12912 2010-09-24 7538165 177.00 +1141 12931 2010-09-30 8105012 262.18 +1151 12941 2010-10-03 8147622 261.87 +1161 12952 2010-10-04 8149414 261.22 +1171 12963 2010-10-09 8160741 260.59 +1181 12973 2010-10-14 8151120 261.78 +1191 12987 2010-10-31 8278780 265.71 +1201 12998 2010-11-04 8284571 269.44 +1211 13011 2010-11-07 8284885 264.55 +1221 13024 2010-11-15 8279701 256.70 +1231 13039 2010-11-20 8281919 258.58 +1241 13058 2010-11-27 8277895 262.19 +1251 13078 2010-12-01 8292504 265.34 +1261 13095 2010-12-15 8295975 262.58 +1271 13105 2010-12-27 8300202 264.16 +1281 13115 2011-01-01 8384671 269.68 +1291 13132 2011-01-10 8414233 269.77 +1301 13143 2011-01-13 8180273 254.40 +1311 13166 2011-01-21 8179908 254.40 +1321 13185 2011-01-26 8180818 249.24 +1331 13195 2011-01-30 8181117 254.51 +1341 13205 2011-02-06 8247327 255.94 +1351 13215 2011-02-12 8250104 258.26 +1361 13226 2011-02-20 8305847 257.65 +1371 13241 2011-03-10 8296393 255.63 +1381 13252 2011-03-16 8304436 252.94 +1391 13262 2011-04-04 8262019 255.71 +1401 13272 2011-04-27 8307606 257.70 +1411 13282 2011-05-21 8306789 251.55 +1421 13292 2011-05-24 8307056 256.02 +1431 13302 2011-05-27 8307269 255.30 +1441 13312 2011-06-08 8357651 255.14 +1451 13322 2011-06-10 8360405 255.16 +1461 13332 2011-06-16 8362496 257.21 +1471 13342 2011-06-17 8366111 253.51 +1491 13362 2011-06-22 8369879 257.04 +1501 13372 2011-07-04 8374815 255.90 +1511 13383 2011-07-09 8381822 255.88 +1521 13401 2011-07-14 8382748 258.38 +1531 13415 2011-07-26 8384053 259.09 +1541 13434 2011-08-02 8383152 251.51 +1551 13444 2011-08-06 8389139 257.85 +1561 13454 2011-08-11 8154597 245.62 +1571 13464 2011-08-11 8155389 243.52 Modified: trunk/abcl/tools/jar-size/build-metrics.lisp ============================================================================== --- trunk/abcl/tools/jar-size/build-metrics.lisp Tue Aug 30 08:42:19 2011 (r13551) +++ trunk/abcl/tools/jar-size/build-metrics.lisp Tue Aug 30 08:48:27 2011 (r13552) @@ -1,11 +1,14 @@ -(defun write () - (with-open-file (s "build-metrics.gnuplot" :direction :output :if-exists :supersede) - (dolist (line (parse)) +(defun write (&key (file "build-metrics.gnuplot")) + (format t "Writing gnuplot file to ~A.~%" file) + (with-open-file (s file :direction :output :if-exists :supersede) + (format s "# hg-changeset-number svn-revision date abcl.jar-size user-build-time~%") + (dolist (line (nreverse (parse))) (format s "~A~%" line)))) -(defun parse () +(defun parse (&key (file "build-metrics.out")) (let (result) - (with-open-file (s "build-metrics.out") + (format t "Reading raw build metrics from ~A.~%" file) + (with-open-file (s file) (loop (unless (equal (peek-char nil s nil #\-) #\-) (return result)) From mevenson at common-lisp.net Wed Aug 31 12:07:29 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 31 Aug 2011 05:07:29 -0700 Subject: [armedbear-cvs] r13553 - trunk/abcl/tools/jar-size Message-ID: Author: mevenson Date: Wed Aug 31 05:07:26 2011 New Revision: 13553 Log: Final metrics for initial run for every tenth commit Added: trunk/abcl/tools/jar-size/build-metrics.data - copied, changed from r13552, trunk/abcl/tools/jar-size/build-metrics.gnuplot Deleted: trunk/abcl/tools/jar-size/build-metrics.gnuplot Modified: trunk/abcl/tools/jar-size/build-metrics.lisp trunk/abcl/tools/jar-size/build-metrics.out Copied and modified: trunk/abcl/tools/jar-size/build-metrics.data (from r13552, trunk/abcl/tools/jar-size/build-metrics.gnuplot) ============================================================================== --- trunk/abcl/tools/jar-size/build-metrics.gnuplot Tue Aug 30 08:48:27 2011 (r13552, copy source) +++ trunk/abcl/tools/jar-size/build-metrics.data Wed Aug 31 05:07:26 2011 (r13553) @@ -152,3 +152,9 @@ 1551 13444 2011-08-06 8389139 257.85 1561 13454 2011-08-11 8154597 245.62 1571 13464 2011-08-11 8155389 243.52 +1581 13484 2011-08-13 8150267 241.97 +1591 13494 2011-08-14 8151646 242.04 +1601 13511 2011-08-19 8158078 241.24 +1611 13521 2011-08-20 8282056 246.42 +1621 13531 2011-08-22 8291943 248.02 +1631 13541 2011-08-27 8305574 246.17 Modified: trunk/abcl/tools/jar-size/build-metrics.lisp ============================================================================== --- trunk/abcl/tools/jar-size/build-metrics.lisp Tue Aug 30 08:48:27 2011 (r13552) +++ trunk/abcl/tools/jar-size/build-metrics.lisp Wed Aug 31 05:07:26 2011 (r13553) @@ -1,16 +1,17 @@ -(defun write (&key (file "build-metrics.gnuplot")) - (format t "Writing gnuplot file to ~A.~%" file) - (with-open-file (s file :direction :output :if-exists :supersede) - (format s "# hg-changeset-number svn-revision date abcl.jar-size user-build-time~%") - (dolist (line (nreverse (parse))) - (format s "~A~%" line)))) +(defun write-data (&key (file "build-metrics.data")) + (let ((results (nreverse (parse)))) + (format t "Writing gnuplot file to ~A.~%" file) + (with-open-file (s file :direction :output :if-exists :supersede) + (format s "# hg-changeset-number svn-revision date abcl.jar-size user-build-time~%") + (dolist (line results) + (format s "~A~%" line))))) (defun parse (&key (file "build-metrics.out")) (let (result) (format t "Reading raw build metrics from ~A.~%" file) (with-open-file (s file) (loop - (unless (equal (peek-char nil s nil #\-) #\-) + (when (eq (peek-char nil s nil 'EOF) 'EOF) (return result)) (let ((record (read-record s))) (when (null record) @@ -39,20 +40,27 @@ result))))))))) (defun read-record (s) - (let ((begin (read-line s)) - result) - (unless (string-equal begin "-----") - (error "Stream ~a not at beginning of record: ~a" s begin)) - (loop - (when (equal (peek-char nil s nil #\-) #\-) (return result)) - (let* ((line (read-line s)) - (space (search " " line))) - (when (numberp space) - (let ((key (subseq line 0 space)) - (value (subseq line (1+ space)))) - (when (equal #\: (char key (1- (length key)))) - (setf key (subseq key 0 (1- (length key))))) - (push (cons key value) result))))) - result)) + (let (result) + (handler-case + (let ((begin (read-line s))) + (unless (string-equal begin "-----") + (error "Stream ~a not at beginning of record: ~a" s begin)) + (loop + (when (equal (peek-char nil s) #\-) (return-from read-record result)) + (let* ((line (read-line s)) + (space (search " " line))) + (when (numberp space) + (let ((key (subseq line 0 space)) + (value (subseq line (1+ space)))) + (when (equal #\: (char key (1- (length key)))) + (setf key (subseq key 0 (1- (length key))))) + (push (cons key value) result))))) + result) + (end-of-file () (return-from read-record result))))) + + + + + \ No newline at end of file Modified: trunk/abcl/tools/jar-size/build-metrics.out ============================================================================== --- trunk/abcl/tools/jar-size/build-metrics.out Tue Aug 30 08:48:27 2011 (r13552) +++ trunk/abcl/tools/jar-size/build-metrics.out Wed Aug 31 05:07:26 2011 (r13553) @@ -1425,4 +1425,59 @@ svn: r13464 description: On second thought: revert r13463, it's not about value assignment, abcl.jar-size: 8155389 ------ \ No newline at end of file +----- +real 194.98 +user 241.97 +sys 12.17 +changeset: 1581:4558d3d2ca0a0a6da5b0b089584cc58523d52064 +date: 2011-08-13 08:29 +0000 +svn: r13484 +description: Store local functions in the parent compiland, since you can't +abcl.jar-size: 8150267 +----- +real 194.44 +user 242.04 +sys 12.30 +changeset: 1591:271ac61fe93c86006b53a85571343c6e11e19c6d +date: 2011-08-14 13:19 +0000 +svn: r13494 +description: Only evaluate atoms in the input stream once. +abcl.jar-size: 8151646 +----- +real 193.62 +user 241.24 +sys 12.22 +changeset: 1601:88c8e659e06749750608326495d0058c9a95afec +date: 2011-08-19 15:42 +0000 +svn: r13511 +description: Re #116: while working to fix the issue, at least tell the user we're +abcl.jar-size: 8158078 +----- +real 197.90 +user 246.42 +sys 11.97 +changeset: 1611:ae2c27358aca112fd48b22cba92f350760bb58cf +date: 2011-08-20 22:18 +0000 +svn: r13521 +description: Revert r13509 because it breaks cl-ppcre compilation and the ANSI tests. +abcl.jar-size: 8282056 +----- +real 207.14 +user 248.02 +sys 12.38 +changeset: 1621:77e29e2bfe758fd287ab68755cb0ee1c16569f47 +date: 2011-08-22 14:48 +0000 +svn: r13531 +description: Optimize the compilation of files with a large number of compilands. +abcl.jar-size: 8291943 +----- +real 206.05 +user 246.17 +sys 12.26 +changeset: 1631:9a3a6bc22b61557de5cfaf2029ec466aa33c5182 +date: 2011-08-27 23:23 +0000 +svn: r13541 +description: Convert docstrings and primitives to standard conventions. +abcl.jar-size: 8305574 + +