diff --git a/src/contrib/asdf/asdf.lisp b/src/contrib/asdf/asdf.lisp index 26ff4276daaf4177f613b87a35e93ad1dd654c23..a95826b07b3b1b4ea21d45b58ea96955fb2e0f53 100644 --- a/src/contrib/asdf/asdf.lisp +++ b/src/contrib/asdf/asdf.lisp @@ -1,5 +1,5 @@ ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; This is ASDF 2.018: Another System Definition Facility. +;;; This is ASDF 2.019: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel@common-lisp.net>. @@ -56,7 +56,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute) ;;; Implementation-dependent tweaks - ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults. + ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; NO: trust implementation defaults. #+allegro (setf excl::*autoload-package-name-alist* (remove "asdf" excl::*autoload-package-name-alist* @@ -86,6 +86,8 @@ (find-symbol (string s) p)) ;; Strip out formatting that is not supported on Genera. ;; Has to be inside the eval-when to make Lispworks happy (!) + (defun strcat (&rest strings) + (apply 'concatenate 'string strings)) (defmacro compatfmt (format) #-(or gcl genera) format #+(or gcl genera) @@ -94,10 +96,8 @@ '(("~3i~_" . "")) #+genera '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do (loop :for found = (search unsupported format) :while found :do - (setf format - (concatenate 'simple-string - (subseq format 0 found) replacement - (subseq format (+ found (length unsupported))))))) + (setf format (strcat (subseq format 0 found) replacement + (subseq format (+ found (length unsupported))))))) format) (let* (;; For bug reporting sanity, please always bump this version when you modify this file. ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version @@ -107,7 +107,7 @@ ;; "2.345.6" would be a development version in the official upstream ;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.018") + (asdf-version "2.019") (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -185,7 +185,7 @@ (push sym bothly-exported-symbols) (push sym formerly-exported-symbols))) (loop :for sym :in export :do - (unless (member sym bothly-exported-symbols :test 'string-equal) + (unless (member sym bothly-exported-symbols :test 'equal) (push sym newly-exported-symbols))) (loop :for user :in (package-used-by-list package) :for shadowing = (package-shadowing-symbols user) :do @@ -226,23 +226,19 @@ #:compile-file* #:source-file-type) :unintern (#:*asdf-revision* #:around #:asdf-method-combination - #:split #:make-collector + #:split #:make-collector #:do-dep #:do-one-dep + #:resolve-relative-location-component #:resolve-absolute-location-component #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function :export - (#:defsystem #:oos #:operate #:find-system #:run-shell-command + (#:defsystem #:oos #:operate #:find-system #:locate-system #:run-shell-command #:system-definition-pathname #:with-system-definitions - #:search-for-system-definition #:find-component ; miscellaneous - #:compile-system #:load-system #:test-system #:clear-system - #:compile-op #:load-op #:load-source-op - #:test-op - #:operation ; operations - #:feature ; sort-of operation - #:version ; metaphorically sort-of an operation - #:version-satisfies + #:search-for-system-definition #:find-component #:component-find-path + #:compile-system #:load-system #:load-systems #:test-system #:clear-system + #:operation #:compile-op #:load-op #:load-source-op #:test-op + #:feature #:version #:version-satisfies #:upgrade-asdf #:implementation-identifier #:implementation-type - - #:input-files #:output-files #:output-file #:perform ; operation methods + #:input-files #:output-files #:output-file #:perform #:operation-done-p #:explain #:component #:source-file @@ -334,11 +330,19 @@ #:process-source-registry #:system-registered-p #:asdf-message + #:user-output-translations-pathname + #:system-output-translations-pathname + #:user-output-translations-directory-pathname + #:system-output-translations-directory-pathname + #:user-source-registry + #:system-source-registry + #:user-source-registry-directory + #:system-source-registry-directory ;; Utilities #:absolute-pathname-p ;; #:aif #:it - ;; #:appendf + ;; #:appendf #:orf #:coerce-name #:directory-pathname-p ;; #:ends-with @@ -346,9 +350,7 @@ #:getenv ;; #:length=n-p ;; #:find-symbol* - #:merge-pathnames* - #:coerce-pathname - #:subpathname + #:merge-pathnames* #:coerce-pathname #:subpathname #:pathname-directory-pathname #:read-file-forms ;; #:remove-keys @@ -411,6 +413,7 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when condition-arguments condition-form condition-format condition-location coerce-name) + (ftype (function (&optional t) (values)) initialize-source-registry) #-(or cormanlisp gcl-pre2.7) (ftype (function (t t) t) (setf module-components-by-name))) @@ -419,8 +422,8 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when #+cormanlisp (progn (deftype logical-pathname () nil) - (defun* make-broadcast-stream () *error-output*) - (defun* file-namestring (p) + (defun make-broadcast-stream () *error-output*) + (defun file-namestring (p) (setf p (pathname p)) (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))) @@ -520,6 +523,9 @@ and NIL NAME, TYPE and VERSION components" :do (pop reldir) (pop defrev) :finally (return (cons defabs (append (reverse defrev) reldir))))))))))) +(defun* ununspecific (x) + (if (eq x :unspecific) nil x)) + (defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*)) "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname does not have an absolute directory, @@ -538,9 +544,7 @@ Also, if either argument is NIL, then the other argument is returned unmodified. (name (or (pathname-name specified) (pathname-name defaults))) (type (or (pathname-type specified) (pathname-type defaults))) (version (or (pathname-version specified) (pathname-version defaults)))) - (labels ((ununspecific (x) - (if (eq x :unspecific) nil x)) - (unspecific-handler (p) + (labels ((unspecific-handler (p) (if (typep p 'logical-pathname) #'ununspecific #'identity))) (multiple-value-bind (host device directory unspecific-handler) (ecase (first directory) @@ -891,24 +895,21 @@ with given pathname and if it exists return its truename." (host (pathname-host pathname)) (port (ext:pathname-port pathname)) (directory (pathname-directory pathname))) - (flet ((not-unspecific (component) - (and (not (eq component :unspecific)) component))) - (cond ((or (not-unspecific port) - (and (not-unspecific host) (plusp (length host))) - (not-unspecific scheme)) - (let ((prefix "")) - (when (not-unspecific port) - (setf prefix (format nil ":~D" port))) - (when (and (not-unspecific host) (plusp (length host))) - (setf prefix (concatenate 'string host prefix))) - (setf prefix (concatenate 'string ":" prefix)) - (when (not-unspecific scheme) - (setf prefix (concatenate 'string scheme prefix))) - (assert (and directory (eq (first directory) :absolute))) - (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) - :defaults pathname))) - (t - pathname))))) + (if (or (ununspecific port) + (and (ununspecific host) (plusp (length host))) + (ununspecific scheme)) + (let ((prefix "")) + (when (ununspecific port) + (setf prefix (format nil ":~D" port))) + (when (and (ununspecific host) (plusp (length host))) + (setf prefix (strcat host prefix))) + (setf prefix (strcat ":" prefix)) + (when (ununspecific scheme) + (setf prefix (strcat scheme prefix))) + (assert (and directory (eq (first directory) :absolute))) + (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) + :defaults pathname))) + pathname)) ;;;; ------------------------------------------------------------------------- ;;;; ASDF Interface, in terms of generic functions. @@ -1171,45 +1172,6 @@ processed in order by OPERATE.")) (properties :accessor component-properties :initarg :properties :initform nil))) -;;; I believe that the following could probably be more efficiently done -;;; by a primary method that invokes SHARED-INITIALIZE in a way that would -;;; appropriately pass the slots to have their initforms re-applied, but I -;;; do not know how to write such a method. [2011/09/02:rpg] -(defmethod reinitialize-instance :after ((obj component) &rest initargs - &key (version nil version-suppliedp) - (description nil description-suppliedp) - (long-description nil - long-description-suppliedp) - (load-dependencies nil - ld-suppliedp) - in-order-to - do-first - inline-methods - parent - properties) - "We reuse component objects from previously-existing systems, so we need to -make sure we clear them thoroughly." - (declare (ignore initargs load-dependencies - long-description description version)) - ;; this is a cache and should be cleared - (slot-makunbound obj 'absolute-pathname) - ;; component operation times are no longer valid when the component changes - (clrhash (component-operation-times obj)) - (unless version-suppliedp (slot-makunbound obj 'version)) - (unless description-suppliedp - (slot-makunbound obj 'description)) - (unless long-description-suppliedp - (slot-makunbound obj 'long-description)) - ;; replicate the logic of the initforms... - (unless ld-suppliedp - (setf (component-load-dependencies obj) nil)) - (setf (component-in-order-to obj) in-order-to - (component-do-first obj) do-first - (component-inline-methods obj) inline-methods - (slot-value obj 'parent) parent - (slot-value obj 'properties) properties)) - - (defun* component-find-path (component) (reverse (loop :for c = component :then (component-parent c) @@ -1282,21 +1244,6 @@ make sure we clear them thoroughly." :initarg :default-component-class :accessor module-default-component-class))) -;;; see comment with REINITIALIZE-INSTANCE method on COMPONENT -;;; [2011/09/02:rpg] -(defmethod reinitialize-instance :after ((obj module) &rest initargs &key) - "Clear MODULE's slots so it can be reused." - (slot-makunbound obj 'components-by-name) - ;; this may be a more elegant approach than in the - ;; COMPONENT method [2011/09/02:rpg] - (loop :for (initarg slot-name default) :in - `((:components components nil) - (:if-component-dep-fails if-component-dep-fails :fail) - (:default-component-class default-component-class - ,*default-component-class*)) - :unless (member initarg initargs) - :do (setf (slot-value obj slot-name) default))) - (defun* component-parent-pathname (component) ;; No default anymore (in particular, no *default-pathname-defaults*). ;; If you force component to have a NULL pathname, you better arrange @@ -1330,7 +1277,12 @@ make sure we clear them thoroughly." (acons property new-value (slot-value c 'properties))))) new-value) -(defclass system (module) +(defclass proto-system () ; slots to keep when resetting a system + ;; To preserve identity for all objects, we'd need keep the components slots + ;; but also to modify parse-component-form to reset the recycled objects. + ((name) #|(components) (components-by-names)|#)) + +(defclass system (module proto-system) (;; description and long-description are now available for all component's, ;; but now also inherited from component, but we add the legacy accessor (description :accessor system-description :initarg :description) @@ -1343,24 +1295,6 @@ make sure we clear them thoroughly." :writer %set-system-source-file) (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on))) -;;; see comment with REINITIALIZE-INSTANCE method on COMPONENT -;;; [2011/09/02:rpg] -(defmethod reinitialize-instance :after ((obj system) &rest initargs &key) - "Clear SYSTEM's slots so it can be reused." - ;; note that SYSTEM-SOURCE-FILE is very specially handled, - ;; by DO-DEFSYSTEM, so we need to *PRESERVE* its value and - ;; not squash it. SYSTEM COMPONENTS are handled very specially, - ;; because they are always, effectively, reused, since the system component - ;; is made early in DO-DEFSYSTEM, instead of being made later, in - ;; PARSE-COMPONENT-FORM [2011/09/02:rpg] - (loop :for (initarg slot-name) :in - `((:author author) - (:maintainer maintainer) - (:licence licence) - (:defsystem-depends-on defsystem-depends-on)) - :unless (member initarg initargs) - :do (slot-makunbound obj slot-name))) - ;;;; ------------------------------------------------------------------------- ;;;; version-satisfies @@ -1448,11 +1382,10 @@ NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3" (file-position s (+ start network-volume-offset #x14)))) - (concatenate 'string - (read-null-terminated-string s) - (progn - (file-position s (+ start remaining-offset)) - (read-null-terminated-string s)))))) + (strcat (read-null-terminated-string s) + (progn + (file-position s (+ start remaining-offset)) + (read-null-terminated-string s)))))) (defun* parse-windows-shortcut (pathname) (with-open-file (s pathname :element-type '(unsigned-byte 8)) @@ -1539,15 +1472,25 @@ called with an object of type asdf:system." ;;; for the sake of keeping things reasonably neat, we adopt a ;;; convention that functions in this list are prefixed SYSDEF- -(defparameter *system-definition-search-functions* - '(sysdef-central-registry-search - sysdef-source-registry-search - sysdef-find-asdf)) +(defvar *system-definition-search-functions* '()) + +(setf *system-definition-search-functions* + (append + ;; Remove known-incompatible sysdef functions from ancient sbcl asdf. + (remove 'contrib-sysdef-search *system-definition-search-functions*) + ;; Tuck our defaults at the end of the list if they were absent. + ;; This is imperfect, in case they were removed on purpose, + ;; but then it will be the responsibility of whoever does that + ;; to upgrade asdf before he does such a thing rather than after. + (remove-if #'(lambda (x) (member x *system-definition-search-functions*)) + '(sysdef-central-registry-search + sysdef-source-registry-search + sysdef-find-asdf)))) (defun* search-for-system-definition (system) - (let ((system-name (coerce-name system))) - (some #'(lambda (x) (funcall x system-name)) - (cons 'find-system-if-being-defined *system-definition-search-functions*)))) + (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name))) + (cons 'find-system-if-being-defined + *system-definition-search-functions*))) (defvar *central-registry* nil "A list of 'system directory designators' ASDF uses to find systems. @@ -1597,7 +1540,7 @@ Going forward, we recommend new users should be using the source-registry. (let ((shortcut (make-pathname :defaults defaults :version :newest :case :local - :name (concatenate 'string name ".asd") + :name (strcat name ".asd") :type "lnk"))) (when (probe-file* shortcut) (let ((target (parse-windows-shortcut shortcut))) @@ -1671,6 +1614,7 @@ Going forward, we recommend new users should be using the source-registry. 0))) (defmethod find-system ((name null) &optional (error-p t)) + (declare (ignorable name)) (when error-p (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>")))) @@ -1690,7 +1634,7 @@ Going forward, we recommend new users should be using the source-registry. (let ((*systems-being-defined* (make-hash-table :test 'equal))) (funcall thunk)))) -(defmacro with-system-definitions (() &body body) +(defmacro with-system-definitions ((&optional) &body body) `(call-with-system-definitions #'(lambda () ,@body))) (defun* load-sysdef (name pathname) @@ -1711,17 +1655,27 @@ Going forward, we recommend new users should be using the source-registry. (load pathname))) (delete-package package))))) -(defmethod find-system ((name string) &optional (error-p t)) - (with-system-definitions () - (let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk - (previous (cdr in-memory)) - (previous (and (typep previous 'system) previous)) - (previous-time (car in-memory)) +(defun* locate-system (name) + "Given a system NAME designator, try to locate where to load the system from. +Returns four values: FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME +FOUNDP is true when a new was found, either a new unregistered one or a previously registered one. +FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is +PATHNAME when not null is a path from where to load the system, associated with FOUND-SYSTEM, or with the PREVIOUS system. +PREVIOUS when not null is a previously loaded SYSTEM object of same name. +PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded." + (let* ((name (coerce-name name)) + (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk + (previous (cdr in-memory)) + (previous (and (typep previous 'system) previous)) + (previous-time (car in-memory)) (found (search-for-system-definition name)) - (found-system (and (typep found 'system) found)) - (pathname (or (and (typep found '(or pathname string)) (pathname found)) - (and found-system (system-source-file found-system)) - (and previous (system-source-file previous))))) + (found-system (and (typep found 'system) found)) + (pathname (or (and (typep found '(or pathname string)) (pathname found)) + (and found-system (system-source-file found-system)) + (and previous (system-source-file previous)))) + (foundp (and (or found-system pathname previous) t))) + (check-type found (or null pathname system)) + (when foundp (setf pathname (resolve-symlinks* pathname)) (when (and pathname (not (absolute-pathname-p pathname))) (setf pathname (ensure-pathname-absolute pathname)) @@ -1731,23 +1685,37 @@ Going forward, we recommend new users should be using the source-registry. (system-source-file previous) pathname))) (%set-system-source-file pathname previous) (setf previous-time nil)) - (when (and found-system (not previous)) - (register-system found-system)) - (when (and pathname - (or (not previous-time) - ;; don't reload if it's already been loaded, - ;; or its filestamp is in the future which means some clock is skewed - ;; and trying to load might cause an infinite loop. - (< previous-time (safe-file-write-date pathname) (get-universal-time)))) - (load-sysdef name pathname)) - (let ((in-memory (system-registered-p name))) ; try again after loading from disk - (cond - (in-memory - (when pathname - (setf (car in-memory) (safe-file-write-date pathname))) - (cdr in-memory)) - (error-p - (error 'missing-component :requires name))))))) + (values foundp found-system pathname previous previous-time)))) + +(defmethod find-system ((name string) &optional (error-p t)) + (with-system-definitions () + (loop + (restart-case + (multiple-value-bind (foundp found-system pathname previous previous-time) + (locate-system name) + (declare (ignore foundp)) + (when (and found-system (not previous)) + (register-system found-system)) + (when (and pathname + (or (not previous-time) + ;; don't reload if it's already been loaded, + ;; or its filestamp is in the future which means some clock is skewed + ;; and trying to load might cause an infinite loop. + (< previous-time (safe-file-write-date pathname) (get-universal-time)))) + (load-sysdef name pathname)) + (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed + (return + (cond + (in-memory + (when pathname + (setf (car in-memory) (safe-file-write-date pathname))) + (cdr in-memory)) + (error-p + (error 'missing-component :requires name)))))) + (reinitialize-source-registry-and-retry () + :report (lambda (s) + (format s "~@<Retry finding system ~A after reinitializing the source-registry.~@:>" name)) + (initialize-source-registry)))))) (defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys) (setf fallback (coerce-name fallback) @@ -1873,12 +1841,9 @@ Host, device and version components are taken from DEFAULTS." (and pathname (merge-pathnames* (coerce-pathname subpath :type type) (pathname-directory-pathname pathname)))) -(defun* try-subpathname (pathname subpath &key type) - (let* ((sp (and pathname (probe-file* pathname) - (subpathname pathname subpath :type type))) - (ts (and sp (probe-file* sp)))) - (and ts (values sp ts)))) - +(defun subpathname* (pathname subpath &key type) + (and pathname + (subpathname (ensure-directory-pathname pathname) subpath :type type))) ;;;; ------------------------------------------------------------------------- ;;;; Operations @@ -1982,10 +1947,9 @@ class specifier, not an operation." (cdr (assoc (type-of o) (component-in-order-to c)))) (defmethod component-self-dependencies ((o operation) (c component)) - (let ((all-deps (component-depends-on o c))) - (remove-if-not #'(lambda (x) - (member (component-name c) (cdr x) :test #'string=)) - all-deps))) + (remove-if-not + #'(lambda (x) (member (component-name c) (cdr x) :test #'string=)) + (component-depends-on o c))) (defmethod input-files ((operation operation) (c component)) (let ((parent (component-parent c)) @@ -2357,10 +2321,18 @@ recursive calls to traverse.") ((component-parent c) (around-compile-hook (component-parent c))))) +(defun ensure-function (fun &key (package :asdf)) + (etypecase fun + ((or symbol function) fun) + (cons (eval `(function ,fun))) + (string (eval `(function ,(with-standard-io-syntax + (let ((*package* (find-package package))) + (read-from-string fun)))))))) + (defmethod call-with-around-compile-hook ((c component) thunk) (let ((hook (around-compile-hook c))) (if hook - (funcall hook thunk) + (funcall (ensure-function hook) thunk) (funcall thunk)))) (defvar *compile-op-compile-file-function* 'compile-file* @@ -2546,31 +2518,38 @@ recursive calls to traverse.") (defgeneric* operate (operation-class system &key &allow-other-keys)) (defgeneric* perform-plan (plan &key)) +;;;; Separating this into a different function makes it more forward-compatible +(defun* cleanup-upgraded-asdf (old-version) + (let ((new-version (asdf:asdf-version))) + (unless (equal old-version new-version) + (cond + ((version-satisfies new-version old-version) + (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") + old-version new-version)) + ((version-satisfies old-version new-version) + (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%") + old-version new-version)) + (t + (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%") + old-version new-version))) + (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf))) + ;; Invalidate all systems but ASDF itself. + (setf *defined-systems* (make-defined-systems-table)) + (register-system asdf) + ;; If we're in the middle of something, restart it. + (when *systems-being-defined* + (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name))) + (clrhash *systems-being-defined*) + (dolist (s l) (find-system s nil)))) + t)))) + ;;;; Try to upgrade of ASDF. If a different version was used, return T. ;;;; We need do that before we operate on anything that depends on ASDF. (defun* upgrade-asdf () (let ((version (asdf:asdf-version))) (handler-bind (((or style-warning warning) #'muffle-warning)) (operate 'load-op :asdf :verbose nil)) - (let ((new-version (asdf:asdf-version))) - (block nil - (cond - ((equal version new-version) - (return nil)) - ((version-satisfies new-version version) - (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") - version new-version)) - ((version-satisfies version new-version) - (warn (compatfmt "~&~@<Downgraded ASDF from version ~A to version ~A~@:>~%") - version new-version)) - (t - (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%") - version new-version))) - (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf))) - ;; invalidate all systems but ASDF itself - (setf *defined-systems* (make-defined-systems-table)) - (register-system asdf) - t))))) + (cleanup-upgraded-asdf version))) (defmethod perform-plan ((steps list) &key) (let ((*package* *package*) @@ -2634,7 +2613,7 @@ created with the same initargs as the original one. ")) (setf (documentation 'oos 'function) (format nil - "Short for _operate on system_ and an alias for the OPERATE function. ~&~&~a" + "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a" operate-docstring)) (setf (documentation 'operate 'function) operate-docstring)) @@ -2646,6 +2625,9 @@ See OPERATE for details." (apply 'operate 'load-op system args) t) +(defun* load-systems (&rest systems) + (map () 'load-system systems)) + (defun* compile-system (system &rest args &key force verbose version &allow-other-keys) "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE @@ -2702,7 +2684,7 @@ Returns the new tree (which probably shares structure with the old one)" (if first-op-tree (progn (aif (assoc op2 (cdr first-op-tree)) - (if (find c (cdr it)) + (if (find c (cdr it) :test #'equal) nil (setf (cdr it) (cons c (cdr it)))) (setf (cdr first-op-tree) @@ -2724,8 +2706,7 @@ Returns the new tree (which probably shares structure with the old one)" (defvar *serial-depends-on* nil) (defun* sysdef-error-component (msg type name value) - (sysdef-error (concatenate 'string msg - (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>")) + (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>")) type name value)) (defun* check-component-input (type name weakly-depends-on @@ -2802,29 +2783,22 @@ Returns the new tree (which probably shares structure with the old one)" (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>") version name parent))) - (let* ((other-args (remove-keys - '(components pathname default-component-class - perform explain output-files operation-done-p - weakly-depends-on - depends-on serial in-order-to) - rest)) + (let* ((args (list* :name (coerce-name name) + :pathname pathname + :parent parent + (remove-keys + '(components pathname default-component-class + perform explain output-files operation-done-p + weakly-depends-on depends-on serial in-order-to) + rest))) (ret (find-component parent name))) (when weakly-depends-on (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on))) (when *serial-depends-on* (push *serial-depends-on* depends-on)) - (if ret - (apply 'reinitialize-instance ret - :name (coerce-name name) - :pathname pathname - :parent parent - other-args) - (setf ret - (apply 'make-instance (class-for-type parent type) - :name (coerce-name name) - :pathname pathname - :parent parent - other-args))) + (if ret ; preserve identity + (apply 'reinitialize-instance ret args) + (setf ret (apply 'make-instance (class-for-type parent type) args))) (component-pathname ret) ; eagerly compute the absolute pathname (when (typep ret 'module) (setf (module-default-component-class ret) @@ -2856,6 +2830,10 @@ Returns the new tree (which probably shares structure with the old one)" (%refresh-component-inline-methods ret rest) ret))) +(defun* reset-system (system &rest keys &key &allow-other-keys) + (change-class (change-class system 'proto-system) 'system) + (apply 'reinitialize-instance system keys)) + (defun* do-defsystem (name &rest options &key pathname (class 'system) defsystem-depends-on &allow-other-keys) @@ -2868,14 +2846,14 @@ Returns the new tree (which probably shares structure with the old one)" (with-system-definitions () (let* ((name (coerce-name name)) (registered (system-registered-p name)) - (system (cdr (or registered - (register-system (make-instance 'system :name name))))) + (registered! (if registered + (rplaca registered (get-universal-time)) + (register-system (make-instance 'system :name name)))) + (system (reset-system (cdr registered!) + :name name :source-file (load-pathname))) (component-options (remove-keys '(:class) options))) - (%set-system-source-file (load-pathname) system) (setf (gethash name *systems-being-defined*) system) - (when registered - (setf (car registered) (get-universal-time))) - (map () 'load-system defsystem-depends-on) + (apply 'load-systems defsystem-depends-on) ;; We change-class (when necessary) AFTER we load the defsystem-dep's ;; since the class might not be defined as part of those. (let ((class (class-for-type nil class))) @@ -2960,7 +2938,7 @@ output to *VERBOSE-OUT*. Returns the shell's exit code." (ccl:run-program (cond ((os-unix-p) "/bin/sh") - ((os-windows-p) (format nil "CMD /C ~A" command)) ; BEWARE! + ((os-windows-p) (strcat "CMD /C " command)) ; BEWARE! (t (error "Unsupported OS"))) (if (os-unix-p) (list "-c" command) '()) :input nil :output *verbose-out* :wait t))) @@ -2972,6 +2950,9 @@ output to *VERBOSE-OUT*. Returns the shell's exit code." (list "-c" command) :input nil :output *verbose-out*)) + #+cormanlisp + (win32:system command) + #+ecl ;; courtesy of Juan Jose Garcia Ripoll (ext:system command) @@ -3162,20 +3143,23 @@ located." (defun* user-configuration-directories () (let ((dirs - `(,(try-subpathname (getenv "XDG_CONFIG_HOME") "common-lisp/") - ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS") - :for dir :in (split-string dirs :separator ":") - :collect (try-subpathname dir "common-lisp/")) + `(,@(when (os-unix-p) + (cons + (subpathname* (getenv "XDG_CONFIG_HOME") "common-lisp/") + (loop :with dirs = (getenv "XDG_CONFIG_DIRS") + :for dir :in (split-string dirs :separator ":") + :collect (subpathname* dir "common-lisp/")))) ,@(when (os-windows-p) - `(,(try-subpathname (or #+lispworks (sys:get-folder-path :local-appdata) - (getenv "LOCALAPPDATA")) - "common-lisp/config/") + `(,(subpathname* (or #+lispworks (sys:get-folder-path :local-appdata) + (getenv "LOCALAPPDATA")) + "common-lisp/config/") ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData - ,(try-subpathname (or #+lispworks (sys:get-folder-path :appdata) - (getenv "APPDATA")) - "common-lisp/config/"))) - ,(try-subpathname (user-homedir) ".config/common-lisp/")))) - (remove-duplicates (remove-if #'null dirs) :from-end t :test 'equal))) + ,(subpathname* (or #+lispworks (sys:get-folder-path :appdata) + (getenv "APPDATA")) + "common-lisp/config/"))) + ,(subpathname (user-homedir) ".config/common-lisp/")))) + (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) + :from-end t :test 'equal))) (defun* system-configuration-directories () (cond @@ -3183,19 +3167,23 @@ located." ((os-windows-p) (aif ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData - (try-subpathname (or #+lispworks (sys:get-folder-path :common-appdata) - (getenv "ALLUSERSAPPDATA") - (subpathname (getenv "ALLUSERSPROFILE") "Application Data/")) - "common-lisp/config/") + (subpathname* (or #+lispworks (sys:get-folder-path :common-appdata) + (getenv "ALLUSERSAPPDATA") + (subpathname* (getenv "ALLUSERSPROFILE") "Application Data/")) + "common-lisp/config/") (list it))))) -(defun* in-first-directory (dirs x) - (loop :for dir :in dirs - :thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir)))))) -(defun* in-user-configuration-directory (x) - (in-first-directory (user-configuration-directories) x)) -(defun* in-system-configuration-directory (x) - (in-first-directory (system-configuration-directories) x)) +(defun* in-first-directory (dirs x &key (direction :input)) + (loop :with fun = (ecase direction + ((nil :input :probe) 'probe-file*) + ((:output :io) 'identity)) + :for dir :in dirs + :thereis (and dir (funcall fun (merge-pathnames* x (ensure-directory-pathname dir)))))) + +(defun* in-user-configuration-directory (x &key (direction :input)) + (in-first-directory (user-configuration-directories) x :direction direction)) +(defun* in-system-configuration-directory (x &key (direction :input)) + (in-first-directory (system-configuration-directories) x :direction direction)) (defun* configuration-inheritance-directive-p (x) (let ((kw '(:inherit-configuration :ignore-inherited-configuration))) @@ -3549,14 +3537,14 @@ Please remove it from your ASDF configuration")) (defparameter *output-translations-file* (coerce-pathname "asdf-output-translations.conf")) (defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/")) -(defun* user-output-translations-pathname () - (in-user-configuration-directory *output-translations-file*)) -(defun* system-output-translations-pathname () - (in-system-configuration-directory *output-translations-file*)) -(defun* user-output-translations-directory-pathname () - (in-user-configuration-directory *output-translations-directory*)) -(defun* system-output-translations-directory-pathname () - (in-system-configuration-directory *output-translations-directory*)) +(defun* user-output-translations-pathname (&key (direction :input)) + (in-user-configuration-directory *output-translations-file* :direction direction)) +(defun* system-output-translations-pathname (&key (direction :input)) + (in-system-configuration-directory *output-translations-file* :direction direction)) +(defun* user-output-translations-directory-pathname (&key (direction :input)) + (in-user-configuration-directory *output-translations-directory* :direction direction)) +(defun* system-output-translations-directory-pathname (&key (direction :input)) + (in-system-configuration-directory *output-translations-directory* :direction direction)) (defun* environment-output-translations () (getenv "ASDF_OUTPUT_TRANSLATIONS")) @@ -3679,8 +3667,8 @@ effectively disabling the output translation facility." (translate-pathname path absolute-source destination)))) (defun* apply-output-translations (path) + #+cormanlisp (truenamize path) #-cormanlisp (etypecase path - #+cormanlisp (t (truenamize path)) (logical-pathname path) ((or pathname string) @@ -3721,7 +3709,7 @@ effectively disabling the output translation facility." (defun* tmpize-pathname (x) (make-pathname - :name (format nil "ASDF-TMP-~A" (pathname-name x)) + :name (strcat "ASDF-TMP-" (pathname-name x)) :defaults x)) (defun* delete-file-if-exists (x) @@ -3852,6 +3840,7 @@ with a different configuration, so the configuration would be re-read then." (loop :for f :in entries :for p = (or (and (typep f 'logical-pathname) f) (let* ((u (ignore-errors (funcall merger f)))) + ;; The first u avoids a cumbersome (truename u) error (and u (equal (ignore-errors (truename u)) f) u))) :when p :collect p) entries)) @@ -3865,8 +3854,9 @@ with a different configuration, so the configuration would be re-read then." (filter-logical-directory-results directory entries #'(lambda (f) - (make-pathname :defaults directory :version (pathname-version f) - :name (pathname-name f) :type (pathname-type f)))))) + (make-pathname :defaults directory + :name (pathname-name f) :type (ununspecific (pathname-type f)) + :version (ununspecific (pathname-version f))))))) (defun* directory-asd-files (directory) (directory-files directory *wild-asd*)) @@ -3875,9 +3865,9 @@ with a different configuration, so the configuration would be re-read then." (let* ((directory (ensure-directory-pathname directory)) #-(or abcl cormanlisp genera xcl) (wild (merge-pathnames* - #-(or abcl allegro cmu lispworks scl xcl) + #-(or abcl allegro cmu lispworks sbcl scl xcl) *wild-directory* - #+(or abcl allegro cmu lispworks scl xcl) "*.*" + #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*" directory)) (dirs #-(or abcl cormanlisp genera xcl) @@ -3887,16 +3877,16 @@ with a different configuration, so the configuration would be re-read then." #+(or abcl xcl) (system:list-directory directory) #+cormanlisp (cl::directory-subdirs directory) #+genera (fs:directory-list directory)) - #+(or abcl allegro cmu genera lispworks scl xcl) + #+(or abcl allegro cmu genera lispworks sbcl scl xcl) (dirs (loop :for x :in dirs :for d = #+(or abcl xcl) (extensions:probe-directory x) #+allegro (excl:probe-directory x) - #+(or cmu scl) (directory-pathname-p x) + #+(or cmu sbcl scl) (directory-pathname-p x) #+genera (getf (cdr x) :directory) #+lispworks (lw:file-directory-p x) :when d :collect #+(or abcl allegro xcl) d #+genera (ensure-directory-pathname (first x)) - #+(or cmu lispworks scl) x))) + #+(or cmu lispworks sbcl scl) x))) (filter-logical-directory-results directory dirs (let ((prefix (normalize-pathname-directory-component @@ -4021,12 +4011,12 @@ with a different configuration, so the configuration would be re-read then." #+scl (:tree #p"file://modules/"))) (defun* default-source-registry () `(:source-registry - #+sbcl (:directory ,(try-subpathname (user-homedir) ".sbcl/systems/")) + #+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/")) (:directory ,(default-directory)) ,@(loop :for dir :in `(,@(when (os-unix-p) `(,(or (getenv "XDG_DATA_HOME") - (try-subpathname (user-homedir) ".local/share/")) + (subpathname (user-homedir) ".local/share/")) ,@(split-string (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share") :separator ":"))) @@ -4037,18 +4027,18 @@ with a different configuration, so the configuration would be re-read then." (getenv "APPDATA")) ,(or #+lispworks (sys:get-folder-path :common-appdata) (getenv "ALLUSERSAPPDATA") - (try-subpathname (getenv "ALLUSERSPROFILE") "Application Data/"))))) - :collect `(:directory ,(try-subpathname dir "common-lisp/systems/")) - :collect `(:tree ,(try-subpathname dir "common-lisp/source/"))) + (subpathname* (getenv "ALLUSERSPROFILE") "Application Data/"))))) + :collect `(:directory ,(subpathname* dir "common-lisp/systems/")) + :collect `(:tree ,(subpathname* dir "common-lisp/source/"))) :inherit-configuration)) -(defun* user-source-registry () - (in-user-configuration-directory *source-registry-file*)) -(defun* system-source-registry () - (in-system-configuration-directory *source-registry-file*)) -(defun* user-source-registry-directory () - (in-user-configuration-directory *source-registry-directory*)) -(defun* system-source-registry-directory () - (in-system-configuration-directory *source-registry-directory*)) +(defun* user-source-registry (&key (direction :input)) + (in-user-configuration-directory *source-registry-file* :direction direction)) +(defun* system-source-registry (&key (direction :input)) + (in-system-configuration-directory *source-registry-file* :direction direction)) +(defun* user-source-registry-directory (&key (direction :input)) + (in-user-configuration-directory *source-registry-directory* :direction direction)) +(defun* system-source-registry-directory (&key (direction :input)) + (in-system-configuration-directory *source-registry-directory* :direction direction)) (defun* environment-source-registry () (getenv "CL_SOURCE_REGISTRY")) @@ -4126,8 +4116,7 @@ with a different configuration, so the configuration would be re-read then." (collect (list directory :recurse recurse :exclude exclude))))) :test 'equal :from-end t))) -;; Will read the configuration and initialize all internal variables, -;; and return the new configuration. +;; Will read the configuration and initialize all internal variables. (defun* compute-source-registry (&optional parameter (registry *source-registry*)) (dolist (entry (flatten-source-registry parameter)) (destructuring-bind (directory &key recurse exclude) entry diff --git a/src/general-info/release-20d.txt b/src/general-info/release-20d.txt index 0c926f7ee01d854babb4ec18d03a643f8622ed69..d73037c65505b2d9feba58874002f89325f2a30f 100644 --- a/src/general-info/release-20d.txt +++ b/src/general-info/release-20d.txt @@ -23,7 +23,7 @@ New in this release: * Feature enhancements * Changes - * ASDF2 updated to version 2.018. + * ASDF2 updated to version 2.019. * Behavior of STRING-TO-OCTETS has changed. This is an incompatible change from the previous version but should be more useful when a buffer is given which is not large enough to hold @@ -33,6 +33,8 @@ New in this release: * ANSI compliance fixes: * Bugfixes: + * DECODE-FLOAT was not correctly declared and could not be + compiled to handle double-double-floats. * Trac Tickets: