Changeset 13125 for trunk/abcl/src/org


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

Upgrade to ASDF-2.012.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • 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.