diff --git a/asdf.lisp b/asdf.lisp index 86439fa34f7964e5b3244a569643f5b2f9620f20..b2fc2d8914e386d9fb2c5aef1d3bcb913c54136c 100644 --- a/asdf.lisp +++ b/asdf.lisp @@ -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.136" (1+ (length "VERSION")))) + (subseq "VERSION:2.137" (1+ (length "VERSION")))) (existing-asdf (fboundp 'find-system)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -534,7 +534,18 @@ Also, if either argument is NIL, then the other argument is returned unmodified. (let* ((specified (pathname specified)) (defaults (pathname defaults)) (directory (pathname-directory specified)) - #-(or sbcl cmu) (directory (if (stringp directory) `(:absolute ,directory) directory)) + (directory + (cond + #-(or sbcl cmu) + ((stringp directory) `(:absolute ,directory) directory) + #+gcl + ((and (consp directory) (stringp (first directory))) + `(:absolute ,@directory)) + ((or (null directory) + (and (consp directory) (member (first directory) '(:absolute :relative)))) + directory) + (t + (error "Unrecognized directory component ~S in pathname ~S" directory specified)))) (name (or (pathname-name specified) (pathname-name defaults))) (type (or (pathname-type specified) (pathname-type defaults))) (version (or (pathname-version specified) (pathname-version defaults)))) @@ -543,7 +554,7 @@ Also, if either argument is NIL, then the other argument is returned unmodified. (unspecific-handler (p) (if (typep p 'logical-pathname) #'ununspecific #'identity))) (multiple-value-bind (host device directory unspecific-handler) - (#-gcl ecase #+gcl case (first directory) + (ecase (first directory) ((nil) (values (pathname-host defaults) (pathname-device defaults) @@ -560,13 +571,6 @@ Also, if either argument is NIL, then the other argument is returned unmodified. (if (pathname-directory defaults) (append (pathname-directory defaults) (cdr directory)) directory) - (unspecific-handler defaults))) - #+gcl - (t - (assert (stringp (first directory))) - (values (pathname-host defaults) - (pathname-device defaults) - (append (pathname-directory defaults) directory) (unspecific-handler defaults)))) (make-pathname :host host :device device :directory directory :name (funcall unspecific-handler name) @@ -621,7 +625,7 @@ starting the separation from the end, e.g. when called with arguments (values filename unspecific) (values name type))))) -(defun* component-name-to-pathname-components (s &optional force-directory) +(defun* component-name-to-pathname-components (s &key force-directory force-relative) "Splits the path string S, returning three values: A flag that is either :absolute or :relative, indicating how the rest of the values are to be interpreted. @@ -638,12 +642,17 @@ The intention of this function is to support structured component names, e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathnames." (check-type s string) + (when (find #\: s) + (error "a portable ASDF pathname designator cannot include a #\: character: ~S" s)) (let* ((components (split-string s :separator "/")) (last-comp (car (last components)))) (multiple-value-bind (relative components) (if (equal (first components) "") (if (equal (first-char s) #\/) - (values :absolute (cdr components)) + (progn + (when force-relative + (error "absolute pathname designator not allowed: ~S" s)) + (values :absolute (cdr components))) (values :relative nil)) (values :relative components)) (setf components (remove "" components :test #'equal)) @@ -840,7 +849,7 @@ with given pathname and if it exists return its truename." (eql x separator))) root-namestring))) (multiple-value-bind (relative path filename) - (component-name-to-pathname-components root-string t) + (component-name-to-pathname-components root-string :force-directory t) (declare (ignore relative filename)) (let ((new-base (make-pathname :defaults root @@ -1371,7 +1380,8 @@ Going forward, we recommend new users should be using the source-registry. (merge-component-name-type (string-downcase name) :type type :defaults defaults)) (string (multiple-value-bind (relative path filename) - (component-name-to-pathname-components name (eq type :directory)) + (component-name-to-pathname-components name :force-directory (eq type :directory) + :force-relative t) (multiple-value-bind (name type) (cond ((or (eq type :directory) (null filename)) @@ -2873,7 +2883,7 @@ with a different configuration, so the configuration would be re-read then." ;; These are for convenience, and can be overridden by the user: #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*")) #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) - ;; If we want to enable the user cache by default, here would be the place: + ;; We enable the user cache by default, and here is the place we do: :enable-user-cache)) (defparameter *output-translations-file* #p"asdf-output-translations.conf") @@ -3052,8 +3062,8 @@ effectively disabling the output translation facility." (when (and x (probe-file x)) (delete-file x))) -(defun* compile-file* (input-file &rest keys &key &allow-other-keys) - (let* ((output-file (apply 'compile-file-pathname* input-file keys)) +(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys) + (let* ((output-file (or output-file (apply 'compile-file-pathname* input-file keys))) (tmp-file (tmpize-pathname output-file)) (status :error)) (multiple-value-bind (output-truename warnings-p failure-p) @@ -3103,7 +3113,8 @@ effectively disabling the output translation facility." (include-per-user-information nil) (map-all-source-files (or #+(or ecl clisp) t nil)) (source-to-target-mappings nil)) - (when (and (null map-all-source-files) #-(or ecl clisp) nil) + #+(or ecl clisp) + (when (null map-all-source-files) (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP")) (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp"))) (wild-inferiors (make-pathname :directory '(:relative :wild-inferiors))) diff --git a/doc/asdf.texinfo b/doc/asdf.texinfo index 40c17a261a864a8fc480f9c6a3e5d3733019e797..31ef914beb0465a7912899bf19a4477ac14325af 100644 --- a/doc/asdf.texinfo +++ b/doc/asdf.texinfo @@ -3417,7 +3417,7 @@ but that's all. The defsystem 4 proposal tends to look more at the external features, whereas this one centres on a protocol for system introspection. -@section kmp's ``The Description of Large Systems'', MIT AI Memu 801 +@section kmp's ``The Description of Large Systems'', MIT AI Memo 801 Available in updated-for-CL form on the web at @url{http://nhplace.com/kent/Papers/Large-Systems.html} diff --git a/test/asdf-pathname-test.script b/test/asdf-pathname-test.script index 77bf9ad3b822823011d5b123549678dea344284f..0e2a0f528407b3e452cd0ab8292ceb17a45194a4 100644 --- a/test/asdf-pathname-test.script +++ b/test/asdf-pathname-test.script @@ -32,7 +32,8 @@ (defun test-component-pathnames (&key (root (asdf::pathname-directory-pathname *asdf-fasl*)) (delete-host t) - (support-string-pathnames nil)) + (support-string-pathnames nil) + (support-absolute-string-pathnames nil)) (unwind-protect (let* ((bin-type (pathname-type (compile-file-pathname "test.lisp"))) (root-directory-namestring (format nil "~{/~a~}/" (rest (pathname-directory root)))) @@ -84,12 +85,12 @@ "module2/" "module2/module3" "module2/module3/" - ,(concatenate 'string root-directory-namestring "asdf-src/system1/module1") - ,(concatenate 'string root-directory-namestring "asdf-src/system1/module1/") - ,(concatenate 'string root-directory-namestring "asdf-src/system1/module2/") - ,(concatenate 'string root-directory-namestring "asdf-src/system1/module2/module3/") - ,(concatenate 'string root-directory-namestring "asdf-src/system2/module4/"))))) - + ,@(when support-absolute-string-pathnames + `(,(concatenate 'string root-directory-namestring "asdf-src/system1/module1") + ,(concatenate 'string root-directory-namestring "asdf-src/system1/module1/") + ,(concatenate 'string root-directory-namestring "asdf-src/system1/module2/") + ,(concatenate 'string root-directory-namestring "asdf-src/system1/module2/module3/") + ,(concatenate 'string root-directory-namestring "asdf-src/system2/module4/"))))))) (files `(nil ,(make-pathname :directory '(:relative) :name "untyped-file" :type nil) "file" @@ -177,9 +178,10 @@ (:static-file "static-file.type" :pathname ,file-pathname) (:file "module2/typed-file.type" :pathname ,file-pathname) (:static-file "module2/static-file.type" :pathname ,file-pathname) - (:static-file ,(concatenate 'string root-directory-namestring + ,@(when support-absolute-string-pathnames + `((:static-file ,(concatenate 'string root-directory-namestring "asdf-src/system1/module1/file.lisp") - :pathname ,file-pathname))))))))) + :pathname ,file-pathname))))))))))) (block :test-system (handler-bind diff --git a/test/test-utilities.script b/test/test-utilities.script index 45084d609d632480d1371d5239670f9e9239aed6..4469be9550921168f7e1472109d0b17afb2b6c16 100644 --- a/test/test-utilities.script +++ b/test/test-utilities.script @@ -24,17 +24,17 @@ ;; These are funky and non portable. Omit from tests. ;; (make-pathname :name "." :type nil :directory '(:absolute "tmp")) ;; (make-pathname :name "." :type "" :directory '(:absolute "tmp")) -(assert (equal (multiple-value-list (component-name-to-pathname-components "" t)) +(assert (equal (multiple-value-list (component-name-to-pathname-components "" :force-directory t)) '(:relative nil nil))) -(assert (equal (multiple-value-list (component-name-to-pathname-components "" nil)) +(assert (equal (multiple-value-list (component-name-to-pathname-components "" :force-directory nil)) '(:relative nil nil))) -(assert (equal (multiple-value-list (component-name-to-pathname-components "/" t)) +(assert (equal (multiple-value-list (component-name-to-pathname-components "/" :force-directory t)) '(:absolute nil nil))) -(assert (equal (multiple-value-list (component-name-to-pathname-components "/" nil)) +(assert (equal (multiple-value-list (component-name-to-pathname-components "/" :force-directory nil)) '(:absolute nil nil))) -(assert (equal (multiple-value-list (component-name-to-pathname-components "/aa/ba" t)) +(assert (equal (multiple-value-list (component-name-to-pathname-components "/aa/ba" :force-directory t)) '(:absolute ("aa" "ba") nil))) -(assert (equal (multiple-value-list (component-name-to-pathname-components "/aa/ba" nil)) +(assert (equal (multiple-value-list (component-name-to-pathname-components "/aa/ba" :force-directory nil)) '(:absolute ("aa") "ba"))) (assert (asdf::version-satisfies (asdf:asdf-version) (asdf:asdf-version)))