diff --git a/asdf.asd b/asdf.asd index 7eed2f037fd4d3efe715d32ca4d33d90ba062361..400b216b6c3bec5044e8e7ba74169dab074cd2ac 100644 --- a/asdf.asd +++ b/asdf.asd @@ -14,7 +14,7 @@ :licence "MIT" :description "Another System Definition Facility" :long-description "ASDF builds Common Lisp software organized into defined systems." - :version "2.20.9" ;; to be automatically updated by bin/bump-revision + :version "2.20.10" ;; to be automatically updated by bin/bump-revision :depends-on () :components ((:file "asdf") diff --git a/asdf.lisp b/asdf.lisp index 8e44c1d2d26a933b3ca64c91dd7886d122bce8d2..9a3091ba88be04116eb5d4224341179e227daa74 100644 --- a/asdf.lisp +++ b/asdf.lisp @@ -1,5 +1,5 @@ ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; This is ASDF 2.20.9: Another System Definition Facility. +;;; This is ASDF 2.20.10: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel@common-lisp.net>. @@ -115,7 +115,7 @@ ;; "2.345.6" would be a development version in the official upstream ;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.20.9") + (asdf-version "2.20.10") (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -541,6 +541,20 @@ and NIL NAME, TYPE and VERSION components" (defun* ununspecific (x) (if (eq x :unspecific) nil x)) +(defun* make-pathname-component-logical (x) + (typecase x + ((eql :unspecific) nil) + #+clisp (string (string-upcase x)) + #+clisp (cons (mapcar 'make-pathname-component-logical x)) + (t x))) + +(defun* make-pathname-logical (x) + (make-pathname + :directory (make-pathname-component-logical (pathname-directory x)) + :name (make-pathname-component-logical (pathname-name x)) + :type (make-pathname-component-logical (pathname-type x)) + :defaults x)) + (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, @@ -560,7 +574,7 @@ Also, if either argument is NIL, then the other argument is returned unmodified. (type (or (pathname-type specified) (pathname-type defaults))) (version (or (pathname-version specified) (pathname-version defaults)))) (labels ((unspecific-handler (p) - (if (typep p 'logical-pathname) #'ununspecific #'identity))) + (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity))) (multiple-value-bind (host device directory unspecific-handler) (ecase (first directory) ((:absolute) @@ -1588,9 +1602,7 @@ Going forward, we recommend new users should be using the source-registry. (defun* probe-asd (name defaults) (block nil (when (directory-pathname-p defaults) - (let ((file (make-pathname - :defaults defaults :name name - :version :newest :case :local :type "asd"))) + (let ((file (subpathname defaults (strcat name ".asd")))) (when (probe-file* file) (return file))) #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!) @@ -2359,9 +2371,7 @@ recursive calls to traverse.") (defun* ensure-all-directories-exist (pathnames) (loop :for pn :in pathnames - :for pathname = (if (typep pn 'logical-pathname) - (translate-logical-pathname pn) - pn) + :for pathname = (translate-logical-pathname pn) :do (ensure-directories-exist pathname))) (defmethod perform :before ((operation compile-op) (c source-file)) @@ -3925,23 +3935,29 @@ with a different configuration, so the configuration would be re-read then." (loop :for f :in entries :for p = (or (and (typep f 'logical-pathname) f) (let* ((u (ignore-errors (funcall merger f)))) - ;; The first u avoids a cumbersome (truename u) error - (and u (equal (ignore-errors (truename u)) f) u))) + ;; The first u avoids a cumbersome (truename u) error. + ;; At this point f should already be a truename, + ;; but isn't quite in CLISP, for doesn't have :version :newest + (and u (equal (ignore-errors (truename u)) (truename f)) u))) :when p :collect p) entries)) (defun* directory-files (directory &optional (pattern *wild-file*)) + (setf directory (pathname directory)) (when (wild-pathname-p directory) (error "Invalid wild in ~S" directory)) (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal) (error "Invalid file pattern ~S" pattern)) + (when (typep directory 'logical-pathname) + (setf pattern (make-pathname-logical pattern))) (let ((entries (ignore-errors (directory* (merge-pathnames* pattern directory))))) (filter-logical-directory-results directory entries #'(lambda (f) (make-pathname :defaults directory - :name (pathname-name f) :type (ununspecific (pathname-type f)) - :version (ununspecific (pathname-version f))))))) + :name (pathname-name f) + :type (make-pathname-component-logical (pathname-type f)) + :version (make-pathname-component-logical (pathname-version f))))))) (defun* directory-asd-files (directory) (directory-files directory *wild-asd*)) @@ -3974,15 +3990,14 @@ with a different configuration, so the configuration would be re-read then." #+(or cmu lispworks sbcl scl) x))) (filter-logical-directory-results directory dirs - (let ((prefix (normalize-pathname-directory-component - (pathname-directory directory)))) + (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory)) + '(:absolute)))) ; because allegro returns NIL for #p"FOO:" #'(lambda (d) - (let ((dir (normalize-pathname-directory-component - (pathname-directory d)))) + (let ((dir (normalize-pathname-directory-component (pathname-directory d)))) (and (consp dir) (consp (cdr dir)) (make-pathname :defaults directory :name nil :type nil :version nil - :directory (append prefix (last dir)))))))))) + :directory (append prefix (make-pathname-component-logical (last dir))))))))))) (defun* collect-asds-in-directory (directory collect) (map () collect (directory-asd-files directory))) diff --git a/test/test-logical-pathname.script b/test/test-logical-pathname.script index d905f61786b0d82237c0d1f763c24bd5c06be64e..e5aae8befdab5f75c7fab19c73990c588dc7e3d6 100644 --- a/test/test-logical-pathname.script +++ b/test/test-logical-pathname.script @@ -3,34 +3,42 @@ (load-asdf) (setf (logical-pathname-translations "ASDF") - `(("**;*.asd.*" ,(make-pathname :type "asd" :defaults (resolve-location `(,*asdf-directory* :**/ :*.*.*)))) - ("**;*.asd" ,(resolve-location `(,*asdf-directory* :**/ #p"*.asd"))) - ("**;*.lisp.*" ,(make-pathname :type "lisp" :defaults (resolve-location `(,*asdf-directory* :**/ :*.*.*)))) - ("**;*.lisp" ,(resolve-location `(,*asdf-directory* :**/ #p"*.lisp"))) + #+(or allegro clisp) + `(("**;*.*.*" ,(asdf::wilden *asdf-directory*))) + #-(or allegro clisp) + `(("**;*.asd.*" ,(make-pathname :type "asd" :defaults (asdf::wilden *asdf-directory*))) + ("**;*.lisp.*" ,(make-pathname :type "lisp" :defaults (asdf::wilden *asdf-directory*))) ("**;*.*.*" ,(resolve-location - `(,*asdf-directory* "tmp/fasls" :implementation "logical-host-asdf" :**/ :*.*.*))))) + `(,*asdf-directory* "tmp/fasls" :implementation "logical-host-asdf") + :wilden t)))) (quit-on-error (format t "~S~%" (translate-logical-pathname "ASDF:test;test-force.asd")) (format t "~S~%" (truename "ASDF:test;test-force.asd")) - (format t "Test logical pathnames in central registry~%") - (setf *central-registry* '("ASDF:test;")) - (initialize-source-registry '(:source-registry :ignore-inherited-configuration)) - (load-system :test-force :force t) + (progn + (format t "Test logical pathnames in central registry~%") + (setf *central-registry* '(#p"ASDF:test;")) + (initialize-source-registry '(:source-registry :ignore-inherited-configuration)) + (load-system :test-force :force t)) - (format t "Test logical pathnames in source-registry, non-recursive~%") - (clear-system :test-force) - (setf *central-registry* '()) - (initialize-source-registry - '(:source-registry (:directory "ASDF:test;") :ignore-inherited-configuration)) - (load-system :test-force :force t) + (progn + (format t "Test logical pathnames in source-registry, non-recursive~%") + (clear-system :test-force) + (setf *central-registry* '()) + (initialize-source-registry + '(:source-registry (:directory #p"ASDF:test;") :ignore-inherited-configuration)) + (load-system :test-force :force t)) - (format t "Test logical pathnames in source-registry, recursive~%") - (clear-system :test-force) - (setf *central-registry* '()) - (initialize-source-registry - '(:source-registry (:tree "ASDF:") :ignore-inherited-configuration)) - (load-system :test-force :force t) + #-allegro ;; Allegro 8.2 seems to have trouble with logical-pathnames. disable for now. + (progn + (format t "Test logical pathnames in source-registry, recursive~%") + (clear-system :test-force) + (setf *central-registry* '()) + (initialize-source-registry + ;; Bug: Allegro Express 8.2 incorrectly reads #p"ASDF:" as relative. + '(:source-registry (:tree #-allegro #p"ASDF:" #+allegro #.(asdf::pathname-root #p"ASDF")) + :ignore-inherited-configuration)) + (load-system :test-force :force t)) (format t "Done~%"))