From mevenson at common-lisp.net Sun Apr 1 18:35:51 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sun, 01 Apr 2012 11:35:51 -0700 Subject: [armedbear-cvs] r13900 - trunk/abcl/contrib/abcl-asdf Message-ID: Author: mevenson Date: Sun Apr 1 11:35:49 2012 New Revision: 13900 Log: abcl-asdf: Clarify the version setting code for MVN compoments. Fix #204, but considerably beyond the patch the Cyrus Harmon submitted. Drastically simplified the ASDF:MAYBE-PARSE-MVN function to take advantage of the fact that we are in the ASDF namespace. At least the function now makes sense Parts of ASDF *reallY* want ASDF:VERSION to be a triple of intergers, and never anything more, which is part of the reason for the shennigans here. Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Sat Mar 31 05:50:25 2012 (r13899) +++ trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Sun Apr 1 11:35:49 2012 (r13900) @@ -1,4 +1,5 @@ (in-package :asdf) + (defclass iri (component) ((schema :initform nil) (authority :initform nil) @@ -8,7 +9,9 @@ (defclass mvn (iri) ((group-id :initform nil) - (artifact-id :initform nil))) + (artifact-id :initform nil) +;; inherited from ASDF:COMPONENT +#+nil (version :initform nil))) #+nil (defmethod find-component ((component iri) path) @@ -28,28 +31,36 @@ ;;; A Maven URI has the form "mvn:group-id/artifact-id/version" ;;; ;;; Currently we "stuff" the group-id/artifact-id into the 'name' and -;;; use the component 'version' for the version string. +;;; use the component 'version' for the version. Parts of ASDF +;;; *reallY* want ASDF:VERSION to be a triple of intergers, and never +;;; anything more, so that is part of the motivation behind this effort. +;;; ??? rename me to ENSURE-MVN-PARSE ?? (defun maybe-parse-mvn (component) - (with-slots (asdf::name asdf::group-id asdf::artifact-id - asdf::version asdf::schema asdf::path) + (with-slots (name group-id artifact-id + version schema path) component (when (null asdf::artifact-id) - (let ((parsed (abcl-asdf::split-string name "/"))) - (unless (or (= (length parsed) 3) - (and (= (length parsed) 2) - asdf::version)) - (error "Failed to construct a mvn reference from name '~A' and version '~A'" - asdf::name - (if asdf::version - asdf::version - "UNSPECIFED"))) - (setf asdf::group-id (first parsed) - asdf::artifact-id (second parsed) - asdf::schema "mvn" - asdf::version (if (third parsed) - (third parsed) - "LATEST")) - (setf asdf::path (format nil "~A/~A" asdf::name asdf::version)))))) + (let ((parsed (abcl-asdf::split-string name "/")) + (asdf-version-p (slot-boundp component 'version)) + (default-version "LATEST")) + (cond ((= (length parsed) 3) + (setf + group-id (first parsed) + artifact-id (second parsed) + version (third parsed))) + ((= (length parsed) 2) + (setf + group-id (first parsed) + artifact-id (second parsed) + version (if asdf-version-p + version + default-version))) + (t + (error "Failed to construct a mvn reference from name '~A' and version '~A'" + name version))) + (setf schema "mvn") + ;;; Always normalized path "on the way out" to contain group-id/artifact-id/version + (setf path (format nil "~A/~A/~A" group-id artifact-id version)))))) (defmethod source-file-type ((component iri) (system system)) nil) From mevenson at common-lisp.net Sun Apr 1 19:15:37 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sun, 01 Apr 2012 12:15:37 -0700 Subject: [armedbear-cvs] r13902 - trunk/abcl/contrib/abcl-asdf Message-ID: Author: mevenson Date: Sun Apr 1 12:15:37 2012 New Revision: 13902 Log: abcl-asdf-0.8.0: commit to an API to specify repository. The ASDF:MVN component now gets an ASDF:REPOSITORY slot to be populated with the Aether repository to pass. Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd ============================================================================== --- trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd Sun Apr 1 12:15:35 2012 (r13901) +++ trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd Sun Apr 1 12:15:37 2012 (r13902) @@ -3,7 +3,7 @@ (defsystem :abcl-asdf :author "Mark Evenson" - :version "0.7.0" + :version "0.8.0" :depends-on (jss) :components ((:module packages :pathname "" Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Sun Apr 1 12:15:35 2012 (r13901) +++ trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Sun Apr 1 12:15:37 2012 (r13902) @@ -1,3 +1,6 @@ +;;;; The ABCL specific overrides in ASDF. +;;;; +;;;; Done separate from asdf.lisp for stability. (in-package :asdf) (defclass iri (component) @@ -10,7 +13,8 @@ (defclass mvn (iri) ((group-id :initform nil) (artifact-id :initform nil) -;; inherited from ASDF:COMPONENT + (repository :initform "http://repo1.maven.org/maven2/") ;;; XXX unimplmented +;; inherited from ASDF:COMPONENT ??? what are the CL semantics on overriding -- ME 2012-04-01 #+nil (version :initform nil))) #+nil From mevenson at common-lisp.net Sun Apr 1 19:15:40 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sun, 01 Apr 2012 12:15:40 -0700 Subject: [armedbear-cvs] r13903 - trunk/abcl/contrib/abcl-asdf Message-ID: Author: mevenson Date: Sun Apr 1 12:15:39 2012 New Revision: 13903 Log: abcl-asdf: Final touches on 0.8.0. Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp trunk/abcl/contrib/abcl-asdf/packages.lisp Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Sun Apr 1 12:15:37 2012 (r13902) +++ trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Sun Apr 1 12:15:39 2012 (r13903) @@ -23,25 +23,31 @@ ;;; We intercept compilation to ensure that load-op will succeed (defmethod perform ((op compile-op) (c mvn)) - (maybe-parse-mvn c) + (ensure-parsed-mvn c) (abcl-asdf:resolve c)) (defmethod perform ((operation load-op) (c mvn)) - (maybe-parse-mvn c) + (ensure-parsed-mvn c) (java:add-to-classpath (abcl-asdf:as-classpath (abcl-asdf:resolve c)))) ;;; A Maven URI has the form "mvn:group-id/artifact-id/version" ;;; +;;; Sometimes people write "group-id:artifact-id:version" to refer to +;;; Maven artifacts. One can use ABCL-ASDF:RESOLVE directly for +;;; serialized references to artifacts of this form. +;;; ;;; Currently we "stuff" the group-id/artifact-id into the 'name' and ;;; use the component 'version' for the version. Parts of ASDF ;;; *reallY* want ASDF:VERSION to be a triple of intergers, and never ;;; anything more, so that is part of the motivation behind this effort. -;;; ??? rename me to ENSURE-MVN-PARSE ?? -(defun maybe-parse-mvn (component) +(defparameter *mvn-repositories* nil + "A list of all Maven repositories encountered in the lifetime of this instance of the implementation.") + +(defun ensure-parsed-mvn (component) (with-slots (name group-id artifact-id - version schema path) + version schema path repository) component (when (null asdf::artifact-id) (let ((parsed (abcl-asdf::split-string name "/")) @@ -63,6 +69,7 @@ (error "Failed to construct a mvn reference from name '~A' and version '~A'" name version))) (setf schema "mvn") + (pushnew repository *mvn-repositories*) ;;; Always normalized path "on the way out" to contain group-id/artifact-id/version (setf path (format nil "~A/~A/~A" group-id artifact-id version)))))) Modified: trunk/abcl/contrib/abcl-asdf/packages.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/packages.lisp Sun Apr 1 12:15:37 2012 (r13902) +++ trunk/abcl/contrib/abcl-asdf/packages.lisp Sun Apr 1 12:15:39 2012 (r13903) @@ -13,6 +13,10 @@ #:init +;;; ASDF +;;; #:iri #:mvn +;;; #:ensure-parsed-mvn + ;;; "Internal" API ;;;; Maven From mevenson at common-lisp.net Sun Apr 1 19:15:41 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sun, 01 Apr 2012 12:15:41 -0700 Subject: [armedbear-cvs] r13901 - trunk/abcl/contrib/abcl-asdf Message-ID: Author: mevenson Date: Sun Apr 1 12:15:35 2012 New Revision: 13901 Log: Part of Fix #204: require the use of maven-3.0.4. Slyrus reports that some parts don't work with maven-3.0.3, so as a favor to user bump requirement. Underneath: Aether is a mess, but looks like it is getting better. Modified: trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Modified: trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Sun Apr 1 11:35:49 2012 (r13900) +++ trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Sun Apr 1 12:15:35 2012 (r13901) @@ -22,6 +22,8 @@ |# +;;; N.b. evaluated *after* we load the ABCL specific modifications of ASDF in abcl-asdf.lisp + (in-package :abcl-asdf) (require :abcl-contrib) @@ -134,7 +136,7 @@ (>= minor 1)) (and (>= major 3) (>= major 0) - (>= patch 3))))) + (>= patch 4))))) (defparameter *init* nil) @@ -143,13 +145,14 @@ (unless (or force *mvn-libs-directory*) (setf *mvn-libs-directory* (find-mvn-libs))) (unless (probe-file *mvn-libs-directory*) - (error "You must download maven-3.0.3 or later from http://maven.apache.org/download.html, then set ABCL-ASDF:*MVN-DIRECTORY* appropiately.")) + (error "You must download maven-3.0.4 or later from http://maven.apache.org/download.html, then set ABCL-ASDF:*MVN-DIRECTORY* appropiately.")) (unless (ensure-mvn-version) - (error "We need maven-3.0.3 or later.")) + (error "We need maven-3.0.4 or later.")) (add-directory-jars-to-class-path *mvn-libs-directory* nil) (setf *init* t)) (defparameter *http-wagon-implementations* + ;;; maven-3.0.3 reported as not working with all needed functionality `("org.apache.maven.wagon.providers.http.HttpWagon" ;; introduced as default with maven-3.0.4 "org.apache.maven.wagon.providers.http.LightweightHttpWagon") "A list of possible candidate implementations that provide access to http and https resources. From mevenson at common-lisp.net Sun Apr 1 20:39:18 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sun, 01 Apr 2012 13:39:18 -0700 Subject: [armedbear-cvs] r13904 - trunk/abcl/contrib/abcl-asdf Message-ID: Author: mevenson Date: Sun Apr 1 13:39:17 2012 New Revision: 13904 Log: abcl-asdf: refactor interface. ENSURE-REMOTE-REPOSITORY now takes a keyword to specify the remote repository to create. RESOLVE-DEPENDENCIES should now use this mechanism to specify the remote repository. The ASDF syntax of adding a :repository doesn't seem to be working. Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Sun Apr 1 12:15:39 2012 (r13903) +++ trunk/abcl/contrib/abcl-asdf/abcl-asdf.lisp Sun Apr 1 13:39:17 2012 (r13904) @@ -1,6 +1,7 @@ ;;;; The ABCL specific overrides in ASDF. ;;;; ;;;; Done separate from asdf.lisp for stability. +(require :asdf) (in-package :asdf) (defclass iri (component) @@ -11,8 +12,8 @@ (fragment :initform nil))) (defclass mvn (iri) - ((group-id :initform nil) - (artifact-id :initform nil) + ((group-id :initarg :group-id :initform nil) + (artifact-id :initarg :artifact-id :initform nil) (repository :initform "http://repo1.maven.org/maven2/") ;;; XXX unimplmented ;; inherited from ASDF:COMPONENT ??? what are the CL semantics on overriding -- ME 2012-04-01 #+nil (version :initform nil))) @@ -21,16 +22,17 @@ (defmethod find-component ((component iri) path) component) + ;;; We intercept compilation to ensure that load-op will succeed (defmethod perform ((op compile-op) (c mvn)) - (ensure-parsed-mvn c) - (abcl-asdf:resolve c)) + (abcl-asdf:resolve + (ensure-parsed-mvn c))) (defmethod perform ((operation load-op) (c mvn)) - (ensure-parsed-mvn c) (java:add-to-classpath (abcl-asdf:as-classpath - (abcl-asdf:resolve c)))) + (abcl-asdf:resolve + (ensure-parsed-mvn c))))) ;;; A Maven URI has the form "mvn:group-id/artifact-id/version" ;;; @@ -45,6 +47,13 @@ (defparameter *mvn-repositories* nil "A list of all Maven repositories encountered in the lifetime of this instance of the implementation.") +#+nil +(defmethod slot-missing ((class mvn) object slot-name operation &optional new-value) + (setf (slot-value object slot-name) + (if new-value + new-value + nil))) + (defun ensure-parsed-mvn (component) (with-slots (name group-id artifact-id version schema path repository) @@ -71,7 +80,11 @@ (setf schema "mvn") (pushnew repository *mvn-repositories*) ;;; Always normalized path "on the way out" to contain group-id/artifact-id/version - (setf path (format nil "~A/~A/~A" group-id artifact-id version)))))) + (setf path (format nil "~A/~A/~A" group-id artifact-id version)))) + component)) + +(export `(mvn iri ensure-parsed-mvn + group-id artifact-id version) 'asdf) (defmethod source-file-type ((component iri) (system system)) nil) Modified: trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Sun Apr 1 12:15:39 2012 (r13903) +++ trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Sun Apr 1 13:39:17 2012 (r13904) @@ -289,19 +289,30 @@ (defun make-remote-repository (id type url) (jss:new 'aether.repository.RemoteRepository id type url)) +(defparameter *default-repository* + "http://repo1.maven.org/maven2/") + +(defun add-repository (repository) + (ensure-remote-repository :repository repository)) + (defparameter *maven-remote-repository* nil "The remote repository used by the Maven Aether embedder.") -(defun ensure-remote-repository () +(defun ensure-remote-repository (&key repository *default-repository* repository-p) (unless *init* (init)) - (unless *maven-remote-repository* - (let ((r (make-remote-repository "central" "default" "http://repo1.maven.org/maven2/"))) + (unless (or repository-p + *maven-remote-repository*) + (let ((r (make-remote-repository "central" "default" repository))) (when *maven-http-proxy* (#"setProxy" r (make-proxy))) (setf *maven-remote-repository* r))) *maven-remote-repository*) -(defun resolve-dependencies (group-id artifact-id &optional (version "LATEST" versionp)) - "Dynamically resolve Maven dependencies for item with GROUP-ID and ARTIFACT-ID at VERSION. +(defun resolve-dependencies (group-id artifact-id + &optional ;;; XXX Uggh. Move to keywords when we get the moxie. + (version "LATEST" versionp) + (repository *maven-remote-repository* repository-p)) + "Dynamically resolve Maven dependencies for item with GROUP-ID and ARTIFACT-ID +optionally with a VERSION and a REPOSITORY. Users of the function are advised All recursive dependencies will be visited before resolution is successful. @@ -321,7 +332,10 @@ artifact (java:jfield (jss:find-java-class "JavaScopes") "RUNTIME"))) (collect-request (java:jnew (jss:find-java-class "CollectRequest")))) (#"setRoot" collect-request dependency) - (#"addRepository" collect-request (ensure-remote-repository)) + (#"addRepository" collect-request + (if repository-p + (ensure-remote-repository :repository repository) + (ensure-remote-repository))) (let* ((node (#"getRoot" (#"collectDependencies" (ensure-repository-system) (ensure-session) collect-request))) (dependency-request @@ -378,7 +392,7 @@ #'log))) -(defmethod resolve ((string t)) +(defmethod resolve ((string string)) "Resolve a colon separated GROUP-ID:ARTIFACT-ID[:VERSION] reference to a Maven artifact. Examples of artifact references: \"log4j:log4j:1.2.14\" for @@ -389,6 +403,13 @@ artifact and all of its transitive dependencies." (let ((result (split-string string ":"))) (cond - ((<= 2 (length result) 3) + ((= (length result) 3) + (resolve-dependencies (first result) (second result) (third result))) + (t (apply #'resolve-dependencies result))))) +#+nil +(defmethod resolve ((mvn asdf:mvn)) + (with-slots (asdf::group-id asdf::artifact-id asdf::version) + (asdf:ensure-parsed-mvn mvn) + (resolve-dependencies (format nil "~A:~A:~A" asdf::group-id asdf::artifact-id asdf::version)))) From rschlatte at common-lisp.net Thu Apr 5 14:42:12 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Thu, 05 Apr 2012 07:42:12 -0700 Subject: [armedbear-cvs] r13905 - trunk/abcl/doc/manual Message-ID: Author: rschlatte Date: Thu Apr 5 07:42:09 2012 New Revision: 13905 Log: fix manual compilation error Modified: trunk/abcl/doc/manual/abcl.tex Modified: trunk/abcl/doc/manual/abcl.tex ============================================================================== --- trunk/abcl/doc/manual/abcl.tex Sun Apr 1 13:39:17 2012 (r13904) +++ trunk/abcl/doc/manual/abcl.tex Thu Apr 5 07:42:09 2012 (r13905) @@ -1027,7 +1027,7 @@ \item \code{quicklisp-abcl} (Not working) boot a local Quicklisp installation via the ASDF:IRI type introduced bia ABCL-ASDF. - \end{enumeration} + \end{enumerate} \end{description} From mevenson at common-lisp.net Fri Apr 6 08:33:15 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 06 Apr 2012 01:33:15 -0700 Subject: [armedbear-cvs] r13906 - trunk/abcl/test/lisp/abcl Message-ID: Author: mevenson Date: Fri Apr 6 01:33:14 2012 New Revision: 13906 Log: ticket #205: putative test for JSS:WITH-CONSTANT-SIGNATURE Modified: trunk/abcl/test/lisp/abcl/bugs.lisp Modified: trunk/abcl/test/lisp/abcl/bugs.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/bugs.lisp Thu Apr 5 07:42:09 2012 (r13905) +++ trunk/abcl/test/lisp/abcl/bugs.lisp Fri Apr 6 01:33:14 2012 (r13906) @@ -105,4 +105,9 @@ t) - \ No newline at end of file + +(deftest bugs.with-constant-signature.1 + (with-constant-signature ((substring "substring")) + (substring "some string" 2)) + t) + From mevenson at common-lisp.net Fri Apr 6 08:33:20 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 06 Apr 2012 01:33:20 -0700 Subject: [armedbear-cvs] r13907 - trunk/abcl/contrib/abcl-asdf Message-ID: Author: mevenson Date: Fri Apr 6 01:33:19 2012 New Revision: 13907 Log: abcl-asdf Maven: fix obvious (?) typo Modified: trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Modified: trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Fri Apr 6 01:33:14 2012 (r13906) +++ trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Fri Apr 6 01:33:19 2012 (r13907) @@ -135,7 +135,7 @@ (and (>= major 3) (>= minor 1)) (and (>= major 3) - (>= major 0) + (>= minor 0) (>= patch 4))))) (defparameter *init* nil) From mevenson at common-lisp.net Fri Apr 6 11:59:49 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 06 Apr 2012 04:59:49 -0700 Subject: [armedbear-cvs] r13908 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri Apr 6 04:59:48 2012 New Revision: 13908 Log: docstrings: document JAVA:JNEW-ARRAY-FROM-LIST and some friends. Modified: trunk/abcl/src/org/armedbear/lisp/java.lisp Modified: trunk/abcl/src/org/armedbear/lisp/java.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/java.lisp Fri Apr 6 01:33:19 2012 (r13907) +++ trunk/abcl/src/org/armedbear/lisp/java.lisp Fri Apr 6 04:59:48 2012 (r13908) @@ -194,6 +194,7 @@ (jcall (jmethod "java.lang.Class" "getComponentType") atype)) (defun jarray-length (java-array) + "Returns the length of a Java primitive array." (jstatic "getLength" "java.lang.reflect.Array" java-array) ) (defun (setf jarray-ref) (new-value java-array &rest indices) @@ -201,7 +202,7 @@ (defun jnew-array-from-array (element-type array) "Returns a new Java array with base type ELEMENT-TYPE (a string or a class-ref) - initialized from ARRAY" + initialized from ARRAY." (flet ((row-major-to-index (dimensions n) (loop for dims on dimensions @@ -220,6 +221,8 @@ (apply #'(setf jarray-ref) (row-major-aref array i) jarray (row-major-to-index dimensions i)))))) (defun jnew-array-from-list (element-type list) + "Returns a new Java array with base type ELEMENT-TYPE (a string or a class-ref) + initialized from a Lisp list." (let ((jarray (jnew-array element-type (length list))) (i 0)) (dolist (x list) @@ -367,8 +370,9 @@ (t (error "Unknown load-form for ~A" class-name))))) -(defun jproperty-value (obj prop) - (%jget-property-value obj prop)) +(defun jproperty-value (object property) + "setf-able access on the Java Beans notion of property named PROPETRY on OBJECT." + (%jget-property-value object property)) (defun (setf jproperty-value) (value obj prop) (%jset-property-value obj prop value)) @@ -451,6 +455,7 @@ supers)) (defun ensure-java-class (jclass) + "Attempt to ensure that the Java class referenced by JCLASS exists in the current process of the implementation." (let ((class (%find-java-class jclass))) (if class class From mevenson at common-lisp.net Tue Apr 10 15:00:48 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 10 Apr 2012 08:00:48 -0700 Subject: [armedbear-cvs] r13909 - trunk/abcl/contrib/jss Message-ID: Author: mevenson Date: Tue Apr 10 08:00:46 2012 New Revision: 13909 Log: jss-3.0.2: fix SET-JAVA-FIELD. Use the setf'able JAVA:JFIELD primitive to handle setting Java fields, performing additional conversion when passed object of type JAVA:JAVA-OBJECT. Modified: trunk/abcl/contrib/jss/invoke.lisp trunk/abcl/contrib/jss/jss.asd trunk/abcl/contrib/jss/packages.lisp Modified: trunk/abcl/contrib/jss/invoke.lisp ============================================================================== --- trunk/abcl/contrib/jss/invoke.lisp Fri Apr 6 04:59:48 2012 (r13908) +++ trunk/abcl/contrib/jss/invoke.lisp Tue Apr 10 08:00:46 2012 (r13909) @@ -319,8 +319,9 @@ (defvar *running-in-osgi* (ignore-errors (jclass "org.osgi.framework.BundleActivator"))) - (defun get-java-field (object field &optional (try-harder *running-in-osgi*)) + "Get the value of the FIELD contained in OBJECT. +If OBJECT is a symbol it names a dot qualified static FIELD." (if try-harder (let* ((class (if (symbolp object) (setq object (find-java-class object)) @@ -338,8 +339,13 @@ (jfield class field)) (jfield field object)))) -;; use #"getSuperclass" and #"getInterfaces" to see whether there are fields in superclasses that we might set +;; TODO use #"getSuperclass" and #"getInterfaces" to see whether there +;; are fields in superclasses that we might set (defun set-java-field (object field value &optional (try-harder *running-in-osgi*)) + "Set the FIELD of OBJECT to VALUE. +If OBJECT is a symbol, it names a dot qualified Java class to look for +a static FIELD. If OBJECT is an instance of java:java-object, the +associated is used to look up the static FIELD." (if try-harder (let* ((class (if (symbolp object) (setq object (find-java-class object)) @@ -353,8 +359,11 @@ (values (#"set" jfield object value) jfield)) (if (symbolp object) (let ((class (find-java-class object))) - (#"pokeStatic" 'invoke class field value)) - (#"poke" 'invoke object field value)))) + (setf (jfield (#"getName" class) field) value)) + (if (typep object 'java-object) + (setf (jfield (jclass-of object) field) value) + (setf (jfield object field) value))))) + (defconstant +for-name+ (jmethod "java.lang.Class" "forName" "java.lang.String" "boolean" "java.lang.ClassLoader")) Modified: trunk/abcl/contrib/jss/jss.asd ============================================================================== --- trunk/abcl/contrib/jss/jss.asd Fri Apr 6 04:59:48 2012 (r13908) +++ trunk/abcl/contrib/jss/jss.asd Tue Apr 10 08:00:46 2012 (r13909) @@ -3,7 +3,7 @@ (defsystem :jss :author "Alan Ruttenberg, Mark Evenson" - :version "3.0.1" + :version "3.0.2" :components ((:module base :pathname "" :serial t Modified: trunk/abcl/contrib/jss/packages.lisp ============================================================================== --- trunk/abcl/contrib/jss/packages.lisp Fri Apr 6 04:59:48 2012 (r13908) +++ trunk/abcl/contrib/jss/packages.lisp Tue Apr 10 08:00:46 2012 (r13909) @@ -26,8 +26,11 @@ #:vector-to-list #:jarray-to-list -;;; deprecated +;;; XXX Necessary to work in OSGi? #:get-java-field ; use JAVA:JFIELD + #:set-java-field ; use JAVA-JFIELD + +;;; deprecated #:list-to-list ;;; Move to JAVA? From mevenson at common-lisp.net Wed Apr 11 15:14:30 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 11 Apr 2012 08:14:30 -0700 Subject: [armedbear-cvs] r13910 - trunk/abcl/contrib/jss Message-ID: Author: mevenson Date: Wed Apr 11 08:14:28 2012 New Revision: 13910 Log: jss: add docstring for the rather useful HASHMAP-TO-HASHTABLE. Modified: trunk/abcl/contrib/jss/invoke.lisp Modified: trunk/abcl/contrib/jss/invoke.lisp ============================================================================== --- trunk/abcl/contrib/jss/invoke.lisp Tue Apr 10 08:00:46 2012 (r13909) +++ trunk/abcl/contrib/jss/invoke.lisp Wed Apr 11 08:14:28 2012 (r13910) @@ -561,7 +561,15 @@ (defun hashmap-to-hashtable (hashmap &rest rest &key (keyfun #'identity) (valfun #'identity) (invert? nil) table - &allow-other-keys ) + &allow-other-keys ) + "Converts the a HASHMAP reference to a java.util.HashMap object to a Lisp hashtable. + +The REST paramter specifies arguments to the underlying MAKE-HASH-TABLE call. + +KEYFUN and VALFUN specifies functions to be run on the keys and values +of the HASHMAP right before they are placed in the hashtable. + +If INVERT? is non-nil than reverse the keys and values in the resulting hashtable." (let ((keyset (#"keySet" hashmap)) (table (or table (apply 'make-hash-table (loop for (key value) on rest by #'cddr From mevenson at common-lisp.net Sun Apr 15 14:37:56 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sun, 15 Apr 2012 07:37:56 -0700 Subject: [armedbear-cvs] r13911 - in trunk/abcl: doc/asdf src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sun Apr 15 07:37:55 2012 New Revision: 13911 Log: Upgradte to asdf-2.20. 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 Wed Apr 11 08:14:28 2012 (r13910) +++ trunk/abcl/doc/asdf/asdf.texinfo Sun Apr 15 07:37:55 2012 (r13911) @@ -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 + | :weakly-depends-on @var{system-list} | :class class-name (see discussion below) | module-option | option @@ -980,6 +981,7 @@ conflict in the current package. @subsection Defsystem depends on + at cindex :defsystem-depends-on The @code{:defsystem-depends-on} option to @code{defsystem} allows the programmer to specify another ASDF-defined system or set of systems that @@ -987,6 +989,22 @@ Typically this is used to load an ASDF extension that is used in the system definition. + at subsection Weakly depends on + at cindex :weakly-depends-on + +The @code{:weakly-depends-on} option to @code{defsystem} allows the +programmer to specify another ASDF-defined system or set of systems that +ASDF should @emph{try} to load, but need not load in order to be +successful. Typically this is used if there are a number of systems +that, if present, could provide additional functionality, but which are +not necessary for basic function. + +Currently, although it is specified to be an option only to + at code{defsystem}, this option is accepted at any component, but it probably +only makes sense at the @code{defsystem} level. Programmers are cautioned not +to use this component option except at the @code{defsystem} level, as +this anomalous behavior may be removed without warning. + @subsection Pathname specifiers @cindex pathname specifiers Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/asdf.lisp Wed Apr 11 08:14:28 2012 (r13910) +++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Sun Apr 15 07:37:55 2012 (r13911) @@ -1,5 +1,5 @@ ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; This is ASDF 2.019: Another System Definition Facility. +;;; This is ASDF 2.20: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to . @@ -61,7 +61,8 @@ (setf excl::*autoload-package-name-alist* (remove "asdf" excl::*autoload-package-name-alist* :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below - #+ecl (unless (member :ecl-bytecmp *features*) (require :cmp)) + #+ecl (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t)) + #+ecl (unless (use-ecl-byte-compiler-p) (require :cmp)) #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011 (when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 fails to fully compile ASDF at all (and (= system::*gcl-major-version* 2) @@ -107,7 +108,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.019") + (asdf-version "2.20") (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -2793,7 +2794,7 @@ rest))) (ret (find-component parent name))) (when weakly-depends-on - (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on))) + (appendf depends-on (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on))) (when *serial-depends-on* (push *serial-depends-on* depends-on)) (if ret ; preserve identity @@ -3085,6 +3086,15 @@ ;; we may have to segregate the code still by architecture. (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))) +#+clozure +(defun* ccl-fasl-version () + ;; the fasl version is target-dependent from CCL 1.8 on. + (or (and (fboundp 'ccl::target-fasl-version) + (funcall 'ccl::target-fasl-version)) + (and (boundp 'ccl::fasl-version) + (symbol-value 'ccl::fasl-version)) + (error "Can't determine fasl version."))) + (defun lisp-version-string () (let ((s (lisp-implementation-version))) (car ; as opposed to OR, this idiom prevents some unreachable code warning @@ -3104,11 +3114,11 @@ (format nil "~d.~d-f~d" ; shorten for windows ccl::*openmcl-major-version* ccl::*openmcl-minor-version* - (logand ccl::fasl-version #xFF)) + (logand (ccl-fasl-version) #xFF)) #+cmu (substitute #\- #\/ s) #+scl (format nil "~A~A" s - ;; ANSI upper case vs lower case. - (ecase ext:*case-mode* (:upper "") (:lower "l"))) + ;; ANSI upper case vs lower case. + (ecase ext:*case-mode* (:upper "") (:lower "l"))) #+ecl (format nil "~A~@[-~A~]" s (let ((vcs-id (ext:lisp-implementation-vcs-id))) (subseq vcs-id 0 (min (length vcs-id) 8)))) @@ -3141,21 +3151,36 @@ #+mcl (current-user-homedir-pathname) #-mcl (user-homedir-pathname)))) +(defun* ensure-absolute-pathname* (x fmt &rest args) + (and (plusp (length x)) + (or (absolute-pathname-p x) + (cerror "ignore relative pathname" + "Invalid relative pathname ~A~@[ ~?~]" x fmt args)) + x)) +(defun* split-absolute-pathnames (x fmt &rest args) + (loop :for dir :in (split-string + x :separator (string (inter-directory-separator))) + :do (apply 'ensure-absolute-pathname* dir fmt args) + :collect dir)) +(defun getenv-absolute-pathname (x &aux (s (getenv x))) + (ensure-absolute-pathname* s "from (getenv ~S)" x)) +(defun getenv-absolute-pathnames (x &aux (s (getenv x))) + (split-absolute-pathnames s "from (getenv ~S) = ~S" x s)) + (defun* user-configuration-directories () (let ((dirs `(,@(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 ":") + (subpathname* (getenv-absolute-pathname "XDG_CONFIG_HOME") "common-lisp/") + (loop :for dir :in (getenv-absolute-pathnames "XDG_CONFIG_DIRS") :collect (subpathname* dir "common-lisp/")))) ,@(when (os-windows-p) `(,(subpathname* (or #+lispworks (sys:get-folder-path :local-appdata) - (getenv "LOCALAPPDATA")) + (getenv-absolute-pathname "LOCALAPPDATA")) "common-lisp/config/") ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData ,(subpathname* (or #+lispworks (sys:get-folder-path :appdata) - (getenv "APPDATA")) + (getenv-absolute-pathname "APPDATA")) "common-lisp/config/"))) ,(subpathname (user-homedir) ".config/common-lisp/")))) (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) @@ -3168,8 +3193,8 @@ (aif ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData (subpathname* (or #+lispworks (sys:get-folder-path :common-appdata) - (getenv "ALLUSERSAPPDATA") - (subpathname* (getenv "ALLUSERSPROFILE") "Application Data/")) + (getenv-absolute-pathname "ALLUSERSAPPDATA") + (subpathname* (getenv-absolute-pathname "ALLUSERSPROFILE") "Application Data/")) "common-lisp/config/") (list it))))) @@ -3293,12 +3318,12 @@ (defvar *user-cache* (flet ((try (x &rest sub) (and x `(,x , at sub)))) (or - (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation) + (try (getenv-absolute-pathname "XDG_CACHE_HOME") "common-lisp" :implementation) (when (os-windows-p) (try (or #+lispworks (sys:get-folder-path :local-appdata) - (getenv "LOCALAPPDATA") + (getenv-absolute-pathname "LOCALAPPDATA") #+lispworks (sys:get-folder-path :appdata) - (getenv "APPDATA")) + (getenv-absolute-pathname "APPDATA")) "common-lisp" "cache" :implementation)) '(:home ".cache" "common-lisp" :implementation)))) @@ -3433,13 +3458,12 @@ (defun* location-function-p (x) (and - (consp x) (length=n-p x 2) - (or (and (equal (first x) :function) - (typep (second x) 'symbol)) - (and (equal (first x) 'lambda) - (cddr x) - (length=n-p (second x) 2))))) + (eq (car x) :function) + (or (symbolp (cadr x)) + (and (consp (cadr x)) + (eq (caadr x) 'lambda) + (length=n-p (cadadr x) 2))))) (defun* validate-output-translations-directive (directive) (or (member directive '(:enable-user-cache :disable-cache nil)) @@ -4015,19 +4039,18 @@ (:directory ,(default-directory)) ,@(loop :for dir :in `(,@(when (os-unix-p) - `(,(or (getenv "XDG_DATA_HOME") + `(,(or (getenv-absolute-pathname "XDG_DATA_HOME") (subpathname (user-homedir) ".local/share/")) - ,@(split-string (or (getenv "XDG_DATA_DIRS") - "/usr/local/share:/usr/share") - :separator ":"))) + ,@(or (getenv-absolute-pathnames "XDG_DATA_DIRS") + '("/usr/local/share" "/usr/share")))) ,@(when (os-windows-p) `(,(or #+lispworks (sys:get-folder-path :local-appdata) - (getenv "LOCALAPPDATA")) + (getenv-absolute-pathname "LOCALAPPDATA")) ,(or #+lispworks (sys:get-folder-path :appdata) - (getenv "APPDATA")) + (getenv-absolute-pathname "APPDATA")) ,(or #+lispworks (sys:get-folder-path :common-appdata) - (getenv "ALLUSERSAPPDATA") - (subpathname* (getenv "ALLUSERSPROFILE") "Application Data/"))))) + (getenv-absolute-pathname "ALLUSERSAPPDATA") + (subpathname* (getenv-absolute-pathname "ALLUSERSPROFILE") "Application Data/"))))) :collect `(:directory ,(subpathname* dir "common-lisp/systems/")) :collect `(:tree ,(subpathname* dir "common-lisp/source/"))) :inherit-configuration)) @@ -4113,8 +4136,8 @@ ,parameter ,@*default-source-registries*) :register #'(lambda (directory &key recurse exclude) - (collect (list directory :recurse recurse :exclude exclude))))) - :test 'equal :from-end t))) + (collect (list directory :recurse recurse :exclude exclude)))))) + :test 'equal :from-end t)) ;; Will read the configuration and initialize all internal variables. (defun* compute-source-registry (&optional parameter (registry *source-registry*)) @@ -4190,9 +4213,6 @@ (progn (setf *compile-op-compile-file-function* 'ecl-compile-file) - (defun use-ecl-byte-compiler-p () - (member :ecl-bytecmp *features*)) - (defun ecl-compile-file (input-file &rest keys &key &allow-other-keys) (if (use-ecl-byte-compiler-p) (apply 'compile-file* input-file keys) From mevenson at common-lisp.net Sun Apr 15 16:24:46 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sun, 15 Apr 2012 09:24:46 -0700 Subject: [armedbear-cvs] r13912 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sun Apr 15 09:24:45 2012 New Revision: 13912 Log: compiler: refuse to load zero-length JVM fasls; added diagnostics. Additionally, if for the ANSI compiler proclamations the condition (> *DEBUG* *SAFETY*) is true, actually load the compiled fasl in the executing JVM. This is a potentially slow operation, but it certainly makes further execution safer. If the ANSI proclamination *DEBUG* is non-zero, set the appropiate plists of symbols containing values of the associatioed compiled representation. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Sun Apr 15 07:37:55 2012 (r13911) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Sun Apr 15 09:24:45 2012 (r13912) @@ -85,14 +85,21 @@ (declaim (ftype (function (t) t) verify-load)) (defun verify-load (classfile) - #|(if (> *safety* 0) (and classfile - (let ((*load-truename* *output-file-pathname*)) - (report-error - (load-compiled-function classfile)))) - t)|# - (declare (ignore classfile)) - t) + (unless + (> (file-length (open classfile :direction :input)) + 0) + ;;; TODO hook into a real ABCL compiler condition hierarchy + (signal "Internal compiler error detected: Fasl contains ~ +zero-length jvm classfile corresponding to ~A." classfile))) + (if (> *safety* *speed*) + (progn + (warn "Because(> *safety* *speed*): Testing fasl via ~ +the potentially slow loading of its JVM bytecode." ) + (let ((*load-truename* *output-file-pathname*)) + (report-error + (load-compiled-function classfile)))) + t)) (declaim (ftype (function (t) t) note-toplevel-form)) (defun note-toplevel-form (form) @@ -150,7 +157,8 @@ ;; and its arguments may be (and should be) more efficient. (return-from convert-toplevel-form (precompiler:precompile-form form nil *compile-file-environment*))) - (let* ((expr `(lambda () ,form)) + (let* ((toplevel-form (third form)) + (expr `(lambda () ,form)) (saved-class-number *class-number*) (classfile (next-classfile-name)) (result @@ -161,17 +169,34 @@ :if-exists :supersede) (report-error (jvm:compile-defun nil expr *compile-file-environment* - classfile f declare-inline)))) - (compiled-function (verify-load classfile))) + classfile f + declare-inline)))) + (compiled-function (handler-case (verify-load classfile) + (t (c) + (error "Compilation failed for JVM class number ~A +corresponding to form ~A~&with condition ~A" + saved-class-number toplevel-form c))))) (declare (ignore result)) - (setf form - (if compiled-function - `(funcall (sys::get-fasl-function *fasl-loader* - ,saved-class-number)) - (precompiler:precompile-form form nil - *compile-file-environment*))))) - - + (progn + (when (> *debug* 0) + ;;; ??? define an API by perhaps exporting these symbols? + (setf (getf form 'form-source) + toplevel-form + + (getf form 'classfile) + classfile + + (getf form 'compiled-function) + compiled-function + + (getf form 'class-number) + saved-class-number)) + (setf form + (if compiled-function + `(funcall (sys::get-fasl-function *fasl-loader* + ,saved-class-number)) + (precompiler:precompile-form form nil + *compile-file-environment*)))))) (declaim (ftype (function (t stream t) t) process-progn)) From mevenson at common-lisp.net Mon Apr 16 11:38:08 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 16 Apr 2012 04:38:08 -0700 Subject: [armedbear-cvs] r13913 - trunk/abcl Message-ID: Author: mevenson Date: Mon Apr 16 04:38:05 2012 New Revision: 13913 Log: build: fix cause of erroneous complaint for java-1.6.0_31 (and the rest). Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml Sun Apr 15 09:24:45 2012 (r13912) +++ trunk/abcl/build.xml Mon Apr 16 04:38:05 2012 (r13913) @@ -146,7 +146,7 @@ - + From mevenson at common-lisp.net Mon Apr 16 11:49:49 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 16 Apr 2012 04:49:49 -0700 Subject: [armedbear-cvs] r13914 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon Apr 16 04:49:48 2012 New Revision: 13914 Log: compiler: don't signal a warning for compiler optimization decision diagnostics. Set the variable SYSTEM::*DIAGNOSTIC* to nil to muffle the output. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Mon Apr 16 04:38:05 2012 (r13913) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Mon Apr 16 04:49:48 2012 (r13914) @@ -83,6 +83,9 @@ (declare (ignore ignored)) (assert nil)) +(defparameter *diagnostic* t + "The stream to emit compiler diagnostic messages to, or nil to muffle output.") + (declaim (ftype (function (t) t) verify-load)) (defun verify-load (classfile) (and classfile @@ -94,8 +97,8 @@ zero-length jvm classfile corresponding to ~A." classfile))) (if (> *safety* *speed*) (progn - (warn "Because(> *safety* *speed*): Testing fasl via ~ -the potentially slow loading of its JVM bytecode." ) + (format *diagnostic* + "~&SYSTEM::*DIAGNOSTIC* Testing compiled bytecode by loading classfile into JVM because (> *safety* *speed*).~%") (let ((*load-truename* *output-file-pathname*)) (report-error (load-compiled-function classfile)))) From mevenson at common-lisp.net Mon Apr 16 20:13:04 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 16 Apr 2012 13:13:04 -0700 Subject: [armedbear-cvs] r13915 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon Apr 16 13:13:03 2012 New Revision: 13915 Log: compiler: don't signal conditions for fasl verification error and muffle diagnostics by default. HEADS UP: problems seem to exist ANSI tests, which triggers the attempt to load the fasl classfile to verify its integrity. Don't signal problems just yet, until satisfied that the correct diagnostic messages are being triggered. Refactored diagnostics interface to use a new SYS::DIAG macro whose output is directed to the value of SYS:*COMPILER-DIAGNOSTIC*. This should be reconsidered in view of all the diagnostic frameworks when I understand how they are to be used Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Mon Apr 16 04:49:48 2012 (r13914) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Mon Apr 16 13:13:03 2012 (r13915) @@ -83,26 +83,31 @@ (declare (ignore ignored)) (assert nil)) -(defparameter *diagnostic* t +;;; ??? rename to something shorter? +(defparameter *compiler-diagnostic* nil "The stream to emit compiler diagnostic messages to, or nil to muffle output.") +(export '*compiler-diagnostic*) +(defmacro diag (fmt &rest args) + `(format *compiler-diagnostic* "~&SYSTEM::*COMPILER-DIAGNOSTIC* ~A~&" (format nil ,fmt , at args))) (declaim (ftype (function (t) t) verify-load)) -(defun verify-load (classfile) - (and classfile - (unless - (> (file-length (open classfile :direction :input)) - 0) +(defun verify-load (classfile &key (force nil)) + "Return whether the file at the path denoted by CLASSFILE is a loadable JVM artifact." + (unless classfile + (diag "Nil classfile argument passed to verify-load.") + (return-from verify-load nil)) + (when + (= 0 (file-length (open classfile :direction :input))) ;;; TODO hook into a real ABCL compiler condition hierarchy - (signal "Internal compiler error detected: Fasl contains ~ -zero-length jvm classfile corresponding to ~A." classfile))) - (if (> *safety* *speed*) - (progn - (format *diagnostic* - "~&SYSTEM::*DIAGNOSTIC* Testing compiled bytecode by loading classfile into JVM because (> *safety* *speed*).~%") - (let ((*load-truename* *output-file-pathname*)) - (report-error - (load-compiled-function classfile)))) - t)) + (diag "Internal compiler error detected: Fasl contains ~ +zero-length jvm classfile corresponding to ~A." classfile) + (return-from verify-load nil)) + (when (or force (> *safety* *speed*)) + (diag "Testing compiled bytecode by loading classfile into JVM.") + (let ((*load-truename* *output-file-pathname*)) + ;; load-compiled-function used to be wrapped via report-error + (return-from verify-load (load-compiled-function classfile)))) + t) (declaim (ftype (function (t) t) note-toplevel-form)) (defun note-toplevel-form (form) @@ -174,14 +179,12 @@ expr *compile-file-environment* classfile f declare-inline)))) - (compiled-function (handler-case (verify-load classfile) - (t (c) - (error "Compilation failed for JVM class number ~A -corresponding to form ~A~&with condition ~A" - saved-class-number toplevel-form c))))) - (declare (ignore result)) + (compiled-function (verify-load classfile))) + (declare (ignore toplevel-form result)) (progn + #+nil (when (> *debug* 0) +;; TODO (annotate form toplevel-form classfile compiled-function fasl-class-number) ;;; ??? define an API by perhaps exporting these symbols? (setf (getf form 'form-source) toplevel-form From mevenson at common-lisp.net Mon Apr 16 21:24:36 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 16 Apr 2012 14:24:36 -0700 Subject: [armedbear-cvs] r13916 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon Apr 16 14:24:36 2012 New Revision: 13916 Log: ansi-interpreted: restore execution. Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Mon Apr 16 13:13:03 2012 (r13915) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Mon Apr 16 14:24:36 2012 (r13916) @@ -93,6 +93,7 @@ (declaim (ftype (function (t) t) verify-load)) (defun verify-load (classfile &key (force nil)) "Return whether the file at the path denoted by CLASSFILE is a loadable JVM artifact." + (declare (ignore force)) (unless classfile (diag "Nil classfile argument passed to verify-load.") (return-from verify-load nil)) @@ -102,6 +103,7 @@ (diag "Internal compiler error detected: Fasl contains ~ zero-length jvm classfile corresponding to ~A." classfile) (return-from verify-load nil)) + #+nil (when (or force (> *safety* *speed*)) (diag "Testing compiled bytecode by loading classfile into JVM.") (let ((*load-truename* *output-file-pathname*)) From mevenson at common-lisp.net Mon Apr 16 22:09:15 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 16 Apr 2012 15:09:15 -0700 Subject: [armedbear-cvs] r13917 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon Apr 16 15:09:14 2012 New Revision: 13917 Log: SYS:AVAILABLE-ENCODINGS returns a list of formats suitable for stream construction. The implementation may actually accept additional synonyms, but they will all be mapped to these underlying encodings native to the hosting JVM. The contents of this list are JVM implementation dependent. 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 Mon Apr 16 14:24:36 2012 (r13916) +++ trunk/abcl/src/org/armedbear/lisp/Stream.java Mon Apr 16 15:09:14 2012 (r13917) @@ -50,6 +50,11 @@ import java.nio.charset.Charset; import java.util.BitSet; +import java.util.List; +import java.util.LinkedList; +import java.util.SortedMap; +import java.util.Set; + import org.armedbear.lisp.util.DecodingReader; /** The stream class @@ -142,6 +147,7 @@ public Stream(Symbol structureClass, InputStream inputStream, LispObject elementType) { this(structureClass, inputStream, elementType, keywordDefault); } + // Input stream constructors. @@ -330,6 +336,35 @@ ((DecodingReader)reader).setCharset(Charset.forName(encoding)); } + + public static final Primitive AVAILABLE_ENCODINGS = new pf_available_encodings(); + @DocString(name="available-encodings", + returns="encodings", + doc="Returns all charset encodings suitable for passing to a stream constructor available at runtime.") + private static final class pf_available_encodings extends Primitive { + pf_available_encodings() { + super("available-encodings", PACKAGE_SYS, true); + } + public LispObject execute() { + LispObject result = NIL; + for (Symbol encoding : availableEncodings()) { + result = result.push(encoding); + } + return result.nreverse(); + } + } + + static public List availableEncodings() { + List result = new LinkedList(); + + SortedMap available = Charset.availableCharsets(); + Set encodings = available.keySet(); + for (String charset : encodings) { + result.add(new Symbol(charset)); + } + return result; + } + public boolean isOpen() { return open; } From mevenson at common-lisp.net Wed Apr 18 08:38:16 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 18 Apr 2012 01:38:16 -0700 Subject: [armedbear-cvs] r13918 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Wed Apr 18 01:38:15 2012 New Revision: 13918 Log: SYS:AVAILABLE-ENCODINGS now returns symbols in the KEYWORD package. 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 Mon Apr 16 15:09:14 2012 (r13917) +++ trunk/abcl/src/org/armedbear/lisp/Stream.java Wed Apr 18 01:38:15 2012 (r13918) @@ -360,7 +360,7 @@ SortedMap available = Charset.availableCharsets(); Set encodings = available.keySet(); for (String charset : encodings) { - result.add(new Symbol(charset)); + result.add(new Symbol(charset, PACKAGE_KEYWORD)); } return result; } From mevenson at common-lisp.net Sun Apr 22 11:46:02 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sun, 22 Apr 2012 04:46:02 -0700 Subject: [armedbear-cvs] r13919 - trunk/abcl Message-ID: Author: mevenson Date: Sun Apr 22 04:46:01 2012 New Revision: 13919 Log: build: Use the 'abcl.diagnostic' Ant target to describe the hosting JVM as plist :key value pairs. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml Wed Apr 18 01:38:15 2012 (r13918) +++ trunk/abcl/build.xml Sun Apr 22 04:46:01 2012 (r13919) @@ -959,7 +959,59 @@ Finished recording test output in ${abcl.test.log.file}. - + + + + + + + :java.version ${java.version} + :java.vendor ${java.vendor} + :java.vm.vendor ${java.vm.vendor} + :java.vm.name ${java.vm.name} + + :os.name ${os.name} + :os.arch ${os.arch} + :os.version ${os.version} + + :java.specification.version ${java.specification.version} + :java.vm.specification.version ${java.vm.specification.version} + + Author: astalla Date: Mon Apr 23 14:14:43 2012 New Revision: 13920 Log: runtime-class: support for :boolean return value in methods Modified: trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Modified: trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Sun Apr 22 04:46:01 2012 (r13919) +++ trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Mon Apr 23 14:14:43 2012 (r13920) @@ -142,6 +142,9 @@ ((eq return-type :int) (emit-invokevirtual +lisp-object+ "intValue" nil :int) (emit 'ireturn)) + ((eq return-type :boolean) + (emit-invokevirtual +lisp-object+ "getBooleanValue" nil :boolean) + (emit 'ireturn)) ((jvm-class-name-p return-type) (emit-invokevirtual +lisp-object+ "javaInstance" nil +java-object+) (emit-checkcast return-type) From mevenson at common-lisp.net Tue Apr 24 21:04:02 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 24 Apr 2012 14:04:02 -0700 Subject: [armedbear-cvs] r13921 - trunk/abcl Message-ID: Author: mevenson Date: Tue Apr 24 14:04:01 2012 New Revision: 13921 Log: build: runtime-class.lisp source compiles again, so don't exclude it from check. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml Mon Apr 23 14:14:43 2012 (r13920) +++ trunk/abcl/build.xml Tue Apr 24 14:04:01 2012 (r13921) @@ -206,7 +206,6 @@ - From mevenson at common-lisp.net Mon Apr 30 07:47:20 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 30 Apr 2012 00:47:20 -0700 Subject: [armedbear-cvs] r13922 - in trunk/abcl: doc/asdf src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon Apr 30 00:47:19 2012 New Revision: 13922 Log: asdf: update to asdf-2.21 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 Tue Apr 24 14:04:01 2012 (r13921) +++ trunk/abcl/doc/asdf/asdf.texinfo Mon Apr 30 00:47:19 2012 (r13922) @@ -35,11 +35,11 @@ You can find the latest version of this manual at @url{http://common-lisp.net/project/asdf/asdf.html}. -ASDF Copyright @copyright{} 2001-2011 Daniel Barlow and contributors. +ASDF Copyright @copyright{} 2001-2012 Daniel Barlow and contributors. -This manual Copyright @copyright{} 2001-2011 Daniel Barlow and contributors. +This manual Copyright @copyright{} 2001-2012 Daniel Barlow and contributors. -This manual revised @copyright{} 2009-2011 Robert P. Goldman and Francois-Rene Rideau. +This manual revised @copyright{} 2009-2012 Robert P. Goldman and Francois-Rene Rideau. Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the @@ -197,6 +197,7 @@ @vindex *central-registry* @cindex link farm @findex load-system + at findex require-system @findex compile-system @findex test-system @cindex system directory designator @@ -219,10 +220,11 @@ As of the writing of this manual, the following implementations provide ASDF 2 this way: -abcl allegro ccl clisp cmucl ecl sbcl xcl. -The following implementations don't provide it yet but will in a future release: -lispworks scl. -The following implementations are obsolete and most probably will never bundle it: +abcl allegro ccl clisp cmucl ecl lispworks sbcl xcl. +The following implementation doesn't provide it yet but will in a future release: +scl. +The following implementations are obsolete, not actively maintained, +and most probably will never bundle it: cormancl gcl genera mcl. If the implementation you are using doesn't provide ASDF 2, @@ -667,6 +669,8 @@ ASDF provides three commands for the most common system operations: @code{load-system}, @code{compile-system} or @code{test-system}. +It also provides @code{require-system}, a version of @code{load-system} +that skips trying to update systems that are already loaded. Because ASDF is an extensible system for defining @emph{operations} on @emph{components}, @@ -2081,7 +2085,7 @@ STRING | ;; relative directory pathname as interpreted by coerce-pathname. ;; In output translations, if last component, **/*.*.* is added PATHNAME | ;; pathname; unless last component, directory is assumed. - :IMPLEMENTATION | ;; directory based on implementation, e.g. sbcl-1.0.49-linux-x64 + :IMPLEMENTATION | ;; directory based on implementation, e.g. sbcl-1.0.45-linux-x64 :IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl :DEFAULT-DIRECTORY | ;; a relativized version of the default directory :*/ | ;; any direct subdirectory (since ASDF 2.011.4) @@ -2904,6 +2908,147 @@ checking that some compile-time side-effects were properly balanced, etc. +Note that there is no around-load hook. This is on purpose. +Some implementations such as ECL or GCL link object files, +which allows for no such hook. +Other implementations allow for concatenating FASL files, +which doesn't allow for such a hook either. +We aim to discourage something that's not portable, +and has some dubious impact on performance and semantics +even when it is possible. +Things you might want to do with an around-load hook +are better done around-compile, +though it may at times require some creativity +(see e.g. the @code{package-renaming} system). + + + at section Controlling source file character encoding + +Starting with ASDF 2.21, components accept a @code{:encoding} option. +By default, only @code{:default}, @code{:utf-8} +and @code{:autodetect} are accepted. + at code{:autodetect} is the default, and calls + at code{*encoding-detection-hook*} which by default always returns + at code{*default-encoding*} which itself defaults to @code{:default}. +In other words, there now are plenty of extension hooks, but +by default ASDF follows the backwards compatible behavior +of using whichever @code{:default} encoding your implementation uses, +which itself may or may not vary based on environment variables +and other locale settings. +In practice this means that only source code that only uses ASCII +is guaranteed to be read the same on all implementations +independently from any user setting. + +Additionally, for backward-compatibility with older versions of ASDF +and/or with implementations that do not support unicode and its many encodings, +you may want to use +the reader conditionals @code{#+asdf-unicode #+asdf-unicode} +to protect any @code{:encoding @emph{encoding}} statement +as @code{:asdf-unicode} will be present in @code{*features*} +only if you're using a recent ASDF +on an implementation that supports unicode. +We recommend that you avoid using unprotected @code{:encoding} specifications +until after ASDF 2.21 becomes widespread, hopefully by the end of 2012. + +While it offers plenty of hooks for extension, +and one such extension is being developed (see below), +ASDF itself only recognizes one encoding beside @code{:default}, +and that is @code{:utf-8}, which is the @emph{de facto} standard, +already used by the vast majority of libraries that use more than ASCII. +On implementations that do not support unicode, +the feature @code{:asdf-unicode} is absent, and +the @code{:default} external-format is used +to read even source files declared as @code{:utf-8}. +On these implementations, non-ASCII characters +intended to be read as one CL character +may thus end up being read as multiple CL characters. +In most cases, this shouldn't affect the software's semantics: +comments will be skipped just the same, strings with be read and printed +with slightly different lengths, symbol names will be accordingly longer, +but none of it should matter. +But a few systems that actually depend on unicode characters +may fail to work properly, or may work in a subtly different way. +See for instance @code{lambda-reader}. + +We invite you to embrace UTF-8 +as the encoding for non-ASCII characters starting today, +even without any explicit specification in your @code{.asd} files. +Indeed, on some implementations and configurations, +UTF-8 is already the @code{:default}, +and loading your code may cause errors if it is encoded in anything but UTF-8. +Therefore, even with the legacy behavior, +non-UTF-8 is guaranteed to break for some users, +whereas UTF-8 is pretty much guaranteed not to break anywhere +(provided you do @emph{not} use a BOM), +although it might be read incorrectly on some implementations. +In the future, we intend to make @code{:utf-8} +the default value of @code{*default-encoding*}, +to be enforced everywhere, so at least the code is guaranteed +to be read correctly everywhere it can be. + +If you need non-standard character encodings for your source code, +use the extension system @code{asdf-encodings}, by specifying + at code{:defsystem-depends-on (:asdf-encodings)} in your @code{defsystem}. +This extension system will register support for more encodings using the + at code{*encoding-external-format-hook*} facility, +so you can explicitly specify @code{:encoding :latin1} +in your @code{.asd} file. +Using the @code{*encoding-detection-hook*} it will also +eventually implement some autodetection of a file's encoding +from an emacs-style @code{-*- mode: lisp ; coding: latin1 -*-} declaration, +or otherwise based on an analysis of octet patterns in the file. +At this point, asdf-encoding only supports the encodings +that are supported as part of your implementation. +Since the list varies depending on implementations, +we once again recommend you use @code{:utf-8} everywhere, +which is the most portable (next is @code{:latin1}). + +If you're not using a version of Quicklisp that has it, +you may get the source for @code{asdf-encodings} using git: + at kbd{git clone git://common-lisp.net/projects/asdf/asdf-encodings.git} +or + at kbd{git clone ssh://common-lisp.net/project/asdf/git/asdf-encodings.git}. +You can also browse the repository on + at url{http://common-lisp.net/gitweb?p=projects/asdf/asdf-encodings.git}. + +In the future, we intend to change the default @code{*default-encoding*} +to @code{:utf-8}, which is already the de facto standard +for most libraries that use non-ASCII characters: +utf-8 works everywhere and was backhandedly enforced by +a lot of people using SBCL and utf-8 and sending reports to authors +so they make their packages compatible. +A survey showed only about a handful few libraries +are incompatible with non-UTF-8, and then, only in comments, +and we believe that authors will adopt UTF-8 when prompted. +See the April 2012 discussion on the asdf-devel mailing-list. +For backwards compatibility with users who insist on a non-UTF-8 encoding, +but cannot immediately transition to using @code{asdf-encodings} +(maybe because it isn't ready), it will still be possible to use +the @code{:encoding :default} option in your @code{defsystem} form +to restore the behavior of ASDF 2.20 and earlier. +This shouldn't be required in libraries, +because user pressure as mentioned above will already have pushed +library authors towards using UTF-8; +but authors of end-user programs might care. + +When you use @code{asdf-encodings}, any further loaded @code{.asd} file +will use the autodetection algorithm to determine its encoding; +yet if you depend on this detection happening, +you may want to explicitly load @code{asdf-encodings} early in your build, +for by the time you can use @code{:defsystem-depends-on}, +it is already too late to load it. +In practice, this means that the @code{*default-encoding*} +is usually used for @code{.asd} files. +Currently, this defaults to @code{:default} for backwards compatibility, +and that means that you shouldn't rely on non-ASCII characters in a .asd file. +Since component (path)names are the only real data in these files, +and non-ASCII characters are not very portable for file names, +this isn't too much of an issue. +We still encourage you to use either plain ASCII or UTF-8 +in @code{.asd} files, +as we intend to make @code{:utf-8} the default encoding in the future. +This might matter, for instance, in meta-data about author's names. + @section Miscellaneous Exported Functions @@ -3005,10 +3150,10 @@ This function is obsolete and present only for the sake of backwards-compatibility: ``If it's not backwards, it's not compatible''. We strongly discourage its use. Its current behavior is only well-defined on Unix platforms -(which includes MacOS X and cygwin). On Windows, anything goes. +(which include MacOS X and cygwin). On Windows, anything goes. Instead we recommend the use of such a function as - at code{xcvb-driver:run-program/process-output-stream} + at code{xcvb-driver:run-program/} from the @code{xcvb-driver} system that is distributed with XCVB: @url{http://common-lisp.net/project/xcvb}. It's only alternative that supports @@ -3017,7 +3162,7 @@ (The only unsupported exception is Genera, since on it @code{run-shell-command} doesn't make sense anyway on that platform). -This function takes as arguments a @code{format} control-string + at code{run-shell-command} takes as arguments a @code{format} control-string and arguments to be passed to @code{format} after this control-string to produce a string. This string is a command that will be evaluated with a POSIX shell if possible; Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/asdf.lisp Tue Apr 24 14:04:01 2012 (r13921) +++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Mon Apr 30 00:47:19 2012 (r13922) @@ -1,5 +1,5 @@ -;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; This is ASDF 2.20: Another System Definition Facility. +;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- +;;; This is ASDF 2.21: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to . @@ -19,7 +19,7 @@ ;;; http://www.opensource.org/licenses/mit-license.html on or about ;;; Monday; July 13, 2009) ;;; -;;; Copyright (c) 2001-2011 Daniel Barlow and contributors +;;; Copyright (c) 2001-2012 Daniel Barlow and contributors ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this software and associated documentation files (the @@ -47,27 +47,33 @@ #+xcvb (module ()) -(cl:in-package #-genera :common-lisp-user #+genera :future-common-lisp-user) +(cl:in-package :common-lisp-user) +#+genera (in-package :future-common-lisp-user) #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl) (error "ASDF is not supported on your implementation. Please help us port it.") +;;;; Create and setup packages in a way that is compatible with hot-upgrade. +;;;; See https://bugs.launchpad.net/asdf/+bug/485687 +;;;; See these two eval-when forms, and more near the end of the file. + #+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this -(eval-when (:compile-toplevel :load-toplevel :execute) - ;;; Implementation-dependent tweaks +(eval-when (:load-toplevel :compile-toplevel :execute) + ;;; Before we do anything, some implementation-dependent tweaks ;; (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* :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below - #+ecl (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t)) - #+ecl (unless (use-ecl-byte-compiler-p) (require :cmp)) #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011 (when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 fails to fully compile ASDF at all (and (= system::*gcl-major-version* 2) (< system::*gcl-minor-version* 7))) (pushnew :gcl-pre2.7 *features*)) + #+(or abcl (and allegro ics) (and clisp unicode) clozure (and cmu unicode) + (and ecl unicode) lispworks (and sbcl sb-unicode) scl) + (pushnew :asdf-unicode *features*) ;;; make package if it doesn't exist yet. ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it. (unless (find-package :asdf) @@ -75,11 +81,13 @@ (in-package :asdf) -;;;; Create packages in a way that is compatible with hot-upgrade. -;;;; See https://bugs.launchpad.net/asdf/+bug/485687 -;;;; See more near the end of the file. - (eval-when (:load-toplevel :compile-toplevel :execute) + ;;; This would belong amongst implementation-dependent tweaks above, + ;;; except that the defun has to be in package asdf. + #+ecl (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t)) + #+ecl (unless (use-ecl-byte-compiler-p) (require :cmp)) + + ;;; Package setup, step 2. (defvar *asdf-version* nil) (defvar *upgraded-p* nil) (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12. @@ -108,7 +116,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.20") + (asdf-version "2.21") (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -168,6 +176,12 @@ (ensure-shadow (package symbols) (shadow symbols package)) (ensure-use (package use) + (dolist (used (package-use-list package)) + (unless (member (package-name used) use :test 'string=) + (unuse-package used) + (do-external-symbols (sym used) + (when (eq sym (find-symbol* sym package)) + (remove-symbol sym package))))) (dolist (used (reverse use)) (do-external-symbols (sym used) (unless (eq sym (find-symbol* sym package)) @@ -199,10 +213,10 @@ (ensure-package (name &key nicknames use unintern shadow export redefined-functions) (let* ((p (ensure-exists name nicknames use))) - (ensure-unintern p unintern) + (ensure-unintern p (append unintern #+cmu redefined-functions)) (ensure-shadow p shadow) (ensure-export p export) - (ensure-fmakunbound p redefined-functions) + #-cmu (ensure-fmakunbound p redefined-functions) p))) (macrolet ((pkgdcl (name &key nicknames use export @@ -234,11 +248,12 @@ (#:defsystem #:oos #:operate #:find-system #:locate-system #:run-shell-command #:system-definition-pathname #:with-system-definitions #:search-for-system-definition #:find-component #:component-find-path - #:compile-system #:load-system #:load-systems #:test-system #:clear-system + #:compile-system #:load-system #:load-systems + #:require-system #:test-system #:clear-system #:operation #:compile-op #:load-op #:load-source-op #:test-op #:feature #:version #:version-satisfies #:upgrade-asdf - #:implementation-identifier #:implementation-type + #:implementation-identifier #:implementation-type #:hostname #:input-files #:output-files #:output-file #:perform #:operation-done-p #:explain @@ -255,7 +270,7 @@ #:unix-dso #:module-components ; component accessors - #:module-components-by-name ; component accessors + #:module-components-by-name #:component-pathname #:component-relative-pathname #:component-name @@ -263,8 +278,9 @@ #:component-parent #:component-property #:component-system - #:component-depends-on + #:component-encoding + #:component-external-format #:system-description #:system-long-description @@ -281,9 +297,9 @@ #:operation-on-warnings #:operation-on-failure #:component-visited-p - ;;#:*component-parent-pathname* - #:*system-definition-search-functions* - #:*central-registry* ; variables + + #:*system-definition-search-functions* ; variables + #:*central-registry* #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* #:*resolve-symlinks* @@ -312,6 +328,11 @@ #:coerce-entry-to-directory #:remove-entry-from-registry + #:*encoding-detection-hook* + #:*encoding-external-format-hook* + #:*default-encoding* + #:*utf-8-external-format* + #:clear-configuration #:*output-translations-parameter* #:initialize-output-translations @@ -329,7 +350,8 @@ #:clear-source-registry #:ensure-source-registry #:process-source-registry - #:system-registered-p + #:system-registered-p #:registered-systems #:loaded-systems + #:resolve-location #:asdf-message #:user-output-translations-pathname #:system-output-translations-pathname @@ -341,28 +363,31 @@ #:system-source-registry-directory ;; Utilities - #:absolute-pathname-p ;; #:aif #:it - ;; #:appendf #:orf + #:appendf #:orf + #:length=n-p + #:remove-keys #:remove-keyword + #:first-char #:last-char #:ends-with #:coerce-name - #:directory-pathname-p - ;; #:ends-with - #:ensure-directory-pathname + #:directory-pathname-p #:ensure-directory-pathname + #:absolute-pathname-p #:ensure-pathname-absolute #:pathname-root #:getenv - ;; #:length=n-p - ;; #:find-symbol* - #:merge-pathnames* #:coerce-pathname #:subpathname - #:pathname-directory-pathname + #:probe-file* + #:find-symbol* #:strcat + #:make-pathname-component-logical #:make-pathname-logical + #:merge-pathnames* #:coerce-pathname #:subpathname #:subpathname* + #:pathname-directory-pathname #:pathname-parent-directory-pathname #:read-file-forms - ;; #:remove-keys - ;; #:remove-keyword - #:resolve-symlinks + #:resolve-symlinks #:truenamize #:split-string #:component-name-to-pathname-components #:split-name-type - #:subdirectories - #:truenamize - #:while-collecting))) + #:subdirectories #:directory-files + #:while-collecting + #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* + #:*wild-path* #:wilden + #:directorize-pathname-host-device + ))) #+genera (import 'scl:boolean :asdf) (setf *asdf-version* asdf-version *upgraded-p* (if existing-version @@ -481,6 +506,7 @@ (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars)))))) (defmacro aif (test then &optional else) + "Anaphoric version of IF, On Lisp style" `(let ((it ,test)) (if it ,then ,else))) (defun* pathname-directory-pathname (pathname) @@ -490,8 +516,9 @@ (make-pathname :name nil :type nil :version nil :defaults pathname))) (defun* normalize-pathname-directory-component (directory) + "Given a pathname directory component, return an equivalent form that is a list" (cond - #-(or cmu sbcl scl) + #-(or cmu sbcl scl) ;; these implementations already normalize directory components. ((stringp directory) `(:absolute ,directory) directory) #+gcl ((and (consp directory) (stringp (first directory))) @@ -503,6 +530,7 @@ (error (compatfmt "~@") directory)))) (defun* merge-pathname-directory-components (specified defaults) + ;; Helper for merge-pathnames* that handles directory components. (let ((directory (normalize-pathname-directory-component specified))) (ecase (first directory) ((nil) defaults) @@ -524,8 +552,23 @@ :do (pop reldir) (pop defrev) :finally (return (cons defabs (append (reverse defrev) reldir))))))))))) -(defun* ununspecific (x) - (if (eq x :unspecific) nil x)) +(defun* make-pathname-component-logical (x) + "Make a pathname component suitable for use in a logical-pathname" + (typecase x + ((eql :unspecific) nil) + #+clisp (string (string-upcase x)) + #+clisp (cons (mapcar 'make-pathname-component-logical x)) + (t x))) + +(defun* make-pathname-logical (pathname host) + "Take a PATHNAME's directory, name, type and version components, +and make a new pathname with corresponding components and specified logical HOST" + (make-pathname + :host host + :directory (make-pathname-component-logical (pathname-directory pathname)) + :name (make-pathname-component-logical (pathname-name pathname)) + :type (make-pathname-component-logical (pathname-type pathname)) + :version (make-pathname-component-logical (pathname-version pathname)))) (defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*)) "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that @@ -546,7 +589,7 @@ (type (or (pathname-type specified) (pathname-type defaults))) (version (or (pathname-version specified) (pathname-version defaults)))) (labels ((unspecific-handler (p) - (if (typep p 'logical-pathname) #'ununspecific #'identity))) + (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity))) (multiple-value-bind (host device directory unspecific-handler) (ecase (first directory) ((:absolute) @@ -614,8 +657,9 @@ (let ((unspecific ;; Giving :unspecific as argument to make-pathname is not portable. ;; See CLHS make-pathname and 19.2.2.2.3. - ;; We only use it on implementations that support it. - (or #+(or clozure gcl lispworks sbcl) :unspecific))) + ;; We only use it on implementations that support it, + #+(or abcl allegro clozure cmu gcl genera lispworks sbcl scl xcl) :unspecific + #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil)) (destructuring-bind (name &optional (type unspecific)) (split-string filename :max 2 :separator ".") (if (equal name "") @@ -745,6 +789,56 @@ (and (typep pathspec '(or pathname string)) (eq :absolute (car (pathname-directory (pathname pathspec)))))) +(defun* coerce-pathname (name &key type defaults) + "coerce NAME into a PATHNAME. +When given a string, portably decompose it into a relative pathname: +#\\/ separates subdirectories. The last #\\/-separated string is as follows: +if TYPE is NIL, its last #\\. if any separates name and type from from type; +if TYPE is a string, it is the type, and the whole string is the name; +if TYPE is :DIRECTORY, the string is a directory component; +if the string is empty, it's a directory. +Any directory named .. is read as :BACK. +Host, device and version components are taken from DEFAULTS." + ;; The defaults are required notably because they provide the default host + ;; to the below make-pathname, which may crucially matter to people using + ;; merge-pathnames with non-default hosts, e.g. for logical-pathnames. + ;; NOTE that the host and device slots will be taken from the defaults, + ;; but that should only matter if you later merge relative pathnames with + ;; CL:MERGE-PATHNAMES instead of ASDF:MERGE-PATHNAMES* + (etypecase name + ((or null pathname) + name) + (symbol + (coerce-pathname (string-downcase name) :type type :defaults defaults)) + (string + (multiple-value-bind (relative path filename) + (component-name-to-pathname-components name :force-directory (eq type :directory) + :force-relative t) + (multiple-value-bind (name type) + (cond + ((or (eq type :directory) (null filename)) + (values nil nil)) + (type + (values filename type)) + (t + (split-name-type filename))) + (apply 'make-pathname :directory (cons relative path) :name name :type type + (when defaults `(:defaults ,defaults)))))))) + +(defun* merge-component-name-type (name &key type defaults) + ;; For backwards compatibility only, for people using internals. + ;; Will be removed in a future release, e.g. 2.016. + (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.") + (coerce-pathname name :type type :defaults defaults)) + +(defun* subpathname (pathname subpath &key type) + (and pathname (merge-pathnames* (coerce-pathname subpath :type type) + (pathname-directory-pathname pathname)))) + +(defun subpathname* (pathname subpath &key type) + (and pathname + (subpathname (ensure-directory-pathname pathname) subpath :type type))) + (defun* length=n-p (x n) ;is it that (= (length x) n) ? (check-type n (integer 0 *)) (loop @@ -896,21 +990,22 @@ (host (pathname-host pathname)) (port (ext:pathname-port pathname)) (directory (pathname-directory pathname))) - (if (or (ununspecific port) - (and (ununspecific host) (plusp (length host))) - (ununspecific scheme)) + (flet ((specificp (x) (and x (not (eq x :unspecific))))) + (if (or (specificp port) + (and (specificp host) (plusp (length host))) + (specificp scheme)) (let ((prefix "")) - (when (ununspecific port) + (when (specificp port) (setf prefix (format nil ":~D" port))) - (when (and (ununspecific host) (plusp (length host))) + (when (and (specificp host) (plusp (length host))) (setf prefix (strcat host prefix))) (setf prefix (strcat ":" prefix)) - (when (ununspecific scheme) + (when (specificp scheme) (setf prefix (strcat scheme prefix))) (assert (and directory (eq (first directory) :absolute))) (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) :defaults pathname))) - pathname)) + pathname))) ;;;; ------------------------------------------------------------------------- ;;;; ASDF Interface, in terms of generic functions. @@ -948,6 +1043,10 @@ (defgeneric* (setf component-property) (new-value component property)) +(defgeneric* component-external-format (component)) + +(defgeneric* component-encoding (component)) + (eval-when (#-gcl :compile-toplevel :load-toplevel :execute) (defgeneric* (setf module-components-by-name) (new-value module))) @@ -1025,22 +1124,22 @@ ;;;; ------------------------------------------------------------------------- ;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687 (when *upgraded-p* - (when (find-class 'module nil) - (eval - '(defmethod update-instance-for-redefined-class :after - ((m module) added deleted plist &key) - (declare (ignorable deleted plist)) - (when *asdf-verbose* - (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%") - m (asdf-version))) - (when (member 'components-by-name added) - (compute-module-components-by-name m)) - (when (typep m 'system) - (when (member 'source-file added) - (%set-system-source-file - (probe-asd (component-name m) (component-pathname m)) m) - (when (equal (component-name m) "asdf") - (setf (component-version m) *asdf-version*)))))))) + (when (find-class 'module nil) + (eval + '(defmethod update-instance-for-redefined-class :after + ((m module) added deleted plist &key) + (declare (ignorable deleted plist)) + (when *asdf-verbose* + (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%") + m (asdf-version))) + (when (member 'components-by-name added) + (compute-module-components-by-name m)) + (when (typep m 'system) + (when (member 'source-file added) + (%set-system-source-file + (probe-asd (component-name m) (component-pathname m)) m) + (when (equal (component-name m) "asdf") + (setf (component-version m) *asdf-version*)))))))) ;;;; ------------------------------------------------------------------------- ;;;; Classes, Conditions @@ -1150,6 +1249,8 @@ ;; it needn't be recompiled just because one of these dependencies ;; hasn't yet been loaded in the current image (do-first). ;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52! + ;; LispWorks's defsystem has caused-by and requires for in-order-to and do-first respectively. + ;; Maybe rename the slots in ASDF? But that's not very backwards compatible. ;; See our ASDF 2 paper for more complete explanations. (in-order-to :initform nil :initarg :in-order-to :accessor component-in-order-to) @@ -1168,6 +1269,7 @@ (operation-times :initform (make-hash-table) :accessor component-operation-times) (around-compile :initarg :around-compile) + (%encoding :accessor %component-encoding :initform nil :initarg :encoding) ;; XXX we should provide some atomic interface for updating the ;; component properties (properties :accessor component-properties :initarg :properties @@ -1278,6 +1380,58 @@ (acons property new-value (slot-value c 'properties))))) new-value) +(defvar *default-encoding* :default + "Default encoding for source files. +The default value :default preserves the legacy behavior. +A future default might be :utf-8 or :autodetect +reading emacs-style -*- coding: utf-8 -*- specifications, +and falling back to utf-8 or latin1 if nothing is specified.") + +(defparameter *utf-8-external-format* + #+(and asdf-unicode (not clisp)) :utf-8 + #+(and asdf-unicode clisp) charset:utf-8 + #-asdf-unicode :default + "Default :external-format argument to pass to CL:OPEN and also +CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file. +On modern implementations, this will decode UTF-8 code points as CL characters. +On legacy implementations, it may fall back on some 8-bit encoding, +with non-ASCII code points being read as several CL characters; +hopefully, if done consistently, that won't affect program behavior too much.") + +(defun* always-default-encoding (pathname) + (declare (ignore pathname)) + *default-encoding*) + +(defvar *encoding-detection-hook* #'always-default-encoding + "Hook for an extension to define a function to automatically detect a file's encoding") + +(defun* detect-encoding (pathname) + (funcall *encoding-detection-hook* pathname)) + +(defmethod component-encoding ((c component)) + (or (loop :for x = c :then (component-parent x) + :while x :thereis (%component-encoding x)) + (detect-encoding (component-pathname c)))) + +(defun* default-encoding-external-format (encoding) + (case encoding + (:default :default) ;; for backwards compatibility only. Explicit usage discouraged. + (:utf-8 *utf-8-external-format*) + (otherwise + (cerror "Continue using :external-format :default" (compatfmt "~@") encoding) + :default))) + +(defvar *encoding-external-format-hook* + #'default-encoding-external-format + "Hook for an extension to define a mapping between non-default encodings +and implementation-defined external-format's") + +(defun encoding-external-format (encoding) + (funcall *encoding-external-format-hook* encoding)) + +(defmethod component-external-format ((c component)) + (encoding-external-format (component-encoding c))) + (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. @@ -1441,6 +1595,10 @@ (defun* system-registered-p (name) (gethash (coerce-name name) *defined-systems*)) +(defun* registered-systems () + (loop :for (() . system) :being :the :hash-values :of *defined-systems* + :collect (coerce-name system))) + (defun* register-system (system) (check-type system system) (let ((name (component-name system))) @@ -1531,10 +1689,8 @@ (defun* probe-asd (name defaults) (block nil (when (directory-pathname-p defaults) - (let ((file (make-pathname - :defaults defaults :name name - :version :newest :case :local :type "asd"))) - (when (probe-file* file) + (let* ((file (probe-file* (subpathname defaults (strcat name ".asd"))))) + (when file (return file))) #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!) (when (os-windows-p) @@ -1650,18 +1806,22 @@ :condition condition)))) (let ((*package* package) (*default-pathname-defaults* - (pathname-directory-pathname pathname))) + ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings. + (pathname-directory-pathname (translate-logical-pathname pathname))) + (external-format (encoding-external-format (detect-encoding pathname)))) (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%") pathname package) - (load pathname))) + (load pathname :external-format external-format))) (delete-package package))))) (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. +Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME +FOUNDP is true when a system 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. +PATHNAME when not null is a path from where to load the system, +either 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)) @@ -1669,7 +1829,7 @@ (previous (cdr in-memory)) (previous (and (typep previous 'system) previous)) (previous-time (car in-memory)) - (found (search-for-system-definition name)) + (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)) @@ -1715,7 +1875,7 @@ (error 'missing-component :requires name)))))) (reinitialize-source-registry-and-retry () :report (lambda (s) - (format s "~@" name)) + (format s (compatfmt "~@") name)) (initialize-source-registry)))))) (defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys) @@ -1789,48 +1949,6 @@ (declare (ignorable s)) (source-file-explicit-type component)) -(defun* coerce-pathname (name &key type defaults) - "coerce NAME into a PATHNAME. -When given a string, portably decompose it into a relative pathname: -#\\/ separates subdirectories. The last #\\/-separated string is as follows: -if TYPE is NIL, its last #\\. if any separates name and type from from type; -if TYPE is a string, it is the type, and the whole string is the name; -if TYPE is :DIRECTORY, the string is a directory component; -if the string is empty, it's a directory. -Any directory named .. is read as :BACK. -Host, device and version components are taken from DEFAULTS." - ;; The defaults are required notably because they provide the default host - ;; to the below make-pathname, which may crucially matter to people using - ;; merge-pathnames with non-default hosts, e.g. for logical-pathnames. - ;; NOTE that the host and device slots will be taken from the defaults, - ;; but that should only matter if you later merge relative pathnames with - ;; CL:MERGE-PATHNAMES instead of ASDF:MERGE-PATHNAMES* - (etypecase name - ((or null pathname) - name) - (symbol - (coerce-pathname (string-downcase name) :type type :defaults defaults)) - (string - (multiple-value-bind (relative path filename) - (component-name-to-pathname-components name :force-directory (eq type :directory) - :force-relative t) - (multiple-value-bind (name type) - (cond - ((or (eq type :directory) (null filename)) - (values nil nil)) - (type - (values filename type)) - (t - (split-name-type filename))) - (apply 'make-pathname :directory (cons relative path) :name name :type type - (when defaults `(:defaults ,defaults)))))))) - -(defun* merge-component-name-type (name &key type defaults) - ;; For backwards compatibility only, for people using internals. - ;; Will be removed in a future release, e.g. 2.016. - (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.") - (coerce-pathname name :type type :defaults defaults)) - (defmethod component-relative-pathname ((component component)) (coerce-pathname (or (slot-value component 'relative-pathname) @@ -1838,14 +1956,6 @@ :type (source-file-type component (component-system component)) :defaults (component-parent-pathname component))) -(defun* subpathname (pathname subpath &key type) - (and pathname (merge-pathnames* (coerce-pathname subpath :type type) - (pathname-directory-pathname pathname)))) - -(defun subpathname* (pathname subpath &key type) - (and pathname - (subpathname (ensure-directory-pathname pathname) subpath :type type))) - ;;;; ------------------------------------------------------------------------- ;;;; Operations @@ -1861,6 +1971,7 @@ ;; to force systems named in a given list ;; However, but this feature has only ever worked but starting with ASDF 2.014.5 (forced :initform nil :initarg :force :accessor operation-forced) + (forced-not :initform nil :initarg :force-not :accessor operation-forced-not) (original-initargs :initform nil :initarg :original-initargs :accessor operation-original-initargs) (visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes) @@ -1873,10 +1984,15 @@ (prin1 (operation-original-initargs o) stream)))) (defmethod shared-initialize :after ((operation operation) slot-names - &key force + &key force force-not &allow-other-keys) - (declare (ignorable operation slot-names force)) - ;; empty method to disable initarg validity checking + ;; the &allow-other-keys disables initarg validity checking + (declare (ignorable operation slot-names force force-not)) + (macrolet ((frob (x) ;; normalize forced and forced-not slots + `(when (consp (,x operation)) + (setf (,x operation) + (mapcar #'coerce-name (,x operation)))))) + (frob operation-forced) (frob operation-forced-not)) (values)) (defun* node-for (o c) @@ -2054,7 +2170,7 @@ comp)) (retry () :report (lambda (s) - (format s "~@" name)) + (format s (compatfmt "~@") name)) :test (lambda (c) (or (null c) @@ -2144,14 +2260,17 @@ (error 'circular-dependency :components (list c))) (setf (visiting-component operation c) t) (unwind-protect - (progn - (let ((f (operation-forced - (operation-ancestor operation)))) - (when (and f (or (not (consp f)) ;; T or :ALL - (and (typep c 'system) ;; list of names of systems to force - (member (component-name c) f - :test #'string=)))) - (setf *forcing* t))) + (block nil + (when (typep c 'system) ;; systems can be forced or forced-not + (let ((ancestor (operation-ancestor operation))) + (flet ((match? (f) + (and f (or (not (consp f)) ;; T or :ALL + (member (component-name c) f :test #'equal))))) + (cond + ((match? (operation-forced ancestor)) + (setf *forcing* t)) + ((match? (operation-forced-not ancestor)) + (return)))))) ;; first we check and do all the dependencies for the module. ;; Operations planned in this loop will show up ;; in the results, and are consumed below. @@ -2206,9 +2325,9 @@ :do (do-dep operation c collect required-op deps))) (do-collect collect (vector module-ops)) (do-collect collect (cons operation c))))) - (setf (visiting-component operation c) nil))) - (visit-component operation c (when flag (incf *visit-count*))) - flag)) + (setf (visiting-component operation c) nil))) + (visit-component operation c (when flag (incf *visit-count*))) + flag)) (defun* flatten-tree (l) ;; You collected things into a list. @@ -2227,9 +2346,6 @@ (r* l)))) (defmethod traverse ((operation operation) (c component)) - (when (consp (operation-forced operation)) - (setf (operation-forced operation) - (mapcar #'coerce-name (operation-forced operation)))) (flatten-tree (while-collecting (collect) (let ((*visit-count* 0)) @@ -2300,14 +2416,11 @@ (first files))) (defun* ensure-all-directories-exist (pathnames) - (loop :for pn :in pathnames - :for pathname = (if (typep pn 'logical-pathname) - (translate-logical-pathname pn) - pn) - :do (ensure-directories-exist pathname))) + (dolist (pathname pathnames) + (ensure-directories-exist (translate-logical-pathname pathname)))) (defmethod perform :before ((operation compile-op) (c source-file)) - (ensure-all-directories-exist (asdf:output-files operation c))) + (ensure-all-directories-exist (output-files operation c))) (defmethod perform :after ((operation operation) (c component)) (mark-operation-done operation c)) @@ -2353,7 +2466,9 @@ (call-with-around-compile-hook c #'(lambda () (apply *compile-op-compile-file-function* source-file - :output-file output-file (compile-op-flags operation)))) + :output-file output-file + :external-format (component-external-format c) + (compile-op-flags operation)))) (unless output (error 'compile-error :component c :operation operation)) (when failure-p @@ -2459,7 +2574,8 @@ (declare (ignorable o)) (let ((source (component-pathname c))) (setf (component-property c 'last-loaded-as-source) - (and (call-with-around-compile-hook c #'(lambda () (load source))) + (and (call-with-around-compile-hook + c #'(lambda () (load source :external-format (component-external-format c)))) (get-universal-time))))) (defmethod perform ((operation load-source-op) (c static-file)) @@ -2521,7 +2637,7 @@ ;;;; Separating this into a different function makes it more forward-compatible (defun* cleanup-upgraded-asdf (old-version) - (let ((new-version (asdf:asdf-version))) + (let ((new-version (asdf-version))) (unless (equal old-version new-version) (cond ((version-satisfies new-version old-version) @@ -2547,7 +2663,7 @@ ;;;; 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))) + (let ((version (asdf-version))) (handler-bind (((or style-warning warning) #'muffle-warning)) (operate 'load-op :asdf :verbose nil)) (cleanup-upgraded-asdf version))) @@ -2629,9 +2745,18 @@ (defun* load-systems (&rest systems) (map () 'load-system systems)) +(defun component-loaded-p (c) + (and (gethash 'load-op (component-operation-times (find-component c nil))) t)) + +(defun loaded-systems () + (remove-if-not 'component-loaded-p (registered-systems))) + +(defun require-system (s) + (load-system s :force-not (loaded-systems))) + (defun* compile-system (system &rest args &key force verbose version &allow-other-keys) - "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE + "Shorthand for `(asdf:operate 'asdf:compile-op system)`. See OPERATE for details." (declare (ignore force verbose version)) (apply 'operate 'compile-op system args) @@ -2639,7 +2764,7 @@ (defun* test-system (system &rest args &key force verbose version &allow-other-keys) - "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for + "Shorthand for `(asdf:operate 'asdf:test-op system)`. See OPERATE for details." (declare (ignore force verbose version)) (apply 'operate 'test-op system args) @@ -2763,8 +2888,8 @@ ;; remove-keys form. important to keep them in sync components pathname default-component-class perform explain output-files operation-done-p - weakly-depends-on - depends-on serial in-order-to do-first + weakly-depends-on depends-on serial in-order-to + do-first (version nil versionp) ;; list ends &allow-other-keys) options @@ -2893,8 +3018,7 @@ ;;;; ;;;; As a suggested replacement which is portable to all ASDF-supported ;;;; implementations and operating systems except Genera, I recommend -;;;; xcvb-driver's xcvb-driver:run-program/process-output-stream and its -;;;; derivatives such as xcvb-driver:run-program/for-side-effects. +;;;; xcvb-driver's xcvb-driver:run-program/ and its derivatives. (defun* run-shell-command (control-string &rest args) "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and @@ -3018,6 +3142,10 @@ (system-source-file x)) (defmethod system-source-file ((system system)) + ;; might be missing when upgrading from ASDF 1 and u-i-f-r-c failed + (unless (slot-boundp system 'source-file) + (%set-system-source-file + (probe-asd (component-name system) (component-pathname system)) system)) (%system-source-file system)) (defmethod system-source-file ((system-name string)) (%system-source-file (find-system system-name))) @@ -3089,8 +3217,8 @@ #+clozure (defun* ccl-fasl-version () ;; the fasl version is target-dependent from CCL 1.8 on. - (or (and (fboundp 'ccl::target-fasl-version) - (funcall 'ccl::target-fasl-version)) + (or (let ((s 'ccl::target-fasl-version)) + (and (fboundp s) (funcall s))) (and (boundp 'ccl::fasl-version) (symbol-value 'ccl::fasl-version)) (error "Can't determine fasl version."))) @@ -3138,6 +3266,14 @@ (or (operating-system) (software-type)) (or (architecture) (machine-type))))) +(defun* hostname () + ;; Note: untested on RMCL + #+(or abcl clozure cmucl ecl genera lispworks mcl sbcl scl xcl) (machine-instance) + #+cormanlisp "localhost" ;; is there a better way? Does it matter? + #+allegro (excl.osi:gethostname) + #+clisp (first (split-string (machine-instance) :separator " ")) + #+gcl (system:gethostname)) + ;;; --------------------------------------------------------------------------- ;;; Generic support for configuration files @@ -3165,7 +3301,8 @@ (defun getenv-absolute-pathname (x &aux (s (getenv x))) (ensure-absolute-pathname* s "from (getenv ~S)" x)) (defun getenv-absolute-pathnames (x &aux (s (getenv x))) - (split-absolute-pathnames s "from (getenv ~S) = ~S" x s)) + (and (plusp (length s)) + (split-absolute-pathnames s "from (getenv ~S) = ~S" x s))) (defun* user-configuration-directories () (let ((dirs @@ -3378,7 +3515,9 @@ ((eql :implementation) (coerce-pathname (implementation-identifier) :type :directory)) ((eql :implementation-type) - (coerce-pathname (string-downcase (implementation-type)) :type :directory))))) + (coerce-pathname (string-downcase (implementation-type)) :type :directory)) + ((eql :hostname) + (coerce-pathname (hostname) :type :directory))))) (when (absolute-pathname-p r) (error (compatfmt "~@") x)) (if (or (pathnamep x) (not wilden)) r (wilden r)))) @@ -3864,23 +4003,29 @@ (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))) + ;; The first u avoids a cumbersome (truename u) error. + ;; At this point f should already be a truename, + ;; but isn't quite in CLISP, for doesn't have :version :newest + (and u (equal (ignore-errors (truename u)) (truename f)) u))) :when p :collect p) entries)) (defun* directory-files (directory &optional (pattern *wild-file*)) + (setf directory (pathname directory)) (when (wild-pathname-p directory) (error "Invalid wild in ~S" directory)) (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal) (error "Invalid file pattern ~S" pattern)) + (when (typep directory 'logical-pathname) + (setf pattern (make-pathname-logical pattern (pathname-host directory)))) (let ((entries (ignore-errors (directory* (merge-pathnames* pattern directory))))) (filter-logical-directory-results directory entries #'(lambda (f) (make-pathname :defaults directory - :name (pathname-name f) :type (ununspecific (pathname-type f)) - :version (ununspecific (pathname-version f))))))) + :name (pathname-name f) + :type (make-pathname-component-logical (pathname-type f)) + :version (make-pathname-component-logical (pathname-version f))))))) (defun* directory-asd-files (directory) (directory-files directory *wild-asd*)) @@ -3913,15 +4058,14 @@ #+(or cmu lispworks sbcl scl) x))) (filter-logical-directory-results directory dirs - (let ((prefix (normalize-pathname-directory-component - (pathname-directory directory)))) + (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory)) + '(:absolute)))) ; because allegro returns NIL for #p"FOO:" #'(lambda (d) - (let ((dir (normalize-pathname-directory-component - (pathname-directory d)))) + (let ((dir (normalize-pathname-directory-component (pathname-directory d)))) (and (consp dir) (consp (cdr dir)) (make-pathname :defaults directory :name nil :type nil :version nil - :directory (append prefix (last dir)))))))))) + :directory (append prefix (make-pathname-component-logical (last dir))))))))))) (defun* collect-asds-in-directory (directory collect) (map () collect (directory-asd-files directory)))