Commit aa5cba5d authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

2.26.100: checkpointing a lot of progress.

* Pathname support has been cleaned up, yet again,
 extending and renaming COERCE-PATHNAME into PARSE-UNIX-NAMESTRING,
 also ENSURE-PATHNAME, many docstrings, and plenty of small enhancements.
* Bundles were refactored to take advantage of the new, more sensible,
 component-depends-on semantics.
* Image support was cleaned up again, and program-op was implemented
 to produce a standalone executable on supported platforms;
 a working hello-world-example is included amongst tests.
* The *compile-file-function* indirection was removed, with the
 ECL and MKCL object file support
 being folded into compile-file* instead.
* systems now can have NIL as component-pathname,
 instead of providing a non-sensible bogus pathname
 when no sensible pathname was determined.
 Most of our pathname functions have sensible default behavior
 when provided NIL instead of a pathname as an argument.
parent 0af76dd1
...@@ -37,6 +37,7 @@ tmp/ ...@@ -37,6 +37,7 @@ tmp/
*.~*~ *.~*~
test/try-reloading-dependency.asd test/try-reloading-dependency.asd
test/fileMissing.lisp test/fileMissing.lisp
test/hello-world-example
build-stamp build-stamp
debian/cl-asdf.debhelper.log debian/cl-asdf.debhelper.log
......
...@@ -4,17 +4,24 @@ webhome_public := "http://common-lisp.net/project/asdf/" ...@@ -4,17 +4,24 @@ webhome_public := "http://common-lisp.net/project/asdf/"
clnet_home := "/project/asdf/public_html/" clnet_home := "/project/asdf/public_html/"
sourceDirectory := $(shell pwd) sourceDirectory := $(shell pwd)
#### Common Lisp implementations available for testing.
## export ASDF_TEST_LISPS to override the default list of such implementations,
## or specify a lisps= argument at the make command-line
ifdef ASDF_TEST_LISPS ifdef ASDF_TEST_LISPS
lisps ?= ${ASDF_TEST_LISPS} lisps ?= ${ASDF_TEST_LISPS}
else else
lisps ?= ccl clisp sbcl ecl ecl_bytecodes cmucl abcl scl allegro lispworks allegromodern xcl gcl lisps ?= ccl clisp sbcl ecl ecl_bytecodes cmucl abcl scl allegro lispworks allegromodern xcl gcl
endif endif
## NOT SUPPORTED BY OUR AUTOMATED TESTS:
## cormancl genera lispworks-personal-edition mkcl rmcl
## Some are manually tested once in a while.
## 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 ASDF_OUTPUT_TRANSLATIONS := (:output-translations (t ("${sourceDirectory}/build/fasls" :implementation)) :ignore-inherited-configuration)
export CL_SOURCE_REGISTRY := (:source-registry (:tree "${sourceDirectory}") :ignore-inherited-configuration) export CL_SOURCE_REGISTRY := (:source-registry (:tree "${sourceDirectory}") :ignore-inherited-configuration)
## MAJOR FAIL: gclcvs -- COMPILER BUG! Upstream fixed it, but upstream fails to compile.
## NOT SUPPORTED BY OUR TESTS: cormancl genera lispworks-personal-edition mkcl rmcl. Manually tested once in a while.
lisp ?= sbcl lisp ?= sbcl
...@@ -37,10 +44,15 @@ XCL ?= xcl ...@@ -37,10 +44,15 @@ XCL ?= xcl
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 driver.lisp 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 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 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) build/asdf.lisp: $(wildcard *.lisp)
mkdir -p build mkdir -p build
cat $(driver_lisp) $(asdf_lisp) > $@ cat $(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`
install: archive-copy install: archive-copy
archive: archive:
...@@ -56,18 +68,13 @@ archive-copy: archive build/asdf.lisp ...@@ -56,18 +68,13 @@ archive-copy: archive build/asdf.lisp
${MAKE} push ${MAKE} push
git checkout master git checkout master
### Count lines separately for asdf-driver and asdf itself:
wc: wc:
@wc $(driver_lisp) | sort -n ; echo ; \ @wc $(driver_lisp) | sort -n ; echo ; \
wc $(asdf_lisp) | sort -n ; \ wc $(asdf_lisp) | sort -n ; \
echo ; \ echo ; \
wc $(driver_lisp) $(asdf_lisp) | tail -n 1 wc $(driver_lisp) $(asdf_lisp) | tail -n 1
wc-driver:
wc $(driver_lisp)
wc-asdf:
wc $(asdf_lisp)
push: push:
git status git status
git push --tags cl.net release master git push --tags cl.net release master
...@@ -136,12 +143,12 @@ debian-package: mrproper ...@@ -136,12 +143,12 @@ debian-package: mrproper
: $${RELEASE:="$$(git tag -l '2.[0-9][0-9]' | tail -n 1)"} ; \ : $${RELEASE:="$$(git tag -l '2.[0-9][0-9]' | tail -n 1)"} ; \
git-buildpackage --git-debian-branch=release --git-upstream-branch=$$RELEASE --git-tag --git-retag --git-ignore-branch git-buildpackage --git-debian-branch=release --git-upstream-branch=$$RELEASE --git-tag --git-retag --git-ignore-branch
# Replace SBCL's ASDF with the current one. -- Not recommended now that SBCL has ASDF2. # Replace SBCL's ASDF with the current one. -- NOT recommended now that SBCL has ASDF2.
# for casual users, just use (asdf:load-system :asdf) # for casual users, just use (asdf:load-system :asdf)
replace-sbcl-asdf: build/asdf.lisp replace-sbcl-asdf: build/asdf.lisp
${SBCL} --eval '(compile-file "$<" :output-file (format nil "~Aasdf/asdf.fasl" (sb-int:sbcl-homedir-pathname)))' --eval '(quit)' ${SBCL} --eval '(compile-file "$<" :output-file (format nil "~Aasdf/asdf.fasl" (sb-int:sbcl-homedir-pathname)))' --eval '(quit)'
# Replace CCL's ASDF with the current one. -- Not recommended now that CCL has ASDF2. # Replace CCL's ASDF with the current one. -- NOT recommended now that CCL has ASDF2.
# for casual users, just use (asdf:load-system :asdf) # for casual users, just use (asdf:load-system :asdf)
replace-ccl-asdf: build/asdf.lisp replace-ccl-asdf: build/asdf.lisp
${CCL} --eval '(progn(compile-file "$<" :output-file (compile-file-pathname (format nil "~Atools/asdf.lisp" (ccl::ccl-directory))))(quit))' ${CCL} --eval '(progn(compile-file "$<" :output-file (compile-file-pathname (format nil "~Atools/asdf.lisp" (ccl::ccl-directory))))(quit))'
...@@ -150,6 +157,7 @@ WRONGFUL_TAGS := 1.37 1.1720 README RELEASE STABLE ...@@ -150,6 +157,7 @@ WRONGFUL_TAGS := 1.37 1.1720 README RELEASE STABLE
# Delete wrongful tags from local repository # Delete wrongful tags from local repository
fix-local-git-tags: fix-local-git-tags:
for i in ${WRONGFUL_TAGS} ; do git tag -d $$i ; done for i in ${WRONGFUL_TAGS} ; do git tag -d $$i ; done
git tag 1.37 c7738c62 # restore the *correct* 1.37 tag.
# Delete wrongful tags from remote repository # Delete wrongful tags from remote repository
fix-remote-git-tags: fix-remote-git-tags:
......
...@@ -112,10 +112,17 @@ You can put together sentences using this phrase.")) ...@@ -112,10 +112,17 @@ You can put together sentences using this phrase."))
"Translate output files, unless asked not to" "Translate output files, unless asked not to"
operation component ;; hush genera, not convinced by declare ignorable(!) operation component ;; hush genera, not convinced by declare ignorable(!)
(values (values
(multiple-value-bind (files fixedp) (call-next-method) (multiple-value-bind (pathnames fixedp) (call-next-method)
(if fixedp ;; 1- Make sure we have absolute pathnames
files (let* ((directory (pathname-directory-pathname (component-pathname component)))
(mapcar *output-translation-function* files))) (absolute-pathnames
(loop :for pathname :in pathnames
:collect (ensure-pathname
(subpathname directory pathname) :want-absolute t))))
;; 2- Translate those pathnames as required
(if fixedp
absolute-pathnames
(mapcar *output-translation-function* absolute-pathnames))))
t)) t))
(defmethod output-files ((o operation) (c component)) (defmethod output-files ((o operation) (c component))
(declare (ignorable o c)) (declare (ignorable o c))
......
;;; -*- mode: lisp -*- ;;; -*- mode: lisp -*-
(defpackage :asdf-driver-system (:use :cl :asdf))
(defun call-without-redefinition-warnings (thunk)
(handler-bind (#+clozure (ccl:compiler-warning #'muffle-warning))
(funcall thunk)))
(defsystem :asdf-driver (defsystem :asdf-driver
:licence "MIT" :licence "MIT"
...@@ -6,6 +11,8 @@ ...@@ -6,6 +11,8 @@
:long-description "Basic general-purpose utilities that is in such a need :long-description "Basic general-purpose utilities that is in such a need
that you can't portably construct a complete program without using them." that you can't portably construct a complete program without using them."
#+asdf2.27 :version #+asdf2.27 (:read-file-form "version.lisp-expr") #+asdf2.27 :version #+asdf2.27 (:read-file-form "version.lisp-expr")
:defsystem-depends-on (#+(and (not asdf2.27) (or clisp xcl)) :asdf)
:around-compile call-without-redefinition-warnings
:components :components
((:file "header") ((:file "header")
(:file "package") (:file "package")
......
...@@ -15,7 +15,7 @@ ...@@ -15,7 +15,7 @@
:licence "MIT" :licence "MIT"
:description "Another System Definition Facility" :description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems." :long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.26.99" ;; to be automatically updated by bin/bump-revision :version "2.26.100" ;; to be automatically updated by bin/bump-revision
:depends-on () :depends-on ()
:components ((:module "build" :components ((:file "asdf")))) :components ((:module "build" :components ((:file "asdf"))))
:in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf)))) :in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf))))
......
...@@ -10,7 +10,6 @@ ...@@ -10,7 +10,6 @@
#:*asdf-verbose* #:*asdf-verbose*
#:component-load-dependencies #:component-load-dependencies
#:enable-asdf-binary-locations-compatibility #:enable-asdf-binary-locations-compatibility
#:merge-component-name-type
#:operation-forced #:operation-forced
#:operation-on-failure #:operation-on-failure
#:operation-on-warnings #:operation-on-warnings
...@@ -22,11 +21,12 @@ ...@@ -22,11 +21,12 @@
;; Old deprecated name for the same thing. Please update your software. ;; Old deprecated name for the same thing. Please update your software.
(component-sibling-dependencies component)) (component-sibling-dependencies component))
(defun* merge-component-name-type (name &key type defaults) (defun* coerce-pathname (name &key type defaults)
;; For backward-compatibility only, for people using internals. ;; For backward-compatibility only, for people using internals
;; Will be removed in a future release, e.g. 2.016. ;; Reported users in quicklisp: hu.dwim.asdf, asdf-utils, xcvb
(warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.") ;; Will be removed in a future release, e.g. 2.30.
(coerce-pathname name :type type :defaults defaults)) (warn "Please don't use ASDF::COERCE-PATHNAME. Use ASDF/PATHNAME:PARSE-UNIX-NAMESTRING.")
(parse-unix-namestring name :type type :defaults defaults))
(defgeneric* operation-forced (operation)) ;; Used by swank.asd for swank-loader. (defgeneric* operation-forced (operation)) ;; Used by swank.asd for swank-loader.
(defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force)) (defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force))
...@@ -71,7 +71,7 @@ if that's whay you mean." ;;) ...@@ -71,7 +71,7 @@ if that's whay you mean." ;;)
#+(or clisp ecl mkcl) #+(or clisp ecl mkcl)
(when (null map-all-source-files) (when (null map-all-source-files)
(error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL")) (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL"))
(let* ((fasl-type (fasl-type)) (let* ((fasl-type (compile-file-type))
(mapped-files (if map-all-source-files *wild-file* (mapped-files (if map-all-source-files *wild-file*
(make-pathname :type fasl-type :defaults *wild-file*))) (make-pathname :type fasl-type :defaults *wild-file*)))
(destination-directory (destination-directory
......
This diff is collapsed.
...@@ -138,10 +138,11 @@ another pathname in a degenerate way.")) ...@@ -138,10 +138,11 @@ another pathname in a degenerate way."))
pathname))) pathname)))
(defmethod component-relative-pathname ((component component)) (defmethod component-relative-pathname ((component component))
(coerce-pathname (parse-unix-namestring
(or (and (slot-boundp component 'relative-pathname) (or (and (slot-boundp component 'relative-pathname)
(slot-value component 'relative-pathname)) (slot-value component 'relative-pathname))
(component-name component)) (component-name component))
:want-relative t
:type (source-file-type component (component-system component)) ;; backward-compatibility :type (source-file-type component (component-system component)) ;; backward-compatibility
:defaults (component-parent-pathname component))) :defaults (component-parent-pathname component)))
......
...@@ -17,76 +17,59 @@ ...@@ -17,76 +17,59 @@
#:monolithic-compile-concatenated-source-op #:monolithic-compile-concatenated-source-op
#:monolithic-load-compiled-concatenated-source-op #:monolithic-load-compiled-concatenated-source-op
#:concatenated-source-system #:concatenated-source-system
#:system-concatenated-source-file #:component-concatenated-source-file
#:system-translate-output-p #:concatenated-source-file))
#:translate-output-p #:concatenated-source-file))
(in-package :asdf/concatenate-source) (in-package :asdf/concatenate-source)
;;; ;;;
;;; Concatenate sources ;;; Concatenate sources
;;; ;;;
(defclass concatenate-source-op (operation) ()) (defclass concatenate-source-op (bundle-op)
(defclass load-concatenated-source-op (basic-load-op operation) ()) ((bundle-type :initform "lisp")))
(defclass compile-concatenated-source-op (basic-compile-op operation) ()) (defclass load-concatenated-source-op (basic-load-op operation)
(defclass load-compiled-concatenated-source-op (basic-load-op operation) ()) ((bundle-type :initform :no-output-file)))
(defclass compile-concatenated-source-op (basic-compile-op bundle-op)
((bundle-type :initform :fasl)))
(defclass load-compiled-concatenated-source-op (basic-load-op operation)
((bundle-type :initform :no-output-file)))
(defclass monolithic-concatenate-source-op (concatenate-source-op monolithic-op) ()) (defclass monolithic-concatenate-source-op (concatenate-source-op monolithic-op) ())
(defclass monolithic-load-concatenated-source-op (load-concatenated-source-op monolithic-op) ()) (defclass monolithic-load-concatenated-source-op (load-concatenated-source-op monolithic-op) ())
(defclass monolithic-compile-concatenated-source-op (compile-concatenated-source-op monolithic-op) ()) (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 monolithic-load-compiled-concatenated-source-op (load-compiled-concatenated-source-op monolithic-op) ())
(defclass concatenated-source-system (system) (defclass concatenated-source-system (bundle-system)
((concatenated-source-file ((bundle-pathname :initarg :concatenated-source-file)
:initform nil :initarg :concatenated-source-file :reader system-concatenated-source-file) (bundle-operation :initform :load-compiled-concatenated-source-op)))
(translate-output-p
:initform t :initarg :translate-output-p :reader system-translate-output-p)))
(defmethod system-concatenated-source-file ((s system))
(declare (ignorable s))
nil)
(defmethod system-translate-output-p ((s system))
(declare (ignorable s))
t)
(defmethod input-files ((o concatenate-source-op) (s system)) (defmethod input-files ((operation concatenate-source-op) (s system))
(loop :with op = (make-operation 'compile-op) (loop :with encoding = (or (component-encoding s) *default-encoding*)
:with components = (gather-components op s
:include-self nil
:filter-type 'source-file
:other-systems (operation-monolithic-p o))
:with non-cl-source-files = nil
:with encoding = (or (component-encoding s) *default-encoding*)
:with other-encodings = '() :with other-encodings = '()
:with around-compile = (around-compile-hook s) :with around-compile = (around-compile-hook s)
:with other-around-compile = '() :with other-around-compile = '()
:for (o . c) :in components :for c :in (gather-components s
:do (cond :goal-operation 'compile-op
((typep c 'cl-source-file) :keep-operation 'compile-op
(let ((e (component-encoding c))) :component-type 'component
(unless (equal e encoding) :other-systems (operation-monolithic-p operation))
(pushnew e other-encodings :test 'equal))) :append
(let ((a (around-compile-hook c))) (when (typep c 'cl-source-file)
(unless (equal a around-compile) (let ((e (component-encoding c)))
(pushnew a other-around-compile :test 'equal)))) (unless (equal e encoding)
(t (pushnew e other-encodings :test 'equal)))
(push c non-cl-source-files))) (let ((a (around-compile-hook c)))
:append (input-files o c) :into inputs (unless (equal a around-compile)
(pushnew a other-around-compile :test 'equal)))
(input-files (make-operation 'compile-op) c)) :into inputs
:finally :finally
(when non-cl-source-files
(warn "~S depends on these non CL source files: ~A"
'concatenated-source-op non-cl-source-files))
(when other-encodings (when other-encodings
(warn "~S uses encoding ~A but has sources that use these encodings: ~A" (warn "~S uses encoding ~A but has sources that use these encodings: ~A"
'concatenated-source-op encoding other-encodings)) operation encoding other-encodings))
(when other-around-compile (when other-around-compile
(warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A" (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A"
'concatenated-source-op around-compile other-around-compile)) operation around-compile other-around-compile))
(return inputs))) (return inputs)))
(defmethod output-files ((o concatenate-source-op) (s system))
(declare (ignorable o))
(let ((of (or (system-concatenated-source-file s) (strcat (coerce-name s) ".lisp")))
(top (system-translate-output-p s)))
(values (list (system-relative-pathname s of)) (not top))))
(defmethod input-files ((o load-concatenated-source-op) (s system)) (defmethod input-files ((o load-concatenated-source-op) (s system))
(output-files (find-operation o 'concatenate-source-op) s)) (output-files (find-operation o 'concatenate-source-op) s))
(defmethod input-files ((o compile-concatenated-source-op) (s system)) (defmethod input-files ((o compile-concatenated-source-op) (s system))
...@@ -97,6 +80,16 @@ ...@@ -97,6 +80,16 @@
(defmethod input-files ((o load-compiled-concatenated-source-op) (s system)) (defmethod input-files ((o load-compiled-concatenated-source-op) (s system))
(output-files (find-operation o 'compile-concatenated-source-op) s)) (output-files (find-operation o 'compile-concatenated-source-op) s))
(defmethod input-files ((o monolithic-load-concatenated-source-op) (s system))
(output-files (find-operation o 'monolithic-concatenate-source-op) s))
(defmethod input-files ((o monolithic-compile-concatenated-source-op) (s system))
(output-files (find-operation o 'monolithic-concatenate-source-op) s))
(defmethod output-files ((o monolithic-compile-concatenated-source-op) (s system))
(let ((input (first (input-files o s))))
(list (compile-file-pathname input))))
(defmethod input-files ((o monolithic-load-compiled-concatenated-source-op) (s system))
(output-files (find-operation o 'monolithic-compile-concatenated-source-op) s))
(defmethod perform ((o concatenate-source-op) (s system)) (defmethod perform ((o concatenate-source-op) (s system))
(let ((inputs (input-files o s)) (let ((inputs (input-files o s))
(output (output-file o s))) (output (output-file o s)))
......
...@@ -132,7 +132,7 @@ be applied to the results to yield a configuration form. Current ...@@ -132,7 +132,7 @@ be applied to the results to yield a configuration form. Current
values of TAG include :source-registry and :output-translations." values of TAG include :source-registry and :output-translations."
(let ((files (sort (ignore-errors (let ((files (sort (ignore-errors
(remove-if (remove-if
'hidden-file-p 'hidden-pathname-p
(directory* (make-pathname :name *wild* :type "conf" :defaults directory)))) (directory* (make-pathname :name *wild* :type "conf" :defaults directory))))
#'string< :key #'namestring))) #'string< :key #'namestring)))
`(,tag `(,tag
...@@ -151,118 +151,114 @@ values of TAG include :source-registry and :output-translations." ...@@ -151,118 +151,114 @@ values of TAG include :source-registry and :output-translations."
:do (report-invalid-form invalid-form-reporter :form form :location file))) :do (report-invalid-form invalid-form-reporter :form form :location file)))
:inherit-configuration))) :inherit-configuration)))
(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean)) (defun* resolve-relative-location-component (x &key want-directory wilden)
(values (or null pathname) &optional)) (let* ((r (etypecase x
resolve-location)) (pathname x)
(string (parse-unix-namestring
(defun* resolve-relative-location-component (x &key directory wilden) x :want-directory want-directory))
(let ((r (etypecase x (cons
(pathname x) (if (null (cdr x))
(string (coerce-pathname x :type (when directory :directory))) (resolve-relative-location-component
(cons (car x) :want-directory want-directory :wilden wilden)
(if (null (cdr x)) (let* ((car (resolve-relative-location-component
(resolve-relative-location-component (car x) :want-directory t :wilden nil)))
(car x) :directory directory :wilden wilden) (merge-pathnames*
(let* ((car (resolve-relative-location-component (resolve-relative-location-component
(car x) :directory t :wilden nil))) (cdr x) :want-directory want-directory :wilden wilden)
(merge-pathnames* car))))
(resolve-relative-location-component ((eql :*/) *wild-directory*)
(cdr x) :directory directory :wilden wilden) ((eql :**/) *wild-inferiors*)
car)))) ((eql :*.*.*) *wild-file*)
((eql :default-directory) (nil-pathname)) ;; OBSOLETE ((eql :implementation)
((eql :*/) *wild-directory*) (parse-unix-namestring
((eql :**/) *wild-inferiors*) (implementation-identifier) :want-directory t))
((eql :*.*.*) *wild-file*) ((eql :implementation-type)
((eql :implementation) (parse-unix-namestring
(coerce-pathname (implementation-identifier) :type :directory)) (string-downcase (implementation-type)) :want-directory t))
((eql :implementation-type) ((eql :hostname)
(coerce-pathname (string-downcase (implementation-type)) :type :directory)) (parse-unix-namestring (hostname) :want-directory t))))
((eql :hostname) (w (if (and wilden (not (pathnamep x)) (not (member x '(:*/ :**/ :*.*.*))))
(coerce-pathname (hostname) :type :directory))))) (wilden r)
(when (absolute-pathname-p r) r)))
(error (compatfmt "~@<pathname ~S is not relative~@:>") x)) (ensure-pathname w :want-relative t)))
(if (or (pathnamep x) (member x '(:*/ :**/ :*.*.*)) (not wilden))
r (wilden r))))
(defvar *here-directory* nil (defvar *here-directory* nil
"This special variable is bound to the currect directory during calls to "This special variable is bound to the currect directory during calls to
PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here
directive.") directive.")
(defvar *user-cache* (defvar *user-cache* nil
(flet ((try (x &rest sub) (and x `(,x ,@sub)))) "A specification as per RESOLVE-LOCATION of where the user keeps his FASL cache")
(or
(try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp" :implementation)
(when (os-windows-p)
(try (or (get-folder-path :local-appdata)
(get-folder-path :appdata))
"common-lisp" "cache" :implementation))
'(:home ".cache" "common-lisp" :implementation))))
(defun* resolve-absolute-location-component (x &key directory wilden) (defun compute-user-cache ()
(let* ((r (setf *user-cache*
(etypecase x (flet ((try (x &rest sub) (and x `(,x ,@sub))))
(pathname x) (or
(string (let ((p (#+mcl probe-posix #-mcl parse-namestring x))) (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp" :implementation)
#+mcl (unless p (error "POSIX pathname ~S does not exist" x)) (when (os-windows-p)
(if directory (ensure-directory-pathname p) p))) (try (or (get-folder-path :local-appdata)
(cons (get-folder-path :appdata))
(return-from resolve-absolute-location-component "common-lisp" "cache" :implementation))
(if (null (cdr x)) '(:home ".cache" "common-lisp" :implementation)))))
(resolve-absolute-location-component (register-image-restore-hook 'compute-user-cache)
(car x) :directory directory :wilden wilden)
(merge-pathnames* (defun* resolve-absolute-location-component (x &key want-directory wilden)
(resolve-relative-location-component (let* ((r (etypecase x
(cdr x) :directory directory :wilden wilden) (pathname x)
(resolve-absolute-location-component (string
(car x) :directory t :wilden nil))))) (let ((p #-mcl (parse-namestring x)
((eql :root) #+mcl (probe-posix x)))
;; special magic! we encode such paths as relative pathnames, #+mcl (unless p (error "POSIX pathname ~S does not exist" x))
;; but it means "relative to the root of the source pathname's host and device". (if want-directory (ensure-directory-pathname p) p)))
(return-from resolve-absolute-location-component (cons
(let ((p (make-pathname* :directory '(:relative)))) (return-from resolve-absolute-location-component
(if wilden (wilden p) p)))) (if (null (cdr x))
((eql :home) (user-homedir)) (resolve-absolute-location-component
((eql :here) (car x) :want-directory want-directory :wilden wilden)
(resolve-location (or *here-directory* (merge-pathnames*
;; give semantics in the case of use interactively (resolve-relative-location-component
:default-directory) (cdr x) :want-directory want-directory :wilden wilden)
:directory t :wilden nil)) (resolve-absolute-location-component
((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil)) (car x) :want-directory t :wilden nil)))))
((eql :system-cache) ((eql :root)
(error "Using the :system-cache is deprecated. ~%~ ;; special magic! we return a relative pathname,
Please remove it from your ASDF configuration")) ;; but what it means to the output-translations is
((eql :default-directory) (default-directory)))) ;; "relative to the root of the source pathname's host and device".
(s (if (and wilden (not (or (pathnamep x)))) (return-from resolve-absolute-location-component
(let ((p (make-pathname* :directory '(:relative))))
(if wilden (wilden p) p))))
((eql :home) (user-homedir))
((eql :here) (resolve-absolute-location-component
*here-directory* :want-directory t :wilden nil))
((eql :user-cache) (resolve-absolute-location-component
*user-cache* :want-directory t :wilden nil))))
(w (if (and wilden (not (pathnamep x)))
(wilden r) (wilden r)
r))) r)))
(unless (absolute-pathname-p s) (ensure-pathname w :want-absolute t)))