Loading asdf.lisp +58 −39 Original line number Diff line number Diff line Loading @@ -72,7 +72,7 @@ (defvar *asdf-version* nil) (defvar *upgraded-p* nil) (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate (subseq "VERSION:2.131" (1+ (length "VERSION")))) (subseq "VERSION:2.132" (1+ (length "VERSION")))) (existing-asdf (fboundp 'find-system)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) Loading Loading @@ -178,7 +178,7 @@ (#:perform #:explain #:output-files #:operation-done-p #:perform-with-restarts #:component-relative-pathname #:system-source-file #:operate #:find-component #:find-system #:apply-output-translations #:translate-pathname*) #:apply-output-translations #:translate-pathname* #:resolve-location) :unintern (#:*asdf-revision* #:around #:asdf-method-combination #:split #:make-collector) Loading Loading @@ -323,12 +323,19 @@ (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 '(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)))))) (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 Loading Loading @@ -2683,19 +2690,24 @@ with a different configuration, so the configuration would be re-read then." (make-pathname :directory '(:relative :wild-inferiors) :name :wild :type "asd" :version :newest)) (declaim (ftype (function (t &optional boolean) (values (or null pathname) &optional)) (declaim (ftype (function (t &key (:directory boolean) (:wilden boolean)) (values (or null pathname) &optional)) resolve-location)) (defun* resolve-relative-location-component (super x &optional wildenp) (defun* resolve-relative-location-component (super x &key directory wilden) (let* ((r (etypecase x (pathname x) (string x) (cons (let ((car (resolve-relative-location-component super (car x) nil))) (return-from resolve-relative-location-component (if (null (cdr x)) car (let ((cdr (resolve-relative-location-component (merge-pathnames* car super) (cdr x) wildenp))) (resolve-relative-location-component super (car x) :directory directory :wilden wilden) (let* ((car (resolve-relative-location-component super (car x) :directory t :wilden nil)) (cdr (resolve-relative-location-component (merge-pathnames* car super) (cdr x) :directory directory :wilden wilden))) (merge-pathnames* cdr car))))) ((eql :default-directory) (relativize-pathname-directory (default-directory))) Loading @@ -2703,49 +2715,55 @@ with a different configuration, so the configuration would be re-read then." ((eql :implementation-type) (string-downcase (implementation-type))) #-(and (or win32 windows mswindows mingw32) (not cygwin)) ((eql :uid) (princ-to-string (get-uid))))) (d (if (pathnamep x) r (ensure-directory-pathname r))) (s (if (and wildenp (not (pathnamep x))) (wilden d) d))) (d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r))) (s (if (or (pathnamep x) (not wilden)) d (wilden d)))) (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super)))) (error "pathname ~S is not relative to ~S" s super)) (merge-pathnames* s super))) (defun* resolve-absolute-location-component (x wildenp) (defun* resolve-absolute-location-component (x &key directory wilden) (let* ((r (etypecase x (pathname x) (string (ensure-directory-pathname x)) (string (if directory (ensure-directory-pathname x) (parse-namestring x))) (cons (let ((car (resolve-absolute-location-component (car x) nil))) (return-from resolve-absolute-location-component (if (null (cdr x)) car (let ((cdr (resolve-relative-location-component car (cdr x) wildenp))) (merge-pathnames* cdr car))))) (resolve-absolute-location-component (car x) :directory directory :wilden wilden) (let* ((car (resolve-absolute-location-component (car x) :directory t :wilden nil)) (cdr (resolve-relative-location-component car (cdr x) :directory directory :wilden wilden))) (merge-pathnames* cdr car))))) ; XXX why is this not just "cdr" ? ((eql :root) ;; special magic! we encode such paths as relative pathnames, ;; but it means "relative to the root of the source pathname's host and device". (return-from resolve-absolute-location-component (make-pathname :directory '(:relative)))) (let ((p (make-pathname :directory '(:relative)))) (if wilden (wilden p) p)))) ((eql :home) (user-homedir)) ((eql :user-cache) (resolve-location *user-cache* nil)) ((eql :system-cache) (resolve-location *system-cache* nil)) ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil)) ((eql :system-cache) (resolve-location *system-cache* :directory t :wilden nil)) ((eql :default-directory) (default-directory)))) (s (if (and wildenp (not (pathnamep x))) (s (if (and wilden (not (pathnamep x))) (wilden r) r))) (unless (absolute-pathname-p s) (error "Not an absolute pathname ~S" s)) s)) (defun* resolve-location (x &optional wildenp) (defun* resolve-location (x &key directory wilden) (if (atom x) (resolve-absolute-location-component x wildenp) (loop :with path = (resolve-absolute-location-component (car x) nil) (resolve-absolute-location-component x :directory directory :wilden wilden) (loop :with path = (resolve-absolute-location-component (car x) :directory (and (or directory (cdr x)) t) :wilden (and wilden (null (cdr x)))) :for (component . morep) :on (cdr x) :for dir = (and (or morep directory) t) :for wild = (and wilden (not morep)) :do (setf path (resolve-relative-location-component path component (and wildenp (not morep)))) path component :directory dir :wilden wild)) :finally (return path)))) (defun* location-designator-p (x) Loading Loading @@ -2920,7 +2938,7 @@ with a different configuration, so the configuration would be re-read then." (process-output-translations (pathname dst) :inherit nil :collect collect)) (when src (let ((trusrc (or (eql src t) (let ((loc (resolve-location src t))) (let ((loc (resolve-location src :directory t :wilden t))) (if (absolute-pathname-p loc) (truenamize loc) loc))))) (cond ((location-function-p dst) Loading @@ -2933,7 +2951,7 @@ with a different configuration, so the configuration would be re-read then." (funcall collect (list trusrc t))) (t (let* ((trudst (make-pathname :defaults (if dst (resolve-location dst t) trusrc))) :defaults (if dst (resolve-location dst :directory t :wilden t) trusrc))) (wilddst (make-pathname :name :wild :type :wild :version :wild :defaults trudst))) Loading Loading @@ -3218,7 +3236,7 @@ with a different configuration, so the configuration would be re-read then." (case kw ((:include :directory :tree) (and (length=n-p rest 1) (typep (car rest) '(or pathname string null)))) (location-designator-p (first rest)))) ((:exclude :also-exclude) (every #'stringp rest)) (null rest)))) Loading Loading @@ -3382,15 +3400,16 @@ with a different configuration, so the configuration would be re-read then." (ecase kw ((:include) (destructuring-bind (pathname) rest (process-source-registry (pathname pathname) :inherit nil :register register))) (process-source-registry (resolve-location pathname) :inherit nil :register register))) ((:directory) (destructuring-bind (pathname) rest (when pathname (funcall register (ensure-directory-pathname pathname))))) (funcall register (resolve-location pathname :directory t))))) ((:tree) (destructuring-bind (pathname) rest (when pathname (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *source-registry-exclusions*)))) (funcall register (resolve-location pathname :directory t) :recurse t :exclude *source-registry-exclusions*)))) ((:exclude) (setf *source-registry-exclusions* rest)) ((:also-exclude) Loading doc/asdf.texinfo +24 −1 Original line number Diff line number Diff line Loading @@ -1752,6 +1752,29 @@ DIRECTIVE := ;; This directive specifies that some default must be spliced. :default-registry REGULAR-FILE-PATHNAME-DESIGNATOR := PATHNAME-DESIGNATOR ;; interpreted as a file DIRECTORY-PATHNAME-DESIGNATOR := PATHNAME-DESIGNATOR ;; interpreted as a directory name PATHNAME-DESIGNATOR := NULL | ;; Special: skip this entry. ABSOLUTE-COMPONENT-DESIGNATOR | (ABSOLUTE-COMPONENT-DESIGNATOR RELATIVE-COMPONENT-DESIGNATOR ...) ABSOLUTE-COMPONENT-DESIGNATOR := STRING | ;; namestring (better be absolute or bust, directory assumed where applicable) PATHNAME | ;; pathname (better be an absolute path, or bust) :HOME | ;; designates the user-homedir-pathname ~/ :USER-CACHE | ;; designates the default location for the user cache :SYSTEM-CACHE ;; designates the default location for the system cache RELATIVE-COMPONENT-DESIGNATOR := STRING | ;; namestring (directory assumed where applicable) PATHNAME | ;; pathname :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.32.30-linux-x86-64 :IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl :UID | ;; current UID -- not available on Windows :USER ;; current USER name -- NOT IMPLEMENTED(!) PATTERN := a string without wildcards, that will be matched exactly against the name of a any subdirectory in the directory component of a path. e.g. @code{"_darcs"} will match @file{#p"/foo/bar/_darcs/src/bar.asd"} Loading @@ -1762,7 +1785,7 @@ which is the default place ASDF looks for this configuration, once contained: @example (:source-registry (:tree "/home/fare/cl/") (:tree (:home "cl")) ;; will expand to e.g. "/home/joeluser/cl/" :inherit-configuration) @end example Loading test/asdf-pathname-test.script +9 −0 Original line number Diff line number Diff line Loading @@ -278,6 +278,15 @@ (asdf:initialize-output-translations) (format t "output translations: ~S~%" (asdf::output-translations)) #-(or clisp ecl) ; clisp has problem with the first one having :version :newest (progn ; 1- we're testing with unix, are we not? (assert (equal (asdf::resolve-location '(:home)) (truename (user-homedir-pathname)))) (assert (equal (asdf::resolve-location '("/foo" "bar" "baz")) #p"/foo/bar/baz")) (assert (equal (asdf::resolve-location '("/foo" "bar" "baz") :directory t) #p"/foo/bar/baz/")) (assert (equal (asdf::resolve-location '("/foo" "bar" "baz") :directory t :wilden t) (asdf::wilden #p"/foo/bar/baz/"))) (assert (equal (asdf::resolve-location '("/foo" "bar" "baz") :directory nil :wilden t) (asdf::wilden #p"/foo/bar/"))) (assert (equal (asdf::resolve-location '("/foo" "bar" #p"**/" "baz" #p"*.*") :directory nil :wilden t) #p"/foo/bar/**/baz/*.*"))) (or (test-component-pathnames :delete-host t :support-string-pathnames nil) (leave-lisp "test failed" 1))) Loading test/compile-asdf.lisp +1 −0 Original line number Diff line number Diff line Loading @@ -21,6 +21,7 @@ (compile-file *asdf-lisp* :output-file tmp :print t :verbose t)) (declare (ignore result)) (cond #-ecl ; 10.7.1 has spurious warnings. Sigh. (warnings-p (leave-lisp "Testsuite failed: ASDF compiled with warnings" 1)) (errors-p Loading test/sources/level1/file1.lisp +4 −0 Original line number Diff line number Diff line Loading @@ -2,3 +2,7 @@ (in-package :test-package) (defvar *file-tmp* t) (eval-when (:compile-toplevel :execute) (format t "compiling level1/file1~%")) (eval-when (:load-toplevel :execute) (format t "loading level1/file1~%")) Loading
asdf.lisp +58 −39 Original line number Diff line number Diff line Loading @@ -72,7 +72,7 @@ (defvar *asdf-version* nil) (defvar *upgraded-p* nil) (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate (subseq "VERSION:2.131" (1+ (length "VERSION")))) (subseq "VERSION:2.132" (1+ (length "VERSION")))) (existing-asdf (fboundp 'find-system)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) Loading Loading @@ -178,7 +178,7 @@ (#:perform #:explain #:output-files #:operation-done-p #:perform-with-restarts #:component-relative-pathname #:system-source-file #:operate #:find-component #:find-system #:apply-output-translations #:translate-pathname*) #:apply-output-translations #:translate-pathname* #:resolve-location) :unintern (#:*asdf-revision* #:around #:asdf-method-combination #:split #:make-collector) Loading Loading @@ -323,12 +323,19 @@ (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 '(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)))))) (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 Loading Loading @@ -2683,19 +2690,24 @@ with a different configuration, so the configuration would be re-read then." (make-pathname :directory '(:relative :wild-inferiors) :name :wild :type "asd" :version :newest)) (declaim (ftype (function (t &optional boolean) (values (or null pathname) &optional)) (declaim (ftype (function (t &key (:directory boolean) (:wilden boolean)) (values (or null pathname) &optional)) resolve-location)) (defun* resolve-relative-location-component (super x &optional wildenp) (defun* resolve-relative-location-component (super x &key directory wilden) (let* ((r (etypecase x (pathname x) (string x) (cons (let ((car (resolve-relative-location-component super (car x) nil))) (return-from resolve-relative-location-component (if (null (cdr x)) car (let ((cdr (resolve-relative-location-component (merge-pathnames* car super) (cdr x) wildenp))) (resolve-relative-location-component super (car x) :directory directory :wilden wilden) (let* ((car (resolve-relative-location-component super (car x) :directory t :wilden nil)) (cdr (resolve-relative-location-component (merge-pathnames* car super) (cdr x) :directory directory :wilden wilden))) (merge-pathnames* cdr car))))) ((eql :default-directory) (relativize-pathname-directory (default-directory))) Loading @@ -2703,49 +2715,55 @@ with a different configuration, so the configuration would be re-read then." ((eql :implementation-type) (string-downcase (implementation-type))) #-(and (or win32 windows mswindows mingw32) (not cygwin)) ((eql :uid) (princ-to-string (get-uid))))) (d (if (pathnamep x) r (ensure-directory-pathname r))) (s (if (and wildenp (not (pathnamep x))) (wilden d) d))) (d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r))) (s (if (or (pathnamep x) (not wilden)) d (wilden d)))) (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super)))) (error "pathname ~S is not relative to ~S" s super)) (merge-pathnames* s super))) (defun* resolve-absolute-location-component (x wildenp) (defun* resolve-absolute-location-component (x &key directory wilden) (let* ((r (etypecase x (pathname x) (string (ensure-directory-pathname x)) (string (if directory (ensure-directory-pathname x) (parse-namestring x))) (cons (let ((car (resolve-absolute-location-component (car x) nil))) (return-from resolve-absolute-location-component (if (null (cdr x)) car (let ((cdr (resolve-relative-location-component car (cdr x) wildenp))) (merge-pathnames* cdr car))))) (resolve-absolute-location-component (car x) :directory directory :wilden wilden) (let* ((car (resolve-absolute-location-component (car x) :directory t :wilden nil)) (cdr (resolve-relative-location-component car (cdr x) :directory directory :wilden wilden))) (merge-pathnames* cdr car))))) ; XXX why is this not just "cdr" ? ((eql :root) ;; special magic! we encode such paths as relative pathnames, ;; but it means "relative to the root of the source pathname's host and device". (return-from resolve-absolute-location-component (make-pathname :directory '(:relative)))) (let ((p (make-pathname :directory '(:relative)))) (if wilden (wilden p) p)))) ((eql :home) (user-homedir)) ((eql :user-cache) (resolve-location *user-cache* nil)) ((eql :system-cache) (resolve-location *system-cache* nil)) ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil)) ((eql :system-cache) (resolve-location *system-cache* :directory t :wilden nil)) ((eql :default-directory) (default-directory)))) (s (if (and wildenp (not (pathnamep x))) (s (if (and wilden (not (pathnamep x))) (wilden r) r))) (unless (absolute-pathname-p s) (error "Not an absolute pathname ~S" s)) s)) (defun* resolve-location (x &optional wildenp) (defun* resolve-location (x &key directory wilden) (if (atom x) (resolve-absolute-location-component x wildenp) (loop :with path = (resolve-absolute-location-component (car x) nil) (resolve-absolute-location-component x :directory directory :wilden wilden) (loop :with path = (resolve-absolute-location-component (car x) :directory (and (or directory (cdr x)) t) :wilden (and wilden (null (cdr x)))) :for (component . morep) :on (cdr x) :for dir = (and (or morep directory) t) :for wild = (and wilden (not morep)) :do (setf path (resolve-relative-location-component path component (and wildenp (not morep)))) path component :directory dir :wilden wild)) :finally (return path)))) (defun* location-designator-p (x) Loading Loading @@ -2920,7 +2938,7 @@ with a different configuration, so the configuration would be re-read then." (process-output-translations (pathname dst) :inherit nil :collect collect)) (when src (let ((trusrc (or (eql src t) (let ((loc (resolve-location src t))) (let ((loc (resolve-location src :directory t :wilden t))) (if (absolute-pathname-p loc) (truenamize loc) loc))))) (cond ((location-function-p dst) Loading @@ -2933,7 +2951,7 @@ with a different configuration, so the configuration would be re-read then." (funcall collect (list trusrc t))) (t (let* ((trudst (make-pathname :defaults (if dst (resolve-location dst t) trusrc))) :defaults (if dst (resolve-location dst :directory t :wilden t) trusrc))) (wilddst (make-pathname :name :wild :type :wild :version :wild :defaults trudst))) Loading Loading @@ -3218,7 +3236,7 @@ with a different configuration, so the configuration would be re-read then." (case kw ((:include :directory :tree) (and (length=n-p rest 1) (typep (car rest) '(or pathname string null)))) (location-designator-p (first rest)))) ((:exclude :also-exclude) (every #'stringp rest)) (null rest)))) Loading Loading @@ -3382,15 +3400,16 @@ with a different configuration, so the configuration would be re-read then." (ecase kw ((:include) (destructuring-bind (pathname) rest (process-source-registry (pathname pathname) :inherit nil :register register))) (process-source-registry (resolve-location pathname) :inherit nil :register register))) ((:directory) (destructuring-bind (pathname) rest (when pathname (funcall register (ensure-directory-pathname pathname))))) (funcall register (resolve-location pathname :directory t))))) ((:tree) (destructuring-bind (pathname) rest (when pathname (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *source-registry-exclusions*)))) (funcall register (resolve-location pathname :directory t) :recurse t :exclude *source-registry-exclusions*)))) ((:exclude) (setf *source-registry-exclusions* rest)) ((:also-exclude) Loading
doc/asdf.texinfo +24 −1 Original line number Diff line number Diff line Loading @@ -1752,6 +1752,29 @@ DIRECTIVE := ;; This directive specifies that some default must be spliced. :default-registry REGULAR-FILE-PATHNAME-DESIGNATOR := PATHNAME-DESIGNATOR ;; interpreted as a file DIRECTORY-PATHNAME-DESIGNATOR := PATHNAME-DESIGNATOR ;; interpreted as a directory name PATHNAME-DESIGNATOR := NULL | ;; Special: skip this entry. ABSOLUTE-COMPONENT-DESIGNATOR | (ABSOLUTE-COMPONENT-DESIGNATOR RELATIVE-COMPONENT-DESIGNATOR ...) ABSOLUTE-COMPONENT-DESIGNATOR := STRING | ;; namestring (better be absolute or bust, directory assumed where applicable) PATHNAME | ;; pathname (better be an absolute path, or bust) :HOME | ;; designates the user-homedir-pathname ~/ :USER-CACHE | ;; designates the default location for the user cache :SYSTEM-CACHE ;; designates the default location for the system cache RELATIVE-COMPONENT-DESIGNATOR := STRING | ;; namestring (directory assumed where applicable) PATHNAME | ;; pathname :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.32.30-linux-x86-64 :IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl :UID | ;; current UID -- not available on Windows :USER ;; current USER name -- NOT IMPLEMENTED(!) PATTERN := a string without wildcards, that will be matched exactly against the name of a any subdirectory in the directory component of a path. e.g. @code{"_darcs"} will match @file{#p"/foo/bar/_darcs/src/bar.asd"} Loading @@ -1762,7 +1785,7 @@ which is the default place ASDF looks for this configuration, once contained: @example (:source-registry (:tree "/home/fare/cl/") (:tree (:home "cl")) ;; will expand to e.g. "/home/joeluser/cl/" :inherit-configuration) @end example Loading
test/asdf-pathname-test.script +9 −0 Original line number Diff line number Diff line Loading @@ -278,6 +278,15 @@ (asdf:initialize-output-translations) (format t "output translations: ~S~%" (asdf::output-translations)) #-(or clisp ecl) ; clisp has problem with the first one having :version :newest (progn ; 1- we're testing with unix, are we not? (assert (equal (asdf::resolve-location '(:home)) (truename (user-homedir-pathname)))) (assert (equal (asdf::resolve-location '("/foo" "bar" "baz")) #p"/foo/bar/baz")) (assert (equal (asdf::resolve-location '("/foo" "bar" "baz") :directory t) #p"/foo/bar/baz/")) (assert (equal (asdf::resolve-location '("/foo" "bar" "baz") :directory t :wilden t) (asdf::wilden #p"/foo/bar/baz/"))) (assert (equal (asdf::resolve-location '("/foo" "bar" "baz") :directory nil :wilden t) (asdf::wilden #p"/foo/bar/"))) (assert (equal (asdf::resolve-location '("/foo" "bar" #p"**/" "baz" #p"*.*") :directory nil :wilden t) #p"/foo/bar/**/baz/*.*"))) (or (test-component-pathnames :delete-host t :support-string-pathnames nil) (leave-lisp "test failed" 1))) Loading
test/compile-asdf.lisp +1 −0 Original line number Diff line number Diff line Loading @@ -21,6 +21,7 @@ (compile-file *asdf-lisp* :output-file tmp :print t :verbose t)) (declare (ignore result)) (cond #-ecl ; 10.7.1 has spurious warnings. Sigh. (warnings-p (leave-lisp "Testsuite failed: ASDF compiled with warnings" 1)) (errors-p Loading
test/sources/level1/file1.lisp +4 −0 Original line number Diff line number Diff line Loading @@ -2,3 +2,7 @@ (in-package :test-package) (defvar *file-tmp* t) (eval-when (:compile-toplevel :execute) (format t "compiling level1/file1~%")) (eval-when (:load-toplevel :execute) (format t "loading level1/file1~%"))