Changeset 13125

01/05/11 07:32:25 (12 years ago)
Mark Evenson

Upgrade to ASDF-2.012.

2 edited


  • trunk/abcl/doc/asdf/asdf.texinfo

    r12986 r13125  
    17911791@section Configuration DSL
    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
     1796@c FIXME: This is too wide for happy compilation into pdf.
    18061809    :ignore-inherited-configuration | ; drop inherited configuration (specified anywhere)
     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
    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)
    18431853    STRING | ;; namestring (directory assumed where applicable)
    18441854    PATHNAME | ;; pathname
    1845     :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-
     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
    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
     1910@subsection The :here directive
     1912The @code{:here} directive is an absolute pathname designator that
     1913refers to the directory containing the configuration file currently
     1914being processed.
     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.
     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:
     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.
     1935In this case, X can put into @file{dir/} a file @file{asdf.conf} that
     1936contains the following:
     1939   (:tree (:here "src/lisp/"))
     1940   (:tree (:here "extlib/lisp"))
     1941   (:directory (:here "outlier/")))
     1942@end example
     1944Then when someone else (call her Y) checks out a copy of this
     1945repository, she need only add
     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.
    19011955@section Shell-friendly syntax for configuration
    21922246@section Backward Compatibility
    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
    21982250We purposefully do NOT provide backward compatibility with earlier versions of
    22222274we provide a limited emulation mode:
    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)
     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
    22672324    ;; include a configuration file or directory
    22682325    (:include PATHNAME-DESIGNATOR) |
    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-
     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(!)
    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:
     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 :*.*.*))}
    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}
    25372615@c @item
    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.
     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.
    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
    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))
     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*))
    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*))))))))
    871882;;;; -------------------------------------------------------------------------
    939950(define-condition compile-failed (compile-error) ())
    940951(define-condition compile-warned (compile-error) ())
     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~]~@{ ~@?~}~>")))
    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*))
    11601183(defun* map-systems (fn)
    12901313  (find-system (coerce-name name) error-p))
     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))))
    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
    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*))
    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)
    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)
    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)))))
    26502680        (and (length=n-p x 1) (member (car x) kw)))))
     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)))))
     2693(defvar *ignored-configuration-form* nil)
    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)
    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))))
     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)))
    26732730(defun* hidden-file-p (pathname)
    26742731  (equal (first-char (pathname-name pathname)) #\.))
    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))))))
     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)))
    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)
    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)))
     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
    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))
    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))))))
    28182919(defun* location-function-p (x)
    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)
    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)))))))
     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))
    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"))
    28562952(defun* validate-output-translations-directory (directory)
    28572953  (validate-configuration-directory
    2858    directory :output-translations 'validate-output-translations-directive))
    2860 (defun* parse-output-translations-string (string)
     2954   directory :output-translations 'validate-output-translations-directive
     2955   :invalid-form-reporter 'invalid-output-translation))
     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)
    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))
    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)
    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)
    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)))))))
     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))
    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"))
    33703455(defun* validate-source-registry-directory (directory)
    33713456  (validate-configuration-directory
    3372    directory :source-registry 'validate-source-registry-directive))
    3374 (defun* parse-source-registry-string (string)
     3457   directory :source-registry 'validate-source-registry-directive
     3458   :invalid-form-reporter 'invalid-source-registry))
     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)))
    35383627;; Will read the configuration and initialize all internal variables,
    36183707      (when system-p (appendf (compile-op-flags op) (list :system-p system-p))))))
     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))
    36203714;;;; -----------------------------------------------------------------
    36213715;;;; Done!
Note: See TracChangeset for help on using the changeset viewer.