Commit a730852a authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

2.26.106: a new primary/secondary convention for subsystems and more

A system named foo/bar will be looked up in a registered file foo.asd.
This makes it possible to sensibly name several systems in a .asd file
and still have asdf find them all by name.
We now use it to not have the asdf header be part of asdf-driver.

A new generic operation build-op makes it possible to deal with
the fact that the default operation for systems need not be load-op,
yet that the end-user does not want to have to know the exact operation
for each of the system he uses.

ensure-pathname has been improved again, and its clients tweaked.

remove-keys was made more sensible by using EQL rather than STRING-EQUAL.

:version need not take the first form in a file, but can take
a path to a subform. This makes it possible to get the exact subform
in a Lisp source file that has the string.
See SUB-OBJECT for how these paths work.

Cleanup of the semantics of ENSURE-FUNCTION on CONSes: use APPLY, not EVAL.
parent 0b681897
......@@ -18,11 +18,6 @@ endif
## MAJOR FAIL: gclcvs -- Compiler bug fixed upstream, but gcl fails to compile on modern Linuxen.
## grep for #+/#- features in the test/ directory to see plenty of disabled tests.
## Make sure testing remains within the confines of this filesystem tree
export ASDF_OUTPUT_TRANSLATIONS := (:output-translations (t ("${sourceDirectory}/build/fasls" :implementation)) :ignore-inherited-configuration)
export CL_SOURCE_REGISTRY := (:source-registry (:tree "${sourceDirectory}") :ignore-inherited-configuration)
lisp ?= sbcl
ABCL ?= abcl
......@@ -41,17 +36,20 @@ XCL ?= xcl
# website, tag, install
driver_lisp := header.lisp package.lisp compatibility.lisp utility.lisp pathname.lisp stream.lisp os.lisp image.lisp run-program.lisp lisp-build.lisp configuration.lisp backward-driver.lisp driver.lisp
header_lisp := header.lisp
driver_lisp := package.lisp compatibility.lisp utility.lisp pathname.lisp stream.lisp os.lisp image.lisp run-program.lisp lisp-build.lisp configuration.lisp backward-driver.lisp driver.lisp
asdf_lisp := upgrade.lisp component.lisp system.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp output-translations.lisp source-registry.lisp backward-internals.lisp defsystem.lisp bundle.lisp concatenate-source.lisp backward-interface.lisp interface.lisp footer.lisp
# Making ASDF itself should be our first, default, target:
build/asdf.lisp: $(wildcard *.lisp)
mkdir -p build
cat $(driver_lisp) $(asdf_lisp) > $@
cat $(header_lisp) $(driver_lisp) $(asdf_lisp) > $@
# This quickly locates such mistakes as unbalanced parentheses:
load:
rlwrap sbcl `for i in $(driver_lisp) $(asdf_lisp) ; do echo --load $$i ; done`
load: build/asdf.lisp
rlwrap sbcl \
`for i in $(driver_lisp) $(asdf_lisp) ; do echo --load $$i ; done` \
--eval '(in-package :asdf)'
install: archive-copy
......@@ -71,7 +69,7 @@ archive-copy: archive build/asdf.lisp
### Count lines separately for asdf-driver and asdf itself:
wc:
@wc $(driver_lisp) | sort -n ; echo ; \
wc $(asdf_lisp) | sort -n ; \
wc $(header_lisp) $(asdf_lisp) | sort -n ; \
echo ; \
wc $(driver_lisp) $(asdf_lisp) | tail -n 1
......
......@@ -11,7 +11,6 @@
#:action
#:explain #:operation-description
#:downward-operation #:upward-operation
#:file-component
#:source-file #:c-source-file #:java-source-file
#:static-file #:doc-file #:html-file
#:operation-error #:error-component #:error-operation
......@@ -140,8 +139,6 @@ You can put together sentences using this phrase."))
;;;; File components
(defclass file-component (child-component)
((type :accessor file-type :initarg :type))) ; no default
(defclass source-file (file-component)
((type :initform nil))) ;; NB: many systems have come to rely on this default.
(defclass c-source-file (source-file)
......@@ -161,13 +158,6 @@ You can put together sentences using this phrase."))
;; I guess we work with the original source file, then
(list (component-pathname c))))
(defmethod source-file-type ((component parent-component) system) ; not just for source-file. ASDF3: rename.
(declare (ignorable component system))
:directory)
(defmethod source-file-type ((component file-component) system)
(declare (ignorable system))
(file-type component))
;;;; Done performing
......@@ -250,3 +240,7 @@ in some previous image, or T if it needs to be done.")
(mark-operation-done operation component)
(return)))))
;;; Generic build operation
(defmethod component-depends-on ((o build-op) (c component))
`((,(or (component-build-operation c) 'load-op) ,c)))
;;; -*- mode: lisp -*-
(defpackage :asdf-driver-system (:use :cl :asdf))
(in-package :asdf)
(defun call-without-redefinition-warnings (thunk)
(handler-bind (#+clozure (ccl:compiler-warning #'muffle-warning))
......
......@@ -15,7 +15,7 @@
:licence "MIT"
:description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.26.105" ;; to be automatically updated by bin/bump-revision
:version "2.26.106" ;; to be automatically updated by bin/bump-revision
:depends-on ()
:components ((:module "build" :components ((:file "asdf"))))
:in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf))))
......@@ -30,3 +30,41 @@
#+(and clisp (not asdf2.27))
(rename-package :asdf :asdf-utilities)
#+asdf2.27
(defsystem :asdf/generate
:licence "MIT"
:description "All the components needed to build asdf.lisp"
:description "Generate asdf.lisp based on this and monolithic-concatenate-source-op"
:defsystem-depends-on (:asdf)
:class :bundle-system
:build-operation monolithic-concatenate-source-op
:bundle-pathname "build/asdf"
:translate-output-p nil
:serial t
:around-compile call-without-redefinition-warnings ;; be the same as asdf-driver
:depends-on (:asdf/header :asdf-driver)
:components
((:file "upgrade")
(:file "component")
(:file "system" :depends-on ("component"))
(:file "find-system" :depends-on ("system"))
(:file "find-component" :depends-on ("find-system"))
(:file "operation")
(:file "action" :depends-on ("find-component" "operation"))
(:file "lisp-action" :depends-on ("action"))
(:file "plan" :depends-on ("action"))
(:file "operate" :depends-on ("plan"))
(:file "output-translations" :depends-on ("operate"))
(:file "source-registry" :depends-on ("find-system"))
(:file "backward-internals" :depends-on ("action" "operate"))
(:file "defsystem" :depends-on ("backward-internals"))
(:file "bundle" :depends-on ("lisp-action"))
(:file "concatenate-source" :depends-on ("lisp-action"))
(:file "backward-interface" :depends-on ("lisp-action"))
(:file "interface")
(:file "footer" :depends-on ("interface"))))
(defsystem :asdf/header
:components
((:static-file "header.lisp")))
......@@ -27,7 +27,7 @@
;; (warn "Please don't use ASDF::COMPONENT-NAME-TO-PATHNAME-COMPONENTS, use SPLIT-UNIX-NAMESTRING-DIRECTORY-COMPONENTS")
(multiple-value-bind (relabs path filename file-only)
(split-unix-namestring-directory-components
unix-style-namestring :want-directory force-directory)
unix-style-namestring :ensure-directory force-directory)
(declare (ignore file-only))
(when (and force-relative (not (eq relabs :relative)))
(error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>")
......
......@@ -7,7 +7,8 @@
:asdf/system :asdf/component :asdf/find-system :asdf/action)
(:export ;; for internal use
#:%refresh-component-inline-methods
#:%resolve-if-component-dep-fails))
#:%resolve-if-component-dep-fails
#:make-sub-operation))
(in-package :asdf/backward-internals)
;;;; Backward compatibility with "inline methods"
......@@ -65,3 +66,6 @@
:when (eq feature? 'feature) :do
(setf (component-if-feature c) feature)))))
(when-upgrade (:when (fboundp 'make-sub-operation))
(defun* make-sub-operation (c o dep-c dep-o)
(declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)))
......@@ -7,6 +7,12 @@
(in-package :fare-utils)
(defparameter *versioned-files*
'(("version.lisp-expr" "\"" "\"")
("asdf.asd" " :version \"" "\" ;; to be automatically updated by bin/bump-revision")
("header.lisp" "This is ASDF " ": Another System Definition Facility.")
("upgrade.lisp" " (asdf-version \"" "\")")))
(defvar *adir* (asdf:system-relative-pathname :asdf nil))
(defun afile (x) (subpathname *adir* x))
......@@ -18,24 +24,28 @@
(defparameter *new-version* nil)
(defun next-version (v)
(let ((pv (parse-version v)))
(let ((pv (parse-version v 'error)))
(incf (third pv))
(unparse-version pv)))
(defun version-from-file ()
(safe-read-first-file-form *version-file*))
(safe-read-file-form *version-file*))
(defun versions-from-argv (argv)
(ecase (length argv)
((2) (values (second argv) (first argv)))
((1) (values (version-from-file) (first argv)))
((0) (let ((old (version-from-file)))
(values old (next-version old))))))
(labels ((check (old new)
(parse-version old 'error)
(parse-version new 'error)
(values old new)))
(ecase (length argv)
((2) (check (second argv) (first argv)))
((1) (check (version-from-file) (first argv)))
((0) (let ((old (version-from-file)))
(check old (next-version old)))))))
(multiple-value-setq (*old-version* *new-version*)
(versions-from-argv *command-line-arguments*))
(format t "Bumping ASDF version from ~A to ~A~%" *old-version* *new-version*)
(a "Bumping ASDF version from " *old-version* " to " *new-version*)
(deftype byte-vector () '(array (unsigned-byte 8) (*)))
......@@ -57,7 +67,7 @@
(clobber-file-with-vector file written-contents :external-format external-format)
(format t "done.~%")))))
(defun version-transformer (new-version file prefix suffix)
(defun version-transformer (new-version file prefix suffix &optional dont-warn)
(let* ((qprefix (cl-ppcre:quote-meta-chars prefix))
(versionrx "([0-9]+(\\.[0-9]+)+)")
(qsuffix (cl-ppcre:quote-meta-chars suffix))
......@@ -67,16 +77,10 @@
(lambda (text)
(multiple-value-bind (new-text foundp)
(cl-ppcre:regex-replace regex text replacement)
(unless (or foundp t)
(unless (or foundp dont-warn)
(warn "Missing version in ~A" (file-namestring file)))
(values new-text foundp)))))
(defparameter *versioned-files*
'(("version.lisp-expr" "\"" "\"")
("asdf.asd" " :version \"" "\" ;; to be automatically updated by bin/bump-revision")
("header.lisp" "This is ASDF " ": Another System Definition Facility.")
("upgrade.lisp" " (asdf-version \"" "\")")))
(defun transform-file (new-version file prefix suffix)
(maybe-replace-file (afile file) (version-transformer new-version file prefix suffix)))
......@@ -87,7 +91,7 @@
(let ((lines (read-file-lines (afile file))))
(dolist (l lines (progn (warn "Couldn't find a match in ~A" file) nil))
(multiple-value-bind (new-text foundp)
(funcall (version-transformer new-version file prefix suffix) l)
(funcall (version-transformer new-version file prefix suffix t) l)
(when foundp
(format t "Found a match:~% ==> ~A~%Replacing with~% ==> ~A~%~%"
l new-text)
......@@ -95,3 +99,6 @@
(defun z () (apply 'test-transform-file *new-version* (first *versioned-files*)))
(transform-files)
(a "Re-generate ASDF with bumped version")
(asdf:build-system :asdf/generate)
......@@ -10,40 +10,103 @@
(asdf-debug)
(describe (find-system :asdf))
;;; Make sure asdf.lisp is built.
(asdf:build-system :asdf/generate)
(defparameter *ad* (find-system :asdf-driver))
;;; ASDF directory
(defparameter *asdf-dir*
(ensure-pathname (system-source-directory *ad*)
:want-existing t :want-absolute t))
(defun apath (x) (subpathname *asdf-dir* x))
(defun ann (x) (native-namestring (apath x)))
(defparameter *build-dir* (apath "build/"))
(defparameter /build-dir/ (ann "build/"))
(defun bpath (x) (subpathname *build-dir* x))
(defun bnn (x) (native-namestring (bpath x)))
(defparameter *files*
(list* "asdf-driver.asd" "version.lisp-expr"
(loop :for c :in (operated-components
*ad* :goal-operation 'load-op
:keep-operation 'load-op)
:for n = (enough-namestring (component-pathname c)
*asdf-directory*)
:when (typep c 'cl-source-file)
:collect n)))
(ensure-pathname (system-relative-pathname :asdf ())
:want-physical t :want-absolute t
:want-existing t :truename t))
(defparameter /asdf-dir/
(native-namestring *asdf-dir*))
;;; build directory
(defparameter *build-dir*
(ensure-pathname
"build/" :defaults *asdf-dir*
:want-relative t :ensure-absolute t
:ensure-subpath t))
(defparameter /build-dir/
(native-namestring *build-dir*))
(defparameter *version*
(safe-read-first-file-form (apath "version.lisp-expr")))
(defparameter *name* (format nil "asdf-driver-~A" *version*))
(defparameter *tarname* (strcat *name* ".tar.gz"))
(defparameter dirname/ (strcat *name* "/"))
(defparameter *destination*
(ensure-pathname (bpath dirname/)
:want-directory t :want-absolute t))
(assert (< 6 (length (pathname-directory *destination*))))
(defparameter /destination/ (native-namestring *destination*))
(run-program/ `("rm" "-rf" ,/destination/))
(ensure-directory-exists *destination*)
(run-program/ `("ln" ,@(mapcar 'ann *files*) ,/destination/))
(run-program/ (format nil "cd ~S && tar zcf ~S ~S"
,/build-dir/, ,*tarname* ,dirname/))
(run-program/ `("rm" "-rf" ,/destination/))
(safe-read-first-file-form
(subpathname *asdf-dir* "version.lisp-expr")))
(defparameter *asdf-driver* (format nil "asdf-driver-~A" *version*))
(defun enough-namestring! (base pathname)
(let ((e (enough-namestring b p)))
(assert (relative-pathname e))
e))
(defun enough-namestrings (base pathnames)
(loop :with b = (ensure-pathname base :want-absolute t :want-directory t)
:for p :in pathnames
:collect (enough-namestring! base p)))
(defun system-source-files (system)
(let* ((sys (find-system system))
(dir (ensure-pathname
(system-source-directory sys)
:want-absolute t :want-directory t))
(components
(operated-components
sys :other-systems nil
:goal-operation 'load-op
:keep-operation 'load-op))
(pathnames (mapcar 'component-pathname components)))
(enough-namestrings dir pathnames)))
(defparameter *driver-files*
(list* "asdf-driver.asd" "version.lisp-expr"
(system-source-files :asdf-driver)))
(defparameter *asdf-only*
(format nil "asdf-only-~A" *version*))
(defparameter *asdf-only-files*
(list* "asdf.asd" "version.lisp-expr"
(system-source-files :asdf/generate)))
(defun tarname (name) (strcat name ".tar.gz"))
(defun make-tarball-under-build (name base files)
(let* ((/base/
(native-namestring
(ensure-pathname
base
:want-absolute t :want-directory t
:want-existing t :want-truename t)))
(destination
(ensure-pathname
name
:defaults *build-dir*
:want-relative t :ensure-absolute t
:ensure-subpath t :ensure-directory t))
(/destination/
(native-namestring destination))
(/tarball/
(native-namestring
(ensure-pathname
(tarname name)
:defaults *build-dir*
:want-relative t :ensure-absolute t
:ensure-subpath t :want-file t
:ensure-directories-exist t)))
(/files/
(mapcar 'native-namestring files)))
(assert (< 6 (length (pathname-directory destination))))
(run-program/ `("rm" "-rf" ,/destination/))
(ensure-directories-exist destination)
(run-program/ (format nil "cd ~S && cp -lax --parents ~{~S ~} ~S"
/base/ /files/ /destination/))
(run-program/ (format nil "tar zcvfC ~S ~S ~S/"
/tarball/ /build/ name))
(run-program/ `("rm" "-rf" ,/destination/))))
(make-tarball-under-build *asdf-driver* *asdf-directory* *asdf-driver-files*)
(make-tarball-under-build *asdf-only* *asdf-directory* *asdf-only-files*)
(run-program/ (format nil "cd ~S && tar zcf build/asdf-~A.tar.gz build/asdf.lisp $(git ls-files)"
/asdf-dir/ *version*))
......@@ -11,7 +11,7 @@
#:fasl-op #:load-fasl-op #:lib-op #:dll-op #:binary-op
#:monolithic-op #:monolithic-bundle-op #:dependency-files
#:monolithic-binary-op #:monolithic-fasl-op #:monolithic-lib-op #:monolithic-dll-op
#:program-op #:program-system
#:program-op
#:compiled-file #:precompiled-system #:prebuilt-system
#:operation-monolithic-p
#:user-system-p #:user-system #:trivial-system-p
......@@ -105,10 +105,6 @@
(translate-output-p
:initform nil :initarg :translate-output-p :accessor component-translate-output-p)))
(defclass program-system (bundle-system)
((bundle-pathname :initarg :executable-name)
(bundle-operation :initform 'program-op)))
(defun* bundle-pathname-type (bundle-type)
(etypecase bundle-type
((eql :no-output-file) nil) ;; should we error out instead?
......@@ -181,13 +177,13 @@
&allow-other-keys)
(operation-original-initargs instance)
(setf (operation-original-initargs instance)
(remove-keys '(lisp-files epilogue-code prologue-code) original-initargs)
(remove-keys '(:lisp-files :epilogue-code :prologue-code) original-initargs)
(monolithic-op-prologue-code instance) prologue-code
(monolithic-op-epilogue-code instance) epilogue-code)
#-ecl (assert (null (or lisp-files epilogue-code prologue-code)))
#+ecl (setf (bundle-op-lisp-files instance) lisp-files)))
(setf (bundle-op-build-args instance)
(remove-keys '(type monolithic name-suffix)
(remove-keys '(:type :monolithic :name-suffix)
(operation-original-initargs instance))))
(defmethod bundle-op-build-args :around ((o lib-op))
......@@ -297,6 +293,12 @@
(declare (ignorable o c))
nil)
(defmethod component-depends-on :around ((o bundle-op) (c component))
(declare (ignorable o c))
(if-bind (op (and (eq (type-of o) 'bundle-op) (component-bundle-operation c)))
`((,op ,c))
(call-next-method)))
(defun* dependency-files (o c &key (test 'identity) (key 'output-files))
(while-collecting (collect)
(visit-dependencies
......@@ -330,7 +332,7 @@
(merge-pathnames "./asdf-output/")))
(operation (apply #'operate operation-name
system
(remove-keys '(monolithic type move-here) args)))
(remove-keys '(:monolithic :type :move-here) args)))
(system (find-system system))
(files (and system (output-files operation system))))
(if (or move-here (and (null move-here-p)
......
......@@ -8,6 +8,8 @@
#:component #:component-find-path
#:component-name #:component-pathname #:component-relative-pathname
#:component-parent #:component-system #:component-parent-pathname
#:child-component #:parent-component #:module
#:file-component
#:source-file-type ;; backward-compatibility
#:component-in-order-to #:component-sibling-dependencies
#:component-if-feature #:around-compile-hook
......@@ -18,6 +20,10 @@
#:component-operation-times ;; For internal use only.
;; portable ASDF encoding and implementation-specific external-format
#:component-external-format #:component-encoding
#:component-children-by-name #:component-children #:compute-children-by-name
#:component-build-operation
#:module-default-component-class
#:module-components ;; backward-compatibility. DO NOT USE.
;; Internals we'd like to share with the ASDF package.
#:name #:version #:description #:long-description
......@@ -44,6 +50,9 @@ another pathname in a degenerate way."))
(defgeneric* component-external-format (component))
(defgeneric* component-encoding (component))
(defgeneric* version-satisfies (component version))
;;; Backward compatible way of computing the FILE-TYPE of a component.
;;; TODO: find users, have them stop using that.
(defgeneric* source-file-type (component system))
(when-upgrade (:when (find-class 'component nil))
......@@ -95,7 +104,9 @@ another pathname in a degenerate way."))
(properties :accessor component-properties :initarg :properties
:initform nil)
;; For backward-compatibility, this slot is part of component rather than child-component
(parent :initarg :parent :initform nil :reader component-parent)))
(parent :initarg :parent :initform nil :reader component-parent)
(build-operation
:initarg :build-operation :initform nil :reader component-build-operation)))
(defun* component-find-path (component)
(check-type component (or null component))
......@@ -113,6 +124,57 @@ another pathname in a degenerate way."))
component))
;;;; Component hierarchy within a system
;; The tree typically but not necessarily follows the filesystem hierarchy.
(defclass child-component (component) ())
(defclass file-component (child-component)
((type :accessor file-type :initarg :type))) ; no default
(defclass parent-component (component)
((children
:initform nil
:initarg :components
:reader module-components ; backward-compatibility
:accessor component-children)
(children-by-name
:reader module-components-by-name ; backward-compatibility
:accessor component-children-by-name)
(default-component-class
:initform nil
:initarg :default-component-class
:accessor module-default-component-class)))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun* compute-children-by-name (parent &key only-if-needed-p)
(unless (and only-if-needed-p (slot-boundp parent 'children-by-name))
(let ((hash (make-hash-table :test 'equal)))
(setf (component-children-by-name parent) hash)
(loop :for c :in (component-children parent)
:for name = (component-name c)
:for previous = (gethash name hash)
:do (when previous (error 'duplicate-names :name name))
(setf (gethash name hash) c))
hash))))
(when-upgrade (:when (find-class 'module nil))
(defmethod reinitialize-instance :after ((m module) &rest initargs &key)
(declare (ignorable m initargs)) (values))
(defmethod update-instance-for-redefined-class :after
((m module) added deleted plist &key)
(declare (ignorable m added deleted plist))
(when (and (member 'children added) (member 'components deleted))
(setf (slot-value m 'children)
;; old ECLs provide an alist instead of a plist(!)
(if (or #+ecl (consp (first plist))) (or #+ecl (cdr (assoc 'components plist)))
(getf plist 'components)))
(compute-children-by-name m))))
(defclass module (child-component parent-component)
())
;;;; component pathnames
(defun* component-parent-pathname (component)
......@@ -138,14 +200,25 @@ another pathname in a degenerate way."))
pathname)))
(defmethod component-relative-pathname ((component component))
;; source-file-type is backward-compatibility with ASDF1;
;; we ought to be able to extract this from the component alone with COMPONENT-TYPE.
;; TODO: track who uses it, and have them not use it anymore.
(parse-unix-namestring
(or (and (slot-boundp component 'relative-pathname)
(slot-value component 'relative-pathname))
(component-name component))
:want-relative t
:type (source-file-type component (component-system component)) ;; backward-compatibility
:type (source-file-type component (component-system component))
:defaults (component-parent-pathname component)))
(defmethod source-file-type ((component parent-component) system)
(declare (ignorable component system))
:directory)
(defmethod source-file-type ((component file-component) system)
(declare (ignorable system))
(file-type component))
;;;; General component-property - ASDF3: remove? Define clean subclasses, not messy "properties".
......
......@@ -16,7 +16,6 @@
#:monolithic-load-concatenated-source-op
#:monolithic-compile-concatenated-source-op
#:monolithic-load-compiled-concatenated-source-op
#:concatenated-source-system
#:component-concatenated-source-file
#:concatenated-source-file))
(in-package :asdf/concatenate-source)
......@@ -38,10 +37,6 @@
(defclass monolithic-compile-concatenated-source-op (compile-concatenated-source-op monolithic-op) ())
(defclass monolithic-load-compiled-concatenated-source-op (load-compiled-concatenated-source-op monolithic-op) ())
(defclass concatenated-source-system (bundle-system)
((bundle-pathname :initarg :concatenated-source-file)
(bundle-operation :initform :load-compiled-concatenated-source-op)))
(defmethod input-files ((operation concatenate-source-op) (s system))
(loop :with encoding = (or (component-encoding s) *default-encoding*)
:with other-encodings = '()
......
......@@ -151,33 +151,33 @@ values of TAG include :source-registry and :output-translations."
:do (report-invalid-form invalid-form-reporter :form form :location file)))
:inherit-configuration)))
(defun* resolve-relative-location-component (x &key want-directory wilden)
(defun* resolve-relative-location-component (x &key ensure-directory wilden)
(ensure-pathname
(etypecase x
(pathname x)
(string (parse-unix-namestring
x :want-directory want-directory))
x :ensure-directory ensure-directory))
(cons
(if (null (cdr x))
(resolve-relative-location-component
(car x) :want-directory want-directory :wilden wilden)
(car x) :ensure-directory ensure-directory :wilden wilden)
(let* ((car (resolve-relative-location-component
(car x) :want-directory t :wilden nil)))
(car x) :ensure-directory t :wilden nil)))
(merge-pathnames*
(resolve-relative-location-component
(cdr x) :want-directory want-directory :wilden wilden)
(cdr x) :ensure-directory ensure-directory :wilden wilden)
car))))
((eql :*/) *wild-directory*)
((eql :**/) *wild-inferiors*)
((eql :*.*.*) *wild-file*)
((eql :implementation)
(parse-unix-namestring
(implementation-identifier) :want-directory t))
(implementation-identifier) :ensure-directory t))
((eql :implementation-type)
(parse-unix-namestring
(string-downcase (implementation-type)) :want-directory t))
(string-downcase (implementation-type)) :ensure-directory t))
((eql :hostname)
(parse-unix-namestring (hostname) :want-directory t)))
(parse-unix-namestring (hostname) :ensure-directory t)))
:wilden (and wilden (not (pathnamep x)) (not (member x '(:*/ :**/ :*.*.*))))
:want-relative t))
......@@ -201,7 +201,7 @@ directive.")
'(:home ".cache" "common-lisp" :implementation)))))
(register-image-restore-hook 'compute-user-cache)
(defun* resolve-absolute-location-component (x &key want-directory wilden)
(defun* resolve-absolute-location-component (x &key ensure-directory wilden)
(ensure-pathname
(etypecase x
(pathname x)
......@@ -209,17 +209,17 @@ directive.")
(let ((p #-mcl (parse-namestring x)
#+mcl (probe-posix x)))
#+mcl (unless p (error "POSIX pathname ~S does not exist" x))
(if want-directory (ensure-directory-pathname p) p)))
(if ensure-directory (ensure-directory-pathname p) p)))
(cons
(return-from resolve-absolute-location-component
(if (null (cdr x))
(resolve-absolute-location-component
(car x) :want-directory want-directory :wilden wilden)
(car x) :ensure-directory ensure-directory :wilden wilden)
(merge-pathnames*
(resolve-relative-location-component
(cdr x) :want-directory want-directory :wilden wilden)
(cdr x) :ensure-directory ensure-directory :wilden wilden)
(resolve-absolute-location-component
(car x) :want-directory t :wilden nil)))))
(car x) :ensure-directory t :wilden nil)))))
((eql :root)
;; special magic! we return a relative pathname,
;; but what it means to the output-translations is
......@@ -229,25 +229,25 @@ directive.")
(if wilden (wilden p) p))))
((eql :home) (user-homedir))
((eql :here) (resolve-absolute-location-component
*here-directory* :want-directory t :wilden nil))
*here-directory* :ensure-directory t :wilden nil))
((eql :user-cache) (resolve-absolute-location-component
*user-cache* :want-directory t :wilden nil)))
*user-cache* :ensure-directory t :wilden nil)))
:wilden (and wilden (not (pathnamep x)))
:want-absolute t))
(defun* resolve-location (x &key want-directory wilden directory)
(when directory (setf want-directory t)) ;; :directory backward compatibility, until 2014-01-16.
(defun* resolve-location (x &key ensure-directory wilden directory)
(when directory (setf ensure-directory t)) ;; :directory backward compatibility, until 2014-01-16.
(if (atom x)
(resolve-absolute-location-component x :want-directory want-directory :wilden wilden)
(resolve-absolute-location-component x :ensure-directory ensure-directory :wilden wilden)
(loop :with path = (resolve-absolute-location-component
(car x) :want-directory (and (or want-directory (cdr x)) t)
(car x) :ensure-directory (and (or ensure-directory (cdr x)) t)
:wilden (and wilden (null (cdr x))))
:for (component . morep) :on (cdr x)
:for dir = (and (or morep want-directory) t)
:for dir = (and (or morep ensure-directory) t)
:for wild = (and wilden (not morep))
:do (setf path (merge-pathnames*
(resolve-relative-location-component
component :want-directory dir :wilden wild)
component :ensure-directory dir :wilden wild)
path))
:finally (return path))))
......
......@@ -26,7 +26,7 @@
;; is considered (as deduced from e.g. *LOAD-PATHNAME*), and
;; if it is indeed available and an absolute pathname, then
;; the PATHNAME argument is normalized to a relative pathname
;; as per PARSE-UNIX-NAMESTRING (with WANT-DIRECTORY T)
;; as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T)
;; and merged into that DIRECTORY as per SUBPATHNAME.
;; If no absolute pathname was found, we return NIL.
(check-type pathname (or null string pathname))
......@@ -71,7 +71,7 @@
type name value))
(defun* check-component-input (type name weakly-depends-on
depends-on components in-order-to)
depends-on components)
"A partial test of the values of a component."
(unless (listp depends-on)
(sysdef-error-component ":depends-on must be a list."
......@@ -81,80 +81,82 @@
type name weakly-depends-on))
(unless (listp components)
(sysdef-error-component ":components must be NIL or a list of components."
type name components))
(unless (and (listp in-order-to) (listp (car in-order-to)))
(sysdef-error-component ":in-order-to must be NIL or a list of components."
type name in-order-to)))
type name components)))
(defun* normalize-version (form pathname)
(cond
((typep form '(or string null)) form)
((length=n-p form 2)
(etypecase form
((or string null) form)
(cons
(ecase (first form)
((:read-file-form)