Changeset 13125


Ignore:
Timestamp:
01/05/11 07:32:25 (11 years ago)
Author:
Mark Evenson
Message:

Upgrade to ASDF-2.012.

Location:
trunk/abcl
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/doc/asdf/asdf.texinfo

    r12986 r13125  
    17911791@section Configuration DSL
    17921792
    1793 Here is the grammar of the s-expression (SEXP) DSL for source-registry configuration:
     1793Here is the grammar of the s-expression (SEXP) DSL for source-registry
     1794configuration:
     1795
     1796@c FIXME: This is too wide for happy compilation into pdf.
    17941797
    17951798@example
     
    18061809    :ignore-inherited-configuration | ; drop inherited configuration (specified anywhere)
    18071810
     1811    ;; forward compatibility directive (since ASDF 2.011.4), useful when
     1812    ;; you want to use new configuration features but have to bootstrap a
     1813    ;; the newer required ASDF from an older release that doesn't sport said features:
     1814    :ignore-invalid-entries | ; drops subsequent invalid entries instead of erroring out
     1815
    18081816    ;; add a single directory to be scanned (no recursion)
    18091817    (:directory DIRECTORY-PATHNAME-DESIGNATOR) |
     
    18381846    :HOME | ;; designates the user-homedir-pathname ~/
    18391847    :USER-CACHE | ;; designates the default location for the user cache
    1840     :SYSTEM-CACHE ;; designates the default location for the system cache
     1848    :SYSTEM-CACHE | ;; designates the default location for the system cache
     1849    :HERE  ;; designates the location of the configuration file
     1850           ;; (or *default-pathname-defaults*, if invoked interactively)
    18411851
    18421852RELATIVE-COMPONENT-DESIGNATOR :=
    18431853    STRING | ;; namestring (directory assumed where applicable)
    18441854    PATHNAME | ;; pathname
    1845     :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.32.30-linux-x86-64
     1855    :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.45-linux-amd64
    18461856    :IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl
    18471857    :UID | ;; current UID -- not available on Windows
     
    18641874@section Configuration Directories
    18651875
    1866 Configuration directories consist in files each contains
     1876Configuration directories consist in files each containing
    18671877a list of directives without any enclosing @code{(:source-registry ...)} form.
    18681878The files will be sorted by namestring as if by @code{string<} and
     
    18981908@end example
    18991909
     1910@subsection The :here directive
     1911
     1912The @code{:here} directive is an absolute pathname designator that
     1913refers to the directory containing the configuration file currently
     1914being processed.
     1915
     1916The @code{:here} directive is intended to simplify the delivery of
     1917complex CL systems, and for easy configuration of projects shared through
     1918revision control systems, in accordance with our design principle that
     1919each participant should be able to provide all and only the information
     1920available to him or her.
     1921
     1922Consider a person X who has set up the source code repository for a
     1923complex project with a master directory @file{dir/}.  Ordinarily, one
     1924might simply have the user add a directive that would look something
     1925like this:
     1926@example
     1927   (:tree  "path/to/dir")
     1928@end example
     1929But what if X knows that there are very large subtrees
     1930under dir that are filled with, e.g., Java source code, image files for
     1931icons, etc.?  All of the asdf system definitions are contained in the
     1932subdirectories @file{dir/src/lisp/} and @file{dir/extlib/lisp/}, and
     1933these are the only directories that should be searched.
     1934
     1935In this case, X can put into @file{dir/} a file @file{asdf.conf} that
     1936contains the following:
     1937@example
     1938(:source-registry
     1939   (:tree (:here "src/lisp/"))
     1940   (:tree (:here "extlib/lisp"))
     1941   (:directory (:here "outlier/")))
     1942@end example
     1943
     1944Then when someone else (call her Y) checks out a copy of this
     1945repository, she need only add
     1946@example
     1947(:include "/path/to/my/checkout/directory/asdf.conf")
     1948@end example
     1949to one of her previously-existing asdf source location configuration
     1950files, or invoke @code{initialize-source-registry} with a configuration
     1951form containing that s-expression.  ASDF will find the .conf file that X
     1952has provided, and then set up source locations within the working
     1953directory according to X's (relative) instructions.
    19001954
    19011955@section Shell-friendly syntax for configuration
     
    21912245
    21922246@section Backward Compatibility
    2193 
    2194 @c FIXME -- I think we should provide an easy way
    2195 @c to get behavior equivalent to A-B-L and
    2196 @c I will propose a technique for doing this.
     2247@cindex ASDF-BINARY-LOCATIONS compatibility
     2248
    21972249
    21982250We purposefully do NOT provide backward compatibility with earlier versions of
     
    22222274we provide a limited emulation mode:
    22232275
    2224 @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
     2276@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
    22252277This function will initialize the new @code{asdf-output-translations} facility in a way
    22262278that emulates the behavior of the old @code{ASDF-Binary-Locations} facility.
     
    22652317    :ignore-inherited-configuration | ; drop inherited configuration (specified anywhere)
    22662318
     2319    ;; forward compatibility directive (since ASDF 2.011.4), useful when
     2320    ;; you want to use new configuration features but have to bootstrap a
     2321    ;; the newer required ASDF from an older release that doesn't sport said features:
     2322    :ignore-invalid-entries | ; drops subsequent invalid entries instead of erroring out
     2323
    22672324    ;; include a configuration file or directory
    22682325    (:include PATHNAME-DESIGNATOR) |
    22692326
    2270     ;; enable global cache in ~/.common-lisp/cache/sbcl-1.0.35-x86-64/ or something.
     2327    ;; enable global cache in ~/.common-lisp/cache/sbcl-1.0.45-linux-amd64/ or something.
    22712328    :enable-user-cache |
    22722329    ;; Disable global cache. Map / to /
     
    22962353    STRING | ;; namestring, directory is assumed. If the last component, /**/*.* is added
    22972354    PATHNAME | ;; pathname unless last component, directory is assumed.
    2298     :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.32.30-linux-x86-64
     2355    :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.45-linux-amd64
    22992356    :IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl
     2357    :*/ | ;; any direct subdirectory (since ASDF 2.011.4)
     2358    :**/ | ;; any recursively inferior subdirectory (since ASDF 2.011.4)
     2359    :*.*.* | ;; any file (since ASDF 2.011.4)
    23002360    :UID | ;; current UID -- not available on Windows
    23012361    :USER ;; current USER name -- NOT IMPLEMENTED(!)
     
    23332393
    23342394When the second designator is @code{t}, the mapping is the identity.
    2335 When the second designator starts with @code{root},
     2395When the second designator starts with @code{:root},
    23362396the mapping preserves the host and device of the original pathname.
     2397Notably, this allows you to map files
     2398to a subdirectory of the whichever directory the file is in.
     2399Though the syntax is not quite as easy to use as we'd like,
     2400you can have an (source destination) mapping entry such as follows
     2401in your configuration file,
     2402or you may use @code{enable-asdf-binary-locations-compatibility}
     2403with @code{:centralize-lisp-binaries nil}
     2404which will do the same thing internally for you:
     2405@verbatim
     2406  #.(let ((wild-subdir (make-pathname :directory '(:relative :wild-inferiors)))
     2407          (wild-file (make-pathname :name :wild :version :wild :type :wild)))
     2408     `((:root ,wild-subdir ,wild-file) ;; Or using the implicit wildcard, just :root
     2409       (:root ,wild-subdir :implementation ,wild-file)))
     2410@end verbatim
     2411Starting with ASDF 2.011.4, you can use the simpler:
     2412  @code{`(:root (:root :**/ :implementation :*.*.*))}
     2413
     2414
    23372415
    23382416@code{:include} statements cause the search to recurse with the path specifications
     
    25332611@c @itemize
    25342612@c @item
    2535 @c SBCL, version 1.0 on Mac OS X for intel: @code{sbcl-1.0-darwin-x86}
     2613@c SBCL, version 1.0.45 on Mac OS X for Intel: @code{sbcl-1.0.45-darwin-x86}
    25362614
    25372615@c @item
     
    26502728
    26512729Decide which version you want.
    2652 HEAD is the newest version and usually OK, whereas
    2653 RELEASE is for cautious people
    2654 (e.g. who already have systems using ASDF that they don't want broken),
    2655 a slightly older version about which none of the HEAD users have complained.
    2656 There is also a STABLE version, which is earlier than release.
     2730The @code{master} branch is where development happens;
     2731its @code{HEAD} is usually OK, including the latest fixes and portability tweaks,
     2732but an occasional regression may happen despite our (limited) test suite.
     2733
     2734The @code{release} branch is what cautious people should be using;
     2735it has usually been tested more, and releases are cut at a point
     2736where there isn't any known unresolved issue.
    26572737
    26582738You may get the ASDF source repository using git:
     
    29223002They replace A-B-L, and there is compatibility mode to emulate
    29233003your previous A-B-L configuration.
    2924 See @code{asdf:enable-asdf-binary-locations-compatibility} in
     3004See @code{enable-asdf-binary-locations-compatibility} in
    29253005@pxref{Controlling where ASDF saves compiled files,,Backward Compatibility}.
    29263006But thou shall not load ABL on top of ASDF 2.
     
    30003080it should always be a good time to upgrade to a recent ASDF.
    30013081You may consult with the maintainer for which specific version they recommend,
    3002 but the latest RELEASE should be correct.
     3082but the latest @code{release} should be correct.
    30033083We trust you to thoroughly test it with your implementation before you release it.
    30043084If there are any issues with the current release,
  • trunk/abcl/src/org/armedbear/lisp/asdf.lisp

    r13087 r13125  
    7575  (defvar *upgraded-p* nil)
    7676  (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
     77         ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version
     78         ;; can help you do these changes in synch (look at the source for documentation).
    7779         ;; "2.345" would be an official release
    7880         ;; "2.345.6" would be a development version in the official upstream
    79          ;; "2.345.0.7" would be your local modification of an official release
    80          ;; "2.345.6.7" would be your local modification of a development version
    81          (asdf-version "2.011")
     81         ;; "2.345.0.7" would be your seventh local modification of official release 2.345
     82         ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
     83         (asdf-version "2.012")
    8284         (existing-asdf (fboundp 'find-system))
    8385         (existing-version *asdf-version*)
     
    497499         ;; See CLHS make-pathname and 19.2.2.2.3.
    498500         ;; We only use it on implementations that support it.
    499          (or #+(or ccl ecl gcl lispworks sbcl) :unspecific)))
     501         (or #+(or ccl gcl lispworks sbcl) :unspecific)))
    500502    (destructuring-bind (name &optional (type unspecific))
    501503        (split-string filename :max 2 :separator ".")
     
    714716  (make-pathname :type "lisp" :defaults input-file))
    715717
     718(defparameter *wild-file*
     719  (make-pathname :name :wild :type :wild :version :wild :directory nil))
     720(defparameter *wild-directory*
     721  (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil))
     722(defparameter *wild-inferiors*
     723  (make-pathname :directory '(:relative :wild-inferiors) :name nil :type nil :version nil))
    716724(defparameter *wild-path*
    717   (make-pathname :directory '(:relative :wild-inferiors)
    718                  :name :wild :type :wild :version :wild))
     725  (merge-pathnames *wild-file* *wild-inferiors*))
    719726
    720727(defun* wilden (path)
     
    866873         (when (member 'components-by-name added)
    867874           (compute-module-components-by-name m))
    868          (when (and (typep m 'system) (member 'source-file added))
    869            (%set-system-source-file (probe-asd (component-name m) (component-pathname m)) m))))))
     875         (when (typep m 'system)
     876           (when (member 'source-file added)
     877             (%set-system-source-file
     878              (probe-asd (component-name m) (component-pathname m)) m)
     879             (when (equal (component-name m) "asdf")
     880               (setf (component-version m) *asdf-version*))))))))
    870881
    871882;;;; -------------------------------------------------------------------------
     
    939950(define-condition compile-failed (compile-error) ())
    940951(define-condition compile-warned (compile-error) ())
     952
     953(define-condition invalid-configuration ()
     954  ((form :reader condition-form :initarg :form)
     955   (location :reader condition-location :initarg :location)
     956   (format :reader condition-format :initarg :format)
     957   (arguments :reader condition-arguments :initarg :arguments :initform nil))
     958  (:report (lambda (c s)
     959             (format s "~@<~? (will be skipped)~@:>"
     960                     (condition-format c)
     961                     (list* (condition-form c) (condition-location c)
     962                            (condition-arguments c))))))
     963(define-condition invalid-source-registry (invalid-configuration warning)
     964  ((format :initform "~@<invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~>")))
     965(define-condition invalid-output-translation (invalid-configuration warning)
     966  ((format :initform "~@<invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~>")))
    941967
    942968(defclass component ()
     
    11521178  ;; There is no "unload" operation in Common Lisp, and a general such operation
    11531179  ;; cannot be portably written, considering how much CL relies on side-effects
    1154   ;; of global data structures.
    1155   ;; Note that this does a setf gethash instead of a remhash
    1156   ;; this way there remains a hint in the *defined-systems* table
    1157   ;; that the system was loaded at some point.
    1158   (setf (gethash (coerce-name name) *defined-systems*) nil))
     1180  ;; to global data structures.
     1181  (remhash (coerce-name name) *defined-systems*))
    11591182
    11601183(defun* map-systems (fn)
     
    12901313  (find-system (coerce-name name) error-p))
    12911314
     1315(defun load-sysdef (name pathname)
     1316  ;; Tries to load system definition with canonical NAME from PATHNAME.
     1317  (let ((package (make-temporary-package)))
     1318    (unwind-protect
     1319         (handler-bind
     1320             ((error (lambda (condition)
     1321                       (error 'load-system-definition-error
     1322                              :name name :pathname pathname
     1323                              :condition condition))))
     1324           (let ((*package* package))
     1325             (asdf-message
     1326              "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%"
     1327              pathname package)
     1328             (load pathname)))
     1329      (delete-package package))))
     1330
    12921331(defmethod find-system ((name string) &optional (error-p t))
    12931332  (catch 'find-system
    1294     (let* ((in-memory (system-registered-p name))
     1333    (let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
    12951334           (on-disk (system-definition-pathname name)))
    12961335      (when (and on-disk
    12971336                 (or (not in-memory)
    1298                      (< (car in-memory) (safe-file-write-date on-disk))))
    1299         (let ((package (make-temporary-package)))
    1300           (unwind-protect
    1301                (handler-bind
    1302                    ((error (lambda (condition)
    1303                              (error 'load-system-definition-error
    1304                                     :name name :pathname on-disk
    1305                                     :condition condition))))
    1306                  (let ((*package* package))
    1307                    (asdf-message
    1308                     "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%"
    1309                     on-disk *package*)
    1310                    (load on-disk)))
    1311             (delete-package package))))
    1312       (let ((in-memory (system-registered-p name)))
     1337                     ;; don't reload if it's already been loaded,
     1338                     ;; or its filestamp is in the future which means some clock is skewed
     1339                     ;; and trying to load might cause an infinite loop.
     1340                     (< (car in-memory) (safe-file-write-date on-disk) (get-universal-time))))
     1341        (load-sysdef name on-disk))
     1342      (let ((in-memory (system-registered-p name))) ; try again after loading from disk
    13131343        (cond
    13141344          (in-memory
     
    13411371
    13421372(defun* sysdef-find-asdf (name)
    1343   (find-system-fallback name "asdf")) ;; :version *asdf-version* wouldn't be updated when ASDF is updated.
     1373  ;; Bug: :version *asdf-version* won't be updated when ASDF is updated.
     1374  (find-system-fallback name "asdf" :version *asdf-version*))
    13441375
    13451376
     
    16511682      (retry ()
    16521683        :report (lambda (s)
    1653                   (format s "~@<Retry loading component ~S.~@:>"
    1654                           (component-find-path required-c)))
     1684                  (format s "~@<Retry loading component ~S.~@:>" required-c))
    16551685        :test
    16561686        (lambda (c)
     
    24092439
    24102440    #+clisp                     ;XXX not exactly *verbose-out*, I know
    2411     (ext:run-shell-command  command :output :terminal :wait t)
     2441    (or (ext:run-shell-command  command :output :terminal :wait t) 0)
    24122442
    24132443    #+clozure
     
    25872617          (os   (maybe-warn (first-feature *os-features*)
    25882618                            "No os feature found in ~a." *os-features*))
    2589           (arch (maybe-warn (first-feature *architecture-features*)
     2619          (arch #+clisp "" #-clisp
     2620                (maybe-warn (first-feature *architecture-features*)
    25902621                            "No architecture feature found in ~a."
    25912622                            *architecture-features*))
     
    25952626       #\_ (lambda (x) (find x " /:\\(){}[]$#`'\""))
    25962627       (format nil "~(~@{~a~^-~}~)" lisp version os arch)))))
    2597 
    25982628
    25992629
     
    26502680        (and (length=n-p x 1) (member (car x) kw)))))
    26512681
     2682(defun* report-invalid-form (reporter &rest args)
     2683  (etypecase reporter
     2684    (null
     2685     (apply 'error 'invalid-configuration args))
     2686    (function
     2687     (apply reporter args))
     2688    ((or symbol string)
     2689     (apply 'error reporter args))
     2690    (cons
     2691     (apply 'apply (append reporter args)))))
     2692
     2693(defvar *ignored-configuration-form* nil)
     2694
    26522695(defun* validate-configuration-form (form tag directive-validator
    2653                                     &optional (description tag))
     2696                                    &key location invalid-form-reporter)
    26542697  (unless (and (consp form) (eq (car form) tag))
    2655     (error "Error: Form doesn't specify ~A ~S~%" description form))
    2656   (loop :with inherit = 0
    2657     :for directive :in (cdr form) :do
    2658     (if (configuration-inheritance-directive-p directive)
    2659         (incf inherit)
    2660         (funcall directive-validator directive))
     2698    (setf *ignored-configuration-form* t)
     2699    (report-invalid-form invalid-form-reporter :form form :location location)
     2700    (return-from validate-configuration-form nil))
     2701  (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag)
     2702    :for directive :in (cdr form)
     2703    :when (cond
     2704            ((configuration-inheritance-directive-p directive)
     2705             (incf inherit) t)
     2706            ((eq directive :ignore-invalid-entries)
     2707             (setf ignore-invalid-p t) t)
     2708            ((funcall directive-validator directive)
     2709             t)
     2710            (ignore-invalid-p
     2711             nil)
     2712            (t
     2713             (setf *ignored-configuration-form* t)
     2714             (report-invalid-form invalid-form-reporter :form directive :location location)
     2715             nil))
     2716    :do (push directive x)
    26612717    :finally
    26622718    (unless (= inherit 1)
    2663       (error "One and only one of ~S or ~S is required"
    2664              :inherit-configuration :ignore-inherited-configuration)))
    2665   form)
    2666 
    2667 (defun* validate-configuration-file (file validator description)
     2719      (report-invalid-form invalid-form-reporter
     2720             :arguments (list "One and only one of ~S or ~S is required"
     2721                              :inherit-configuration :ignore-inherited-configuration)))
     2722    (return (nreverse x))))
     2723
     2724(defun* validate-configuration-file (file validator &key description)
    26682725  (let ((forms (read-file-forms file)))
    26692726    (unless (length=n-p forms 1)
    26702727      (error "One and only one form allowed for ~A. Got: ~S~%" description forms))
    2671     (funcall validator (car forms))))
     2728    (funcall validator (car forms) :location file)))
    26722729
    26732730(defun* hidden-file-p (pathname)
    26742731  (equal (first-char (pathname-name pathname)) #\.))
    26752732
    2676 (defun* validate-configuration-directory (directory tag validator)
     2733(defun* directory* (pathname-spec &rest keys &key &allow-other-keys)
     2734  (apply 'directory pathname-spec
     2735         (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
     2736                             #+ccl '(:follow-links nil)
     2737                             #+clisp '(:circle t :if-does-not-exist :ignore)
     2738                             #+(or cmu scl) '(:follow-links nil :truenamep nil)
     2739                             #+sbcl (when (find-symbol "RESOLVE-SYMLINKS" "SB-IMPL") '(:resolve-symlinks nil))))))
     2740
     2741(defun* validate-configuration-directory (directory tag validator &key invalid-form-reporter)
     2742  "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will
     2743be applied to the results to yield a configuration form.  Current
     2744values of TAG include :source-registry and :output-translations."
    26772745  (let ((files (sort (ignore-errors
    26782746                       (remove-if
    26792747                        'hidden-file-p
    2680                         (directory (make-pathname :name :wild :type "conf" :defaults directory)
    2681                                    #+sbcl :resolve-symlinks #+sbcl nil)))
     2748                        (directory* (make-pathname :name :wild :type "conf" :defaults directory))))
    26822749                     #'string< :key #'namestring)))
    26832750    `(,tag
    26842751      ,@(loop :for file :in files :append
    2685           (mapcar validator (read-file-forms file)))
     2752          (loop :with ignore-invalid-p = nil
     2753            :for form :in (read-file-forms file)
     2754            :when (eq form :ignore-invalid-entries)
     2755              :do (setf ignore-invalid-p t)
     2756            :else
     2757              :when (funcall validator form)
     2758                :collect form
     2759              :else
     2760                :when ignore-invalid-p
     2761                  :do (setf *ignored-configuration-form* t)
     2762                :else
     2763                  :do (report-invalid-form invalid-form-reporter :form form :location file)))
    26862764      :inherit-configuration)))
    26872765
     
    27232801                               ((eql t) -1)
    27242802                               (pathname
    2725                                 (length (pathname-directory (car x)))))))))
     2803                                (let ((directory (pathname-directory (car x))))
     2804                                  (if (listp directory) (length directory) 0))))))))
    27262805  new-value)
    27272806
     
    27572836              ((eql :default-directory)
    27582837               (relativize-pathname-directory (default-directory)))
     2838              ((eql :*/) *wild-directory*)
     2839              ((eql :**/) *wild-inferiors*)
     2840              ((eql :*.*.*) *wild-file*)
    27592841              ((eql :implementation) (implementation-identifier))
    27602842              ((eql :implementation-type) (string-downcase (implementation-type)))
     
    27662848      (error "pathname ~S is not relative to ~S" s super))
    27672849    (merge-pathnames* s super)))
     2850
     2851(defvar *here-directory* nil
     2852  "This special variable is bound to the currect directory during calls to
     2853PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here
     2854directive.")
    27682855
    27692856(defun* resolve-absolute-location-component (x &key directory wilden)
     
    27892876                 (if wilden (wilden p) p))))
    27902877            ((eql :home) (user-homedir))
     2878            ((eql :here)
     2879             (resolve-location (or *here-directory*
     2880                                   ;; give semantics in the case of use interactively
     2881                                   :default-directory)
     2882                          :directory t :wilden nil))
    27912883            ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
    27922884            ((eql :system-cache) (resolve-location *system-cache* :directory t :wilden nil))
     
    28132905
    28142906(defun* location-designator-p (x)
    2815   (flet ((componentp (c) (typep c '(or string pathname keyword))))
    2816     (or (typep x 'boolean) (componentp x) (and (consp x) (every #'componentp x)))))
     2907  (flet ((absolute-component-p (c)
     2908           (typep c '(or string pathname
     2909                      (member :root :home :here :user-cache :system-cache :default-directory))))
     2910         (relative-component-p (c)
     2911           (typep c '(or string pathname
     2912                      (member :default-directory :*/ :**/ :*.*.*
     2913                        :implementation :implementation-type
     2914                        #-(and (or win32 windows mswindows mingw32) (not cygwin)) :uid)))))
     2915    (or (typep x 'boolean)
     2916        (absolute-component-p x)
     2917        (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x))))))
    28172918
    28182919(defun* location-function-p (x)
     
    28272928
    28282929(defun* validate-output-translations-directive (directive)
    2829   (unless
    2830       (or (member directive '(:inherit-configuration
    2831                               :ignore-inherited-configuration
    2832                               :enable-user-cache :disable-cache nil))
    2833           (and (consp directive)
    2834                (or (and (length=n-p directive 2)
    2835                         (or (and (eq (first directive) :include)
    2836                                  (typep (second directive) '(or string pathname null)))
    2837                             (and (location-designator-p (first directive))
    2838                                  (or (location-designator-p (second directive))
    2839                                      (location-function-p (second directive))))))
    2840                    (and (length=n-p directive 1)
    2841                         (location-designator-p (first directive))))))
    2842     (error "Invalid directive ~S~%" directive))
    2843   directive)
    2844 
    2845 (defun* validate-output-translations-form (form)
     2930  (or (member directive '(:enable-user-cache :disable-cache nil))
     2931      (and (consp directive)
     2932           (or (and (length=n-p directive 2)
     2933                    (or (and (eq (first directive) :include)
     2934                             (typep (second directive) '(or string pathname null)))
     2935                        (and (location-designator-p (first directive))
     2936                             (or (location-designator-p (second directive))
     2937                                 (location-function-p (second directive))))))
     2938               (and (length=n-p directive 1)
     2939                    (location-designator-p (first directive)))))))
     2940
     2941(defun* validate-output-translations-form (form &key location)
    28462942  (validate-configuration-form
    28472943   form
    28482944   :output-translations
    28492945   'validate-output-translations-directive
    2850    "output translations"))
     2946   :location location :invalid-form-reporter 'invalid-output-translation))
    28512947
    28522948(defun* validate-output-translations-file (file)
    28532949  (validate-configuration-file
    2854    file 'validate-output-translations-form "output translations"))
     2950   file 'validate-output-translations-form :description "output translations"))
    28552951
    28562952(defun* validate-output-translations-directory (directory)
    28572953  (validate-configuration-directory
    2858    directory :output-translations 'validate-output-translations-directive))
    2859 
    2860 (defun* parse-output-translations-string (string)
     2954   directory :output-translations 'validate-output-translations-directive
     2955   :invalid-form-reporter 'invalid-output-translation))
     2956
     2957(defun* parse-output-translations-string (string &key location)
    28612958  (cond
    28622959    ((or (null string) (equal string ""))
     
    28652962     (error "environment string isn't: ~S" string))
    28662963    ((eql (char string 0) #\")
    2867      (parse-output-translations-string (read-from-string string)))
     2964     (parse-output-translations-string (read-from-string string) :location location))
    28682965    ((eql (char string 0) #\()
    2869      (validate-output-translations-form (read-from-string string)))
     2966     (validate-output-translations-form (read-from-string string) :location location))
    28702967    (t
    28712968     (loop
     
    29753072        ((:inherit-configuration)
    29763073         (inherit-output-translations inherit :collect collect))
    2977         ((:ignore-inherited-configuration nil)
     3074        ((:ignore-inherited-configuration :ignore-invalid-entries nil)
    29783075         nil))
    29793076      (let ((src (first directive))
     
    29983095                   (let* ((trudst (make-pathname
    29993096                                   :defaults (if dst (resolve-location dst :directory t :wilden t) trusrc)))
    3000                           (wilddst (make-pathname
    3001                                     :name :wild :type :wild :version :wild
    3002                                     :defaults trudst)))
     3097                          (wilddst (merge-pathnames* *wild-file* trudst)))
    30033098                     (funcall collect (list wilddst t))
    30043099                     (funcall collect (list trusrc trudst)))))))))))
     
    31613256    (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP"))
    31623257  (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
    3163          (wild-inferiors (make-pathname :directory '(:relative :wild-inferiors)))
    3164          (mapped-files (make-pathname
    3165                         :name :wild :version :wild
    3166                         :type (if map-all-source-files :wild fasl-type)))
     3258         (mapped-files (if map-all-source-files *wild-file*
     3259                           (make-pathname :name :wild :version :wild :type fasl-type)))
    31673260         (destination-directory
    31683261          (if centralize-lisp-binaries
     
    31703263                ,@(when include-per-user-information
    31713264                        (cdr (pathname-directory (user-homedir))))
    3172                 :implementation ,wild-inferiors)
    3173               `(:root ,wild-inferiors :implementation))))
     3265                :implementation ,*wild-inferiors*)
     3266              `(:root ,*wild-inferiors* :implementation))))
    31743267    (initialize-output-translations
    31753268     `(:output-translations
    31763269       ,@source-to-target-mappings
    3177        ((:root ,wild-inferiors ,mapped-files)
     3270       ((:root ,*wild-inferiors* ,mapped-files)
    31783271        (,@destination-directory ,mapped-files))
    31793272       (t t)
     
    32953388
    32963389(defun directory-has-asd-files-p (directory)
    3297   (and (ignore-errors
    3298          (directory (merge-pathnames* *wild-asd* directory)
    3299                     #+sbcl #+sbcl :resolve-symlinks nil
    3300                     #+ccl #+ccl :follow-links nil
    3301                     #+clisp #+clisp :circle t))
    3302        t))
     3390  (ignore-errors
     3391    (directory* (merge-pathnames* *wild-asd* directory))
     3392    t))
    33033393
    33043394(defun subdirectories (directory)
     
    33073397         (wild (merge-pathnames*
    33083398                #-(or abcl allegro lispworks scl)
    3309                 (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil)
     3399                *wild-directory*
    33103400                #+(or abcl allegro lispworks scl) "*.*"
    33113401                directory))
     
    33133403          #-cormanlisp
    33143404          (ignore-errors
    3315             (directory wild .
    3316               #.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
    3317                     #+ccl '(:follow-links nil :directories t :files nil)
    3318                     #+clisp '(:circle t :if-does-not-exist :ignore)
    3319                     #+(or cmu scl) '(:follow-links nil :truenamep nil)
    3320                     #+digitool '(:directories t)
    3321                     #+sbcl '(:resolve-symlinks nil))))
     3405            (directory* wild . #.(or #+ccl '(:directories t :files nil)
     3406                                     #+digitool '(:directories t))))
    33223407          #+cormanlisp (cl::directory-subdirs directory))
    33233408         #+(or abcl allegro lispworks scl)
     
    33473432
    33483433(defun* validate-source-registry-directive (directive)
    3349   (unless
    3350       (or (member directive '(:default-registry (:default-registry)) :test 'equal)
    3351           (destructuring-bind (kw &rest rest) directive
    3352             (case kw
    3353               ((:include :directory :tree)
    3354                (and (length=n-p rest 1)
    3355                     (location-designator-p (first rest))))
    3356               ((:exclude :also-exclude)
    3357                (every #'stringp rest))
    3358               (null rest))))
    3359     (error "Invalid directive ~S~%" directive))
    3360   directive)
    3361 
    3362 (defun* validate-source-registry-form (form)
     3434  (or (member directive '(:default-registry))
     3435      (and (consp directive)
     3436           (let ((rest (rest directive)))
     3437             (case (first directive)
     3438               ((:include :directory :tree)
     3439                (and (length=n-p rest 1)
     3440                     (location-designator-p (first rest))))
     3441               ((:exclude :also-exclude)
     3442                (every #'stringp rest))
     3443               ((:default-registry)
     3444                (null rest)))))))
     3445
     3446(defun* validate-source-registry-form (form &key location)
    33633447  (validate-configuration-form
    3364    form :source-registry 'validate-source-registry-directive "a source registry"))
     3448   form :source-registry 'validate-source-registry-directive
     3449   :location location :invalid-form-reporter 'invalid-source-registry))
    33653450
    33663451(defun* validate-source-registry-file (file)
    33673452  (validate-configuration-file
    3368    file 'validate-source-registry-form "a source registry"))
     3453   file 'validate-source-registry-form :description "a source registry"))
    33693454
    33703455(defun* validate-source-registry-directory (directory)
    33713456  (validate-configuration-directory
    3372    directory :source-registry 'validate-source-registry-directive))
    3373 
    3374 (defun* parse-source-registry-string (string)
     3457   directory :source-registry 'validate-source-registry-directive
     3458   :invalid-form-reporter 'invalid-source-registry))
     3459
     3460(defun* parse-source-registry-string (string &key location)
    33753461  (cond
    33763462    ((or (null string) (equal string ""))
     
    33793465     (error "environment string isn't: ~S" string))
    33803466    ((find (char string 0) "\"(")
    3381      (validate-source-registry-form (read-from-string string)))
     3467     (validate-source-registry-form (read-from-string string) :location location))
    33823468    (t
    33833469     (loop
     
    34763562  (cond
    34773563    ((directory-pathname-p pathname)
    3478      (process-source-registry (validate-source-registry-directory pathname)
    3479                               :inherit inherit :register register))
     3564     (let ((*here-directory* (truenamize pathname)))
     3565       (process-source-registry (validate-source-registry-directory pathname)
     3566                                :inherit inherit :register register)))
    34803567    ((probe-file pathname)
    3481      (process-source-registry (validate-source-registry-file pathname)
    3482                               :inherit inherit :register register))
     3568     (let ((*here-directory* (pathname-directory-pathname pathname)))
     3569       (process-source-registry (validate-source-registry-file pathname)
     3570                                :inherit inherit :register register)))
    34833571    (t
    34843572     (inherit-source-registry inherit :register register))))
     
    35283616  (remove-duplicates
    35293617   (while-collecting (collect)
    3530      (inherit-source-registry
    3531       `(wrapping-source-registry
    3532         ,parameter
    3533         ,@*default-source-registries*)
    3534       :register (lambda (directory &key recurse exclude)
    3535                   (collect (list directory :recurse recurse :exclude exclude)))))
    3536    :test 'equal :from-end t))
     3618     (let ((*default-pathname-defaults* (default-directory)))
     3619       (inherit-source-registry
     3620        `(wrapping-source-registry
     3621          ,parameter
     3622          ,@*default-source-registries*)
     3623        :register (lambda (directory &key recurse exclude)
     3624                    (collect (list directory :recurse recurse :exclude exclude)))))
     3625     :test 'equal :from-end t)))
    35373626
    35383627;; Will read the configuration and initialize all internal variables,
     
    36183707      (when system-p (appendf (compile-op-flags op) (list :system-p system-p))))))
    36193708
     3709;;; If a previous version of ASDF failed to read some configuration, try again.
     3710(when *ignored-configuration-form*
     3711  (clear-configuration)
     3712  (setf *ignored-configuration-form* nil))
     3713
    36203714;;;; -----------------------------------------------------------------
    36213715;;;; Done!
Note: See TracChangeset for help on using the changeset viewer.