diff --git a/asdf.lisp b/asdf.lisp index 23ab0c0bd1db0c30758ca432885687d47b3f9961..8dc233770ed7dd713c7ba2c1eda43759a8a1de0c 100644 --- a/asdf.lisp +++ b/asdf.lisp @@ -60,7 +60,7 @@ (eval-when (:load-toplevel :compile-toplevel :execute) (let* ((asdf-version ;; the 1+ hair is to ensure that we don't do an inadvertent find and replace - (subseq "VERSION:1.675" (1+ (length "VERSION")))) + (subseq "VERSION:1.676" (1+ (length "VERSION")))) #+allegro (excl::*autoload-package-name-alist* nil) (existing-asdf (find-package :asdf)) (versym '#:*asdf-version*) @@ -441,9 +441,15 @@ Deprecated. Use PATHNAME-DIRECTORY-PATHNAME instead." and NIL NAME, TYPE and VERSION components" (make-pathname :name nil :type nil :version nil :defaults pathname)) +(defun current-directory () + (truenamize (pathname-directory-pathname *default-pathname-defaults*))) + (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, then the HOST and DEVICE come from the DEFAULTS." +does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS. +Also, if either argument is NIL, then the other argument is returned unmodified." + (when (null specified) (return-from merge-pathnames* defaults)) + (when (null defaults) (return-from merge-pathnames* specified)) (let* ((specified (pathname specified)) (defaults (pathname defaults)) (directory (pathname-directory specified)) @@ -783,6 +789,7 @@ actually-existing directory." ;; no direct accessor for pathname, we do this as a method to allow ;; it to default in funky ways if not supplied (relative-pathname :initarg :pathname) + (absolute-pathname) (operation-times :initform (make-hash-table) :accessor component-operation-times) ;; XXX we should provide some atomic interface for updating the @@ -838,13 +845,25 @@ actually-existing directory." :initform 'cl-source-file :initarg :default-component-class))) (defun component-parent-pathname (component) - (aif (component-parent component) - (component-pathname it) - (truenamize *default-pathname-defaults*))) + ;; No default anymore (in particular, no *default-pathname-defaults*). + ;; If you force component to have a NULL pathname, you better arrange + ;; for any of its children to explicitly provide a proper absolute pathname + ;; wherever a pathname is actually wanted. + (let ((parent (component-parent component))) + (when parent + (component-pathname parent)))) (defmethod component-pathname ((component component)) - (merge-pathnames* (component-relative-pathname component) - (component-parent-pathname component))) + (if (slot-boundp component 'absolute-pathname) + (slot-value component 'absolute-pathname) + (let ((pathname + (merge-pathnames* + (component-relative-pathname component) + (component-parent-pathname component)))) + (unless (or (null pathname) (absolute-pathname-p pathname)) + (error "Invalid relative pathname ~S for component ~S" pathname component)) + (setf (slot-value component 'absolute-pathname) pathname) + pathname))) (defmethod component-property ((c component) property) (cdr (assoc property (slot-value c 'properties) :test #'equal))) @@ -1138,9 +1157,7 @@ to `~a` which is not a directory.~@:>" (or (slot-value component 'relative-pathname) (component-name component)) :type (source-file-type component (component-system component)) - :defaults (let ((parent (component-parent component))) - (and parent (component-pathname parent))))) - + :defaults (component-parent-pathname component))) ;;;; ------------------------------------------------------------------------- ;;;; Operations @@ -1771,13 +1788,15 @@ details." ;; to resolve symbolic links. If not resolving symlinks, then we use ;; *load-pathname* instead of *load-truename* since in some ;; implementations, the latter has *already resolved it. - (or (and pathname-supplied-p pathname) - (when *load-pathname* - (pathname-directory-pathname - (if *resolve-symlinks* - (resolve-symlinks *load-truename*) - *load-pathname*))) - *default-pathname-defaults*)) + (let ((file-pathname + (when (or *load-pathname* *compile-file-pathname*) + (pathname-directory-pathname + (if *resolve-symlinks* + (resolve-symlinks (or *load-truename* *compile-file-truename*)) + *load-pathname*))))) + (or (and pathname-supplied-p (merge-pathnames pathname file-pathname)) + file-pathname + (current-directory)))) (defmacro defsystem (name &body options) (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system) @@ -1946,6 +1965,7 @@ Returns the new tree (which probably shares structure with the old one)" :pathname pathname :parent parent other-args) + (component-pathname ret) ; eagerly compute the absolute pathname (when (typep ret 'module) (setf (module-default-component-class ret) (or default-component-class @@ -1977,7 +1997,6 @@ Returns the new tree (which probably shares structure with the old one)" (component-do-first ret) `((compile-op (load-op ,@depends-on)))) (%refresh-component-inline-methods ret rest) - ret))) ;;;; --------------------------------------------------------------------------- @@ -2357,7 +2376,7 @@ with a different configuration, so the configuration would be re-read then." ((eql :home) (user-homedir)) ((eql :user-cache) (resolve-location *user-cache* nil)) ((eql :system-cache) (resolve-location *system-cache* nil)) - ((eql :current-directory) (truenamize *default-pathname-defaults*)))) + ((eql :current-directory) (current-directory)))) (s (if (and wildenp (not (pathnamep x))) (wilden r) r))) @@ -2377,8 +2396,7 @@ with a different configuration, so the configuration would be re-read then." (merge-pathnames* car super) (cdr x) wildenp))) (merge-pathnames* cdr car))))) ((eql :current-directory) - (relativize-pathname-directory - (truenamize *default-pathname-defaults*))) + (relativize-pathname-directory (current-directory))) ((eql :implementation) (implementation-identifier)) ((eql :implementation-type) (string-downcase (implementation-type))) ((eql :uid) (princ-to-string (get-uid))))) diff --git a/test/test-module-excessive-depend.script b/test/test-module-excessive-depend.script index 1e07ed16bdd1502ce0d21e5cf4c131a23d1fe415..21827890f38cb217d109d2e46ec556191c1c9534 100644 --- a/test/test-module-excessive-depend.script +++ b/test/test-module-excessive-depend.script @@ -42,8 +42,8 @@ ;; dependency bug is fixed and the excessive compilation bug is fixed. (let ((before file2-date)) - (asdf::run-shell-command "touch file1.lisp") (sleep 1) + (asdf::run-shell-command "touch file1.lisp") (let ((plan (asdf::traverse (make-instance 'asdf:load-op) (asdf:find-system 'test-module-excessive-depend))) diff --git a/test/test1.script b/test/test1.script index a0306b6c3ba2d76b25603cd7c163655967ac3349..3768e0eeb3a6dce357cef557938c49d73978df85 100644 --- a/test/test1.script +++ b/test/test1.script @@ -33,7 +33,7 @@ ;; unix cwd. this is not a problem for run-tests.sh, but can be in general (let ((before (file-write-date file2))) - (asdf::run-shell-command "touch file1.lisp") (sleep 1) + (asdf::run-shell-command "touch file1.lisp") (asdf:operate 'asdf:load-op 'test1) (assert (> (file-write-date file2) before))))) diff --git a/test/test3.asd b/test/test3.asd index 23848d6584ba9aa8a176a22250dec53730a8ebea..b655bef82a32a1739f61a3f5a949e8e75f39dc3f 100644 --- a/test/test3.asd +++ b/test/test3.asd @@ -4,8 +4,7 @@ :components ((:module "deps" :if-component-dep-fails :try-next - :pathname "." + :pathname "" :components ((:file "file1" :in-order-to ((compile-op (feature :f1)))) (:file "file2" :in-order-to ((compile-op (feature :f2)))))))) -