Index: /trunk/source/tools/asdf.lisp =================================================================== --- /trunk/source/tools/asdf.lisp (revision 14469) +++ /trunk/source/tools/asdf.lisp (revision 14470) @@ -50,4 +50,6 @@ (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. @@ -67,10 +69,15 @@ ;;;; 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*) @@ -78,7 +85,7 @@ (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) @@ -181,5 +188,6 @@ :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 @@ -235,4 +243,5 @@ #:map-systems + #:operation-description #:operation-on-warnings #:operation-on-failure @@ -287,5 +296,5 @@ ;; Utilities #:absolute-pathname-p - ;; #:aif #:it + ;; #:aif #:it ;; #:appendf #:coerce-name @@ -296,9 +305,10 @@ ;; #: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 @@ -313,29 +323,4 @@ *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 @@ -379,5 +364,6 @@ ;;;; ------------------------------------------------------------------------- -;;;; ASDF Interface, in terms of generic functions. +;;;; General Purpose Utilities + (macrolet ((defdef (def* def) @@ -390,111 +376,4 @@ (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: - - ( *), where is a class - designator and each is a component - designator, which means that the component depends on - having been performed on each ; or - - (FEATURE ), which means that the component depends - on '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) @@ -536,9 +415,9 @@ (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)))) @@ -676,7 +555,6 @@ (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=))) @@ -724,5 +602,6 @@ (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) ? @@ -756,5 +635,5 @@ #+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) @@ -778,4 +657,7 @@ :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 @@ -786,6 +668,6 @@ (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) @@ -858,4 +740,132 @@ :directory `(:absolute ,@path)))) (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: + + ( *), where is a class + designator and each is a component + designator, which means that the component depends on + having been performed on each ; or + + (FEATURE ), which means that the component depends + on '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)))))) ;;;; ------------------------------------------------------------------------- @@ -1001,5 +1011,5 @@ (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) @@ -1296,5 +1306,5 @@ (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))) @@ -1310,5 +1320,5 @@ (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))) @@ -1316,5 +1326,8 @@ (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) @@ -1322,5 +1335,5 @@ (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)) @@ -2202,7 +2215,7 @@ (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)) @@ -2391,6 +2404,6 @@ :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) @@ -3121,4 +3134,16 @@ ;;;; ----------------------------------------------------------------- ;;;; 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 @@ -3549,5 +3574,5 @@ ;;;; ----------------------------------------------------------------- -;;;; 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) @@ -3565,5 +3590,5 @@ #+(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