diff --git a/Makefile b/Makefile index b989fd66e259b7c0f3dd05a54bfa11009f045f02..71883caf0ec10f7acd687f29e6b8d751badd7d8d 100644 --- a/Makefile +++ b/Makefile @@ -87,7 +87,7 @@ test-upgrade: ll="(handler-bind (#+sbcl (sb-kernel:redefinition-warning #'muffle-warning)) (format t \"ll~%\") (load \"asdf.lisp\"))" ; \ cf="(handler-bind ((warning #'muffle-warning)) (format t \"cf~%\") (compile-file \"asdf.lisp\" :output-file \"$$fa\" :verbose t :print t))" ; \ lf="(handler-bind (#+sbcl (sb-kernel:redefinition-warning #'muffle-warning)) (format t \"lf\") (load \"$$fa\" :verbose t :print t))" ; \ - te="(quit-on-error $$l (push #p\"${sourceDirectory}/test/\" asdf:*central-registry*) (princ \"te\") (asdf:oos 'asdf:load-op :test-module-depend :verbose t))" ; \ + te="(asdf-test::quit-on-error $$l (push #p\"${sourceDirectory}/test/\" asdf:*central-registry*) (princ \"te\") (asdf:oos 'asdf:load-op :test-module-depend :verbose t))" ; \ use_ccl () { li="${CCL} --no-init --quiet --load" ; ev="--eval" ; } ; \ use_clisp () { li="${CLISP} -norc -ansi --quiet --quiet -i" ; ev="-x" ; } ; \ use_sbcl () { li="${SBCL} --noinform --no-userinit --load" ; ev="--eval" ; } ; \ diff --git a/asdf.asd b/asdf.asd index 5b52f229e2ff1547239ffbf31322449db1b40a61..8b74db74ccc0ffe4d88904138754254492877463 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.11" ;; to be automatically updated by bin/bump-revision + :version "2.20.12" ;; to be automatically updated by bin/bump-revision :depends-on () :components ((:file "asdf") diff --git a/asdf.lisp b/asdf.lisp index a3e53cf48838756e0abde278ddb4a37615406c47..a9e170715dffac56880871739f2af690377f0985 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.11: Another System Definition Facility. +;;; This is ASDF 2.20.12: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to . @@ -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.11") + (asdf-version "2.20.12") (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -773,6 +773,56 @@ actually-existing directory." (and (typep pathspec '(or pathname string)) (eq :absolute (car (pathname-directory (pathname pathspec)))))) +(defun* coerce-pathname (name &key type defaults) + "coerce NAME into a PATHNAME. +When given a string, portably decompose it into a relative pathname: +#\\/ separates subdirectories. The last #\\/-separated string is as follows: +if TYPE is NIL, its last #\\. if any separates name and type from from type; +if TYPE is a string, it is the type, and the whole string is the name; +if TYPE is :DIRECTORY, the string is a directory component; +if the string is empty, it's a directory. +Any directory named .. is read as :BACK. +Host, device and version components are taken from DEFAULTS." + ;; The defaults are required notably because they provide the default host + ;; to the below make-pathname, which may crucially matter to people using + ;; merge-pathnames with non-default hosts, e.g. for logical-pathnames. + ;; NOTE that the host and device slots will be taken from the defaults, + ;; but that should only matter if you later merge relative pathnames with + ;; CL:MERGE-PATHNAMES instead of ASDF:MERGE-PATHNAMES* + (etypecase name + ((or null pathname) + name) + (symbol + (coerce-pathname (string-downcase name) :type type :defaults defaults)) + (string + (multiple-value-bind (relative path filename) + (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)) + (values nil nil)) + (type + (values filename type)) + (t + (split-name-type filename))) + (apply 'make-pathname :directory (cons relative path) :name name :type type + (when defaults `(:defaults ,defaults)))))))) + +(defun* merge-component-name-type (name &key type defaults) + ;; For backwards compatibility only, for people using internals. + ;; Will be removed in a future release, e.g. 2.016. + (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.") + (coerce-pathname name :type type :defaults defaults)) + +(defun* subpathname (pathname subpath &key type) + (and pathname (merge-pathnames* (coerce-pathname subpath :type type) + (pathname-directory-pathname pathname)))) + +(defun subpathname* (pathname subpath &key type) + (and pathname + (subpathname (ensure-directory-pathname pathname) subpath :type type))) + (defun* length=n-p (x n) ;is it that (= (length x) n) ? (check-type n (integer 0 *)) (loop @@ -1602,9 +1652,9 @@ 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 (subpathname defaults (strcat name ".asd")))) - (when (probe-file* file) - (return file))) + (let* ((file (probe-file* (subpathname defaults (strcat name ".asd"))))) + (when file) + (return file)) #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!) (when (os-windows-p) (let ((shortcut @@ -1862,48 +1912,6 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (declare (ignorable s)) (source-file-explicit-type component)) -(defun* coerce-pathname (name &key type defaults) - "coerce NAME into a PATHNAME. -When given a string, portably decompose it into a relative pathname: -#\\/ separates subdirectories. The last #\\/-separated string is as follows: -if TYPE is NIL, its last #\\. if any separates name and type from from type; -if TYPE is a string, it is the type, and the whole string is the name; -if TYPE is :DIRECTORY, the string is a directory component; -if the string is empty, it's a directory. -Any directory named .. is read as :BACK. -Host, device and version components are taken from DEFAULTS." - ;; The defaults are required notably because they provide the default host - ;; to the below make-pathname, which may crucially matter to people using - ;; merge-pathnames with non-default hosts, e.g. for logical-pathnames. - ;; NOTE that the host and device slots will be taken from the defaults, - ;; but that should only matter if you later merge relative pathnames with - ;; CL:MERGE-PATHNAMES instead of ASDF:MERGE-PATHNAMES* - (etypecase name - ((or null pathname) - name) - (symbol - (coerce-pathname (string-downcase name) :type type :defaults defaults)) - (string - (multiple-value-bind (relative path filename) - (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)) - (values nil nil)) - (type - (values filename type)) - (t - (split-name-type filename))) - (apply 'make-pathname :directory (cons relative path) :name name :type type - (when defaults `(:defaults ,defaults)))))))) - -(defun* merge-component-name-type (name &key type defaults) - ;; For backwards compatibility only, for people using internals. - ;; Will be removed in a future release, e.g. 2.016. - (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.") - (coerce-pathname name :type type :defaults defaults)) - (defmethod component-relative-pathname ((component component)) (coerce-pathname (or (slot-value component 'relative-pathname) @@ -1911,14 +1919,6 @@ Host, device and version components are taken from DEFAULTS." :type (source-file-type component (component-system component)) :defaults (component-parent-pathname component))) -(defun* subpathname (pathname subpath &key type) - (and pathname (merge-pathnames* (coerce-pathname subpath :type type) - (pathname-directory-pathname pathname)))) - -(defun subpathname* (pathname subpath &key type) - (and pathname - (subpathname (ensure-directory-pathname pathname) subpath :type type))) - ;;;; ------------------------------------------------------------------------- ;;;; Operations @@ -3163,8 +3163,8 @@ located." #+clozure (defun* ccl-fasl-version () ;; the fasl version is target-dependent from CCL 1.8 on. - (or (and (fboundp 'ccl::target-fasl-version) - (funcall 'ccl::target-fasl-version)) + (or (let ((s 'ccl::target-fasl-version)) + (and (fboundp s) (funcall s))) (and (boundp 'ccl::fasl-version) (symbol-value 'ccl::fasl-version)) (error "Can't determine fasl version."))) diff --git a/test/logical-file.lisp b/test/logical-file.lisp new file mode 100644 index 0000000000000000000000000000000000000000..f1baaa6b9fd0ea2d06c225ad9f5adc1c4605253a --- /dev/null +++ b/test/logical-file.lisp @@ -0,0 +1,3 @@ +(defpackage :test-package (:use :cl)) +(in-package :test-package) +(defvar *logical-file* t) diff --git a/test/test-logical-pathname.asd b/test/test-logical-pathname.asd new file mode 100644 index 0000000000000000000000000000000000000000..2e8b331a5e6b188a3f1d74cee5163db8eebd8d30 --- /dev/null +++ b/test/test-logical-pathname.asd @@ -0,0 +1,4 @@ +;;; -*- Lisp -*- +(defsystem test-logical-pathname + :components + ((:file "logical-file"))) diff --git a/test/test-logical-pathname.script b/test/test-logical-pathname.script index 82807e35ae05cb6688d3107b91c63c56167bc543..64bd15d03972ba3681ed2035fe34750c6e1d12af 100644 --- a/test/test-logical-pathname.script +++ b/test/test-logical-pathname.script @@ -20,24 +20,24 @@ (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)) + (load-system :test-logical-pathname :force t)) (progn (format t "Test logical pathnames in source-registry, non-recursive~%") - (clear-system :test-force) + (clear-system :test-logical-pathname) (setf *central-registry* '()) (initialize-source-registry '(:source-registry (:directory #p"ASDF:test;") :ignore-inherited-configuration)) - (load-system :test-force :force t)) + (load-system :test-logical-pathname :force t)) (progn (format t "Test logical pathnames in source-registry, recursive~%") - (clear-system :test-force) + (clear-system :test-logical-pathname) (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)) + (load-system :test-logical-pathname :force t)) (format t "Done~%"))