[armedbear-cvs] r13125 - in trunk/abcl: doc/asdf src/org/armedbear/lisp
Mark Evenson
mevenson at common-lisp.net
Wed Jan 5 07:32:28 UTC 2011
Author: mevenson
Date: Wed Jan 5 02:32:25 2011
New Revision: 13125
Log:
Upgrade to ASDF-2.012.
Modified:
trunk/abcl/doc/asdf/asdf.texinfo
trunk/abcl/src/org/armedbear/lisp/asdf.lisp
Modified: trunk/abcl/doc/asdf/asdf.texinfo
==============================================================================
--- trunk/abcl/doc/asdf/asdf.texinfo (original)
+++ trunk/abcl/doc/asdf/asdf.texinfo Wed Jan 5 02:32:25 2011
@@ -1790,7 +1790,10 @@
@section Configuration DSL
-Here is the grammar of the s-expression (SEXP) DSL for source-registry configuration:
+Here is the grammar of the s-expression (SEXP) DSL for source-registry
+configuration:
+
+ at c FIXME: This is too wide for happy compilation into pdf.
@example
;; A configuration is a single SEXP starting with keyword :source-registry
@@ -1805,6 +1808,11 @@
:inherit-configuration | ; splices inherited configuration (often specified last)
:ignore-inherited-configuration | ; drop inherited configuration (specified anywhere)
+ ;; forward compatibility directive (since ASDF 2.011.4), useful when
+ ;; you want to use new configuration features but have to bootstrap a
+ ;; the newer required ASDF from an older release that doesn't sport said features:
+ :ignore-invalid-entries | ; drops subsequent invalid entries instead of erroring out
+
;; add a single directory to be scanned (no recursion)
(:directory DIRECTORY-PATHNAME-DESIGNATOR) |
@@ -1837,12 +1845,14 @@
PATHNAME | ;; pathname (better be an absolute path, or bust)
:HOME | ;; designates the user-homedir-pathname ~/
:USER-CACHE | ;; designates the default location for the user cache
- :SYSTEM-CACHE ;; designates the default location for the system cache
+ :SYSTEM-CACHE | ;; designates the default location for the system cache
+ :HERE ;; designates the location of the configuration file
+ ;; (or *default-pathname-defaults*, if invoked interactively)
RELATIVE-COMPONENT-DESIGNATOR :=
STRING | ;; namestring (directory assumed where applicable)
PATHNAME | ;; pathname
- :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.32.30-linux-x86-64
+ :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.45-linux-amd64
:IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl
:UID | ;; current UID -- not available on Windows
:USER ;; current USER name -- NOT IMPLEMENTED(!)
@@ -1863,7 +1873,7 @@
@section Configuration Directories
-Configuration directories consist in files each contains
+Configuration directories consist in files each containing
a list of directives without any enclosing @code{(:source-registry ...)} form.
The files will be sorted by namestring as if by @code{string<} and
the lists of directives of these files with be concatenated in order.
@@ -1897,6 +1907,50 @@
(:tree "/home/fare/cl/")
@end example
+ at subsection The :here directive
+
+The @code{:here} directive is an absolute pathname designator that
+refers to the directory containing the configuration file currently
+being processed.
+
+The @code{:here} directive is intended to simplify the delivery of
+complex CL systems, and for easy configuration of projects shared through
+revision control systems, in accordance with our design principle that
+each participant should be able to provide all and only the information
+available to him or her.
+
+Consider a person X who has set up the source code repository for a
+complex project with a master directory @file{dir/}. Ordinarily, one
+might simply have the user add a directive that would look something
+like this:
+ at example
+ (:tree "path/to/dir")
+ at end example
+But what if X knows that there are very large subtrees
+under dir that are filled with, e.g., Java source code, image files for
+icons, etc.? All of the asdf system definitions are contained in the
+subdirectories @file{dir/src/lisp/} and @file{dir/extlib/lisp/}, and
+these are the only directories that should be searched.
+
+In this case, X can put into @file{dir/} a file @file{asdf.conf} that
+contains the following:
+ at example
+(:source-registry
+ (:tree (:here "src/lisp/"))
+ (:tree (:here "extlib/lisp"))
+ (:directory (:here "outlier/")))
+ at end example
+
+Then when someone else (call her Y) checks out a copy of this
+repository, she need only add
+ at example
+(:include "/path/to/my/checkout/directory/asdf.conf")
+ at end example
+to one of her previously-existing asdf source location configuration
+files, or invoke @code{initialize-source-registry} with a configuration
+form containing that s-expression. ASDF will find the .conf file that X
+has provided, and then set up source locations within the working
+directory according to X's (relative) instructions.
@section Shell-friendly syntax for configuration
@@ -2190,10 +2244,8 @@
@section Backward Compatibility
+ at cindex ASDF-BINARY-LOCATIONS compatibility
- at c FIXME -- I think we should provide an easy way
- at c to get behavior equivalent to A-B-L and
- at c I will propose a technique for doing this.
We purposefully do NOT provide backward compatibility with earlier versions of
@code{ASDF-Binary-Locations} (8 Sept 2009),
@@ -2221,7 +2273,7 @@
Nevertheless, if you are a fan of @code{ASDF-Binary-Locations},
we provide a limited emulation mode:
- at defun asdf:enable-asdf-binary-locations-compatibility @&key centralize-lisp-binaries default-toplevel-directory include-per-user-information map-all-source-files source-to-target-mappings
+ at defun enable-asdf-binary-locations-compatibility @&key centralize-lisp-binaries default-toplevel-directory include-per-user-information map-all-source-files source-to-target-mappings
This function will initialize the new @code{asdf-output-translations} facility in a way
that emulates the behavior of the old @code{ASDF-Binary-Locations} facility.
Where you would previously set global variables
@@ -2264,10 +2316,15 @@
:inherit-configuration | ; splices inherited configuration (often specified last)
:ignore-inherited-configuration | ; drop inherited configuration (specified anywhere)
+ ;; forward compatibility directive (since ASDF 2.011.4), useful when
+ ;; you want to use new configuration features but have to bootstrap a
+ ;; the newer required ASDF from an older release that doesn't sport said features:
+ :ignore-invalid-entries | ; drops subsequent invalid entries instead of erroring out
+
;; include a configuration file or directory
(:include PATHNAME-DESIGNATOR) |
- ;; enable global cache in ~/.common-lisp/cache/sbcl-1.0.35-x86-64/ or something.
+ ;; enable global cache in ~/.common-lisp/cache/sbcl-1.0.45-linux-amd64/ or something.
:enable-user-cache |
;; Disable global cache. Map / to /
:disable-cache |
@@ -2295,8 +2352,11 @@
RELATIVE-COMPONENT-DESIGNATOR :=
STRING | ;; namestring, directory is assumed. If the last component, /**/*.* is added
PATHNAME | ;; pathname unless last component, directory is assumed.
- :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.32.30-linux-x86-64
+ :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.45-linux-amd64
:IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl
+ :*/ | ;; any direct subdirectory (since ASDF 2.011.4)
+ :**/ | ;; any recursively inferior subdirectory (since ASDF 2.011.4)
+ :*.*.* | ;; any file (since ASDF 2.011.4)
:UID | ;; current UID -- not available on Windows
:USER ;; current USER name -- NOT IMPLEMENTED(!)
@@ -2332,8 +2392,26 @@
before it is translated.
When the second designator is @code{t}, the mapping is the identity.
-When the second designator starts with @code{root},
+When the second designator starts with @code{:root},
the mapping preserves the host and device of the original pathname.
+Notably, this allows you to map files
+to a subdirectory of the whichever directory the file is in.
+Though the syntax is not quite as easy to use as we'd like,
+you can have an (source destination) mapping entry such as follows
+in your configuration file,
+or you may use @code{enable-asdf-binary-locations-compatibility}
+with @code{:centralize-lisp-binaries nil}
+which will do the same thing internally for you:
+ at verbatim
+ #.(let ((wild-subdir (make-pathname :directory '(:relative :wild-inferiors)))
+ (wild-file (make-pathname :name :wild :version :wild :type :wild)))
+ `((:root ,wild-subdir ,wild-file) ;; Or using the implicit wildcard, just :root
+ (:root ,wild-subdir :implementation ,wild-file)))
+ at end verbatim
+Starting with ASDF 2.011.4, you can use the simpler:
+ @code{`(:root (:root :**/ :implementation :*.*.*))}
+
+
@code{:include} statements cause the search to recurse with the path specifications
from the file specified.
@@ -2532,7 +2610,7 @@
@c @itemize
@c @item
- at c SBCL, version 1.0 on Mac OS X for intel: @code{sbcl-1.0-darwin-x86}
+ at c SBCL, version 1.0.45 on Mac OS X for Intel: @code{sbcl-1.0.45-darwin-x86}
@c @item
@c Franz Allegro, version 8.0, ANSI Common Lisp: @code{allegro-8.0a-macosx-x86}
@@ -2649,11 +2727,13 @@
@chapter Getting the latest version
Decide which version you want.
-HEAD is the newest version and usually OK, whereas
-RELEASE is for cautious people
-(e.g. who already have systems using ASDF that they don't want broken),
-a slightly older version about which none of the HEAD users have complained.
-There is also a STABLE version, which is earlier than release.
+The @code{master} branch is where development happens;
+its @code{HEAD} is usually OK, including the latest fixes and portability tweaks,
+but an occasional regression may happen despite our (limited) test suite.
+
+The @code{release} branch is what cautious people should be using;
+it has usually been tested more, and releases are cut at a point
+where there isn't any known unresolved issue.
You may get the ASDF source repository using git:
@kbd{git clone git://common-lisp.net/projects/asdf/asdf.git}
@@ -2921,7 +3001,7 @@
The new ASDF output translations are incompatible with ASDF-Binary-Locations.
They replace A-B-L, and there is compatibility mode to emulate
your previous A-B-L configuration.
-See @code{asdf:enable-asdf-binary-locations-compatibility} in
+See @code{enable-asdf-binary-locations-compatibility} in
@pxref{Controlling where ASDF saves compiled files,,Backward Compatibility}.
But thou shall not load ABL on top of ASDF 2.
@@ -2999,7 +3079,7 @@
Starting with current candidate releases of ASDF 2,
it should always be a good time to upgrade to a recent ASDF.
You may consult with the maintainer for which specific version they recommend,
-but the latest RELEASE should be correct.
+but the latest @code{release} should be correct.
We trust you to thoroughly test it with your implementation before you release it.
If there are any issues with the current release,
it's a bug that you should report upstream and that we will fix ASAP.
Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/asdf.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Wed Jan 5 02:32:25 2011
@@ -74,11 +74,13 @@
(defvar *asdf-version* nil)
(defvar *upgraded-p* nil)
(let* (;; For bug reporting sanity, please always bump this version when you modify this file.
+ ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version
+ ;; can help you do these changes in synch (look at the source for documentation).
;; "2.345" would be an official release
;; "2.345.6" would be a development version in the official upstream
- ;; "2.345.0.7" would be your local modification of an official release
- ;; "2.345.6.7" would be your local modification of a development version
- (asdf-version "2.011")
+ ;; "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.012")
(existing-asdf (fboundp 'find-system))
(existing-version *asdf-version*)
(already-there (equal asdf-version existing-version)))
@@ -496,7 +498,7 @@
;; Giving :unspecific as argument to make-pathname is not portable.
;; See CLHS make-pathname and 19.2.2.2.3.
;; We only use it on implementations that support it.
- (or #+(or ccl ecl gcl lispworks sbcl) :unspecific)))
+ (or #+(or ccl gcl lispworks sbcl) :unspecific)))
(destructuring-bind (name &optional (type unspecific))
(split-string filename :max 2 :separator ".")
(if (equal name "")
@@ -713,9 +715,14 @@
(defun* lispize-pathname (input-file)
(make-pathname :type "lisp" :defaults input-file))
+(defparameter *wild-file*
+ (make-pathname :name :wild :type :wild :version :wild :directory nil))
+(defparameter *wild-directory*
+ (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil))
+(defparameter *wild-inferiors*
+ (make-pathname :directory '(:relative :wild-inferiors) :name nil :type nil :version nil))
(defparameter *wild-path*
- (make-pathname :directory '(:relative :wild-inferiors)
- :name :wild :type :wild :version :wild))
+ (merge-pathnames *wild-file* *wild-inferiors*))
(defun* wilden (path)
(merge-pathnames* *wild-path* path))
@@ -865,8 +872,12 @@
(asdf-message "~&~@<; ~@; Updating ~A for ASDF ~A~@:>~%" m ,(asdf-version)))
(when (member 'components-by-name added)
(compute-module-components-by-name m))
- (when (and (typep m 'system) (member 'source-file added))
- (%set-system-source-file (probe-asd (component-name m) (component-pathname m)) m))))))
+ (when (typep m 'system)
+ (when (member 'source-file added)
+ (%set-system-source-file
+ (probe-asd (component-name m) (component-pathname m)) m)
+ (when (equal (component-name m) "asdf")
+ (setf (component-version m) *asdf-version*))))))))
;;;; -------------------------------------------------------------------------
;;;; Classes, Conditions
@@ -939,6 +950,21 @@
(define-condition compile-failed (compile-error) ())
(define-condition compile-warned (compile-error) ())
+(define-condition invalid-configuration ()
+ ((form :reader condition-form :initarg :form)
+ (location :reader condition-location :initarg :location)
+ (format :reader condition-format :initarg :format)
+ (arguments :reader condition-arguments :initarg :arguments :initform nil))
+ (:report (lambda (c s)
+ (format s "~@<~? (will be skipped)~@:>"
+ (condition-format c)
+ (list* (condition-form c) (condition-location c)
+ (condition-arguments c))))))
+(define-condition invalid-source-registry (invalid-configuration warning)
+ ((format :initform "~@<invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~>")))
+(define-condition invalid-output-translation (invalid-configuration warning)
+ ((format :initform "~@<invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~>")))
+
(defclass component ()
((name :accessor component-name :initarg :name :documentation
"Component name: designator for a string composed of portable pathname characters")
@@ -1151,11 +1177,8 @@
Note that this does NOT in any way cause the code of the system to be unloaded."
;; There is no "unload" operation in Common Lisp, and a general such operation
;; cannot be portably written, considering how much CL relies on side-effects
- ;; of global data structures.
- ;; Note that this does a setf gethash instead of a remhash
- ;; this way there remains a hint in the *defined-systems* table
- ;; that the system was loaded at some point.
- (setf (gethash (coerce-name name) *defined-systems*) nil))
+ ;; to global data structures.
+ (remhash (coerce-name name) *defined-systems*))
(defun* map-systems (fn)
"Apply FN to each defined system.
@@ -1289,27 +1312,34 @@
(defmethod find-system (name &optional (error-p t))
(find-system (coerce-name name) error-p))
+(defun load-sysdef (name pathname)
+ ;; Tries to load system definition with canonical NAME from PATHNAME.
+ (let ((package (make-temporary-package)))
+ (unwind-protect
+ (handler-bind
+ ((error (lambda (condition)
+ (error 'load-system-definition-error
+ :name name :pathname pathname
+ :condition condition))))
+ (let ((*package* package))
+ (asdf-message
+ "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%"
+ pathname package)
+ (load pathname)))
+ (delete-package package))))
+
(defmethod find-system ((name string) &optional (error-p t))
(catch 'find-system
- (let* ((in-memory (system-registered-p name))
+ (let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
(on-disk (system-definition-pathname name)))
(when (and on-disk
(or (not in-memory)
- (< (car in-memory) (safe-file-write-date on-disk))))
- (let ((package (make-temporary-package)))
- (unwind-protect
- (handler-bind
- ((error (lambda (condition)
- (error 'load-system-definition-error
- :name name :pathname on-disk
- :condition condition))))
- (let ((*package* package))
- (asdf-message
- "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%"
- on-disk *package*)
- (load on-disk)))
- (delete-package package))))
- (let ((in-memory (system-registered-p name)))
+ ;; don't reload if it's already been loaded,
+ ;; or its filestamp is in the future which means some clock is skewed
+ ;; and trying to load might cause an infinite loop.
+ (< (car in-memory) (safe-file-write-date on-disk) (get-universal-time))))
+ (load-sysdef name on-disk))
+ (let ((in-memory (system-registered-p name))) ; try again after loading from disk
(cond
(in-memory
(when on-disk
@@ -1340,7 +1370,8 @@
(throw 'find-system system))))
(defun* sysdef-find-asdf (name)
- (find-system-fallback name "asdf")) ;; :version *asdf-version* wouldn't be updated when ASDF is updated.
+ ;; Bug: :version *asdf-version* won't be updated when ASDF is updated.
+ (find-system-fallback name "asdf" :version *asdf-version*))
;;;; -------------------------------------------------------------------------
@@ -1650,8 +1681,7 @@
required-op required-c required-v))
(retry ()
:report (lambda (s)
- (format s "~@<Retry loading component ~S.~@:>"
- (component-find-path required-c)))
+ (format s "~@<Retry loading component ~S.~@:>" required-c))
:test
(lambda (c)
(or (null c)
@@ -2408,7 +2438,7 @@
exit-code)
#+clisp ;XXX not exactly *verbose-out*, I know
- (ext:run-shell-command command :output :terminal :wait t)
+ (or (ext:run-shell-command command :output :terminal :wait t) 0)
#+clozure
(nth-value 1
@@ -2586,7 +2616,8 @@
*implementation-features*))
(os (maybe-warn (first-feature *os-features*)
"No os feature found in ~a." *os-features*))
- (arch (maybe-warn (first-feature *architecture-features*)
+ (arch #+clisp "" #-clisp
+ (maybe-warn (first-feature *architecture-features*)
"No architecture feature found in ~a."
*architecture-features*))
(version (maybe-warn (lisp-version-string)
@@ -2596,7 +2627,6 @@
(format nil "~(~@{~a~^-~}~)" lisp version os arch)))))
-
;;; ---------------------------------------------------------------------------
;;; Generic support for configuration files
@@ -2649,40 +2679,88 @@
(or (member x kw)
(and (length=n-p x 1) (member (car x) kw)))))
+(defun* report-invalid-form (reporter &rest args)
+ (etypecase reporter
+ (null
+ (apply 'error 'invalid-configuration args))
+ (function
+ (apply reporter args))
+ ((or symbol string)
+ (apply 'error reporter args))
+ (cons
+ (apply 'apply (append reporter args)))))
+
+(defvar *ignored-configuration-form* nil)
+
(defun* validate-configuration-form (form tag directive-validator
- &optional (description tag))
+ &key location invalid-form-reporter)
(unless (and (consp form) (eq (car form) tag))
- (error "Error: Form doesn't specify ~A ~S~%" description form))
- (loop :with inherit = 0
- :for directive :in (cdr form) :do
- (if (configuration-inheritance-directive-p directive)
- (incf inherit)
- (funcall directive-validator directive))
+ (setf *ignored-configuration-form* t)
+ (report-invalid-form invalid-form-reporter :form form :location location)
+ (return-from validate-configuration-form nil))
+ (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag)
+ :for directive :in (cdr form)
+ :when (cond
+ ((configuration-inheritance-directive-p directive)
+ (incf inherit) t)
+ ((eq directive :ignore-invalid-entries)
+ (setf ignore-invalid-p t) t)
+ ((funcall directive-validator directive)
+ t)
+ (ignore-invalid-p
+ nil)
+ (t
+ (setf *ignored-configuration-form* t)
+ (report-invalid-form invalid-form-reporter :form directive :location location)
+ nil))
+ :do (push directive x)
:finally
(unless (= inherit 1)
- (error "One and only one of ~S or ~S is required"
- :inherit-configuration :ignore-inherited-configuration)))
- form)
+ (report-invalid-form invalid-form-reporter
+ :arguments (list "One and only one of ~S or ~S is required"
+ :inherit-configuration :ignore-inherited-configuration)))
+ (return (nreverse x))))
-(defun* validate-configuration-file (file validator description)
+(defun* validate-configuration-file (file validator &key description)
(let ((forms (read-file-forms file)))
(unless (length=n-p forms 1)
(error "One and only one form allowed for ~A. Got: ~S~%" description forms))
- (funcall validator (car forms))))
+ (funcall validator (car forms) :location file)))
(defun* hidden-file-p (pathname)
(equal (first-char (pathname-name pathname)) #\.))
-(defun* validate-configuration-directory (directory tag validator)
+(defun* directory* (pathname-spec &rest keys &key &allow-other-keys)
+ (apply 'directory pathname-spec
+ (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
+ #+ccl '(:follow-links nil)
+ #+clisp '(:circle t :if-does-not-exist :ignore)
+ #+(or cmu scl) '(:follow-links nil :truenamep nil)
+ #+sbcl (when (find-symbol "RESOLVE-SYMLINKS" "SB-IMPL") '(:resolve-symlinks nil))))))
+
+(defun* validate-configuration-directory (directory tag validator &key invalid-form-reporter)
+ "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will
+be applied to the results to yield a configuration form. Current
+values of TAG include :source-registry and :output-translations."
(let ((files (sort (ignore-errors
(remove-if
'hidden-file-p
- (directory (make-pathname :name :wild :type "conf" :defaults directory)
- #+sbcl :resolve-symlinks #+sbcl nil)))
+ (directory* (make-pathname :name :wild :type "conf" :defaults directory))))
#'string< :key #'namestring)))
`(,tag
,@(loop :for file :in files :append
- (mapcar validator (read-file-forms file)))
+ (loop :with ignore-invalid-p = nil
+ :for form :in (read-file-forms file)
+ :when (eq form :ignore-invalid-entries)
+ :do (setf ignore-invalid-p t)
+ :else
+ :when (funcall validator form)
+ :collect form
+ :else
+ :when ignore-invalid-p
+ :do (setf *ignored-configuration-form* t)
+ :else
+ :do (report-invalid-form invalid-form-reporter :form form :location file)))
:inherit-configuration)))
@@ -2722,7 +2800,8 @@
(etypecase (car x)
((eql t) -1)
(pathname
- (length (pathname-directory (car x)))))))))
+ (let ((directory (pathname-directory (car x))))
+ (if (listp directory) (length directory) 0))))))))
new-value)
(defun* output-translations-initialized-p ()
@@ -2756,6 +2835,9 @@
(merge-pathnames* cdr car)))))
((eql :default-directory)
(relativize-pathname-directory (default-directory)))
+ ((eql :*/) *wild-directory*)
+ ((eql :**/) *wild-inferiors*)
+ ((eql :*.*.*) *wild-file*)
((eql :implementation) (implementation-identifier))
((eql :implementation-type) (string-downcase (implementation-type)))
#-(and (or win32 windows mswindows mingw32) (not cygwin))
@@ -2766,6 +2848,11 @@
(error "pathname ~S is not relative to ~S" s super))
(merge-pathnames* s super)))
+(defvar *here-directory* nil
+ "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
+directive.")
+
(defun* resolve-absolute-location-component (x &key directory wilden)
(let* ((r
(etypecase x
@@ -2788,6 +2875,11 @@
(let ((p (make-pathname :directory '(:relative))))
(if wilden (wilden p) p))))
((eql :home) (user-homedir))
+ ((eql :here)
+ (resolve-location (or *here-directory*
+ ;; give semantics in the case of use interactively
+ :default-directory)
+ :directory t :wilden nil))
((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
((eql :system-cache) (resolve-location *system-cache* :directory t :wilden nil))
((eql :default-directory) (default-directory))))
@@ -2812,8 +2904,17 @@
:finally (return path))))
(defun* location-designator-p (x)
- (flet ((componentp (c) (typep c '(or string pathname keyword))))
- (or (typep x 'boolean) (componentp x) (and (consp x) (every #'componentp x)))))
+ (flet ((absolute-component-p (c)
+ (typep c '(or string pathname
+ (member :root :home :here :user-cache :system-cache :default-directory))))
+ (relative-component-p (c)
+ (typep c '(or string pathname
+ (member :default-directory :*/ :**/ :*.*.*
+ :implementation :implementation-type
+ #-(and (or win32 windows mswindows mingw32) (not cygwin)) :uid)))))
+ (or (typep x 'boolean)
+ (absolute-component-p x)
+ (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x))))))
(defun* location-function-p (x)
(and
@@ -2826,47 +2927,43 @@
(length=n-p (second x) 2)))))
(defun* validate-output-translations-directive (directive)
- (unless
- (or (member directive '(:inherit-configuration
- :ignore-inherited-configuration
- :enable-user-cache :disable-cache nil))
- (and (consp directive)
- (or (and (length=n-p directive 2)
- (or (and (eq (first directive) :include)
- (typep (second directive) '(or string pathname null)))
- (and (location-designator-p (first directive))
- (or (location-designator-p (second directive))
- (location-function-p (second directive))))))
- (and (length=n-p directive 1)
- (location-designator-p (first directive))))))
- (error "Invalid directive ~S~%" directive))
- directive)
+ (or (member directive '(:enable-user-cache :disable-cache nil))
+ (and (consp directive)
+ (or (and (length=n-p directive 2)
+ (or (and (eq (first directive) :include)
+ (typep (second directive) '(or string pathname null)))
+ (and (location-designator-p (first directive))
+ (or (location-designator-p (second directive))
+ (location-function-p (second directive))))))
+ (and (length=n-p directive 1)
+ (location-designator-p (first directive)))))))
-(defun* validate-output-translations-form (form)
+(defun* validate-output-translations-form (form &key location)
(validate-configuration-form
form
:output-translations
'validate-output-translations-directive
- "output translations"))
+ :location location :invalid-form-reporter 'invalid-output-translation))
(defun* validate-output-translations-file (file)
(validate-configuration-file
- file 'validate-output-translations-form "output translations"))
+ file 'validate-output-translations-form :description "output translations"))
(defun* validate-output-translations-directory (directory)
(validate-configuration-directory
- directory :output-translations 'validate-output-translations-directive))
+ directory :output-translations 'validate-output-translations-directive
+ :invalid-form-reporter 'invalid-output-translation))
-(defun* parse-output-translations-string (string)
+(defun* parse-output-translations-string (string &key location)
(cond
((or (null string) (equal string ""))
'(:output-translations :inherit-configuration))
((not (stringp string))
(error "environment string isn't: ~S" string))
((eql (char string 0) #\")
- (parse-output-translations-string (read-from-string string)))
+ (parse-output-translations-string (read-from-string string) :location location))
((eql (char string 0) #\()
- (validate-output-translations-form (read-from-string string)))
+ (validate-output-translations-form (read-from-string string) :location location))
(t
(loop
:with inherit = nil
@@ -2974,7 +3071,7 @@
(process-output-translations-directive '(t t) :collect collect))
((:inherit-configuration)
(inherit-output-translations inherit :collect collect))
- ((:ignore-inherited-configuration nil)
+ ((:ignore-inherited-configuration :ignore-invalid-entries nil)
nil))
(let ((src (first directive))
(dst (second directive)))
@@ -2997,9 +3094,7 @@
(t
(let* ((trudst (make-pathname
:defaults (if dst (resolve-location dst :directory t :wilden t) trusrc)))
- (wilddst (make-pathname
- :name :wild :type :wild :version :wild
- :defaults trudst)))
+ (wilddst (merge-pathnames* *wild-file* trudst)))
(funcall collect (list wilddst t))
(funcall collect (list trusrc trudst)))))))))))
@@ -3160,21 +3255,19 @@
(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)))
- (mapped-files (make-pathname
- :name :wild :version :wild
- :type (if map-all-source-files :wild fasl-type)))
+ (mapped-files (if map-all-source-files *wild-file*
+ (make-pathname :name :wild :version :wild :type fasl-type)))
(destination-directory
(if centralize-lisp-binaries
`(,default-toplevel-directory
,@(when include-per-user-information
(cdr (pathname-directory (user-homedir))))
- :implementation ,wild-inferiors)
- `(:root ,wild-inferiors :implementation))))
+ :implementation ,*wild-inferiors*)
+ `(:root ,*wild-inferiors* :implementation))))
(initialize-output-translations
`(:output-translations
, at source-to-target-mappings
- ((:root ,wild-inferiors ,mapped-files)
+ ((:root ,*wild-inferiors* ,mapped-files)
(, at destination-directory ,mapped-files))
(t t)
:ignore-inherited-configuration))))
@@ -3294,31 +3387,23 @@
(make-pathname :directory nil :name :wild :type "asd" :version :newest))
(defun directory-has-asd-files-p (directory)
- (and (ignore-errors
- (directory (merge-pathnames* *wild-asd* directory)
- #+sbcl #+sbcl :resolve-symlinks nil
- #+ccl #+ccl :follow-links nil
- #+clisp #+clisp :circle t))
- t))
+ (ignore-errors
+ (directory* (merge-pathnames* *wild-asd* directory))
+ t))
(defun subdirectories (directory)
(let* ((directory (ensure-directory-pathname directory))
#-cormanlisp
(wild (merge-pathnames*
#-(or abcl allegro lispworks scl)
- (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil)
+ *wild-directory*
#+(or abcl allegro lispworks scl) "*.*"
directory))
(dirs
#-cormanlisp
(ignore-errors
- (directory wild .
- #.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
- #+ccl '(:follow-links nil :directories t :files nil)
- #+clisp '(:circle t :if-does-not-exist :ignore)
- #+(or cmu scl) '(:follow-links nil :truenamep nil)
- #+digitool '(:directories t)
- #+sbcl '(:resolve-symlinks nil))))
+ (directory* wild . #.(or #+ccl '(:directories t :files nil)
+ #+digitool '(:directories t))))
#+cormanlisp (cl::directory-subdirs directory))
#+(or abcl allegro lispworks scl)
(dirs (remove-if-not #+abcl #'extensions:probe-directory
@@ -3346,39 +3431,40 @@
collect))
(defun* validate-source-registry-directive (directive)
- (unless
- (or (member directive '(:default-registry (:default-registry)) :test 'equal)
- (destructuring-bind (kw &rest rest) directive
- (case kw
- ((:include :directory :tree)
- (and (length=n-p rest 1)
- (location-designator-p (first rest))))
- ((:exclude :also-exclude)
- (every #'stringp rest))
- (null rest))))
- (error "Invalid directive ~S~%" directive))
- directive)
+ (or (member directive '(:default-registry))
+ (and (consp directive)
+ (let ((rest (rest directive)))
+ (case (first directive)
+ ((:include :directory :tree)
+ (and (length=n-p rest 1)
+ (location-designator-p (first rest))))
+ ((:exclude :also-exclude)
+ (every #'stringp rest))
+ ((:default-registry)
+ (null rest)))))))
-(defun* validate-source-registry-form (form)
+(defun* validate-source-registry-form (form &key location)
(validate-configuration-form
- form :source-registry 'validate-source-registry-directive "a source registry"))
+ form :source-registry 'validate-source-registry-directive
+ :location location :invalid-form-reporter 'invalid-source-registry))
(defun* validate-source-registry-file (file)
(validate-configuration-file
- file 'validate-source-registry-form "a source registry"))
+ file 'validate-source-registry-form :description "a source registry"))
(defun* validate-source-registry-directory (directory)
(validate-configuration-directory
- directory :source-registry 'validate-source-registry-directive))
+ directory :source-registry 'validate-source-registry-directive
+ :invalid-form-reporter 'invalid-source-registry))
-(defun* parse-source-registry-string (string)
+(defun* parse-source-registry-string (string &key location)
(cond
((or (null string) (equal string ""))
'(:source-registry :inherit-configuration))
((not (stringp string))
(error "environment string isn't: ~S" string))
((find (char string 0) "\"(")
- (validate-source-registry-form (read-from-string string)))
+ (validate-source-registry-form (read-from-string string) :location location))
(t
(loop
:with inherit = nil
@@ -3475,11 +3561,13 @@
(defmethod process-source-registry ((pathname pathname) &key inherit register)
(cond
((directory-pathname-p pathname)
- (process-source-registry (validate-source-registry-directory pathname)
- :inherit inherit :register register))
+ (let ((*here-directory* (truenamize pathname)))
+ (process-source-registry (validate-source-registry-directory pathname)
+ :inherit inherit :register register)))
((probe-file pathname)
- (process-source-registry (validate-source-registry-file pathname)
- :inherit inherit :register register))
+ (let ((*here-directory* (pathname-directory-pathname pathname)))
+ (process-source-registry (validate-source-registry-file pathname)
+ :inherit inherit :register register)))
(t
(inherit-source-registry inherit :register register))))
(defmethod process-source-registry ((string string) &key inherit register)
@@ -3527,13 +3615,14 @@
(defun* flatten-source-registry (&optional parameter)
(remove-duplicates
(while-collecting (collect)
- (inherit-source-registry
- `(wrapping-source-registry
- ,parameter
- ,@*default-source-registries*)
- :register (lambda (directory &key recurse exclude)
- (collect (list directory :recurse recurse :exclude exclude)))))
- :test 'equal :from-end t))
+ (let ((*default-pathname-defaults* (default-directory)))
+ (inherit-source-registry
+ `(wrapping-source-registry
+ ,parameter
+ ,@*default-source-registries*)
+ :register (lambda (directory &key recurse exclude)
+ (collect (list directory :recurse recurse :exclude exclude)))))
+ :test 'equal :from-end t)))
;; Will read the configuration and initialize all internal variables,
;; and return the new configuration.
@@ -3617,6 +3706,11 @@
(declare (ignorable initargs))
(when system-p (appendf (compile-op-flags op) (list :system-p system-p))))))
+;;; If a previous version of ASDF failed to read some configuration, try again.
+(when *ignored-configuration-form*
+ (clear-configuration)
+ (setf *ignored-configuration-form* nil))
+
;;;; -----------------------------------------------------------------
;;;; Done!
(when *load-verbose*
More information about the armedbear-cvs
mailing list