[cmucl-cvs] CMUCL commit: src/contrib/asdf (asdf.lisp)
Raymond Toy
rtoy at common-lisp.net
Wed Dec 8 23:57:02 UTC 2010
Date: Wednesday, December 8, 2010 @ 18:57:02
Author: rtoy
Path: /project/cmucl/cvsroot/src/contrib/asdf
Modified: asdf.lisp
Update to version 2.011.
-----------+
asdf.lisp | 351 ++++++++++++++++++++++++++++++++----------------------------
1 file changed, 188 insertions(+), 163 deletions(-)
Index: src/contrib/asdf/asdf.lisp
diff -u src/contrib/asdf/asdf.lisp:1.10 src/contrib/asdf/asdf.lisp:1.11
--- src/contrib/asdf/asdf.lisp:1.10 Thu Nov 4 10:04:10 2010
+++ src/contrib/asdf/asdf.lisp Wed Dec 8 18:57:02 2010
@@ -49,6 +49,8 @@
(cl:in-package :cl-user)
+#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this
+
(eval-when (:compile-toplevel :load-toplevel :execute)
;;; make package if it doesn't exist yet.
;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
@@ -66,20 +68,25 @@
;;;; Create packages in a way that is compatible with hot-upgrade.
;;;; See https://bugs.launchpad.net/asdf/+bug/485687
-;;;; See more at the end of the file.
+;;;; See more near the end of the file.
(eval-when (:load-toplevel :compile-toplevel :execute)
(defvar *asdf-version* nil)
(defvar *upgraded-p* nil)
- (let* ((asdf-version "2.010") ;; same as 2.146
+ (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
+ ;; "2.345" would be an official release
+ ;; "2.345.6" would be a development version in the official upstream
+ ;; "2.345.0.7" would be your local modification of an official release
+ ;; "2.345.6.7" would be your local modification of a development version
+ (asdf-version "2.011")
(existing-asdf (fboundp 'find-system))
(existing-version *asdf-version*)
(already-there (equal asdf-version existing-version)))
(unless (and existing-asdf already-there)
(when existing-asdf
- (format *error-output*
- "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
- existing-version asdf-version))
+ (format *trace-output*
+ "~&~@<; ~@;Upgrading ASDF package ~@[from version ~A ~]to version ~A~@:>~%"
+ existing-version asdf-version))
(labels
((unlink-package (package)
(let ((u (find-package package)))
@@ -180,7 +187,8 @@
#:apply-output-translations #:translate-pathname* #:resolve-location)
:unintern
(#:*asdf-revision* #:around #:asdf-method-combination
- #:split #:make-collector)
+ #:split #:make-collector
+ #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function
:fmakunbound
(#:system-source-file
#:component-relative-pathname #:system-relative-pathname
@@ -234,6 +242,7 @@
#:system-relative-pathname
#:map-systems
+ #:operation-description
#:operation-on-warnings
#:operation-on-failure
#:component-visited-p
@@ -286,7 +295,7 @@
;; Utilities
#:absolute-pathname-p
- ;; #:aif #:it
+ ;; #:aif #:it
;; #:appendf
#:coerce-name
#:directory-pathname-p
@@ -295,11 +304,12 @@
#:getenv
;; #:get-uid
;; #:length=n-p
+ ;; #:find-symbol*
#:merge-pathnames*
#:pathname-directory-pathname
#:read-file-forms
- ;; #:remove-keys
- ;; #:remove-keyword
+ ;; #:remove-keys
+ ;; #:remove-keyword
#:resolve-symlinks
#:split-string
#:component-name-to-pathname-components
@@ -312,31 +322,6 @@
(cons existing-version *upgraded-p*)
*upgraded-p*))))))
-;; More cleanups in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
-(when *upgraded-p*
- #+ecl
- (when (find-class 'compile-op nil)
- (defmethod update-instance-for-redefined-class :after
- ((c compile-op) added deleted plist &key)
- (declare (ignore added deleted))
- (let ((system-p (getf plist 'system-p)))
- (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p)))))
- (when (find-class 'module nil)
- (eval
- '(progn
- (defmethod update-instance-for-redefined-class :after
- ((m module) added deleted plist &key)
- (declare (ignorable deleted plist))
- (when *asdf-verbose* (format *trace-output* "Updating ~A~%" m))
- (when (member 'components-by-name added)
- (compute-module-components-by-name m)))
- (defmethod update-instance-for-redefined-class :after
- ((s system) added deleted plist &key)
- (declare (ignorable deleted plist))
- (when *asdf-verbose* (format *trace-output* "Updating ~A~%" s))
- (when (member 'source-file added)
- (%set-system-source-file (probe-asd (component-name s) (component-pathname s)) s)))))))
-
;;;; -------------------------------------------------------------------------
;;;; User-visible parameters
;;;;
@@ -378,7 +363,8 @@
(setf excl:*warn-on-nested-reader-conditionals* nil)))
;;;; -------------------------------------------------------------------------
-;;;; ASDF Interface, in terms of generic functions.
+;;;; General Purpose Utilities
+
(macrolet
((defdef (def* def)
`(defmacro ,def* (name formals &rest rest)
@@ -390,113 +376,6 @@
(defdef defgeneric* defgeneric)
(defdef defun* defun))
-(defgeneric* find-system (system &optional error-p))
-(defgeneric* perform-with-restarts (operation component))
-(defgeneric* perform (operation component))
-(defgeneric* operation-done-p (operation component))
-(defgeneric* explain (operation component))
-(defgeneric* output-files (operation component))
-(defgeneric* input-files (operation component))
-(defgeneric* component-operation-time (operation component))
-(defgeneric* operation-description (operation component)
- (:documentation "returns a phrase that describes performing this operation
-on this component, e.g. \"loading /a/b/c\".
-You can put together sentences using this phrase."))
-
-(defgeneric* system-source-file (system)
- (:documentation "Return the source file in which system is defined."))
-
-(defgeneric* component-system (component)
- (:documentation "Find the top-level system containing COMPONENT"))
-
-(defgeneric* component-pathname (component)
- (:documentation "Extracts the pathname applicable for a particular component."))
-
-(defgeneric* component-relative-pathname (component)
- (:documentation "Returns a pathname for the component argument intended to be
-interpreted relative to the pathname of that component's parent.
-Despite the function's name, the return value may be an absolute
-pathname, because an absolute pathname may be interpreted relative to
-another pathname in a degenerate way."))
-
-(defgeneric* component-property (component property))
-
-(defgeneric* (setf component-property) (new-value component property))
-
-(defgeneric* version-satisfies (component version))
-
-(defgeneric* find-component (base path)
- (:documentation "Finds the component with PATH starting from BASE module;
-if BASE is nil, then the component is assumed to be a system."))
-
-(defgeneric* source-file-type (component system))
-
-(defgeneric* operation-ancestor (operation)
- (:documentation
- "Recursively chase the operation's parent pointer until we get to
-the head of the tree"))
-
-(defgeneric* component-visited-p (operation component)
- (:documentation "Returns the value stored by a call to
-VISIT-COMPONENT, if that has been called, otherwise NIL.
-This value stored will be a cons cell, the first element
-of which is a computed key, so not interesting. The
-CDR wil be the DATA value stored by VISIT-COMPONENT; recover
-it as (cdr (component-visited-p op c)).
- In the current form of ASDF, the DATA value retrieved is
-effectively a boolean, indicating whether some operations are
-to be performed in order to do OPERATION X COMPONENT. If the
-data value is NIL, the combination had been explored, but no
-operations needed to be performed."))
-
-(defgeneric* visit-component (operation component data)
- (:documentation "Record DATA as being associated with OPERATION
-and COMPONENT. This is a side-effecting function: the association
-will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the
-OPERATION\).
- No evidence that DATA is ever interesting, beyond just being
-non-NIL. Using the data field is probably very risky; if there is
-already a record for OPERATION X COMPONENT, DATA will be quietly
-discarded instead of recorded.
- Starting with 2.006, TRAVERSE will store an integer in data,
-so that nodes can be sorted in decreasing order of traversal."))
-
-
-(defgeneric* (setf visiting-component) (new-value operation component))
-
-(defgeneric* component-visiting-p (operation component))
-
-(defgeneric* component-depends-on (operation component)
- (:documentation
- "Returns a list of dependencies needed by the component to perform
- the operation. A dependency has one of the following forms:
-
- (<operation> <component>*), where <operation> is a class
- designator and each <component> is a component
- designator, which means that the component depends on
- <operation> having been performed on each <component>; or
-
- (FEATURE <feature>), which means that the component depends
- on <feature>'s presence in *FEATURES*.
-
- Methods specialized on subclasses of existing component types
- should usually append the results of CALL-NEXT-METHOD to the
- list."))
-
-(defgeneric* component-self-dependencies (operation component))
-
-(defgeneric* traverse (operation component)
- (:documentation
-"Generate and return a plan for performing OPERATION on COMPONENT.
-
-The plan returned is a list of dotted-pairs. Each pair is the CONS
-of ASDF operation object and a COMPONENT object. The pairs will be
-processed in order by OPERATE."))
-
-
-;;;; -------------------------------------------------------------------------
-;;;; General Purpose Utilities
-
(defmacro while-collecting ((&rest collectors) &body body)
"COLLECTORS should be a list of names for collections. A collector
defines a function that, when applied to an argument inside BODY, will
@@ -535,11 +414,11 @@
(directory (pathname-directory specified))
(directory
(cond
- #-(or sbcl cmu)
+ #-(or sbcl cmu scl)
((stringp directory) `(:absolute ,directory) directory)
#+gcl
- ((and (consp directory) (stringp (first directory)))
- `(:absolute , at directory))
+ ((and (consp directory) (not (member (first directory) '(:absolute :relative))))
+ `(:relative , at directory))
((or (null directory)
(and (consp directory) (member (first directory) '(:absolute :relative))))
directory)
@@ -675,9 +554,8 @@
:append (list k v)))
(defun* getenv (x)
- (#+abcl ext:getenv
+ (#+(or abcl clisp) ext:getenv
#+allegro sys:getenv
- #+clisp ext:getenv
#+clozure ccl:getenv
#+(or cmu scl) (lambda (x) (cdr (assoc x ext:*environment-list* :test #'string=)))
#+ecl si:getenv
@@ -723,7 +601,8 @@
:defaults pathspec))))
(defun* absolute-pathname-p (pathspec)
- (and pathspec (eq :absolute (car (pathname-directory (pathname pathspec))))))
+ (and (typep pathspec '(or pathname string))
+ (eq :absolute (car (pathname-directory (pathname pathspec))))))
(defun* length=n-p (x n) ;is it that (= (length x) n) ?
(check-type n (integer 0 *))
@@ -755,7 +634,7 @@
(defun* get-uid ()
#+allegro (excl.osi:getuid)
#+clisp (loop :for s :in '("posix:uid" "LINUX:getuid")
- :for f = (ignore-errors (read-from-string s))
+ :for f = (ignore-errors (read-from-string s))
:when f :return (funcall f))
#+(or cmu scl) (unix:unix-getuid)
#+ecl #.(cl:if (cl:< ext:+ecl-version-number+ 100601)
@@ -777,6 +656,9 @@
:directory '(:absolute)
:name nil :type nil :version nil))
+(defun* find-symbol* (s p)
+ (find-symbol (string s) p))
+
(defun* probe-file* (p)
"when given a pathname P, probes the filesystem for a file or directory
with given pathname and if it exists return its truename."
@@ -785,8 +667,8 @@
(string (probe-file* (parse-namestring p)))
(pathname (unless (wild-pathname-p p)
#.(or #+(or allegro clozure cmu ecl sbcl scl) '(probe-file p)
- #+clisp (aif (find-symbol (string :probe-pathname) :ext) `(ignore-errors (,it p)))
- '(ignore-errors (truename p)))))))
+ #+clisp (aif (find-symbol (string '#:probe-pathname) :ext) `(ignore-errors (,it p)))
+ '(ignore-errors (truename p)))))))
(defun* truenamize (p)
"Resolve as much of a pathname as possible"
@@ -859,6 +741,134 @@
(translate-pathname absolute-pathname wild-root (wilden new-base))))))
;;;; -------------------------------------------------------------------------
+;;;; ASDF Interface, in terms of generic functions.
+(defgeneric* find-system (system &optional error-p))
+(defgeneric* perform-with-restarts (operation component))
+(defgeneric* perform (operation component))
+(defgeneric* operation-done-p (operation component))
+(defgeneric* explain (operation component))
+(defgeneric* output-files (operation component))
+(defgeneric* input-files (operation component))
+(defgeneric* component-operation-time (operation component))
+(defgeneric* operation-description (operation component)
+ (:documentation "returns a phrase that describes performing this operation
+on this component, e.g. \"loading /a/b/c\".
+You can put together sentences using this phrase."))
+
+(defgeneric* system-source-file (system)
+ (:documentation "Return the source file in which system is defined."))
+
+(defgeneric* component-system (component)
+ (:documentation "Find the top-level system containing COMPONENT"))
+
+(defgeneric* component-pathname (component)
+ (:documentation "Extracts the pathname applicable for a particular component."))
+
+(defgeneric* component-relative-pathname (component)
+ (:documentation "Returns a pathname for the component argument intended to be
+interpreted relative to the pathname of that component's parent.
+Despite the function's name, the return value may be an absolute
+pathname, because an absolute pathname may be interpreted relative to
+another pathname in a degenerate way."))
+
+(defgeneric* component-property (component property))
+
+(defgeneric* (setf component-property) (new-value component property))
+
+(defgeneric* version-satisfies (component version))
+
+(defgeneric* find-component (base path)
+ (:documentation "Finds the component with PATH starting from BASE module;
+if BASE is nil, then the component is assumed to be a system."))
+
+(defgeneric* source-file-type (component system))
+
+(defgeneric* operation-ancestor (operation)
+ (:documentation
+ "Recursively chase the operation's parent pointer until we get to
+the head of the tree"))
+
+(defgeneric* component-visited-p (operation component)
+ (:documentation "Returns the value stored by a call to
+VISIT-COMPONENT, if that has been called, otherwise NIL.
+This value stored will be a cons cell, the first element
+of which is a computed key, so not interesting. The
+CDR wil be the DATA value stored by VISIT-COMPONENT; recover
+it as (cdr (component-visited-p op c)).
+ In the current form of ASDF, the DATA value retrieved is
+effectively a boolean, indicating whether some operations are
+to be performed in order to do OPERATION X COMPONENT. If the
+data value is NIL, the combination had been explored, but no
+operations needed to be performed."))
+
+(defgeneric* visit-component (operation component data)
+ (:documentation "Record DATA as being associated with OPERATION
+and COMPONENT. This is a side-effecting function: the association
+will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the
+OPERATION\).
+ No evidence that DATA is ever interesting, beyond just being
+non-NIL. Using the data field is probably very risky; if there is
+already a record for OPERATION X COMPONENT, DATA will be quietly
+discarded instead of recorded.
+ Starting with 2.006, TRAVERSE will store an integer in data,
+so that nodes can be sorted in decreasing order of traversal."))
+
+
+(defgeneric* (setf visiting-component) (new-value operation component))
+
+(defgeneric* component-visiting-p (operation component))
+
+(defgeneric* component-depends-on (operation component)
+ (:documentation
+ "Returns a list of dependencies needed by the component to perform
+ the operation. A dependency has one of the following forms:
+
+ (<operation> <component>*), where <operation> is a class
+ designator and each <component> is a component
+ designator, which means that the component depends on
+ <operation> having been performed on each <component>; or
+
+ (FEATURE <feature>), which means that the component depends
+ on <feature>'s presence in *FEATURES*.
+
+ Methods specialized on subclasses of existing component types
+ should usually append the results of CALL-NEXT-METHOD to the
+ list."))
+
+(defgeneric* component-self-dependencies (operation component))
+
+(defgeneric* traverse (operation component)
+ (:documentation
+"Generate and return a plan for performing OPERATION on COMPONENT.
+
+The plan returned is a list of dotted-pairs. Each pair is the CONS
+of ASDF operation object and a COMPONENT object. The pairs will be
+processed in order by OPERATE."))
+
+
+;;;; -------------------------------------------------------------------------
+;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
+(when *upgraded-p*
+ #+ecl
+ (when (find-class 'compile-op nil)
+ (defmethod update-instance-for-redefined-class :after
+ ((c compile-op) added deleted plist &key)
+ (declare (ignore added deleted))
+ (let ((system-p (getf plist 'system-p)))
+ (when system-p (setf (getf (slot-value c 'flags) :system-p) system-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 (or *asdf-verbose* *load-verbose*)
+ (asdf-message "~&~@<; ~@; Updating ~A for ASDF ~A~@:>~%" m ,(asdf-version)))
+ (when (member 'components-by-name added)
+ (compute-module-components-by-name m))
+ (when (and (typep m 'system) (member 'source-file added))
+ (%set-system-source-file (probe-asd (component-name m) (component-pathname m)) m))))))
+
+;;;; -------------------------------------------------------------------------
;;;; Classes, Conditions
(define-condition system-definition-error (error) ()
@@ -1000,7 +1010,7 @@
(format s "~@<component ~S not found~@[ in ~A~]~@:>"
(missing-requires c)
(when (missing-parent c)
- (component-name (missing-parent c)))))
+ (coerce-name (missing-parent c)))))
(defmethod print-object ((c missing-component-of-version) s)
(format s "~@<component ~S does not match version ~A~@[ in ~A~]~@:>"
@@ -1295,7 +1305,7 @@
:condition condition))))
(let ((*package* package))
(asdf-message
- "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
+ "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%"
on-disk *package*)
(load on-disk)))
(delete-package package))))
@@ -1309,19 +1319,22 @@
(error 'missing-component :requires name)))))))
(defun* register-system (name system)
- (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
+ (asdf-message "~&~@<; ~@;Registering ~A as ~A~@:>~%" system name)
(setf (gethash (coerce-name name) *defined-systems*)
(cons (get-universal-time) system)))
(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
(setf fallback (coerce-name fallback)
- source-file (or source-file *compile-file-truename* *load-truename*)
+ source-file (or source-file
+ (if *resolve-symlinks*
+ (or *compile-file-truename* *load-truename*)
+ (or *compile-file-pathname* *load-pathname*)))
requested (coerce-name requested))
(when (equal requested fallback)
(let* ((registered (cdr (gethash fallback *defined-systems*)))
(system (or registered
(apply 'make-instance 'system
- :name fallback :source-file source-file keys))))
+ :name fallback :source-file source-file keys))))
(unless registered
(register-system fallback system))
(throw 'find-system system))))
@@ -2201,9 +2214,9 @@
(defun* class-for-type (parent type)
(or (loop :for symbol :in (list
- (unless (keywordp type) type)
- (find-symbol (symbol-name type) *package*)
- (find-symbol (symbol-name type) :asdf))
+ type
+ (find-symbol* type *package*)
+ (find-symbol* type :asdf))
:for class = (and symbol (find-class symbol nil))
:when (and class (subtypep class 'component))
:return class)
@@ -2390,8 +2403,8 @@
#+mswindows "sh" #-mswindows "/bin/sh" command)
:input nil :whole nil
#+mswindows :show-window #+mswindows :hide)
- (format *verbose-out* "~{~&; ~a~%~}~%" stderr)
- (format *verbose-out* "~{~&; ~a~%~}~%" stdout)
+ (asdf-message "~{~&; ~a~%~}~%" stderr)
+ (asdf-message "~{~&; ~a~%~}~%" stdout)
exit-code)
#+clisp ;XXX not exactly *verbose-out*, I know
@@ -3121,6 +3134,18 @@
;;;; -----------------------------------------------------------------
;;;; Compatibility mode for ASDF-Binary-Locations
+(defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
+ (declare (ignorable operation-class system args))
+ (when (find-symbol* '#:output-files-for-system-and-operation :asdf)
+ (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using.
+ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS,
+which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS,
+and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.
+In case you insist on preserving your previous A-B-L configuration, but
+do not know how to achieve the same effect with A-O-T, you may use function
+ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual;
+call that function where you would otherwise have loaded and configured A-B-L.")))
+
(defun* enable-asdf-binary-locations-compatibility
(&key
(centralize-lisp-binaries nil)
@@ -3548,7 +3573,7 @@
(clear-output-translations))
;;;; -----------------------------------------------------------------
-;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL
+;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL and SBCL
;;;;
(defun* module-provide-asdf (name)
(handler-bind
@@ -3564,7 +3589,7 @@
t))))
#+(or abcl clisp clozure cmu ecl sbcl)
-(let ((x (and #+clisp (find-symbol "*MODULE-PROVIDER-FUNCTIONS*" :custom))))
+(let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom))))
(when x
(eval `(pushnew 'module-provide-asdf
#+abcl sys::*module-provider-functions*
More information about the cmucl-cvs
mailing list