[cmucl-cvs] [git] CMU Common Lisp branch master updated. release-20c-24-g576ae2a
Raymond Toy
rtoy at common-lisp.net
Thu Dec 1 05:15:48 UTC 2011
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CMU Common Lisp".
The branch, master has been updated
via 576ae2a5a8f79bf983ac3da8237854b2b21dd8c6 (commit)
from eea87468f7479a152a34ff2ad8f6fd53a011c36b (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 576ae2a5a8f79bf983ac3da8237854b2b21dd8c6
Author: Raymond Toy <toy.raymond at gmail.com>
Date: Mon Nov 28 20:39:27 2011 -0800
Update to asdf 2.019; update release info.
diff --git a/src/contrib/asdf/asdf.lisp b/src/contrib/asdf/asdf.lisp
index 26ff427..a95826b 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 at 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 () , at 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 0c926f7..d73037c 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:
-----------------------------------------------------------------------
Summary of changes:
src/contrib/asdf/asdf.lisp | 539 +++++++++++++++++++-------------------
src/general-info/release-20d.txt | 4 +-
2 files changed, 267 insertions(+), 276 deletions(-)
hooks/post-receive
--
CMU Common Lisp
More information about the cmucl-cvs
mailing list