From mevenson at common-lisp.net Mon Dec 5 11:10:18 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 05 Dec 2011 03:10:18 -0800 Subject: [armedbear-cvs] r13701 - in trunk/abcl: contrib/abcl-asdf src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon Dec 5 03:10:17 2011 New Revision: 13701 Log: mop: implement mop:extract-specializer-names as specified in AMOP page 189. Patch by Rudolf Schlatte. Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp trunk/abcl/src/org/armedbear/lisp/clos.lisp trunk/abcl/src/org/armedbear/lisp/mop.lisp Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Tue Nov 29 04:25:08 2011 (r13700) +++ trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Mon Dec 5 03:10:17 2011 (r13701) @@ -41,6 +41,9 @@ (setf asdf::group-id (subseq asdf::name 0 slash) asdf::artifact-id (subseq asdf::name (1+ slash)) asdf::schema "mvn" + asdf::version (if (eq asdf::version :latest) + "LATEST" + asdf::version) asdf::path (format nil "~A/~A" asdf::name asdf::version)))))) (defmethod source-file-type ((component iri) (system system)) Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue Nov 29 04:25:08 2011 (r13700) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Mon Dec 5 03:10:17 2011 (r13701) @@ -1483,7 +1483,7 @@ (values function-name qualifiers (extract-lambda-list specialized-lambda-list) - (extract-specializers specialized-lambda-list) + (extract-specializer-names specialized-lambda-list) documentation declarations (list* 'block @@ -1514,7 +1514,7 @@ ,@(if opts `(&optional , at opts) ()) ,@(if auxs `(&aux , at auxs) ())))) -(defun extract-specializers (specialized-lambda-list) +(defun extract-specializer-names (specialized-lambda-list) (let ((plist (analyze-lambda-list specialized-lambda-list))) (getf plist ':specializers))) Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/mop.lisp Tue Nov 29 04:25:08 2011 (r13700) +++ trunk/abcl/src/org/armedbear/lisp/mop.lisp Mon Dec 5 03:10:17 2011 (r13701) @@ -62,6 +62,7 @@ eql-specializer-object extract-lambda-list + extract-specializer-names intern-eql-specializer)) From mevenson at common-lisp.net Sun Dec 18 15:25:20 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sun, 18 Dec 2011 07:25:20 -0800 Subject: [armedbear-cvs] r13702 - in trunk/abcl: doc/asdf src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sun Dec 18 07:25:19 2011 New Revision: 13702 Log: asdf-2.019 with patch to get around ticket #181. Modified: trunk/abcl/doc/asdf/asdf.texinfo trunk/abcl/src/org/armedbear/lisp/asdf.lisp Modified: trunk/abcl/doc/asdf/asdf.texinfo ============================================================================== --- trunk/abcl/doc/asdf/asdf.texinfo Mon Dec 5 03:10:17 2011 (r13701) +++ trunk/abcl/doc/asdf/asdf.texinfo Sun Dec 18 07:25:19 2011 (r13702) @@ -895,7 +895,8 @@ @example system-definition := ( defsystem system-designator @var{system-option}* ) -system-option := :defsystem-depends-on system-list +system-option := :defsystem-depends-on system-list + | :class class-name (see discussion below) | module-option | option @@ -959,6 +960,25 @@ the current package @code{my-system-asd} can be specified as @code{:my-component-type}, or @code{my-component-type}. + at subsection System class names + +A system class name will be looked up in the same way as a Component +type (see above). Typically, one will not need to specify a system +class name, unless using a non-standard system class defined in some +ASDF extension, typically loaded through @code{DEFSYSTEM-DEPENDS-ON}, +see below. For such class names in the ASDF package, we recommend that +the @code{:class} option be specified using a keyword symbol, such as + + at example +:class :MY-NEW-SYSTEM-SUBCLASS + at end example + +This practice will ensure that package name conflicts are avoided. +Otherwise, the symbol @code{MY-NEW-SYSTEM-SUBCLASS} will be read into +the current package @emph{before} it has been exported from the ASDF +extension loaded by @code{:defsystem-depends-on}, causing a name +conflict in the current package. + @subsection Defsystem depends on The @code{:defsystem-depends-on} option to @code{defsystem} allows the @@ -2830,16 +2850,29 @@ @section Controlling file compilation When declaring a component (system, module, file), -you can specify a keyword argument @code{:around-compile some-symbol}. -If left unspecified, the value will be inherited from the parent component if any, -or with a default of @code{nil} if no value is specified in any transitive parent. - -The argument must be a either fbound symbol or @code{nil}. +you can specify a keyword argument @code{:around-compile function}. +If left unspecified, +the value will be inherited from the parent component if any, +or with a default of @code{nil} +if no value is specified in any transitive parent. + +The argument must be a either @code{nil}, a fbound symbol, +a lambda-expression (e.g. @code{(lambda (thunk) ...(funcall thunk) ...)}) +a function object (e.g. using @code{#.#'} but that's discouraged +because it prevents the introspection done by e.g. asdf-dependency-grovel), +or a string that when read yields a symbol or a lambda-expression. @code{nil} means the normal compile-file function will be called. -A symbol means the function fbound to it will be called with a single argument, -a thunk that calls the compile-file function; -the function you specify must then funcall that thunk -inside whatever wrapping you want. +A non-nil value designates a function of one argument +that will be called with a thunk for calling +the compile-file function with proper arguments. + +Note that by using a string, you may reference +a function, symbol and/or package +that will only be created later during the build, but +isn't yet present at the time the defsystem form is evaluated. +However, if your entire system is using such a hook, you may have to +explicitly override the hook with @code{nil} for all the modules and files +that are compiled before the hook is defined. Using this hook, you may achieve such effects as: locally renaming packages, @@ -3649,6 +3682,8 @@ "lis") @end lisp + at comment FIXME: Add a FAQ about how to use a new system class... + @node TODO list, Inspiration, FAQ, Top @comment node-name, next, previous, up Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/asdf.lisp Mon Dec 5 03:10:17 2011 (r13701) +++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Sun Dec 18 07:25:19 2011 (r13702) @@ -1,5 +1,5 @@ ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; This is ASDF 2.018: Another System Definition Facility. +;;; This is ASDF 2.019: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to . @@ -56,7 +56,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute) ;;; Implementation-dependent tweaks - ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults. + ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; NO: trust implementation defaults. #+allegro (setf excl::*autoload-package-name-alist* (remove "asdf" excl::*autoload-package-name-alist* @@ -86,6 +86,8 @@ (find-symbol (string s) p)) ;; Strip out formatting that is not supported on Genera. ;; Has to be inside the eval-when to make Lispworks happy (!) + (defun strcat (&rest strings) + (apply 'concatenate 'string strings)) (defmacro compatfmt (format) #-(or gcl genera) format #+(or gcl genera) @@ -94,10 +96,8 @@ '(("~3i~_" . "")) #+genera '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do (loop :for found = (search unsupported format) :while found :do - (setf format - (concatenate 'simple-string - (subseq format 0 found) replacement - (subseq format (+ found (length unsupported))))))) + (setf format (strcat (subseq format 0 found) replacement + (subseq format (+ found (length unsupported))))))) format) (let* (;; For bug reporting sanity, please always bump this version when you modify this file. ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version @@ -107,7 +107,7 @@ ;; "2.345.6" would be a development version in the official upstream ;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.018") + (asdf-version "2.019") (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -185,7 +185,7 @@ (push sym bothly-exported-symbols) (push sym formerly-exported-symbols))) (loop :for sym :in export :do - (unless (member sym bothly-exported-symbols :test 'string-equal) + (unless (member sym bothly-exported-symbols :test 'equal) (push sym newly-exported-symbols))) (loop :for user :in (package-used-by-list package) :for shadowing = (package-shadowing-symbols user) :do @@ -226,23 +226,19 @@ #:compile-file* #:source-file-type) :unintern (#:*asdf-revision* #:around #:asdf-method-combination - #:split #:make-collector + #:split #:make-collector #:do-dep #:do-one-dep + #:resolve-relative-location-component #:resolve-absolute-location-component #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function :export - (#:defsystem #:oos #:operate #:find-system #:run-shell-command + (#:defsystem #:oos #:operate #:find-system #:locate-system #:run-shell-command #:system-definition-pathname #:with-system-definitions - #:search-for-system-definition #:find-component ; miscellaneous - #:compile-system #:load-system #:test-system #:clear-system - #:compile-op #:load-op #:load-source-op - #:test-op - #:operation ; operations - #:feature ; sort-of operation - #:version ; metaphorically sort-of an operation - #:version-satisfies + #:search-for-system-definition #:find-component #:component-find-path + #:compile-system #:load-system #:load-systems #:test-system #:clear-system + #:operation #:compile-op #:load-op #:load-source-op #:test-op + #:feature #:version #:version-satisfies #:upgrade-asdf #:implementation-identifier #:implementation-type - - #:input-files #:output-files #:output-file #:perform ; operation methods + #:input-files #:output-files #:output-file #:perform #:operation-done-p #:explain #:component #:source-file @@ -334,11 +330,19 @@ #:process-source-registry #:system-registered-p #:asdf-message + #:user-output-translations-pathname + #:system-output-translations-pathname + #:user-output-translations-directory-pathname + #:system-output-translations-directory-pathname + #:user-source-registry + #:system-source-registry + #:user-source-registry-directory + #:system-source-registry-directory ;; Utilities #:absolute-pathname-p ;; #:aif #:it - ;; #:appendf + ;; #:appendf #:orf #:coerce-name #:directory-pathname-p ;; #:ends-with @@ -346,9 +350,7 @@ #:getenv ;; #:length=n-p ;; #:find-symbol* - #:merge-pathnames* - #:coerce-pathname - #:subpathname + #:merge-pathnames* #:coerce-pathname #:subpathname #:pathname-directory-pathname #:read-file-forms ;; #:remove-keys @@ -411,6 +413,7 @@ condition-arguments condition-form condition-format condition-location coerce-name) + (ftype (function (&optional t) (values)) initialize-source-registry) #-(or cormanlisp gcl-pre2.7) (ftype (function (t t) t) (setf module-components-by-name))) @@ -419,8 +422,8 @@ #+cormanlisp (progn (deftype logical-pathname () nil) - (defun* make-broadcast-stream () *error-output*) - (defun* file-namestring (p) + (defun make-broadcast-stream () *error-output*) + (defun file-namestring (p) (setf p (pathname p)) (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))) @@ -520,6 +523,9 @@ :do (pop reldir) (pop defrev) :finally (return (cons defabs (append (reverse defrev) reldir))))))))))) +(defun* ununspecific (x) + (if (eq x :unspecific) nil x)) + (defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*)) "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname does not have an absolute directory, @@ -538,9 +544,7 @@ (name (or (pathname-name specified) (pathname-name defaults))) (type (or (pathname-type specified) (pathname-type defaults))) (version (or (pathname-version specified) (pathname-version defaults)))) - (labels ((ununspecific (x) - (if (eq x :unspecific) nil x)) - (unspecific-handler (p) + (labels ((unspecific-handler (p) (if (typep p 'logical-pathname) #'ununspecific #'identity))) (multiple-value-bind (host device directory unspecific-handler) (ecase (first directory) @@ -891,24 +895,21 @@ (host (pathname-host pathname)) (port (ext:pathname-port pathname)) (directory (pathname-directory pathname))) - (flet ((not-unspecific (component) - (and (not (eq component :unspecific)) component))) - (cond ((or (not-unspecific port) - (and (not-unspecific host) (plusp (length host))) - (not-unspecific scheme)) - (let ((prefix "")) - (when (not-unspecific port) - (setf prefix (format nil ":~D" port))) - (when (and (not-unspecific host) (plusp (length host))) - (setf prefix (concatenate 'string host prefix))) - (setf prefix (concatenate 'string ":" prefix)) - (when (not-unspecific scheme) - (setf prefix (concatenate 'string scheme prefix))) - (assert (and directory (eq (first directory) :absolute))) - (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) - :defaults pathname))) - (t - pathname))))) + (if (or (ununspecific port) + (and (ununspecific host) (plusp (length host))) + (ununspecific scheme)) + (let ((prefix "")) + (when (ununspecific port) + (setf prefix (format nil ":~D" port))) + (when (and (ununspecific host) (plusp (length host))) + (setf prefix (strcat host prefix))) + (setf prefix (strcat ":" prefix)) + (when (ununspecific scheme) + (setf prefix (strcat scheme prefix))) + (assert (and directory (eq (first directory) :absolute))) + (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) + :defaults pathname))) + pathname)) ;;;; ------------------------------------------------------------------------- ;;;; ASDF Interface, in terms of generic functions. @@ -1171,45 +1172,6 @@ (properties :accessor component-properties :initarg :properties :initform nil))) -;;; I believe that the following could probably be more efficiently done -;;; by a primary method that invokes SHARED-INITIALIZE in a way that would -;;; appropriately pass the slots to have their initforms re-applied, but I -;;; do not know how to write such a method. [2011/09/02:rpg] -(defmethod reinitialize-instance :after ((obj component) &rest initargs - &key (version nil version-suppliedp) - (description nil description-suppliedp) - (long-description nil - long-description-suppliedp) - (load-dependencies nil - ld-suppliedp) - in-order-to - do-first - inline-methods - parent - properties) - "We reuse component objects from previously-existing systems, so we need to -make sure we clear them thoroughly." - (declare (ignore initargs load-dependencies - long-description description version)) - ;; this is a cache and should be cleared - (slot-makunbound obj 'absolute-pathname) - ;; component operation times are no longer valid when the component changes - (clrhash (component-operation-times obj)) - (unless version-suppliedp (slot-makunbound obj 'version)) - (unless description-suppliedp - (slot-makunbound obj 'description)) - (unless long-description-suppliedp - (slot-makunbound obj 'long-description)) - ;; replicate the logic of the initforms... - (unless ld-suppliedp - (setf (component-load-dependencies obj) nil)) - (setf (component-in-order-to obj) in-order-to - (component-do-first obj) do-first - (component-inline-methods obj) inline-methods - (slot-value obj 'parent) parent - (slot-value obj 'properties) properties)) - - (defun* component-find-path (component) (reverse (loop :for c = component :then (component-parent c) @@ -1282,21 +1244,6 @@ :initarg :default-component-class :accessor module-default-component-class))) -;;; see comment with REINITIALIZE-INSTANCE method on COMPONENT -;;; [2011/09/02:rpg] -(defmethod reinitialize-instance :after ((obj module) &rest initargs &key) - "Clear MODULE's slots so it can be reused." - (slot-makunbound obj 'components-by-name) - ;; this may be a more elegant approach than in the - ;; COMPONENT method [2011/09/02:rpg] - (loop :for (initarg slot-name default) :in - `((:components components nil) - (:if-component-dep-fails if-component-dep-fails :fail) - (:default-component-class default-component-class - ,*default-component-class*)) - :unless (member initarg initargs) - :do (setf (slot-value obj slot-name) default))) - (defun* component-parent-pathname (component) ;; No default anymore (in particular, no *default-pathname-defaults*). ;; If you force component to have a NULL pathname, you better arrange @@ -1330,7 +1277,12 @@ (acons property new-value (slot-value c 'properties))))) new-value) -(defclass system (module) +(defclass proto-system () ; slots to keep when resetting a system + ;; To preserve identity for all objects, we'd need keep the components slots + ;; but also to modify parse-component-form to reset the recycled objects. + ((name) #|(components) (components-by-names)|#)) + +(defclass system (module proto-system) (;; description and long-description are now available for all component's, ;; but now also inherited from component, but we add the legacy accessor (description :accessor system-description :initarg :description) @@ -1343,24 +1295,6 @@ :writer %set-system-source-file) (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on))) -;;; see comment with REINITIALIZE-INSTANCE method on COMPONENT -;;; [2011/09/02:rpg] -(defmethod reinitialize-instance :after ((obj system) &rest initargs &key) - "Clear SYSTEM's slots so it can be reused." - ;; note that SYSTEM-SOURCE-FILE is very specially handled, - ;; by DO-DEFSYSTEM, so we need to *PRESERVE* its value and - ;; not squash it. SYSTEM COMPONENTS are handled very specially, - ;; because they are always, effectively, reused, since the system component - ;; is made early in DO-DEFSYSTEM, instead of being made later, in - ;; PARSE-COMPONENT-FORM [2011/09/02:rpg] - (loop :for (initarg slot-name) :in - `((:author author) - (:maintainer maintainer) - (:licence licence) - (:defsystem-depends-on defsystem-depends-on)) - :unless (member initarg initargs) - :do (slot-makunbound obj slot-name))) - ;;;; ------------------------------------------------------------------------- ;;;; version-satisfies @@ -1448,11 +1382,10 @@ (file-position s (+ start network-volume-offset #x14)))) - (concatenate 'string - (read-null-terminated-string s) - (progn - (file-position s (+ start remaining-offset)) - (read-null-terminated-string s)))))) + (strcat (read-null-terminated-string s) + (progn + (file-position s (+ start remaining-offset)) + (read-null-terminated-string s)))))) (defun* parse-windows-shortcut (pathname) (with-open-file (s pathname :element-type '(unsigned-byte 8)) @@ -1539,15 +1472,25 @@ ;;; for the sake of keeping things reasonably neat, we adopt a ;;; convention that functions in this list are prefixed SYSDEF- -(defparameter *system-definition-search-functions* - '(sysdef-central-registry-search - sysdef-source-registry-search - sysdef-find-asdf)) +(defvar *system-definition-search-functions* '()) + +(setf *system-definition-search-functions* + (append + ;; Remove known-incompatible sysdef functions from ancient sbcl asdf. + (remove 'contrib-sysdef-search *system-definition-search-functions*) + ;; Tuck our defaults at the end of the list if they were absent. + ;; This is imperfect, in case they were removed on purpose, + ;; but then it will be the responsibility of whoever does that + ;; to upgrade asdf before he does such a thing rather than after. + (remove-if #'(lambda (x) (member x *system-definition-search-functions*)) + '(sysdef-central-registry-search + sysdef-source-registry-search + sysdef-find-asdf)))) (defun* search-for-system-definition (system) - (let ((system-name (coerce-name system))) - (some #'(lambda (x) (funcall x system-name)) - (cons 'find-system-if-being-defined *system-definition-search-functions*)))) + (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name))) + (cons 'find-system-if-being-defined + *system-definition-search-functions*))) (defvar *central-registry* nil "A list of 'system directory designators' ASDF uses to find systems. @@ -1597,7 +1540,7 @@ (let ((shortcut (make-pathname :defaults defaults :version :newest :case :local - :name (concatenate 'string name ".asd") + :name (strcat name ".asd") :type "lnk"))) (when (probe-file* shortcut) (let ((target (parse-windows-shortcut shortcut))) @@ -1671,6 +1614,7 @@ 0))) (defmethod find-system ((name null) &optional (error-p t)) + (declare (ignorable name)) (when error-p (sysdef-error (compatfmt "~@")))) @@ -1690,7 +1634,7 @@ (let ((*systems-being-defined* (make-hash-table :test 'equal))) (funcall thunk)))) -(defmacro with-system-definitions (() &body body) +(defmacro with-system-definitions ((&optional) &body body) `(call-with-system-definitions #'(lambda () , at body))) (defun* load-sysdef (name pathname) @@ -1706,8 +1650,7 @@ (let ((*package* package) (*default-pathname-defaults* (pathname-directory-pathname pathname))) - ;;; XXX Under ABCL, if the PATHNAME is a JAR-PATHNAME the - ;;; MERGE-PATHNAMES are perhaps a bit wonky. + ;;; XXX Kludge for ABCL ticket #181 #+abcl (when (ext:pathname-jar-p pathname) (setf *default-pathname-defaults* @@ -1717,17 +1660,27 @@ (load pathname))) (delete-package package))))) -(defmethod find-system ((name string) &optional (error-p t)) - (with-system-definitions () - (let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk - (previous (cdr in-memory)) - (previous (and (typep previous 'system) previous)) - (previous-time (car in-memory)) +(defun* locate-system (name) + "Given a system NAME designator, try to locate where to load the system from. +Returns four values: FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME +FOUNDP is true when a new was found, either a new unregistered one or a previously registered one. +FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is +PATHNAME when not null is a path from where to load the system, associated with FOUND-SYSTEM, or with the PREVIOUS system. +PREVIOUS when not null is a previously loaded SYSTEM object of same name. +PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded." + (let* ((name (coerce-name name)) + (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk + (previous (cdr in-memory)) + (previous (and (typep previous 'system) previous)) + (previous-time (car in-memory)) (found (search-for-system-definition name)) - (found-system (and (typep found 'system) found)) - (pathname (or (and (typep found '(or pathname string)) (pathname found)) - (and found-system (system-source-file found-system)) - (and previous (system-source-file previous))))) + (found-system (and (typep found 'system) found)) + (pathname (or (and (typep found '(or pathname string)) (pathname found)) + (and found-system (system-source-file found-system)) + (and previous (system-source-file previous)))) + (foundp (and (or found-system pathname previous) t))) + (check-type found (or null pathname system)) + (when foundp (setf pathname (resolve-symlinks* pathname)) (when (and pathname (not (absolute-pathname-p pathname))) (setf pathname (ensure-pathname-absolute pathname)) @@ -1737,23 +1690,37 @@ (system-source-file previous) pathname))) (%set-system-source-file pathname previous) (setf previous-time nil)) - (when (and found-system (not previous)) - (register-system found-system)) - (when (and pathname - (or (not previous-time) - ;; don't reload if it's already been loaded, - ;; or its filestamp is in the future which means some clock is skewed - ;; and trying to load might cause an infinite loop. - (< previous-time (safe-file-write-date pathname) (get-universal-time)))) - (load-sysdef name pathname)) - (let ((in-memory (system-registered-p name))) ; try again after loading from disk - (cond - (in-memory - (when pathname - (setf (car in-memory) (safe-file-write-date pathname))) - (cdr in-memory)) - (error-p - (error 'missing-component :requires name))))))) + (values foundp found-system pathname previous previous-time)))) + +(defmethod find-system ((name string) &optional (error-p t)) + (with-system-definitions () + (loop + (restart-case + (multiple-value-bind (foundp found-system pathname previous previous-time) + (locate-system name) + (declare (ignore foundp)) + (when (and found-system (not previous)) + (register-system found-system)) + (when (and pathname + (or (not previous-time) + ;; don't reload if it's already been loaded, + ;; or its filestamp is in the future which means some clock is skewed + ;; and trying to load might cause an infinite loop. + (< previous-time (safe-file-write-date pathname) (get-universal-time)))) + (load-sysdef name pathname)) + (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed + (return + (cond + (in-memory + (when pathname + (setf (car in-memory) (safe-file-write-date pathname))) + (cdr in-memory)) + (error-p + (error 'missing-component :requires name)))))) + (reinitialize-source-registry-and-retry () + :report (lambda (s) + (format s "~@" name)) + (initialize-source-registry)))))) (defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys) (setf fallback (coerce-name fallback) @@ -1879,12 +1846,9 @@ (and pathname (merge-pathnames* (coerce-pathname subpath :type type) (pathname-directory-pathname pathname)))) -(defun* try-subpathname (pathname subpath &key type) - (let* ((sp (and pathname (probe-file* pathname) - (subpathname pathname subpath :type type))) - (ts (and sp (probe-file* sp)))) - (and ts (values sp ts)))) - +(defun subpathname* (pathname subpath &key type) + (and pathname + (subpathname (ensure-directory-pathname pathname) subpath :type type))) ;;;; ------------------------------------------------------------------------- ;;;; Operations @@ -1988,10 +1952,9 @@ (cdr (assoc (type-of o) (component-in-order-to c)))) (defmethod component-self-dependencies ((o operation) (c component)) - (let ((all-deps (component-depends-on o c))) - (remove-if-not #'(lambda (x) - (member (component-name c) (cdr x) :test #'string=)) - all-deps))) + (remove-if-not + #'(lambda (x) (member (component-name c) (cdr x) :test #'string=)) + (component-depends-on o c))) (defmethod input-files ((operation operation) (c component)) (let ((parent (component-parent c)) @@ -2363,10 +2326,18 @@ ((component-parent c) (around-compile-hook (component-parent c))))) +(defun ensure-function (fun &key (package :asdf)) + (etypecase fun + ((or symbol function) fun) + (cons (eval `(function ,fun))) + (string (eval `(function ,(with-standard-io-syntax + (let ((*package* (find-package package))) + (read-from-string fun)))))))) + (defmethod call-with-around-compile-hook ((c component) thunk) (let ((hook (around-compile-hook c))) (if hook - (funcall hook thunk) + (funcall (ensure-function hook) thunk) (funcall thunk)))) (defvar *compile-op-compile-file-function* 'compile-file* @@ -2552,31 +2523,38 @@ (defgeneric* operate (operation-class system &key &allow-other-keys)) (defgeneric* perform-plan (plan &key)) +;;;; Separating this into a different function makes it more forward-compatible +(defun* cleanup-upgraded-asdf (old-version) + (let ((new-version (asdf:asdf-version))) + (unless (equal old-version new-version) + (cond + ((version-satisfies new-version old-version) + (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") + old-version new-version)) + ((version-satisfies old-version new-version) + (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%") + old-version new-version)) + (t + (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%") + old-version new-version))) + (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf))) + ;; Invalidate all systems but ASDF itself. + (setf *defined-systems* (make-defined-systems-table)) + (register-system asdf) + ;; If we're in the middle of something, restart it. + (when *systems-being-defined* + (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name))) + (clrhash *systems-being-defined*) + (dolist (s l) (find-system s nil)))) + t)))) + ;;;; Try to upgrade of ASDF. If a different version was used, return T. ;;;; We need do that before we operate on anything that depends on ASDF. (defun* upgrade-asdf () (let ((version (asdf:asdf-version))) (handler-bind (((or style-warning warning) #'muffle-warning)) (operate 'load-op :asdf :verbose nil)) - (let ((new-version (asdf:asdf-version))) - (block nil - (cond - ((equal version new-version) - (return nil)) - ((version-satisfies new-version version) - (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") - version new-version)) - ((version-satisfies version new-version) - (warn (compatfmt "~&~@~%") - version new-version)) - (t - (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%") - version new-version))) - (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf))) - ;; invalidate all systems but ASDF itself - (setf *defined-systems* (make-defined-systems-table)) - (register-system asdf) - t))))) + (cleanup-upgraded-asdf version))) (defmethod perform-plan ((steps list) &key) (let ((*package* *package*) @@ -2640,7 +2618,7 @@ ")) (setf (documentation 'oos 'function) (format nil - "Short for _operate on system_ and an alias for the OPERATE function. ~&~&~a" + "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a" operate-docstring)) (setf (documentation 'operate 'function) operate-docstring)) @@ -2652,6 +2630,9 @@ (apply 'operate 'load-op system args) t) +(defun* load-systems (&rest systems) + (map () 'load-system systems)) + (defun* compile-system (system &rest args &key force verbose version &allow-other-keys) "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE @@ -2708,7 +2689,7 @@ (if first-op-tree (progn (aif (assoc op2 (cdr first-op-tree)) - (if (find c (cdr it)) + (if (find c (cdr it) :test #'equal) nil (setf (cdr it) (cons c (cdr it)))) (setf (cdr first-op-tree) @@ -2730,8 +2711,7 @@ (defvar *serial-depends-on* nil) (defun* sysdef-error-component (msg type name value) - (sysdef-error (concatenate 'string msg - (compatfmt "~&~@")) + (sysdef-error (strcat msg (compatfmt "~&~@")) type name value)) (defun* check-component-input (type name weakly-depends-on @@ -2808,29 +2788,22 @@ (warn (compatfmt "~@") version name parent))) - (let* ((other-args (remove-keys - '(components pathname default-component-class - perform explain output-files operation-done-p - weakly-depends-on - depends-on serial in-order-to) - rest)) + (let* ((args (list* :name (coerce-name name) + :pathname pathname + :parent parent + (remove-keys + '(components pathname default-component-class + perform explain output-files operation-done-p + weakly-depends-on depends-on serial in-order-to) + rest))) (ret (find-component parent name))) (when weakly-depends-on (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on))) (when *serial-depends-on* (push *serial-depends-on* depends-on)) - (if ret - (apply 'reinitialize-instance ret - :name (coerce-name name) - :pathname pathname - :parent parent - other-args) - (setf ret - (apply 'make-instance (class-for-type parent type) - :name (coerce-name name) - :pathname pathname - :parent parent - other-args))) + (if ret ; preserve identity + (apply 'reinitialize-instance ret args) + (setf ret (apply 'make-instance (class-for-type parent type) args))) (component-pathname ret) ; eagerly compute the absolute pathname (when (typep ret 'module) (setf (module-default-component-class ret) @@ -2862,6 +2835,10 @@ (%refresh-component-inline-methods ret rest) ret))) +(defun* reset-system (system &rest keys &key &allow-other-keys) + (change-class (change-class system 'proto-system) 'system) + (apply 'reinitialize-instance system keys)) + (defun* do-defsystem (name &rest options &key pathname (class 'system) defsystem-depends-on &allow-other-keys) @@ -2874,14 +2851,14 @@ (with-system-definitions () (let* ((name (coerce-name name)) (registered (system-registered-p name)) - (system (cdr (or registered - (register-system (make-instance 'system :name name))))) + (registered! (if registered + (rplaca registered (get-universal-time)) + (register-system (make-instance 'system :name name)))) + (system (reset-system (cdr registered!) + :name name :source-file (load-pathname))) (component-options (remove-keys '(:class) options))) - (%set-system-source-file (load-pathname) system) (setf (gethash name *systems-being-defined*) system) - (when registered - (setf (car registered) (get-universal-time))) - (map () 'load-system defsystem-depends-on) + (apply 'load-systems defsystem-depends-on) ;; We change-class (when necessary) AFTER we load the defsystem-dep's ;; since the class might not be defined as part of those. (let ((class (class-for-type nil class))) @@ -2966,7 +2943,7 @@ (ccl:run-program (cond ((os-unix-p) "/bin/sh") - ((os-windows-p) (format nil "CMD /C ~A" command)) ; BEWARE! + ((os-windows-p) (strcat "CMD /C " command)) ; BEWARE! (t (error "Unsupported OS"))) (if (os-unix-p) (list "-c" command) '()) :input nil :output *verbose-out* :wait t))) @@ -2978,6 +2955,9 @@ (list "-c" command) :input nil :output *verbose-out*)) + #+cormanlisp + (win32:system command) + #+ecl ;; courtesy of Juan Jose Garcia Ripoll (ext:system command) @@ -3168,20 +3148,23 @@ (defun* user-configuration-directories () (let ((dirs - `(,(try-subpathname (getenv "XDG_CONFIG_HOME") "common-lisp/") - ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS") - :for dir :in (split-string dirs :separator ":") - :collect (try-subpathname dir "common-lisp/")) + `(,@(when (os-unix-p) + (cons + (subpathname* (getenv "XDG_CONFIG_HOME") "common-lisp/") + (loop :with dirs = (getenv "XDG_CONFIG_DIRS") + :for dir :in (split-string dirs :separator ":") + :collect (subpathname* dir "common-lisp/")))) ,@(when (os-windows-p) - `(,(try-subpathname (or #+lispworks (sys:get-folder-path :local-appdata) - (getenv "LOCALAPPDATA")) - "common-lisp/config/") + `(,(subpathname* (or #+lispworks (sys:get-folder-path :local-appdata) + (getenv "LOCALAPPDATA")) + "common-lisp/config/") ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData - ,(try-subpathname (or #+lispworks (sys:get-folder-path :appdata) - (getenv "APPDATA")) - "common-lisp/config/"))) - ,(try-subpathname (user-homedir) ".config/common-lisp/")))) - (remove-duplicates (remove-if #'null dirs) :from-end t :test 'equal))) + ,(subpathname* (or #+lispworks (sys:get-folder-path :appdata) + (getenv "APPDATA")) + "common-lisp/config/"))) + ,(subpathname (user-homedir) ".config/common-lisp/")))) + (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) + :from-end t :test 'equal))) (defun* system-configuration-directories () (cond @@ -3189,19 +3172,23 @@ ((os-windows-p) (aif ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData - (try-subpathname (or #+lispworks (sys:get-folder-path :common-appdata) - (getenv "ALLUSERSAPPDATA") - (subpathname (getenv "ALLUSERSPROFILE") "Application Data/")) - "common-lisp/config/") + (subpathname* (or #+lispworks (sys:get-folder-path :common-appdata) + (getenv "ALLUSERSAPPDATA") + (subpathname* (getenv "ALLUSERSPROFILE") "Application Data/")) + "common-lisp/config/") (list it))))) -(defun* in-first-directory (dirs x) - (loop :for dir :in dirs - :thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir)))))) -(defun* in-user-configuration-directory (x) - (in-first-directory (user-configuration-directories) x)) -(defun* in-system-configuration-directory (x) - (in-first-directory (system-configuration-directories) x)) +(defun* in-first-directory (dirs x &key (direction :input)) + (loop :with fun = (ecase direction + ((nil :input :probe) 'probe-file*) + ((:output :io) 'identity)) + :for dir :in dirs + :thereis (and dir (funcall fun (merge-pathnames* x (ensure-directory-pathname dir)))))) + +(defun* in-user-configuration-directory (x &key (direction :input)) + (in-first-directory (user-configuration-directories) x :direction direction)) +(defun* in-system-configuration-directory (x &key (direction :input)) + (in-first-directory (system-configuration-directories) x :direction direction)) (defun* configuration-inheritance-directive-p (x) (let ((kw '(:inherit-configuration :ignore-inherited-configuration))) @@ -3555,14 +3542,14 @@ (defparameter *output-translations-file* (coerce-pathname "asdf-output-translations.conf")) (defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/")) -(defun* user-output-translations-pathname () - (in-user-configuration-directory *output-translations-file*)) -(defun* system-output-translations-pathname () - (in-system-configuration-directory *output-translations-file*)) -(defun* user-output-translations-directory-pathname () - (in-user-configuration-directory *output-translations-directory*)) -(defun* system-output-translations-directory-pathname () - (in-system-configuration-directory *output-translations-directory*)) +(defun* user-output-translations-pathname (&key (direction :input)) + (in-user-configuration-directory *output-translations-file* :direction direction)) +(defun* system-output-translations-pathname (&key (direction :input)) + (in-system-configuration-directory *output-translations-file* :direction direction)) +(defun* user-output-translations-directory-pathname (&key (direction :input)) + (in-user-configuration-directory *output-translations-directory* :direction direction)) +(defun* system-output-translations-directory-pathname (&key (direction :input)) + (in-system-configuration-directory *output-translations-directory* :direction direction)) (defun* environment-output-translations () (getenv "ASDF_OUTPUT_TRANSLATIONS")) @@ -3685,8 +3672,8 @@ (translate-pathname path absolute-source destination)))) (defun* apply-output-translations (path) + #+cormanlisp (truenamize path) #-cormanlisp (etypecase path - #+cormanlisp (t (truenamize path)) (logical-pathname path) ((or pathname string) @@ -3727,7 +3714,7 @@ (defun* tmpize-pathname (x) (make-pathname - :name (format nil "ASDF-TMP-~A" (pathname-name x)) + :name (strcat "ASDF-TMP-" (pathname-name x)) :defaults x)) (defun* delete-file-if-exists (x) @@ -3858,6 +3845,7 @@ (loop :for f :in entries :for p = (or (and (typep f 'logical-pathname) f) (let* ((u (ignore-errors (funcall merger f)))) + ;; The first u avoids a cumbersome (truename u) error (and u (equal (ignore-errors (truename u)) f) u))) :when p :collect p) entries)) @@ -3871,8 +3859,9 @@ (filter-logical-directory-results directory entries #'(lambda (f) - (make-pathname :defaults directory :version (pathname-version f) - :name (pathname-name f) :type (pathname-type f)))))) + (make-pathname :defaults directory + :name (pathname-name f) :type (ununspecific (pathname-type f)) + :version (ununspecific (pathname-version f))))))) (defun* directory-asd-files (directory) (directory-files directory *wild-asd*)) @@ -3881,9 +3870,9 @@ (let* ((directory (ensure-directory-pathname directory)) #-(or abcl cormanlisp genera xcl) (wild (merge-pathnames* - #-(or abcl allegro cmu lispworks scl xcl) + #-(or abcl allegro cmu lispworks sbcl scl xcl) *wild-directory* - #+(or abcl allegro cmu lispworks scl xcl) "*.*" + #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*" directory)) (dirs #-(or abcl cormanlisp genera xcl) @@ -3893,16 +3882,16 @@ #+(or abcl xcl) (system:list-directory directory) #+cormanlisp (cl::directory-subdirs directory) #+genera (fs:directory-list directory)) - #+(or abcl allegro cmu genera lispworks scl xcl) + #+(or abcl allegro cmu genera lispworks sbcl scl xcl) (dirs (loop :for x :in dirs :for d = #+(or abcl xcl) (extensions:probe-directory x) #+allegro (excl:probe-directory x) - #+(or cmu scl) (directory-pathname-p x) + #+(or cmu sbcl scl) (directory-pathname-p x) #+genera (getf (cdr x) :directory) #+lispworks (lw:file-directory-p x) :when d :collect #+(or abcl allegro xcl) d #+genera (ensure-directory-pathname (first x)) - #+(or cmu lispworks scl) x))) + #+(or cmu lispworks sbcl scl) x))) (filter-logical-directory-results directory dirs (let ((prefix (normalize-pathname-directory-component @@ -4027,12 +4016,12 @@ #+scl (:tree #p"file://modules/"))) (defun* default-source-registry () `(:source-registry - #+sbcl (:directory ,(try-subpathname (user-homedir) ".sbcl/systems/")) + #+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/")) (:directory ,(default-directory)) ,@(loop :for dir :in `(,@(when (os-unix-p) `(,(or (getenv "XDG_DATA_HOME") - (try-subpathname (user-homedir) ".local/share/")) + (subpathname (user-homedir) ".local/share/")) ,@(split-string (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share") :separator ":"))) @@ -4043,18 +4032,18 @@ (getenv "APPDATA")) ,(or #+lispworks (sys:get-folder-path :common-appdata) (getenv "ALLUSERSAPPDATA") - (try-subpathname (getenv "ALLUSERSPROFILE") "Application Data/"))))) - :collect `(:directory ,(try-subpathname dir "common-lisp/systems/")) - :collect `(:tree ,(try-subpathname dir "common-lisp/source/"))) + (subpathname* (getenv "ALLUSERSPROFILE") "Application Data/"))))) + :collect `(:directory ,(subpathname* dir "common-lisp/systems/")) + :collect `(:tree ,(subpathname* dir "common-lisp/source/"))) :inherit-configuration)) -(defun* user-source-registry () - (in-user-configuration-directory *source-registry-file*)) -(defun* system-source-registry () - (in-system-configuration-directory *source-registry-file*)) -(defun* user-source-registry-directory () - (in-user-configuration-directory *source-registry-directory*)) -(defun* system-source-registry-directory () - (in-system-configuration-directory *source-registry-directory*)) +(defun* user-source-registry (&key (direction :input)) + (in-user-configuration-directory *source-registry-file* :direction direction)) +(defun* system-source-registry (&key (direction :input)) + (in-system-configuration-directory *source-registry-file* :direction direction)) +(defun* user-source-registry-directory (&key (direction :input)) + (in-user-configuration-directory *source-registry-directory* :direction direction)) +(defun* system-source-registry-directory (&key (direction :input)) + (in-system-configuration-directory *source-registry-directory* :direction direction)) (defun* environment-source-registry () (getenv "CL_SOURCE_REGISTRY")) @@ -4132,8 +4121,7 @@ (collect (list directory :recurse recurse :exclude exclude))))) :test 'equal :from-end t))) -;; Will read the configuration and initialize all internal variables, -;; and return the new configuration. +;; Will read the configuration and initialize all internal variables. (defun* compute-source-registry (&optional parameter (registry *source-registry*)) (dolist (entry (flatten-source-registry parameter)) (destructuring-bind (directory &key recurse exclude) entry From mevenson at common-lisp.net Sun Dec 18 16:03:24 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sun, 18 Dec 2011 08:03:24 -0800 Subject: [armedbear-cvs] r13703 - in trunk/abcl: src/org/armedbear/lisp tools Message-ID: Author: mevenson Date: Sun Dec 18 08:03:22 2011 New Revision: 13703 Log: Fix #183: move threads-jss.lisp out of system source. 'threads-jss.lisp' provides a rudimentary implementation of a server framework using the java.util.concurrent abstractions. Ripped out of another project, the code uses the JSS syntax for brevity making it more or less impossible to actually compile as system source as it depends on the JSS contrib. We move it to the tools directory until we can rewrite the use of primitives to use the lower-level Java FFI. Added: trunk/abcl/tools/threads-jss.lisp - copied, changed from r13702, trunk/abcl/src/org/armedbear/lisp/threads-jss.lisp Deleted: trunk/abcl/src/org/armedbear/lisp/threads-jss.lisp Copied and modified: trunk/abcl/tools/threads-jss.lisp (from r13702, trunk/abcl/src/org/armedbear/lisp/threads-jss.lisp) ============================================================================== From mevenson at common-lisp.net Sun Dec 18 21:08:15 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sun, 18 Dec 2011 13:08:15 -0800 Subject: [armedbear-cvs] r13704 - in trunk/abcl: src/org/armedbear/lisp test/lisp/abcl Message-ID: Author: mevenson Date: Sun Dec 18 13:08:13 2011 New Revision: 13704 Log: Fix #181: TRUENAME doesn't always canonicalize the outer DEVICE component of JAR-PATHNAME. If *DEFAULT-PATHNAME-DEFAULTS* is a JAR-PATHNAME, then TRUENAME will not attempt to canonicalize the outer DEVICE component of a JAR-PATHNAME. Remove corresponding kludge from ASDF. Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java trunk/abcl/src/org/armedbear/lisp/asdf.lisp trunk/abcl/test/lisp/abcl/jar-pathname.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java Sun Dec 18 08:03:22 2011 (r13703) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Sun Dec 18 13:08:13 2011 (r13704) @@ -2179,9 +2179,18 @@ // Possibly canonicalize jar file directory Cons jars = (Cons) pathname.device; LispObject o = jars.car(); - if (o instanceof Pathname && ! (((Pathname)o).isURL())) { + if (o instanceof Pathname + && !(((Pathname)o).isURL()) + // XXX Silently fail to call truename() if the default + // pathname defaults exist within a jar, as that will + // (probably) not succeed. The better solution would + // probably be to parametize the value of + // *DEFAULT-PATHNAME-DEFAULTS* on invocations of + // truename(). + && !coerceToPathname(Symbol.DEFAULT_PATHNAME_DEFAULTS.symbolValue()).isJar()) + { LispObject truename = Pathname.truename((Pathname)o, errorIfDoesNotExist); - if (truename != null + if (truename != null && truename != NIL && truename instanceof Pathname) { Pathname truePathname = (Pathname)truename; // A jar that is a directory makes no sense, so exit Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/asdf.lisp Sun Dec 18 08:03:22 2011 (r13703) +++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Sun Dec 18 13:08:13 2011 (r13704) @@ -1650,11 +1650,6 @@ (let ((*package* package) (*default-pathname-defaults* (pathname-directory-pathname pathname))) - ;;; XXX Kludge for ABCL ticket #181 - #+abcl - (when (ext:pathname-jar-p pathname) - (setf *default-pathname-defaults* - (make-pathname :device nil :defaults *default-pathname-defaults*))) (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%") pathname package) (load pathname))) Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/jar-pathname.lisp Sun Dec 18 08:03:22 2011 (r13703) +++ trunk/abcl/test/lisp/abcl/jar-pathname.lisp Sun Dec 18 13:08:13 2011 (r13704) @@ -484,11 +484,15 @@ ;;; ticket #181 ;;; TODO Make reasons for failure more clear (deftest jar-pathname.truename.1 - (let* ((abcl (slot-value (asdf:find-system 'abcl) 'asdf::absolute-pathname)) - (jar (pathname (format nil "jar:file:~A/dist/abcl-contrib.jar!/jss/jss.asd" (namestring abcl)))) - (jar-dir (make-pathname :defaults jar :name nil :type nil)) - (defaults *default-pathname-defaults*)) - (let ((*default-pathname-defaults* jar-dir)) - (not (probe-file (merge-pathnames jar))))) + (let* ((abcl + (slot-value (asdf:find-system 'abcl) 'asdf::absolute-pathname)) + (jar-entry + (pathname (format nil "jar:file:~A/dist/abcl-contrib.jar!/jss/jss.asd" (namestring abcl)))) + (jar-entry-dir + (make-pathname :defaults jar-entry :name nil :type nil)) + (defaults + *default-pathname-defaults*)) + (let ((*default-pathname-defaults* jar-entry-dir)) + (not (probe-file (merge-pathnames jar-entry))))) nil) \ No newline at end of file From ehuelsmann at common-lisp.net Tue Dec 20 21:48:23 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 20 Dec 2011 13:48:23 -0800 Subject: [armedbear-cvs] r13705 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Dec 20 13:48:22 2011 New Revision: 13705 Log: Create two utility functions allowing more efficient symbol lookup in the reader (see my next commit). Modified: trunk/abcl/src/org/armedbear/lisp/Package.java Modified: trunk/abcl/src/org/armedbear/lisp/Package.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Package.java Sun Dec 18 13:08:13 2011 (r13704) +++ trunk/abcl/src/org/armedbear/lisp/Package.java Tue Dec 20 13:48:22 2011 (r13705) @@ -209,11 +209,21 @@ return internalSymbols.get(name.toString()); } + public Symbol findInternalSymbol(String name) + { + return internalSymbols.get(name); + } + public Symbol findExternalSymbol(SimpleString name) { return externalSymbols.get(name.toString()); } + public Symbol findExternalSymbol(String name) + { + return externalSymbols.get(name); + } + public Symbol findExternalSymbol(SimpleString name, int hash) { return externalSymbols.get(name.toString()); From ehuelsmann at common-lisp.net Tue Dec 20 21:52:14 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 20 Dec 2011 13:52:14 -0800 Subject: [armedbear-cvs] r13706 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Dec 20 13:52:14 2011 New Revision: 13706 Log: Refactor Stream.readToken() to fix an issue reported by Blake McBride where ABCL treats the symbol and package specifier as one - which is incorrect. Also improve symbol lookup in case of internal and external symbols by not creating SimpleStrings for the symbol name before looking up. Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Stream.java Tue Dec 20 13:48:22 2011 (r13705) +++ trunk/abcl/src/org/armedbear/lisp/Stream.java Tue Dec 20 13:52:14 2011 (r13706) @@ -1030,11 +1030,8 @@ if (Symbol.READ_SUPPRESS.symbolValue(thread) != NIL) return NIL; final LispObject readtableCase = rt.getReadtableCase(); - final String token; - if (readtableCase == Keyword.INVERT) - token = invert(sb.toString(), flags); - else - token = sb.toString(); + final String token = sb.toString(); + final boolean invert = readtableCase == Keyword.INVERT; final int length = token.length(); if (length > 0) { final char firstChar = token.charAt(0); @@ -1073,33 +1070,62 @@ return number; } } - if (firstChar == ':') - if (flags == null || !flags.get(0)) - return PACKAGE_KEYWORD.intern(token.substring(1)); - int index = findUnescapedDoubleColon(token, flags); - if (index > 0) { - String packageName = token.substring(0, index); - String symbolName = token.substring(index + 2); - Package pkg = Packages.findPackage(packageName); - if (pkg == null) - return error(new LispError("Package \"" + packageName + - "\" not found.")); - return pkg.intern(symbolName); + + String symbolName; + String packageName = null; + BitSet symbolFlags; + BitSet packageFlags = null; + Package pkg = null; + boolean internSymbol = true; + if (firstChar == ':' && (flags == null || !flags.get(0))) { + symbolName = token.substring(1); + pkg = PACKAGE_KEYWORD; + if (flags != null) + symbolFlags = flags.get(1, flags.size()); + else + symbolFlags = null; + } else { + int index = findUnescapedDoubleColon(token, flags); + if (index > 0) { + packageName = token.substring(0, index); + packageFlags = (flags != null) ? flags.get(0, index) : null; + symbolName = token.substring(index + 2); + symbolFlags = (flags != null) ? flags.get(index+2, flags.size()) : null; + } else { + index = findUnescapedSingleColon(token, flags); + if (index > 0) { + packageName = token.substring(0, index); + packageFlags = (flags != null) ? flags.get(0, index) : null; + symbolName = token.substring(index + 1); + symbolFlags = (flags != null) ? flags.get(index+2, flags.size()) : null; + internSymbol = false; + } else { + pkg = (Package)Symbol._PACKAGE_.symbolValue(thread); + symbolName = token; + symbolFlags = flags; + } + } } - index = findUnescapedSingleColon(token, flags); - if (index > 0) { - final String packageName = token.substring(0, index); - Package pkg = Packages.findPackage(packageName); + if (pkg == null) { + if (invert) + packageName = invert(packageName, packageFlags); + + pkg = Packages.findPackage(packageName); if (pkg == null) - return error(new PackageError("Package \"" + packageName + - "\" not found.")); - final String symbolName = token.substring(index + 1); - final SimpleString s = new SimpleString(symbolName); - Symbol symbol = pkg.findExternalSymbol(s); + return error(new ReaderError("The package \"" + packageName + "\" can't be found.", this)); + } + if (invert) + symbolName = invert(symbolName, symbolFlags); + + if (internSymbol) { + return pkg.intern(symbolName); + } else { + Symbol symbol = pkg.findExternalSymbol(symbolName); if (symbol != null) return symbol; + // Error! - if (pkg.findInternalSymbol(s) != null) + if (pkg.findInternalSymbol(symbolName) != null) return error(new ReaderError("The symbol \"" + symbolName + "\" is not external in package " + packageName + '.', @@ -1111,8 +1137,7 @@ this)); } } - // Intern token in current package. - return ((Package)Symbol._PACKAGE_.symbolValue(thread)).intern(new SimpleString(token)); + return error(new ReaderError("Can't intern zero-length symbol.", this)); } private final BitSet _readToken(StringBuilder sb, Readtable rt) From ehuelsmann at common-lisp.net Tue Dec 20 22:00:27 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 20 Dec 2011 14:00:27 -0800 Subject: [armedbear-cvs] r13707 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Dec 20 14:00:26 2011 New Revision: 13707 Log: Fix #182: ADJUST-ARRAY failure. Modified: trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte8.java Modified: trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte8.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte8.java Tue Dec 20 13:52:14 2011 (r13706) +++ trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte8.java Tue Dec 20 14:00:26 2011 (r13707) @@ -287,12 +287,13 @@ } if (capacity != newCapacity) { - LispObject[] newElements = new LispObject[newCapacity]; + byte[] newElements = new byte[newCapacity]; System.arraycopy(elements, 0, newElements, 0, Math.min(capacity, newCapacity)); + byte initValue = (byte)(initialElement.intValue() & 0xFF); if (initialElement != null) for (int i = capacity; i < newCapacity; i++) - newElements[i] = initialElement; + newElements[i] = initValue; return new BasicVector_UnsignedByte8(newElements); } // No change. From ehuelsmann at common-lisp.net Tue Dec 20 22:04:34 2011 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 20 Dec 2011 14:04:34 -0800 Subject: [armedbear-cvs] r13708 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Dec 20 14:04:33 2011 New Revision: 13708 Log: Follow-up to last commit: Fix #182. Modified: trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte8.java Modified: trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte8.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte8.java Tue Dec 20 14:00:26 2011 (r13707) +++ trunk/abcl/src/org/armedbear/lisp/BasicVector_UnsignedByte8.java Tue Dec 20 14:04:33 2011 (r13708) @@ -290,10 +290,11 @@ byte[] newElements = new byte[newCapacity]; System.arraycopy(elements, 0, newElements, 0, Math.min(capacity, newCapacity)); - byte initValue = (byte)(initialElement.intValue() & 0xFF); - if (initialElement != null) + if (initialElement != null) { + byte initValue = (byte)(initialElement.intValue() & 0xFF); for (int i = capacity; i < newCapacity; i++) newElements[i] = initValue; + } return new BasicVector_UnsignedByte8(newElements); } // No change. From mevenson at common-lisp.net Thu Dec 22 11:37:34 2011 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 22 Dec 2011 03:37:34 -0800 Subject: [armedbear-cvs] r13709 - trunk/abcl Message-ID: Author: mevenson Date: Thu Dec 22 03:37:34 2011 New Revision: 13709 Log: Spellcheck README Modified: trunk/abcl/README Modified: trunk/abcl/README ============================================================================== --- trunk/abcl/README Tue Dec 20 14:04:33 2011 (r13708) +++ trunk/abcl/README Thu Dec 22 03:37:34 2011 (r13709) @@ -64,7 +64,7 @@ * Use the Ant build tool for Java environments. -* Use the Netbeans 6.x IDE to open ABCL as a project. +* Use the NetBeans 6.x IDE to open ABCL as a project. * Bootstrap ABCL using a Common Lisp implementation. Supported implementations for this process: SBCL, CMUCL, OpenMCL, Allegro @@ -104,7 +104,7 @@ Using NetBeans -------------- -Obtain and install the [Netbeans IDE][2]. One should be able to open +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. @@ -126,7 +126,7 @@ 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 +value of '*JDK*' there should be an executable Java compiler in 'bin/javac' ('bin/java.exe' under Windows). Then, one may either use the 'build-from-lisp.sh' shell script or load @@ -175,19 +175,19 @@ ABCL is a conforming ANSI Common Lisp implementation. Any other behavior should be reported as a bug. -ABCL now has a manual stating its confomance to the ANSI standard, -providing a compliant and practicalCommon Lisp implementation. +ABCL now has a manual stating its conformance to the ANSI standard, +providing a compliant and practical Common Lisp implementation. Because of this, ### Tests -ABCL 0.28.0 now fails only 18 out of 21708 total tests in the ANSI CL -test suite (derived from the tests orginally written for GCL). +ABCL 1.0.0 now fails only 18 out of 21708 total tests in the ANSI CL +test suite (derived from the tests originally written for GCL). Maxima's test suite runs without failures. -### Deficencies +### Deficiencies The MOP implementation is incomplete. From astalla at common-lisp.net Tue Dec 27 19:50:09 2011 From: astalla at common-lisp.net (astalla at common-lisp.net) Date: Tue, 27 Dec 2011 11:50:09 -0800 Subject: [armedbear-cvs] r13710 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Tue Dec 27 11:50:08 2011 New Revision: 13710 Log: First stab at restoring runtime-class. Supported: extending a Java class, implementing interfaces, defining methods of up to 7 non-primitive arguments returning void or a non-primitive object. Unsupported: everything else, including fields, constructors, annotations, primitive arguments and return values, and the LispObject[] call convention for functions with more than 8 arguments. Modified: trunk/abcl/src/org/armedbear/lisp/MemoryClassLoader.java trunk/abcl/src/org/armedbear/lisp/autoloads.lisp trunk/abcl/src/org/armedbear/lisp/compile-system.lisp trunk/abcl/src/org/armedbear/lisp/java.lisp trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Modified: trunk/abcl/src/org/armedbear/lisp/MemoryClassLoader.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/MemoryClassLoader.java Thu Dec 22 03:37:34 2011 (r13709) +++ trunk/abcl/src/org/armedbear/lisp/MemoryClassLoader.java Tue Dec 27 11:50:08 2011 (r13710) @@ -42,8 +42,14 @@ private final HashMap hashtable = new HashMap(); private final JavaObject boxedThis = new JavaObject(this); + private final String internalNamePrefix; public MemoryClassLoader() { + this("org/armedbear/lisp/"); + } + + public MemoryClassLoader(String internalNamePrefix) { + this.internalNamePrefix = internalNamePrefix; } @Override @@ -59,7 +65,7 @@ * which - in ABCL - is pretty deep, most of the time. */ if (hashtable.containsKey(name)) { - String internalName = "org/armedbear/lisp/" + name; + String internalName = internalNamePrefix + name; Class c = this.findLoadedClass(internalName); if (c == null) { Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Thu Dec 22 03:37:34 2011 (r13709) +++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Tue Dec 27 11:50:08 2011 (r13710) @@ -278,10 +278,6 @@ (autoload 'jmember-protected-p "java") (export 'jnew-runtime-class "JAVA") (autoload 'jnew-runtime-class "runtime-class") -(export 'jredefine-method "JAVA") -(autoload 'jredefine-method "runtime-class") -(export 'jruntime-class-exists-p "JAVA") -(autoload 'jruntime-class-exists-p "runtime-class") (export 'ensure-java-class "JAVA") (autoload 'ensure-java-class "java") (export 'chain "JAVA") Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Thu Dec 22 03:37:34 2011 (r13709) +++ trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Tue Dec 27 11:50:08 2011 (r13710) @@ -243,7 +243,7 @@ ;;"run-benchmarks.lisp" "run-program.lisp" "run-shell-command.lisp" - ;;"runtime-class.lisp" + "runtime-class.lisp" "search.lisp" "sequences.lisp" "sets.lisp" Modified: trunk/abcl/src/org/armedbear/lisp/java.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/java.lisp Thu Dec 22 03:37:34 2011 (r13709) +++ trunk/abcl/src/org/armedbear/lisp/java.lisp Tue Dec 27 11:50:08 2011 (r13710) @@ -288,7 +288,7 @@ (declare (ignore unused-value)) (if instance-supplied-p (jfield class-ref-or-field field-or-instance instance newvalue) - (jfield class-ref-or-field field-or-instance newvalue))) + (jfield class-ref-or-field field-or-instance nil newvalue))) (defun jclass-methods (class &key declared public) "Return a vector of all (or just the declared/public, if DECLARED/PUBLIC is true) methods of CLASS" Modified: trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Thu Dec 22 03:37:34 2011 (r13709) +++ trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Tue Dec 27 11:50:08 2011 (r13710) @@ -233,6 +233,7 @@ (define-opcode lreturn 173 1 nil nil) (define-opcode freturn 174 1 nil nil) (define-opcode dreturn 175 1 nil nil) +(define-opcode ireturn 172 1 -1 nil) (define-opcode areturn 176 1 -1 nil) (define-opcode return 177 1 0 nil) (define-opcode getstatic 178 3 1 nil) @@ -568,6 +569,7 @@ 165 ; if_acmpeq 166 ; if_acmpne 167 ; goto + 172 ; ireturn 176 ; areturn 177 ; return 178 ; getstatic @@ -721,7 +723,9 @@ (internal-compiler-error "Stack inconsistency detected ~ in ~A at index ~D: ~ found ~S, expected ~S." - (compiland-name *current-compiland*) + (if *current-compiland* + (compiland-name *current-compiland*) + "") i instruction-depth (+ depth instruction-stack))) (return-from analyze-stack-path)) @@ -732,7 +736,9 @@ (internal-compiler-error "Stack inconsistency detected ~ in ~A at index ~D: ~ negative depth ~S." - (compiland-name *current-compiland*) + (if *current-compiland* + (compiland-name *current-compiland*) + "") i depth)) (when (branch-p opcode) (let ((label (car (instruction-args instruction)))) Modified: trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Thu Dec 22 03:37:34 2011 (r13709) +++ trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Tue Dec 27 11:50:08 2011 (r13710) @@ -1,559 +1,12 @@ -;;; runtime-class.lisp -;;; -;;; Copyright (C) 2004 Peter Graves -;;; $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. +(require "COMPILER-PASS2") -(in-package :java) +(in-package :jvm) -(require :format) +(defconstant +abcl-java-object+ (make-jvm-class-name "org.armedbear.lisp.JavaObject")) -;; jparse generated definitions, somewhat simplified - -(defclass java-class nil ((java-instance :initarg :java-instance :reader java-instance))) -(defclass jboolean (java-class) nil) -(defmethod initialize-instance :after ((b jboolean) &key &allow-other-keys) - (setf (slot-value b 'java-instance) (make-immediate-object (java-instance b) :boolean))) -(defclass jarray (java-class) nil) -(defclass |java.lang.Object| (java-class) nil) -(defclass output-stream (java-class) nil) -(defclass file-output-stream (output-stream java-class) nil) -(defclass class-visitor (java-class) nil) -(defclass class-writer (class-visitor java-class) nil) -(defclass code-visitor (java-class) nil) -(defclass code-writer (code-visitor java-class) nil) -(defclass attribute (java-class) nil) -(defclass constants (java-class) nil) -(defclass label (java-class) nil) -(defmethod make-file-output-stream-1 ((v1 string)) - (make-instance 'file-output-stream :java-instance - (jnew (jconstructor "java.io.FileOutputStream" "java.lang.String") v1))) -(defmethod write-1 ((instance file-output-stream) (v1 jarray)) - (jcall (jmethod "java.io.FileOutputStream" "write" "[B") (java-instance instance) (java-instance v1))) -(defmethod close-0 ((instance file-output-stream)) - (jcall (jmethod "java.io.FileOutputStream" "close") (java-instance instance))) -(defmethod make-class-writer-1 ((v1 jboolean)) - (make-instance 'class-writer :java-instance - (jnew (jconstructor "org.objectweb.asm.ClassWriter" "boolean") (java-instance v1)))) -(defmethod visit-end-0 ((instance class-writer)) - (jcall (jmethod "org.objectweb.asm.ClassWriter" "visitEnd") (java-instance instance))) -(defmethod to-byte-array-0 ((instance class-writer)) - (make-instance 'jarray :java-instance - (jcall (jmethod "org.objectweb.asm.ClassWriter" "toByteArray") (java-instance instance)))) -(defmethod visit-insn-1 ((instance code-visitor) (v1 fixnum)) - (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitInsn" "int") (java-instance instance) v1)) -(defmethod visit-int-insn-2 ((instance code-visitor) (v1 fixnum) (v2 fixnum)) - (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitIntInsn" "int" "int") (java-instance instance) v1 - v2)) -(defmethod visit-var-insn-2 ((instance code-visitor) (v1 fixnum) (v2 fixnum)) - (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitVarInsn" "int" "int") (java-instance instance) v1 - v2)) -(defmethod visit-type-insn-2 ((instance code-visitor) (v1 fixnum) (v2 string)) - (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitTypeInsn" "int" "java.lang.String") - (java-instance instance) v1 v2)) -(defmethod visit-field-insn-4 ((instance code-visitor) (v1 fixnum) (v2 string) (v3 string) (v4 string)) - (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitFieldInsn" "int" "java.lang.String" - "java.lang.String" "java.lang.String") - (java-instance instance) v1 v2 v3 v4)) -(defmethod visit-method-insn-4 ((instance code-visitor) (v1 fixnum) (v2 string) (v3 string) (v4 string)) - (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitMethodInsn" "int" "java.lang.String" - "java.lang.String" "java.lang.String") - (java-instance instance) v1 v2 v3 v4)) -(defmethod visit-jump-insn-2 ((instance code-visitor) (v1 fixnum) (v2 label)) - (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitJumpInsn" "int" "org.objectweb.asm.Label") - (java-instance instance) v1 (java-instance v2))) -(defmethod visit-label-1 ((instance code-visitor) (v1 label)) - (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitLabel" "org.objectweb.asm.Label") - (java-instance instance) (java-instance v1))) -(defmethod visit-ldc-insn-1 ((instance code-visitor) (v1 |java.lang.Object|)) - (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitLdcInsn" "java.lang.Object") - (java-instance instance) (java-instance v1))) -(defmethod visit-try-catch-block-4 ((instance code-visitor) (v1 label) (v2 label) (v3 label) (v4 string)) - (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitTryCatchBlock" "org.objectweb.asm.Label" - "org.objectweb.asm.Label" "org.objectweb.asm.Label" "java.lang.String") - (java-instance instance) (java-instance v1) (java-instance v2) (java-instance v3) v4)) -(defmethod visit-maxs-2 ((instance code-visitor) (v1 fixnum) (v2 fixnum)) - (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitMaxs" "int" "int") (java-instance instance) v1 v2)) -(defconstant constants.ifnonnull (jfield "org.objectweb.asm.Constants" "IFNONNULL")) -(defconstant constants.ifnull (jfield "org.objectweb.asm.Constants" "IFNULL")) -(defconstant constants.multianewarray (jfield "org.objectweb.asm.Constants" "MULTIANEWARRAY")) -(defconstant constants.monitorexit (jfield "org.objectweb.asm.Constants" "MONITOREXIT")) -(defconstant constants.monitorenter (jfield "org.objectweb.asm.Constants" "MONITORENTER")) -(defconstant constants.instanceof (jfield "org.objectweb.asm.Constants" "INSTANCEOF")) -(defconstant constants.checkcast (jfield "org.objectweb.asm.Constants" "CHECKCAST")) -(defconstant constants.athrow (jfield "org.objectweb.asm.Constants" "ATHROW")) -(defconstant constants.arraylength (jfield "org.objectweb.asm.Constants" "ARRAYLENGTH")) -(defconstant constants.anewarray (jfield "org.objectweb.asm.Constants" "ANEWARRAY")) -(defconstant constants.newarray (jfield "org.objectweb.asm.Constants" "NEWARRAY")) -(defconstant constants.new (jfield "org.objectweb.asm.Constants" "NEW")) -(defconstant constants.invokeinterface (jfield "org.objectweb.asm.Constants" "INVOKEINTERFACE")) -(defconstant constants.invokestatic (jfield "org.objectweb.asm.Constants" "INVOKESTATIC")) -(defconstant constants.invokespecial (jfield "org.objectweb.asm.Constants" "INVOKESPECIAL")) -(defconstant constants.invokevirtual (jfield "org.objectweb.asm.Constants" "INVOKEVIRTUAL")) -(defconstant constants.putfield (jfield "org.objectweb.asm.Constants" "PUTFIELD")) -(defconstant constants.getfield (jfield "org.objectweb.asm.Constants" "GETFIELD")) -(defconstant constants.putstatic (jfield "org.objectweb.asm.Constants" "PUTSTATIC")) -(defconstant constants.getstatic (jfield "org.objectweb.asm.Constants" "GETSTATIC")) -(defconstant constants.return (jfield "org.objectweb.asm.Constants" "RETURN")) -(defconstant constants.areturn (jfield "org.objectweb.asm.Constants" "ARETURN")) -(defconstant constants.dreturn (jfield "org.objectweb.asm.Constants" "DRETURN")) -(defconstant constants.freturn (jfield "org.objectweb.asm.Constants" "FRETURN")) -(defconstant constants.lreturn (jfield "org.objectweb.asm.Constants" "LRETURN")) -(defconstant constants.ireturn (jfield "org.objectweb.asm.Constants" "IRETURN")) -(defconstant constants.lookupswitch (jfield "org.objectweb.asm.Constants" "LOOKUPSWITCH")) -(defconstant constants.tableswitch (jfield "org.objectweb.asm.Constants" "TABLESWITCH")) -(defconstant constants.ret (jfield "org.objectweb.asm.Constants" "RET")) -(defconstant constants.jsr (jfield "org.objectweb.asm.Constants" "JSR")) -(defconstant constants.goto (jfield "org.objectweb.asm.Constants" "GOTO")) -(defconstant constants.if-acmpne (jfield "org.objectweb.asm.Constants" "IF_ACMPNE")) -(defconstant constants.if-acmpeq (jfield "org.objectweb.asm.Constants" "IF_ACMPEQ")) -(defconstant constants.if-icmple (jfield "org.objectweb.asm.Constants" "IF_ICMPLE")) -(defconstant constants.if-icmpgt (jfield "org.objectweb.asm.Constants" "IF_ICMPGT")) -(defconstant constants.if-icmpge (jfield "org.objectweb.asm.Constants" "IF_ICMPGE")) -(defconstant constants.if-icmplt (jfield "org.objectweb.asm.Constants" "IF_ICMPLT")) -(defconstant constants.if-icmpne (jfield "org.objectweb.asm.Constants" "IF_ICMPNE")) -(defconstant constants.if-icmpeq (jfield "org.objectweb.asm.Constants" "IF_ICMPEQ")) -(defconstant constants.ifle (jfield "org.objectweb.asm.Constants" "IFLE")) -(defconstant constants.ifgt (jfield "org.objectweb.asm.Constants" "IFGT")) -(defconstant constants.ifge (jfield "org.objectweb.asm.Constants" "IFGE")) -(defconstant constants.iflt (jfield "org.objectweb.asm.Constants" "IFLT")) -(defconstant constants.ifne (jfield "org.objectweb.asm.Constants" "IFNE")) -(defconstant constants.ifeq (jfield "org.objectweb.asm.Constants" "IFEQ")) -(defconstant constants.dcmpg (jfield "org.objectweb.asm.Constants" "DCMPG")) -(defconstant constants.dcmpl (jfield "org.objectweb.asm.Constants" "DCMPL")) -(defconstant constants.fcmpg (jfield "org.objectweb.asm.Constants" "FCMPG")) -(defconstant constants.fcmpl (jfield "org.objectweb.asm.Constants" "FCMPL")) -(defconstant constants.lcmp (jfield "org.objectweb.asm.Constants" "LCMP")) -(defconstant constants.i2s (jfield "org.objectweb.asm.Constants" "I2S")) -(defconstant constants.i2c (jfield "org.objectweb.asm.Constants" "I2C")) -(defconstant constants.i2b (jfield "org.objectweb.asm.Constants" "I2B")) -(defconstant constants.d2f (jfield "org.objectweb.asm.Constants" "D2F")) -(defconstant constants.d2l (jfield "org.objectweb.asm.Constants" "D2L")) -(defconstant constants.d2i (jfield "org.objectweb.asm.Constants" "D2I")) -(defconstant constants.f2d (jfield "org.objectweb.asm.Constants" "F2D")) -(defconstant constants.f2l (jfield "org.objectweb.asm.Constants" "F2L")) -(defconstant constants.f2i (jfield "org.objectweb.asm.Constants" "F2I")) -(defconstant constants.l2d (jfield "org.objectweb.asm.Constants" "L2D")) -(defconstant constants.l2f (jfield "org.objectweb.asm.Constants" "L2F")) -(defconstant constants.l2i (jfield "org.objectweb.asm.Constants" "L2I")) -(defconstant constants.i2d (jfield "org.objectweb.asm.Constants" "I2D")) -(defconstant constants.i2f (jfield "org.objectweb.asm.Constants" "I2F")) -(defconstant constants.i2l (jfield "org.objectweb.asm.Constants" "I2L")) -(defconstant constants.iinc (jfield "org.objectweb.asm.Constants" "IINC")) -(defconstant constants.lxor (jfield "org.objectweb.asm.Constants" "LXOR")) -(defconstant constants.ixor (jfield "org.objectweb.asm.Constants" "IXOR")) -(defconstant constants.lor (jfield "org.objectweb.asm.Constants" "LOR")) -(defconstant constants.ior (jfield "org.objectweb.asm.Constants" "IOR")) -(defconstant constants.land (jfield "org.objectweb.asm.Constants" "LAND")) -(defconstant constants.iand (jfield "org.objectweb.asm.Constants" "IAND")) -(defconstant constants.lushr (jfield "org.objectweb.asm.Constants" "LUSHR")) -(defconstant constants.iushr (jfield "org.objectweb.asm.Constants" "IUSHR")) -(defconstant constants.lshr (jfield "org.objectweb.asm.Constants" "LSHR")) -(defconstant constants.ishr (jfield "org.objectweb.asm.Constants" "ISHR")) -(defconstant constants.lshl (jfield "org.objectweb.asm.Constants" "LSHL")) -(defconstant constants.ishl (jfield "org.objectweb.asm.Constants" "ISHL")) -(defconstant constants.dneg (jfield "org.objectweb.asm.Constants" "DNEG")) -(defconstant constants.fneg (jfield "org.objectweb.asm.Constants" "FNEG")) -(defconstant constants.lneg (jfield "org.objectweb.asm.Constants" "LNEG")) -(defconstant constants.ineg (jfield "org.objectweb.asm.Constants" "INEG")) -(defconstant constants.drem (jfield "org.objectweb.asm.Constants" "DREM")) -(defconstant constants.frem (jfield "org.objectweb.asm.Constants" "FREM")) -(defconstant constants.lrem (jfield "org.objectweb.asm.Constants" "LREM")) -(defconstant constants.irem (jfield "org.objectweb.asm.Constants" "IREM")) -(defconstant constants.ddiv (jfield "org.objectweb.asm.Constants" "DDIV")) -(defconstant constants.fdiv (jfield "org.objectweb.asm.Constants" "FDIV")) -(defconstant constants.ldiv (jfield "org.objectweb.asm.Constants" "LDIV")) -(defconstant constants.idiv (jfield "org.objectweb.asm.Constants" "IDIV")) -(defconstant constants.dmul (jfield "org.objectweb.asm.Constants" "DMUL")) -(defconstant constants.fmul (jfield "org.objectweb.asm.Constants" "FMUL")) -(defconstant constants.lmul (jfield "org.objectweb.asm.Constants" "LMUL")) -(defconstant constants.imul (jfield "org.objectweb.asm.Constants" "IMUL")) -(defconstant constants.dsub (jfield "org.objectweb.asm.Constants" "DSUB")) -(defconstant constants.fsub (jfield "org.objectweb.asm.Constants" "FSUB")) -(defconstant constants.lsub (jfield "org.objectweb.asm.Constants" "LSUB")) -(defconstant constants.isub (jfield "org.objectweb.asm.Constants" "ISUB")) -(defconstant constants.dadd (jfield "org.objectweb.asm.Constants" "DADD")) -(defconstant constants.fadd (jfield "org.objectweb.asm.Constants" "FADD")) -(defconstant constants.ladd (jfield "org.objectweb.asm.Constants" "LADD")) -(defconstant constants.iadd (jfield "org.objectweb.asm.Constants" "IADD")) -(defconstant constants.swap (jfield "org.objectweb.asm.Constants" "SWAP")) -(defconstant constants.dup2_x2 (jfield "org.objectweb.asm.Constants" "DUP2_X2")) -(defconstant constants.dup2_x1 (jfield "org.objectweb.asm.Constants" "DUP2_X1")) -(defconstant constants.dup2 (jfield "org.objectweb.asm.Constants" "DUP2")) -(defconstant constants.dup_x2 (jfield "org.objectweb.asm.Constants" "DUP_X2")) -(defconstant constants.dup_x1 (jfield "org.objectweb.asm.Constants" "DUP_X1")) -(defconstant constants.dup (jfield "org.objectweb.asm.Constants" "DUP")) -(defconstant constants.pop2 (jfield "org.objectweb.asm.Constants" "POP2")) -(defconstant constants.pop (jfield "org.objectweb.asm.Constants" "POP")) -(defconstant constants.sastore (jfield "org.objectweb.asm.Constants" "SASTORE")) -(defconstant constants.castore (jfield "org.objectweb.asm.Constants" "CASTORE")) -(defconstant constants.bastore (jfield "org.objectweb.asm.Constants" "BASTORE")) -(defconstant constants.aastore (jfield "org.objectweb.asm.Constants" "AASTORE")) -(defconstant constants.dastore (jfield "org.objectweb.asm.Constants" "DASTORE")) -(defconstant constants.fastore (jfield "org.objectweb.asm.Constants" "FASTORE")) -(defconstant constants.lastore (jfield "org.objectweb.asm.Constants" "LASTORE")) -(defconstant constants.iastore (jfield "org.objectweb.asm.Constants" "IASTORE")) -(defconstant constants.astore (jfield "org.objectweb.asm.Constants" "ASTORE")) -(defconstant constants.dstore (jfield "org.objectweb.asm.Constants" "DSTORE")) -(defconstant constants.fstore (jfield "org.objectweb.asm.Constants" "FSTORE")) -(defconstant constants.lstore (jfield "org.objectweb.asm.Constants" "LSTORE")) -(defconstant constants.istore (jfield "org.objectweb.asm.Constants" "ISTORE")) -(defconstant constants.saload (jfield "org.objectweb.asm.Constants" "SALOAD")) -(defconstant constants.caload (jfield "org.objectweb.asm.Constants" "CALOAD")) -(defconstant constants.baload (jfield "org.objectweb.asm.Constants" "BALOAD")) -(defconstant constants.aaload (jfield "org.objectweb.asm.Constants" "AALOAD")) -(defconstant constants.daload (jfield "org.objectweb.asm.Constants" "DALOAD")) -(defconstant constants.faload (jfield "org.objectweb.asm.Constants" "FALOAD")) -(defconstant constants.laload (jfield "org.objectweb.asm.Constants" "LALOAD")) -(defconstant constants.iaload (jfield "org.objectweb.asm.Constants" "IALOAD")) -(defconstant constants.aload (jfield "org.objectweb.asm.Constants" "ALOAD")) -(defconstant constants.dload (jfield "org.objectweb.asm.Constants" "DLOAD")) -(defconstant constants.fload (jfield "org.objectweb.asm.Constants" "FLOAD")) -(defconstant constants.lload (jfield "org.objectweb.asm.Constants" "LLOAD")) -(defconstant constants.iload (jfield "org.objectweb.asm.Constants" "ILOAD")) -(defconstant constants.ldc (jfield "org.objectweb.asm.Constants" "LDC")) -(defconstant constants.sipush (jfield "org.objectweb.asm.Constants" "SIPUSH")) -(defconstant constants.bipush (jfield "org.objectweb.asm.Constants" "BIPUSH")) -(defconstant constants.dconst_1 (jfield "org.objectweb.asm.Constants" "DCONST_1")) -(defconstant constants.dconst_0 (jfield "org.objectweb.asm.Constants" "DCONST_0")) -(defconstant constants.fconst_2 (jfield "org.objectweb.asm.Constants" "FCONST_2")) -(defconstant constants.fconst_1 (jfield "org.objectweb.asm.Constants" "FCONST_1")) -(defconstant constants.fconst_0 (jfield "org.objectweb.asm.Constants" "FCONST_0")) -(defconstant constants.lconst_1 (jfield "org.objectweb.asm.Constants" "LCONST_1")) -(defconstant constants.lconst_0 (jfield "org.objectweb.asm.Constants" "LCONST_0")) -(defconstant constants.iconst_5 (jfield "org.objectweb.asm.Constants" "ICONST_5")) -(defconstant constants.iconst_4 (jfield "org.objectweb.asm.Constants" "ICONST_4")) -(defconstant constants.iconst_3 (jfield "org.objectweb.asm.Constants" "ICONST_3")) -(defconstant constants.iconst_2 (jfield "org.objectweb.asm.Constants" "ICONST_2")) -(defconstant constants.iconst_1 (jfield "org.objectweb.asm.Constants" "ICONST_1")) -(defconstant constants.iconst_0 (jfield "org.objectweb.asm.Constants" "ICONST_0")) -(defconstant constants.iconst_m1 (jfield "org.objectweb.asm.Constants" "ICONST_M1")) -(defconstant constants.aconst-null (jfield "org.objectweb.asm.Constants" "ACONST_NULL")) -(defconstant constants.nop (jfield "org.objectweb.asm.Constants" "NOP")) -(defconstant constants.t-long (jfield "org.objectweb.asm.Constants" "T_LONG")) -(defconstant constants.t-int (jfield "org.objectweb.asm.Constants" "T_INT")) -(defconstant constants.t-short (jfield "org.objectweb.asm.Constants" "T_SHORT")) -(defconstant constants.t-byte (jfield "org.objectweb.asm.Constants" "T_BYTE")) -(defconstant constants.t-double (jfield "org.objectweb.asm.Constants" "T_DOUBLE")) -(defconstant constants.t-float (jfield "org.objectweb.asm.Constants" "T_FLOAT")) -(defconstant constants.t-char (jfield "org.objectweb.asm.Constants" "T_CHAR")) -(defconstant constants.t-boolean (jfield "org.objectweb.asm.Constants" "T_BOOLEAN")) -(defconstant constants.acc-deprecated (jfield "org.objectweb.asm.Constants" "ACC_DEPRECATED")) -(defconstant constants.acc-synthetic (jfield "org.objectweb.asm.Constants" "ACC_SYNTHETIC")) -(defconstant constants.acc-super (jfield "org.objectweb.asm.Constants" "ACC_SUPER")) -(defconstant constants.acc-strict (jfield "org.objectweb.asm.Constants" "ACC_STRICT")) -(defconstant constants.acc-abstract (jfield "org.objectweb.asm.Constants" "ACC_ABSTRACT")) -(defconstant constants.acc-interface (jfield "org.objectweb.asm.Constants" "ACC_INTERFACE")) -(defconstant constants.acc-enum (jfield "org.objectweb.asm.Constants" "ACC_ENUM")) -(defconstant constants.acc-native (jfield "org.objectweb.asm.Constants" "ACC_NATIVE")) -(defconstant constants.acc-transient (jfield "org.objectweb.asm.Constants" "ACC_TRANSIENT")) -(defconstant constants.acc-varargs (jfield "org.objectweb.asm.Constants" "ACC_VARARGS")) -(defconstant constants.acc-bridge (jfield "org.objectweb.asm.Constants" "ACC_BRIDGE")) -(defconstant constants.acc-volatile (jfield "org.objectweb.asm.Constants" "ACC_VOLATILE")) -(defconstant constants.acc-synchronized (jfield "org.objectweb.asm.Constants" "ACC_SYNCHRONIZED")) -(defconstant constants.acc-final (jfield "org.objectweb.asm.Constants" "ACC_FINAL")) -(defconstant constants.acc-static (jfield "org.objectweb.asm.Constants" "ACC_STATIC")) -(defconstant constants.acc-protected (jfield "org.objectweb.asm.Constants" "ACC_PROTECTED")) -(defconstant constants.acc-private (jfield "org.objectweb.asm.Constants" "ACC_PRIVATE")) -(defconstant constants.acc-public (jfield "org.objectweb.asm.Constants" "ACC_PUBLIC")) -(defconstant constants.v1-1 (jfield "org.objectweb.asm.Constants" "V1_1")) -(defmethod make-label-0 nil - (make-instance 'label :java-instance (jnew (jconstructor "org.objectweb.asm.Label")))) - -;;end of jparse generated definitions - - -(defmethod visit-4 ((instance class-writer) (v1 fixnum) (v2 string) (v3 string) v4) - (jcall - (jmethod "org.objectweb.asm.ClassWriter" "visit" "int" "int" "java.lang.String" "java.lang.String" "[Ljava.lang.String;" "java.lang.String") - (java-instance instance) constants.v1-1 v1 v2 v3 v4 nil)) - -(defmethod visit-field-3 ((instance class-writer) (v1 fixnum) (v2 string) (v3 string)) - (jcall - (jmethod "org.objectweb.asm.ClassWriter" "visitField" "int" "java.lang.String" "java.lang.String" "java.lang.Object" "org.objectweb.asm.Attribute") - (java-instance instance) v1 v2 v3 nil nil)) - -(defmethod visit-method-3 ((instance class-writer) (v1 fixnum) (v2 string) (v3 string)) - (make-instance 'code-visitor :java-instance - (jcall - (jmethod "org.objectweb.asm.ClassWriter" "visitMethod" "int" "java.lang.String" "java.lang.String" "[Ljava.lang.String;" "org.objectweb.asm.Attribute") - (java-instance instance) v1 v2 v3 nil nil))) - -(defun make-java-string (string) - (make-instance '|java.lang.Object| - :java-instance (jnew (jconstructor "java.lang.String" "[C") (jnew-array-from-array "char" string)))) - -(defparameter *primitive-types* - (acons - "void" (list "V" (list "" "" "") -1 constants.return -1) - (acons - "byte" - (list "B" (list "org/armedbear/lisp/Fixnum" "java/lang/Byte" "byteValue") - constants.iload constants.ireturn constants.iconst_0) - (acons - "short" - (list "S" (list "org/armedbear/lisp/Fixnum" "java/lang/Short" "shortValue") - constants.iload constants.ireturn constants.iconst_0) - (acons - "int" - (list "I" (list "org/armedbear/lisp/Fixnum" "java/lang/Integer" "intValue") - constants.iload constants.ireturn constants.iconst_0) - (acons - "long" - (list "J" (list "org/armedbear/lisp/Fixnum" "java/lang/Long" "longValue") - constants.lload constants.lreturn constants.lconst_0) - (acons - "float" - (list "F" (list "org/armedbear/lisp/SingleFloat" "java/lang/Float" "floatValue") - constants.fload constants.freturn constants.fconst_0) - (acons - "double" - (list "D" (list "org/armedbear/lisp/DoubleFloat" "java/lang/Double" "doubleValue") - constants.dload constants.dreturn constants.dconst_0) - (acons - "char" - (list "C" (list "org/armedbear/lisp/LispCharacter" "java/lang/Character" "charValue") - constants.iload constants.ireturn constants.iconst_0) - (acons - "boolean" - (list "Z" (list "org/armedbear/lisp/LispObject" "" "") - constants.iload constants.ireturn constants.iconst_0) - nil)))))))))) - -(defun primitive-type-p (type) - (assoc type *primitive-types* :test #'string=)) - -(defun type-name (type) - (let* ((dim (count #\[ type :test #'char=)) - (prefix (make-string dim :initial-element #\[)) - (base-type (string-right-trim "[ ]" type)) - (base-name (assoc base-type *primitive-types* :test #'string=))) - (concatenate 'string prefix - (if base-name (cadr base-name) - (substitute #\/ #\. - (if (zerop dim) base-type (decorate-type-name base-type))))))) - - -(defun decorate-type-name (type) - (if (char= (char type 0) #\[) type - (format nil "L~a;" type))) - -(defun decorated-type-name (type) - (let ((name (type-name type))) - (if (primitive-type-p type) name (decorate-type-name name)))) - -(defun arg-type-for-make-lisp-object (type) - (if (primitive-type-p type) - (decorated-type-name type) - "Ljava/lang/Object;")) - -(defun return-type-for-make-lisp-object (type) - (let ((name (assoc type *primitive-types* :test #'string=))) - (if name (caaddr name) "org/armedbear/lisp/LispObject"))) - -(defun cast-type (type) - (let ((name (assoc type *primitive-types* :test #'string=))) - (if name (cadr (caddr name)) (type-name type)))) - -(defun converter-for-primitive-return-type (type) - (assert (and (primitive-type-p type) - (not (or (string= type "void")(string= type "boolean"))))) - (caddr (caddr (assoc type *primitive-types* :test #'string=)))) - -(defun load-instruction (type) - (let ((name (assoc type *primitive-types* :test #'string=))) - (if name (cadddr name) constants.aload))) - -(defun return-instruction (type) - (let ((name (assoc type *primitive-types* :test #'string=))) - (if name (car (cddddr name)) constants.areturn))) - -(defun error-constant (type) - (let ((name (assoc type *primitive-types* :test #'string=))) - (if name (cadr (cddddr name)) constants.aconst-null))) - - -(defun size (type) - (if (or (string= type "long") (string= type "double")) 2 1)) - -(defun modifier (m) - (cond ((string= "public" m) constants.acc-public) - ((string= "protected" m) constants.acc-protected) - ((string= "private" m) constants.acc-private) - ((string= "static" m) constants.acc-static) - ((string= "abstract" m) constants.acc-abstract) - ((string= "final" m) constants.acc-final) - ((string= "transient" m) constants.acc-transient) - ((string= "volatile" m) constants.acc-volatile) - ((string= "synchronized" m) constants.acc-synchronized) - (t (error "Invalid modifier ~s." m)))) - - -(defun write-method - (class-writer class-name class-type-name method-name unique-method-name modifiers result-type arg-types &optional super-invocation) - - (let* ((args-size (reduce #'+ arg-types :key #'size)) - (index (+ 2 args-size)) - (cv (visit-method-3 - class-writer - (reduce #'+ modifiers :key #'modifier) - method-name - (format nil "(~{~a~})~a" - (mapcar #'decorated-type-name arg-types) (decorated-type-name result-type))))) - - (when super-invocation - (visit-var-insn-2 cv constants.aload 0) - (loop for arg-number in (cdr super-invocation) - with super-arg-types = (make-string-output-stream) - do - (visit-var-insn-2 cv - (load-instruction (nth (1- arg-number) arg-types)) - (reduce #'+ arg-types :end (1- arg-number) :key #'size :initial-value 1)) - (write-string (decorated-type-name (nth (1- arg-number) arg-types)) super-arg-types) - finally - (visit-method-insn-4 cv constants.invokespecial - (type-name (car super-invocation)) "" - (format nil "(~a)~a" - (get-output-stream-string super-arg-types) "V")))) - (visit-ldc-insn-1 cv (make-java-string class-name)) - (visit-method-insn-4 cv constants.invokestatic - "org/armedbear/lisp/RuntimeClass" - "getRuntimeClass" - "(Ljava/lang/String;)Lorg/armedbear/lisp/RuntimeClass;") - (visit-field-insn-4 cv constants.putstatic - class-type-name "rc" "Lorg/armedbear/lisp/RuntimeClass;") - (visit-field-insn-4 cv constants.getstatic - class-type-name "rc" "Lorg/armedbear/lisp/RuntimeClass;") - (visit-ldc-insn-1 cv (make-java-string unique-method-name)) - (visit-method-insn-4 cv constants.invokevirtual - "org/armedbear/lisp/RuntimeClass" - "getLispMethod" - "(Ljava/lang/String;)Lorg/armedbear/lisp/Function;") - (visit-var-insn-2 cv constants.astore (1+ args-size)) - (visit-field-insn-4 cv constants.getstatic - "org/armedbear/lisp/Lisp" "NIL" "Lorg/armedbear/lisp/LispObject;") - (visit-var-insn-2 cv constants.astore (+ 2 args-size)) - - - (let ((l0 (make-label-0))(l1 (make-label-0))(l2 (make-label-0))(l3 (make-label-0))) - (visit-label-1 cv l0) - - (visit-var-insn-2 cv constants.aload index) - (visit-var-insn-2 cv constants.aload 0) ; (visit-var-insn-2 cv constants.aload 0) - (visit-method-insn-4 cv constants.invokestatic - "org/armedbear/lisp/RuntimeClass" "makeLispObject" - (format nil "(~a)~a" - (arg-type-for-make-lisp-object "java.lang.Object") - (decorate-type-name (return-type-for-make-lisp-object "java.lang.Object")))) - (visit-method-insn-4 cv constants.invokevirtual - "org/armedbear/lisp/LispObject" - "push" - "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;") - (visit-var-insn-2 cv constants.astore (+ 2 args-size)) - - (loop for arg-type in (reverse arg-types) and j = args-size then (- j (size arg-type)) - do - (visit-var-insn-2 cv constants.aload index) - - (visit-var-insn-2 cv (load-instruction arg-type) j) - (visit-method-insn-4 cv constants.invokestatic - "org/armedbear/lisp/RuntimeClass" "makeLispObject" - (format nil "(~a)~a" - (arg-type-for-make-lisp-object arg-type) - (decorate-type-name (return-type-for-make-lisp-object arg-type)))) - (visit-method-insn-4 cv constants.invokevirtual - "org/armedbear/lisp/LispObject" - "push" - "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;") ;uj - (visit-var-insn-2 cv constants.astore (+ 2 args-size))) - - - (visit-var-insn-2 cv constants.aload (1- index)) - (visit-var-insn-2 cv constants.aload index) - - (visit-type-insn-2 cv constants.new "org/armedbear/lisp/Environment") - (visit-insn-1 cv constants.dup) - (visit-method-insn-4 cv constants.invokespecial "org/armedbear/lisp/Environment" "" "()V") - (visit-method-insn-4 cv constants.invokestatic - "org/armedbear/lisp/LispThread" - "currentThread" - "()Lorg/armedbear/lisp/LispThread;") - (visit-method-insn-4 cv constants.invokestatic - "org/armedbear/lisp/RuntimeClass" - "evalC" - "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/Environment;Lorg/armedbear/lisp/LispThread;)Lorg/armedbear/lisp/LispObject;") - (cond - ((string= "void" result-type) - (visit-insn-1 cv constants.pop)) - ((string= "boolean" result-type) - (visit-method-insn-4 cv constants.invokevirtual - (return-type-for-make-lisp-object result-type) - "getBooleanValue" - (concatenate 'string "()" (type-name result-type)))) - ((primitive-type-p result-type) - (visit-method-insn-4 cv constants.invokevirtual - "org/armedbear/lisp/LispObject" - "javaInstance" - "()Ljava/lang/Object;") - (visit-type-insn-2 cv constants.checkcast (cast-type result-type)) - (visit-method-insn-4 cv constants.invokevirtual - (cast-type result-type) - (converter-for-primitive-return-type result-type) - (concatenate 'string "()" (type-name result-type)) - )) - (t - (visit-method-insn-4 cv constants.invokevirtual - "org/armedbear/lisp/LispObject" "javaInstance" "()Ljava/lang/Object;") - (visit-type-insn-2 cv constants.checkcast (cast-type result-type)))) - - - (visit-label-1 cv l1) - (if (string= "void" result-type) - (visit-jump-insn-2 cv constants.goto l3) - (visit-insn-1 cv (return-instruction result-type))) - (visit-label-1 cv l2) - (visit-var-insn-2 cv constants.astore (1+ index)) - (visit-var-insn-2 cv constants.aload (1+ index)) - (visit-method-insn-4 cv constants.invokevirtual - "org/armedbear/lisp/ConditionThrowable" "printStackTrace" "()V") - - (if (string= "void" result-type) - (progn (visit-insn-1 cv (return-instruction result-type))(visit-label-1 cv l3) ) - (visit-insn-1 cv (error-constant result-type))) - - (visit-insn-1 cv (return-instruction result-type)) - (visit-try-catch-block-4 cv l0 l1 l2 "org/armedbear/lisp/ConditionThrowable") - - (visit-maxs-2 cv 0 0)))) - - - -(defun jnew-runtime-class (class-name super-name interfaces constructors methods fields &optional filename) +(defun java:jnew-runtime-class + (class-name &key (superclass (make-jvm-class-name "java.lang.Object")) + interfaces constructors methods fields (access-flags '(:public))) "Creates and loads a Java class with methods calling Lisp closures as given in METHODS. CLASS-NAME and SUPER-NAME are strings, INTERFACES is a list of strings, CONSTRUCTORS, METHODS and FIELDS are @@ -573,91 +26,112 @@ Method definitions are lists of the form (method-name return-type argument-types function modifier*) - where method-name and return-type are strings, argument-types is a list of strings and function - is a lisp function of (1+ (length argument-types)) arguments; the instance (`this') is - passed in as the last argument. + where method-name is a string, return-type and argument-types are strings or keywords for + primitive types (:void, :int, etc.), and function is a Lisp function of minimum arity + (1+ (length argument-types)); the instance (`this') is passed in as the last argument. Field definitions are lists of the form (field-name type modifier*) If FILE-NAME is given, a .class file will be written; this is useful for debugging only." + (declare (ignorable constructors fields)) + (let* ((jvm-class-name (make-jvm-class-name class-name)) + (class-file (make-class-file jvm-class-name superclass access-flags)) + (stream (sys::%make-byte-array-output-stream)) + ;;TODO provide constructor in MemoryClassLoader + (memory-class-loader (java:jnew "org.armedbear.lisp.MemoryClassLoader" "")) + method-implementation-fields) + (setf (class-file-interfaces class-file) + (mapcar #'make-jvm-class-name interfaces)) + (dolist (m methods) + (destructuring-bind (name return-type argument-types function &rest flags) m + (let* ((argument-types (mapcar #'make-jvm-class-name argument-types)) + (argc (length argument-types)) + (return-type (if (keywordp return-type) + return-type + (make-jvm-class-name return-type))) + (jmethod (make-jvm-method name return-type argument-types :flags (or flags '(:public)))) + (field-name (string (gensym name)))) + (class-add-method class-file jmethod) + (let ((field (make-field field-name +lisp-object+ :flags '(:public :static)))) + (class-add-field class-file field) + (push (cons field-name function) method-implementation-fields)) + (with-code-to-method (class-file jmethod) + ;;Allocate registers (2 * argc to load and store arguments + 2 to box "this") + (dotimes (i (* 2 (1+ argc))) + (allocate-register nil)) + ;;Box "this" (to be passed as the first argument to the Lisp function) + (aload 0) + (emit 'iconst_1) ;;true + (emit-invokestatic +abcl-java-object+ "getInstance" + (list +java-object+ :boolean) +lisp-object+) + (astore (1+ argc)) + ;;Box each argument + (loop + :for arg-type :in argument-types + :for i :from 1 + :do (progn + (cond + ((keywordp arg-type) + (error "Unsupported arg-type: ~A" arg-type)) + ((eq arg-type :int) :todo) + (t (aload i) + (emit 'iconst_1) ;;true + (emit-invokestatic +abcl-java-object+ "getInstance" + (list +java-object+ :boolean) +lisp-object+))) + (astore (+ i (1+ argc))))) + ;;Load the Lisp function from its static field + (emit-getstatic jvm-class-name field-name +lisp-object+) + (if (<= (1+ argc) call-registers-limit) + (progn + ;;Load the boxed this + (aload (1+ argc)) + ;;Load each boxed argument + (dotimes (i argc) + (aload (+ argc 2 i)))) + (error "execute(LispObject[]) is currently not supported")) + (emit-call-execute (1+ (length argument-types))) + (cond + ((eq return-type :void) + (emit 'pop) + (emit 'return)) + ((eq return-type :int) + (emit-invokevirtual +lisp-object+ "intValue" nil :int) + (emit 'ireturn)) + ((keywordp return-type) + (error "Unsupported return type: ~A" return-type)) + (t + (emit-invokevirtual +lisp-object+ "javaInstance" nil +java-object+) + (emit-checkcast return-type) + (emit 'areturn))))))) + (when (null constructors) + (let ((ctor (make-jvm-method :constructor :void nil :flags '(:public)))) + (class-add-method class-file ctor) + (with-code-to-method (class-file ctor) + (aload 0) + (emit-invokespecial-init (class-file-superclass class-file) nil) + (emit 'return)))) + (finalize-class-file class-file) + (write-class-file class-file stream) + (finish-output stream) + #+test-record-generated-class-file + (with-open-file (f (format nil "~A.class" class-name) :direction :output :element-type '(signed-byte 8)) + (write-sequence (java::list-from-jarray (sys::%get-output-stream-bytes stream)) f)) + (sys::put-memory-function memory-class-loader + class-name (sys::%get-output-stream-bytes stream)) + (let ((jclass (java:jcall "loadClass" memory-class-loader class-name))) + (dolist (method method-implementation-fields) + (setf (java:jfield jclass (car method)) (cdr method))) + jclass))) + +#+example +(java:jnew-runtime-class + "Foo" + :interfaces (list "java.lang.Comparable") + :methods (list + (list "foo" :void '("java.lang.Object") + (lambda (this that) (print (list this that)))) + (list "bar" :int '("java.lang.Object") + (lambda (this that) (print (list this that)) 23)))) - (let ((cw (make-class-writer-1 (make-instance 'jboolean :java-instance t))) - (class-type-name (type-name class-name)) - (super-type-name (type-name super-name)) - (interface-type-names - (when interfaces - (let* ((no-of-interfaces (length interfaces)) - (ifarray (jnew-array "java.lang.String" no-of-interfaces))) - (dotimes (i no-of-interfaces ifarray) - (setf (jarray-ref ifarray i) (type-name (nth i interfaces))))))) - (args-for-%jnew)) - (visit-4 cw (+ constants.acc-public constants.acc-super) - class-type-name super-type-name interface-type-names) - (visit-field-3 cw (+ constants.acc-private constants.acc-static) - "rc" "Lorg/armedbear/lisp/RuntimeClass;") - - (dolist (field-def fields) - (visit-field-3 cw - (reduce #'+ (cddr field-def) :key #'modifier) - (car field-def) - (decorated-type-name (cadr field-def)))) - - - (if constructors - (loop for (arg-types constr-def super-invocation-args) in constructors - for unique-method-name = (apply #'concatenate 'string "|" arg-types) - then (apply #'concatenate 'string "|" arg-types) - collect unique-method-name into args - collect (coerce constr-def 'function) into args - do - (write-method - cw class-name class-type-name "" unique-method-name '("public") "void" arg-types - (cons super-type-name super-invocation-args)) - finally - (setf args-for-%jnew (append args-for-%jnew args))) - (let ((cv (visit-method-3 cw constants.acc-public "" "()V"))) - (visit-var-insn-2 cv constants.aload 0) - (visit-method-insn-4 cv constants.invokespecial super-type-name "" "()V") - (visit-insn-1 cv constants.return) - (visit-maxs-2 cv 1 1))) - - (loop for (method-name ret-type arg-types method-def . modifiers) in methods - for unique-method-name = (apply #'concatenate 'string method-name "|" arg-types) - then (apply #'concatenate 'string method-name "|" arg-types) - collect unique-method-name into args - collect (coerce method-def 'function) into args - do - (write-method - cw class-name class-type-name method-name unique-method-name modifiers ret-type arg-types) - finally - (apply #'java::%jnew-runtime-class class-name (append args-for-%jnew args))) - - (visit-end-0 cw) - - (when filename - (let ((os (make-file-output-stream-1 filename))) - (write-1 os (to-byte-array-0 cw)) - (close-0 os))) - - (java::%load-java-class-from-byte-array class-name (java-instance (to-byte-array-0 cw))))) - -(defun jredefine-method (class-name method-name arg-types method-def) - "Replace the definition of the method named METHDO-NAME (or - constructor, if METHD-NAME is nil) of argument types ARG-TYPES of the - class named CLASS-NAME defined with JNEW-RUNTIME-CLASS with - METHOD-DEF. See the documentation of JNEW-RUNTIME-CLASS." - (assert (jruntime-class-exists-p class-name) (class-name) - "Can't redefine methods of undefined runtime class ~a" class-name) - (let ((unique-method-name - (apply #'concatenate 'string (if method-name method-name "") "|" arg-types))) - (java::%jredefine-method class-name unique-method-name (compile nil method-def)))) - -(defun jruntime-class-exists-p (class-name) - "Returns true if a class named CLASS-NAME has been created and loaded by JNEW-RUNTIME-CLASS. - Needed because Java classes cannot be reloaded." - (when - (jstatic (jmethod "org.armedbear.lisp.RuntimeClass" "getRuntimeClass" "java.lang.String") - "org.armedbear.lisp.RuntimeClass" - class-name) - t)) +(provide "RUNTIME-CLASS") \ No newline at end of file