Changeset 13768


Ignore:
Timestamp:
Jun 1, 2010, 7:12:11 PM (10 years ago)
Author:
rme
Message:

Import ASDF 2.000 release from upstream.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/tools/asdf.lisp

    r13686 r13768  
    5050(cl:in-package :cl-user)
    5151
     52#|(declaim (optimize (speed 2) (debug 2) (safety 3))
     53#+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))|#
     54
    5255#+ecl (require :cmp)
    5356
     
    6871  (let* ((asdf-version
    6972          ;; the 1+ helps the version bumping script discriminate
    70           (subseq "VERSION:1.719" (1+ (length "VERSION"))))
     73          (subseq "VERSION:2.000" (1+ (length "VERSION"))))
    7174         (existing-asdf (find-package :asdf))
    7275         (vername '#:*asdf-version*)
     
    7881      #-gcl
    7982      (when existing-asdf
    80         (format *error-output*
     83        (format *trace-output*
    8184                "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
    8285                existing-version asdf-version))
     
    325328           ((m module) added deleted plist &key)
    326329         (declare (ignorable deleted plist))
     330         (format *trace-output* "Updating ~A~%" m)
    327331         (when (member 'components-by-name added)
    328332           (compute-module-components-by-name m))))))
     
    334338  "Exported interface to the version of ASDF currently installed. A string.
    335339You can compare this string with e.g.:
    336 (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"1.704\")."
     340(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.000\")."
    337341  *asdf-version*)
    338342
     
    453457(defgeneric traverse (operation component)
    454458  (:documentation
    455 "Generate and return a plan for performing `operation` on `component`.
    456 
    457 The plan returned is a list of dotted-pairs. Each pair is the `cons`
    458 of ASDF operation object and a `component` object. The pairs will be
    459 processed in order by `operate`."))
     459"Generate and return a plan for performing OPERATION on COMPONENT.
     460
     461The plan returned is a list of dotted-pairs. Each pair is the CONS
     462of ASDF operation object and a COMPONENT object. The pairs will be
     463processed in order by OPERATE."))
    460464
    461465
     
    477481  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
    478482and NIL NAME, TYPE and VERSION components"
    479   (make-pathname :name nil :type nil :version nil :defaults pathname))
    480 
    481 (defun current-directory ()
    482   (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
     483  (when pathname
     484    (make-pathname :name nil :type nil :version nil :defaults pathname)))
    483485
    484486(defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
     
    491493         (defaults (pathname defaults))
    492494         (directory (pathname-directory specified))
    493          (directory (if (stringp directory) `(:absolute ,directory) directory))
     495         #-sbcl (directory (if (stringp directory) `(:absolute ,directory) directory))
    494496         (name (or (pathname-name specified) (pathname-name defaults)))
    495497         (type (or (pathname-type specified) (pathname-type defaults)))
     
    514516             (values (pathname-host defaults)
    515517                     (pathname-device defaults)
    516                      (append (pathname-directory defaults) (cdr directory))
     518                     (if (pathname-directory defaults)
     519                         (append (pathname-directory defaults) (cdr directory))
     520                         directory)
    517521                     (unspecific-handler defaults)))
    518522            #+gcl
     
    534538  or "or a flag")
    535539
     540(defun first-char (s)
     541  (and (stringp s) (plusp (length s)) (char s 0)))
     542
     543(defun last-char (s)
     544  (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
     545
    536546(defun asdf-message (format-string &rest format-args)
    537547  (declare (dynamic-extent format-args))
     
    539549
    540550(defun split-string (string &key max (separator '(#\Space #\Tab)))
    541   "Split STRING in components separater by any of the characters in the sequence SEPARATOR,
    542 return a list.
     551  "Split STRING into a list of components separated by
     552any of the characters in the sequence SEPARATOR.
    543553If MAX is specified, then no more than max(1,MAX) components will be returned,
    544554starting the separation from the end, e.g. when called with arguments
     
    591601    (multiple-value-bind (relative components)
    592602        (if (equal (first components) "")
    593             (if (and (plusp (length s)) (eql (char s 0) #\/))
     603            (if (equal (first-char s) #\/)
    594604                (values :absolute (cdr components))
    595605                (values :relative nil))
     
    614624    :append (list k v)))
    615625
    616 (defun resolve-symlinks (path)
    617   #-allegro (truenamize path)
    618   #+allegro (excl:pathname-resolve-symbolic-links path))
    619 
    620626(defun getenv (x)
    621627  #+abcl
     
    624630  (sb-ext:posix-getenv x)
    625631  #+clozure
    626   (ccl::getenv x)
     632  (ccl:getenv x)
    627633  #+clisp
    628634  (ext:getenv x)
     
    639645
    640646(defun directory-pathname-p (pathname)
    641   "Does `pathname` represent a directory?
     647  "Does PATHNAME represent a directory?
    642648
    643649A directory-pathname is a pathname _without_ a filename. The three
    644 ways that the filename components can be missing are for it to be `nil`,
    645 `:unspecific` or the empty string.
    646 
    647 Note that this does _not_ check to see that `pathname` points to an
     650ways that the filename components can be missing are for it to be NIL,
     651:UNSPECIFIC or the empty string.
     652
     653Note that this does _not_ check to see that PATHNAME points to an
    648654actually-existing directory."
    649655  (flet ((check-one (x)
     
    729735      (when (typep p 'logical-pathname) (return p))
    730736      (ignore-errors (return (truename p)))
    731       (when (stringp directory)
    732          (return p))
    733       (when (not (eq :absolute (car directory)))
    734         (return p))
     737      #-sbcl (when (stringp directory) (return p))
     738      (when (not (eq :absolute (car directory))) (return p))
    735739      (let ((sofar (ignore-errors (truename (pathname-root p)))))
    736740        (unless sofar (return p))
     
    756760            (return (solution nil))))))))
    757761
     762(defun resolve-symlinks (path)
     763  #-allegro (truenamize path)
     764  #+allegro (excl:pathname-resolve-symbolic-links path))
     765
     766(defun default-directory ()
     767  (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
     768
    758769(defun lispize-pathname (input-file)
    759770  (make-pathname :type "lisp" :defaults input-file))
     771
     772(defparameter *wild-path*
     773  (make-pathname :directory '(:relative :wild-inferiors)
     774                 :name :wild :type :wild :version :wild))
     775
     776(defun wilden (path)
     777  (merge-pathnames* *wild-path* path))
     778
     779(defun directorize-pathname-host-device (pathname)
     780  (let* ((root (pathname-root pathname))
     781         (wild-root (wilden root))
     782         (absolute-pathname (merge-pathnames* pathname root))
     783         (foo (make-pathname :directory '(:absolute "FOO") :defaults root))
     784         (separator (last-char (namestring foo)))
     785         (root-namestring (namestring root))
     786         (root-string
     787          (substitute-if #\/
     788                         (lambda (x) (or (eql x #\:)
     789                                         (eql x separator)))
     790                         root-namestring)))
     791    (multiple-value-bind (relative path filename)
     792        (component-name-to-pathname-components root-string t)
     793      (declare (ignore relative filename))
     794      (let ((new-base
     795             (make-pathname :defaults root
     796                            :directory `(:absolute ,@path))))
     797        (translate-pathname absolute-pathname wild-root (wilden new-base))))))
    760798
    761799;;;; -------------------------------------------------------------------------
     
    770808  ;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]
    771809  #+cmu (:report print-object))
     810
     811(declaim (ftype (function (t) t)
     812                format-arguments format-control
     813                error-name error-pathname error-condition
     814                duplicate-names-name
     815                error-component error-operation
     816                module-components module-components-by-name)
     817         (ftype (function (t t) t) (setf module-components-by-name)))
     818
    772819
    773820(define-condition formatted-system-definition-error (system-definition-error)
     
    890937
    891938(defun compute-module-components-by-name (module)
    892   (let ((hash (module-components-by-name module)))
    893     (clrhash hash)
     939  (let ((hash (make-hash-table :test 'equal)))
     940    (setf (module-components-by-name module) hash)
    894941    (loop :for c :in (module-components module)
    895942      :for name = (component-name c)
     
    907954    :accessor module-components)
    908955   (components-by-name
    909     :initform (make-hash-table :test 'equal)
    910956    :accessor module-components-by-name)
    911957   ;; What to do if we can't satisfy a dependency of one of this module's
     
    935981             (merge-pathnames*
    936982             (component-relative-pathname component)
    937              (component-parent-pathname component))))
     983             (pathname-directory-pathname (component-parent-pathname component)))))
    938984        (unless (or (null pathname) (absolute-pathname-p pathname))
    939985          (error "Invalid relative pathname ~S for component ~S" pathname component))
     
    10091055
    10101056(defun map-systems (fn)
    1011   "Apply `fn` to each defined system.
    1012 
    1013 `fn` should be a function of one argument. It will be
     1057  "Apply FN to each defined system.
     1058
     1059FN should be a function of one argument. It will be
    10141060called with an object of type asdf:system."
    10151061  (maphash (lambda (_ datum)
     
    10241070
    10251071(defparameter *system-definition-search-functions*
    1026   '(sysdef-central-registry-search sysdef-source-registry-search))
     1072  '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf))
     1073
     1074(defun sysdef-find-asdf (system)
     1075  (let ((name (coerce-name system)))
     1076    (when (equal name "asdf")
     1077      (eval
     1078       `(defsystem :asdf
     1079          :pathname ,(or *compile-file-truename* *load-truename*)
     1080          :depends-on () :components ())))))
    10271081
    10281082(defun system-definition-pathname (system)
     
    10491103Going forward, we recommend new users should be using the source-registry.
    10501104")
     1105
     1106(defun probe-asd (name defaults)
     1107  (block nil
     1108    (when (directory-pathname-p defaults)
     1109      (let ((file
     1110             (make-pathname
     1111              :defaults defaults :version :newest :case :local
     1112              :name name
     1113              :type "asd")))
     1114        (when (probe-file file)
     1115          (return file)))
     1116      #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
     1117      (let ((shortcut
     1118             (make-pathname
     1119              :defaults defaults :version :newest :case :local
     1120              :name (concatenate 'string name ".asd")
     1121              :type "lnk")))
     1122        (when (probe-file shortcut)
     1123          (let ((target (parse-windows-shortcut shortcut)))
     1124            (when target
     1125              (return (pathname target)))))))))
    10511126
    10521127(defun sysdef-central-registry-search (system)
     
    10681143                                   (message
    10691144                                    (format nil
    1070                                             "~@<While searching for system `~a`: `~a` evaluated ~
    1071 to `~a` which is not a directory.~@:>"
     1145                                            "~@<While searching for system ~S: ~S evaluated ~
     1146to ~S which is not a directory.~@:>"
    10721147                                            system dir defaults)))
    10731148                              (error message))
     
    11671242
    11681243(defmethod find-component ((module module) (name string))
    1169   (when (slot-boundp module 'components-by-name)
    1170     (values (gethash name (module-components-by-name module)))))
     1244  (unless (slot-boundp module 'components-by-name) ;; SBCL may miss the u-i-f-r-c method!!!
     1245    (compute-module-components-by-name module))
     1246  (values (gethash name (module-components-by-name module))))
    11711247
    11721248(defmethod find-component ((component component) (name symbol))
     
    15981674      flag))
    15991675
    1600 (defmethod traverse ((operation operation) (c component))
    1601   ;; cerror'ing a feature that seems to have NEVER EVER worked
    1602   ;; ever since danb created it in his 2003-03-16 commit e0d02781.
    1603   ;; It was both fixed and disabled in the 1.700 rewrite.
    1604   (when (consp (operation-forced operation))
    1605     (cerror "Continue nonetheless."
    1606             "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.")
    1607     (setf (operation-forced operation)
    1608           (mapcar #'coerce-name (operation-forced operation))))
    1609   (flatten-tree
    1610    (while-collecting (collect)
    1611      (do-traverse operation c #'collect))))
    1612 
    16131676(defun flatten-tree (l)
    16141677  ;; You collected things into a list.
     
    16261689               (dolist (x l) (r x))))
    16271690      (r* l))))
     1691
     1692(defmethod traverse ((operation operation) (c component))
     1693  ;; cerror'ing a feature that seems to have NEVER EVER worked
     1694  ;; ever since danb created it in his 2003-03-16 commit e0d02781.
     1695  ;; It was both fixed and disabled in the 1.700 rewrite.
     1696  (when (consp (operation-forced operation))
     1697    (cerror "Continue nonetheless."
     1698            "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.")
     1699    (setf (operation-forced operation)
     1700          (mapcar #'coerce-name (operation-forced operation))))
     1701  (flatten-tree
     1702   (while-collecting (collect)
     1703     (do-traverse operation c #'collect))))
    16281704
    16291705(defmethod perform ((operation operation) (c source-file))
     
    18991975  "Operate does three things:
    19001976
    1901 1. It creates an instance of `operation-class` using any keyword parameters
     19771. It creates an instance of OPERATION-CLASS using any keyword parameters
    19021978as initargs.
    1903 2. It finds the  asdf-system specified by `system` (possibly loading
     19792. It finds the  asdf-system specified by SYSTEM (possibly loading
    19041980it from disk).
    1905 3. It then calls `traverse` with the operation and system as arguments
    1906 
    1907 The traverse operation is wrapped in `with-compilation-unit` and error
    1908 handling code. If a `version` argument is supplied, then operate also
    1909 ensures that the system found satisfies it using the `version-satisfies`
     19813. It then calls TRAVERSE with the operation and system as arguments
     1982
     1983The traverse operation is wrapped in WITH-COMPILATION-UNIT and error
     1984handling code. If a VERSION argument is supplied, then operate also
     1985ensures that the system found satisfies it using the VERSION-SATISFIES
    19101986method.
    19111987
     
    19452021;;;; Defsystem
    19462022
     2023(defun load-pathname ()
     2024  (let ((pn (or *load-pathname* *compile-file-pathname*)))
     2025    (if *resolve-symlinks*
     2026        (and pn (resolve-symlinks pn))
     2027        pn)))
     2028
    19472029(defun determine-system-pathname (pathname pathname-supplied-p)
    1948   ;; called from the defsystem macro.
    1949   ;; the pathname of a system is either
     2030  ;; The defsystem macro calls us to determine
     2031  ;; the pathname of a system as follows:
    19502032  ;; 1. the one supplied,
    1951   ;; 2. derived from the *load-truename* (see below), or
    1952   ;; 3. taken from *default-pathname-defaults*
    1953   ;;
    1954   ;; if using *load-truename*, then we also deal with whether or not
    1955   ;; to resolve symbolic links. If not resolving symlinks, then we use
    1956   ;; *load-pathname* instead of *load-truename* since in some
    1957   ;; implementations, the latter has *already resolved it.
    1958   (let ((file-pathname
    1959          (when (or *load-pathname* *compile-file-pathname*)
    1960            (pathname-directory-pathname
    1961             (if *resolve-symlinks*
    1962                 (resolve-symlinks (or *load-truename* *compile-file-truename*))
    1963                 *load-pathname*)))))
    1964     (or (and pathname-supplied-p (merge-pathnames* pathname file-pathname))
     2033  ;; 2. derived from *load-pathname* via load-pathname
     2034  ;; 3. taken from the *default-pathname-defaults* via default-directory
     2035  (let* ((file-pathname (load-pathname))
     2036         (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
     2037    (or (and pathname-supplied-p (merge-pathnames* pathname directory-pathname))
    19652038        file-pathname
    1966         (current-directory))))
     2039        (default-directory))))
    19672040
    19682041(defmacro defsystem (name &body options)
     
    19852058                  (register-system (quote ,name)
    19862059                                   (make-instance ',class :name ',name))))
    1987            (%set-system-source-file *load-truename*
     2060           (%set-system-source-file (load-pathname)
    19882061                                    (cdr (system-registered-p ',name))))
    19892062         (parse-component-form
     
    21742247
    21752248(defun run-shell-command (control-string &rest args)
    2176   "Interpolate `args` into `control-string` as if by `format`, and
     2249  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
    21772250synchronously execute the result using a Bourne-compatible shell, with
    2178 output to `*verbose-out*`.  Returns the shell's exit code."
     2251output to *VERBOSE-OUT*.  Returns the shell's exit code."
    21792252  (let ((command (apply #'format nil control-string args)))
    21802253    (asdf-message "; $ ~A~%" command)
     
    24472520    (funcall validator (car forms))))
    24482521
     2522(defun hidden-file-p (pathname)
     2523  (equal (first-char (pathname-name pathname)) #\.))
     2524
    24492525(defun validate-configuration-directory (directory tag validator)
    24502526  (let ((files (sort (ignore-errors
    2451                        (directory (make-pathname :name :wild :type :wild :defaults directory)
    2452                                   #+sbcl :resolve-symlinks #+sbcl nil))
     2527                       (remove-if
     2528                        'hidden-file-p
     2529                        (directory (make-pathname :name :wild :type "conf" :defaults directory)
     2530                                   #+sbcl :resolve-symlinks #+sbcl nil)))
    24532531                     #'string< :key #'namestring)))
    24542532    `(,tag
     
    25072585  (values))
    25082586
    2509 (defparameter *wild-path*
    2510   (make-pathname :directory '(:relative :wild-inferiors)
    2511                  :name :wild :type :wild :version :wild))
    2512 
    25132587(defparameter *wild-asd*
    25142588  (make-pathname :directory '(:relative :wild-inferiors)
    25152589                 :name :wild :type "asd" :version :newest))
    25162590
    2517 (defun wilden (path)
    2518   (merge-pathnames* *wild-path* path))
     2591
     2592(declaim (ftype (function (t &optional boolean) (or null pathname))
     2593                resolve-location))
     2594
     2595(defun resolve-relative-location-component (super x &optional wildenp)
     2596  (let* ((r (etypecase x
     2597              (pathname x)
     2598              (string x)
     2599              (cons
     2600               (let ((car (resolve-relative-location-component super (car x) nil)))
     2601                 (if (null (cdr x))
     2602                     car
     2603                     (let ((cdr (resolve-relative-location-component
     2604                                 (merge-pathnames* car super) (cdr x) wildenp)))
     2605                       (merge-pathnames* cdr car)))))
     2606              ((eql :default-directory)
     2607               (relativize-pathname-directory (default-directory)))
     2608              ((eql :implementation) (implementation-identifier))
     2609              ((eql :implementation-type) (string-downcase (implementation-type)))
     2610              #-(and (or win32 windows mswindows mingw32) (not cygwin))
     2611              ((eql :uid) (princ-to-string (get-uid)))))
     2612         (d (if (pathnamep x) r (ensure-directory-pathname r)))
     2613         (s (if (and wildenp (not (pathnamep x)))
     2614                (wilden d)
     2615                d)))
     2616    (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
     2617      (error "pathname ~S is not relative to ~S" s super))
     2618    (merge-pathnames* s super)))
    25192619
    25202620(defun resolve-absolute-location-component (x wildenp)
     
    25382638            ((eql :user-cache) (resolve-location *user-cache* nil))
    25392639            ((eql :system-cache) (resolve-location *system-cache* nil))
    2540             ((eql :current-directory) (current-directory))))
     2640            ((eql :default-directory) (default-directory))))
    25412641         (s (if (and wildenp (not (pathnamep x)))
    25422642                (wilden r)
     
    25452645      (error "Not an absolute pathname ~S" s))
    25462646    s))
    2547 
    2548 (defun resolve-relative-location-component (super x &optional wildenp)
    2549   (let* ((r (etypecase x
    2550               (pathname x)
    2551               (string x)
    2552               (cons
    2553                (let ((car (resolve-relative-location-component super (car x) nil)))
    2554                  (if (null (cdr x))
    2555                      car
    2556                      (let ((cdr (resolve-relative-location-component
    2557                                  (merge-pathnames* car super) (cdr x) wildenp)))
    2558                        (merge-pathnames* cdr car)))))
    2559               ((eql :current-directory)
    2560                (relativize-pathname-directory (current-directory)))
    2561               ((eql :implementation) (implementation-identifier))
    2562               ((eql :implementation-type) (string-downcase (implementation-type)))
    2563               ((eql :uid) (princ-to-string (get-uid)))))
    2564          (d (if (pathnamep x) r (ensure-directory-pathname r)))
    2565          (s (if (and wildenp (not (pathnamep x)))
    2566                 (wilden d)
    2567                 d)))
    2568     (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
    2569       (error "pathname ~S is not relative to ~S" s super))
    2570     (merge-pathnames* s super)))
    25712647
    25722648(defun resolve-location (x &optional wildenp)
     
    26752751    ;; so we must disable translations for implementation paths.
    26762752    #+sbcl (,(getenv "SBCL_HOME") ())
    2677     #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; only needed if LPNs are resolved manually.
    2678     #+clozure (,(wilden (ccl::ccl-directory)) ()) ; not needed: no precompiled ASDF system
     2753    #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system
     2754    #+clozure (,(wilden (truename #p"ccl:")) ()) ; not needed: no precompiled ASDF system
    26792755    ;; All-import, here is where we want user stuff to be:
    26802756    :inherit-configuration
     
    27002776
    27012777(defgeneric process-output-translations (spec &key inherit collect))
     2778(declaim (ftype (function (t &key (:collect (or symbol function))) t)
     2779                inherit-output-translations))
     2780(declaim (ftype (function (t &key (:collect (or symbol function)) (:inherit list)) t)
     2781                process-output-translations-directive))
     2782
    27022783(defmethod process-output-translations ((x symbol) &key
    27032784                                        (inherit *default-output-translations*)
     
    28272908       :finally (return p)))))
    28282909
    2829 (defun last-char (s)
    2830   (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
    2831 
    2832 (defun directorize-pathname-host-device (pathname)
    2833   (let* ((root (pathname-root pathname))
    2834          (wild-root (wilden root))
    2835          (absolute-pathname (merge-pathnames* pathname root))
    2836          (foo (make-pathname :directory '(:absolute "FOO") :defaults root))
    2837          (separator (last-char (namestring foo)))
    2838          (root-namestring (namestring root))
    2839          (root-string
    2840           (substitute-if #\/
    2841                          (lambda (x) (or (eql x #\:)
    2842                                          (eql x separator)))
    2843                          root-namestring)))
    2844     (multiple-value-bind (relative path filename)
    2845         (component-name-to-pathname-components root-string t)
    2846       (declare (ignore relative filename))
    2847       (let ((new-base
    2848              (make-pathname :defaults root
    2849                             :directory `(:absolute ,@path))))
    2850         (translate-pathname absolute-pathname wild-root (wilden new-base))))))
    2851 
    28522910(defmethod output-files :around (operation component)
    28532911  "Translate output files, unless asked not to"
     
    29923050
    29933051;; Using ack 1.2 exclusions
    2994 (defvar *default-exclusions*
     3052(defvar *default-source-registry-exclusions*
    29953053  '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst"
    29963054    ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
    29973055    "_sgbak" "autom4te.cache" "cover_db" "_build"))
     3056
     3057(defvar *source-registry-exclusions* *default-source-registry-exclusions*)
    29983058
    29993059(defvar *source-registry* ()
     
    30173077  (setf *source-registry* '())
    30183078  (values))
    3019 
    3020 (defun probe-asd (name defaults)
    3021   (block nil
    3022     (when (directory-pathname-p defaults)
    3023       (let ((file
    3024              (make-pathname
    3025               :defaults defaults :version :newest :case :local
    3026               :name name
    3027               :type "asd")))
    3028         (when (probe-file file)
    3029           (return file)))
    3030       #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
    3031       (let ((shortcut
    3032              (make-pathname
    3033               :defaults defaults :version :newest :case :local
    3034               :name (concatenate 'string name ".asd")
    3035               :type "lnk")))
    3036         (when (probe-file shortcut)
    3037           (let ((target (parse-windows-shortcut shortcut)))
    3038             (when target
    3039               (return (pathname target)))))))))
    3040 
    3041 (defun sysdef-source-registry-search (system)
    3042   (ensure-source-registry)
    3043   (loop :with name = (coerce-name system)
    3044     :for defaults :in (source-registry)
    3045     :for file = (probe-asd name defaults)
    3046     :when file :return file))
    30473079
    30483080(defun validate-source-registry-directive (directive)
     
    30543086               (and (length=n-p rest 1)
    30553087                    (typep (car rest) '(or pathname string null))))
    3056               ((:exclude)
     3088              ((:exclude :also-exclude)
    30573089               (every #'stringp rest))
    30583090              (null rest))))
     
    31403172  `(:source-registry
    31413173    #+sbcl (:tree ,(getenv "SBCL_HOME"))
    3142    :inherit-configuration))
     3174    :inherit-configuration
     3175    #+cmu (:tree #p"modules:")))
    31433176(defun default-source-registry ()
    31443177  (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
     
    31793212
    31803213(defgeneric process-source-registry (spec &key inherit register))
     3214(declaim (ftype (function (t &key (:register (or symbol function))) t)
     3215                inherit-source-registry))
     3216(declaim (ftype (function (t &key (:register (or symbol function)) (:inherit list)) t)
     3217                process-source-registry-directive))
     3218
    31813219(defmethod process-source-registry ((x symbol) &key inherit register)
    31823220  (process-source-registry (funcall x) :inherit inherit :register register))
     
    31983236  (inherit-source-registry inherit :register register))
    31993237(defmethod process-source-registry ((form cons) &key inherit register)
    3200   (let ((*default-exclusions* *default-exclusions*))
     3238  (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
    32013239    (dolist (directive (cdr (validate-source-registry-form form)))
    32023240      (process-source-registry-directive directive :inherit inherit :register register))))
     
    32193257       (destructuring-bind (pathname) rest
    32203258         (when pathname
    3221            (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *default-exclusions*))))
     3259           (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *source-registry-exclusions*))))
    32223260      ((:exclude)
    3223        (setf *default-exclusions* rest))
     3261       (setf *source-registry-exclusions* rest))
     3262      ((:also-exclude)
     3263       (appendf *source-registry-exclusions* rest))
    32243264      ((:default-registry)
    32253265       (inherit-source-registry '(default-source-registry) :register register))
     
    32273267       (inherit-source-registry inherit :register register))
    32283268      ((:ignore-inherited-configuration)
    3229        nil))))
     3269       nil)))
     3270  nil)
    32303271
    32313272(defun flatten-source-registry (&optional parameter)
     
    32623303      (initialize-source-registry)))
    32633304
     3305(defun sysdef-source-registry-search (system)
     3306  (ensure-source-registry)
     3307  (loop :with name = (coerce-name system)
     3308    :for defaults :in (source-registry)
     3309    :for file = (probe-asd name defaults)
     3310    :when file :return file))
     3311
    32643312;;;; -----------------------------------------------------------------
    32653313;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL
     
    32723320         (missing-component (constantly nil))
    32733321         (error (lambda (e)
    3274                   (format *error-output* "ASDF could not load ~A because ~A.~%"
     3322                  (format *error-output* "ASDF could not load ~(~A~) because ~A.~%"
    32753323                          name e))))
    32763324      (let* ((*verbose-out* (make-broadcast-stream))
    3277              (system (find-system name nil)))
     3325             (system (find-system (string-downcase name) nil)))
    32783326        (when system
    3279           (load-system name)
     3327          (load-system system)
    32803328          t))))
    32813329  (pushnew 'module-provide-asdf
    32823330           #+abcl sys::*module-provider-functions*
    3283            #+clozure ccl::*module-provider-functions*
     3331           #+clozure ccl:*module-provider-functions*
    32843332           #+cmu ext:*module-provider-functions*
    32853333           #+ecl si:*module-provider-functions*
     
    33143362
    33153363(pushnew :asdf *features*)
    3316 ;; this is a release candidate for ASDF 2.0
    33173364(pushnew :asdf2 *features*)
    33183365
Note: See TracChangeset for help on using the changeset viewer.