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 ,@directory)) + ((and (consp directory) (not (member (first directory) '(:absolute :relative)))) + `(:relative ,@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*