CMUCL commit: src/contrib/asdf (asdf.lisp)
Raymond Toy
rtoy at common-lisp.net
Tue May 25 22:05:53 CEST 2010
Date: Tuesday, May 25, 2010 @ 16:05:53
Author: rtoy
Path: /project/cmucl/cvsroot/src/contrib/asdf
Modified: asdf.lisp
Update to version 1.728. This fixes some pathname merging issues,
among other things.
-----------+
asdf.lisp | 345 +++++++++++++++++++++++++++++++++---------------------------
1 file changed, 191 insertions(+), 154 deletions(-)
Index: src/contrib/asdf/asdf.lisp
diff -u src/contrib/asdf/asdf.lisp:1.3 src/contrib/asdf/asdf.lisp:1.4
--- src/contrib/asdf/asdf.lisp:1.3 Thu May 13 13:13:52 2010
+++ src/contrib/asdf/asdf.lisp Tue May 25 16:05:53 2010
@@ -70,7 +70,7 @@
:test 'equalp :key 'car))
(let* ((asdf-version
;; the 1+ helps the version bumping script discriminate
- (subseq "VERSION:1.722" (1+ (length "VERSION"))))
+ (subseq "VERSION:1.728" (1+ (length "VERSION"))))
(existing-asdf (find-package :asdf))
(vername '#:*asdf-version*)
(versym (and existing-asdf
@@ -80,7 +80,7 @@
(unless (and existing-asdf already-there)
#-gcl
(when existing-asdf
- (format *error-output*
+ (format *trace-output*
"~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
existing-version asdf-version))
(labels
@@ -327,6 +327,7 @@
'(defmethod update-instance-for-redefined-class :after
((m module) added deleted plist &key)
(declare (ignorable deleted plist))
+ (format *trace-output* "Updating ~A~%" m)
(when (member 'components-by-name added)
(compute-module-components-by-name m))))))
@@ -455,11 +456,11 @@
(defgeneric traverse (operation component)
(:documentation
-"Generate and return a plan for performing `operation` on `component`.
+"Generate and return a plan for performing OPERATION on COMPONENT.
-The plan returned is a list of dotted-pairs. Each pair is the `cons`
-of ASDF operation object and a `component` object. The pairs will be
-processed in order by `operate`."))
+The plan returned is a list of dotted-pairs. Each pair is the CONS
+of ASDF operation object and a COMPONENT object. The pairs will be
+processed in order by OPERATE."))
;;;; -------------------------------------------------------------------------
@@ -479,10 +480,8 @@
(defun pathname-directory-pathname (pathname)
"Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
and NIL NAME, TYPE and VERSION components"
- (make-pathname :name nil :type nil :version nil :defaults pathname))
-
-(defun current-directory ()
- (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
+ (when pathname
+ (make-pathname :name nil :type nil :version nil :defaults pathname)))
(defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
"MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname
@@ -493,7 +492,7 @@
(let* ((specified (pathname specified))
(defaults (pathname defaults))
(directory (pathname-directory specified))
- (directory (if (stringp directory) `(:absolute ,directory) directory))
+ #-sbcl (directory (if (stringp directory) `(:absolute ,directory) directory))
(name (or (pathname-name specified) (pathname-name defaults)))
(type (or (pathname-type specified) (pathname-type defaults)))
(version (or (pathname-version specified) (pathname-version defaults))))
@@ -516,7 +515,9 @@
((:relative)
(values (pathname-host defaults)
(pathname-device defaults)
- (append (pathname-directory defaults) (cdr directory))
+ (if (pathname-directory defaults)
+ (append (pathname-directory defaults) (cdr directory))
+ directory)
(unspecific-handler defaults)))
#+gcl
(t
@@ -536,13 +537,19 @@
(define-modify-macro orf (&rest args)
or "or a flag")
+(defun first-char (s)
+ (and (stringp s) (plusp (length s)) (char s 0)))
+
+(defun last-char (s)
+ (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
+
(defun asdf-message (format-string &rest format-args)
(declare (dynamic-extent format-args))
(apply #'format *verbose-out* format-string format-args))
(defun split-string (string &key max (separator '(#\Space #\Tab)))
- "Split STRING in components separater by any of the characters in the sequence SEPARATOR,
-return a list.
+ "Split STRING into a list of components separated by
+any of the characters in the sequence SEPARATOR.
If MAX is specified, then no more than max(1,MAX) components will be returned,
starting the separation from the end, e.g. when called with arguments
\"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
@@ -616,10 +623,6 @@
:unless (eq k key)
:append (list k v)))
-(defun resolve-symlinks (path)
- #-allegro (truenamize path)
- #+allegro (excl:pathname-resolve-symbolic-links path))
-
(defun getenv (x)
#+abcl
(ext:getenv x)
@@ -641,13 +644,13 @@
(si:getenv x))
(defun directory-pathname-p (pathname)
- "Does `pathname` represent a directory?
+ "Does PATHNAME represent a directory?
A directory-pathname is a pathname _without_ a filename. The three
-ways that the filename components can be missing are for it to be `nil`,
-`:unspecific` or the empty string.
+ways that the filename components can be missing are for it to be NIL,
+:UNSPECIFIC or the empty string.
-Note that this does _not_ check to see that `pathname` points to an
+Note that this does _not_ check to see that PATHNAME points to an
actually-existing directory."
(flet ((check-one (x)
(member x '(nil :unspecific "") :test 'equal)))
@@ -731,10 +734,8 @@
(directory (pathname-directory p)))
(when (typep p 'logical-pathname) (return p))
(ignore-errors (return (truename p)))
- (when (stringp directory)
- (return p))
- (when (not (eq :absolute (car directory)))
- (return p))
+ #-sbcl (when (stringp directory) (return p))
+ (when (not (eq :absolute (car directory))) (return p))
(let ((sofar (ignore-errors (truename (pathname-root p)))))
(unless sofar (return p))
(flet ((solution (directories)
@@ -758,9 +759,43 @@
:finally
(return (solution nil))))))))
+(defun resolve-symlinks (path)
+ #-allegro (truenamize path)
+ #+allegro (excl:pathname-resolve-symbolic-links path))
+
+(defun default-directory ()
+ (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
+
(defun lispize-pathname (input-file)
(make-pathname :type "lisp" :defaults input-file))
+(defparameter *wild-path*
+ (make-pathname :directory '(:relative :wild-inferiors)
+ :name :wild :type :wild :version :wild))
+
+(defun wilden (path)
+ (merge-pathnames* *wild-path* path))
+
+(defun directorize-pathname-host-device (pathname)
+ (let* ((root (pathname-root pathname))
+ (wild-root (wilden root))
+ (absolute-pathname (merge-pathnames* pathname root))
+ (foo (make-pathname :directory '(:absolute "FOO") :defaults root))
+ (separator (last-char (namestring foo)))
+ (root-namestring (namestring root))
+ (root-string
+ (substitute-if #\/
+ (lambda (x) (or (eql x #\:)
+ (eql x separator)))
+ root-namestring)))
+ (multiple-value-bind (relative path filename)
+ (component-name-to-pathname-components root-string t)
+ (declare (ignore relative filename))
+ (let ((new-base
+ (make-pathname :defaults root
+ :directory `(:absolute , at path))))
+ (translate-pathname absolute-pathname wild-root (wilden new-base))))))
+
;;;; -------------------------------------------------------------------------
;;;; Classes, Conditions
@@ -773,6 +808,15 @@
;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.]
#+cmu (:report print-object))
+(declaim (ftype (function (t) t)
+ format-arguments format-control
+ error-name error-pathname error-condition
+ duplicate-names-name
+ error-component error-operation
+ module-components module-components-by-name)
+ (ftype (function (t t) t) (setf module-components-by-name)))
+
+
(define-condition formatted-system-definition-error (system-definition-error)
((format-control :initarg :format-control :reader format-control)
(format-arguments :initarg :format-arguments :reader format-arguments))
@@ -892,8 +936,8 @@
(defvar *default-component-class* 'cl-source-file)
(defun compute-module-components-by-name (module)
- (let ((hash (module-components-by-name module)))
- (clrhash hash)
+ (let ((hash (make-hash-table :test 'equal)))
+ (setf (module-components-by-name module) hash)
(loop :for c :in (module-components module)
:for name = (component-name c)
:for previous = (gethash name (module-components-by-name module))
@@ -909,7 +953,6 @@
:initarg :components
:accessor module-components)
(components-by-name
- :initform (make-hash-table :test 'equal)
:accessor module-components-by-name)
;; What to do if we can't satisfy a dependency of one of this module's
;; components. This allows a limited form of conditional processing.
@@ -937,7 +980,7 @@
(let ((pathname
(merge-pathnames*
(component-relative-pathname component)
- (component-parent-pathname component))))
+ (pathname-directory-pathname (component-parent-pathname component)))))
(unless (or (null pathname) (absolute-pathname-p pathname))
(error "Invalid relative pathname ~S for component ~S" pathname component))
(setf (slot-value component 'absolute-pathname) pathname)
@@ -1011,9 +1054,9 @@
(gethash (coerce-name name) *defined-systems*))
(defun map-systems (fn)
- "Apply `fn` to each defined system.
+ "Apply FN to each defined system.
-`fn` should be a function of one argument. It will be
+FN should be a function of one argument. It will be
called with an object of type asdf:system."
(maphash (lambda (_ datum)
(declare (ignore _))
@@ -1026,7 +1069,15 @@
;;; convention that functions in this list are prefixed SYSDEF-
(defparameter *system-definition-search-functions*
- '(sysdef-central-registry-search sysdef-source-registry-search))
+ '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf))
+
+(defun sysdef-find-asdf (system)
+ (let ((name (coerce-name system)))
+ (when (equal name "asdf")
+ (eval
+ `(defsystem :asdf
+ :pathname ,(or *compile-file-truename* *load-truename*)
+ :depends-on () :components ())))))
(defun system-definition-pathname (system)
(let ((system-name (coerce-name system)))
@@ -1052,6 +1103,27 @@
Going forward, we recommend new users should be using the source-registry.
")
+(defun probe-asd (name defaults)
+ (block nil
+ (when (directory-pathname-p defaults)
+ (let ((file
+ (make-pathname
+ :defaults defaults :version :newest :case :local
+ :name name
+ :type "asd")))
+ (when (probe-file file)
+ (return file)))
+ #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
+ (let ((shortcut
+ (make-pathname
+ :defaults defaults :version :newest :case :local
+ :name (concatenate 'string name ".asd")
+ :type "lnk")))
+ (when (probe-file shortcut)
+ (let ((target (parse-windows-shortcut shortcut)))
+ (when target
+ (return (pathname target)))))))))
+
(defun sysdef-central-registry-search (system)
(let ((name (coerce-name system))
(to-remove nil)
@@ -1070,8 +1142,8 @@
(let* ((*print-circle* nil)
(message
(format nil
- "~@<While searching for system `~a`: `~a` evaluated ~
-to `~a` which is not a directory.~@:>"
+ "~@<While searching for system ~S: ~S evaluated ~
+to ~S which is not a directory.~@:>"
system dir defaults)))
(error message))
(remove-entry-from-registry ()
@@ -1169,8 +1241,9 @@
(find-component (car base) (cons (cdr base) path)))
(defmethod find-component ((module module) (name string))
- (when (slot-boundp module 'components-by-name)
- (values (gethash name (module-components-by-name module)))))
+ (unless (slot-boundp module 'components-by-name) ;; SBCL may miss the u-i-f-r-c method!!!
+ (compute-module-components-by-name module))
+ (values (gethash name (module-components-by-name module))))
(defmethod find-component ((component component) (name symbol))
(if name
@@ -1600,19 +1673,6 @@
(visit-component operation c flag)
flag))
-(defmethod traverse ((operation operation) (c component))
- ;; cerror'ing a feature that seems to have NEVER EVER worked
- ;; ever since danb created it in his 2003-03-16 commit e0d02781.
- ;; It was both fixed and disabled in the 1.700 rewrite.
- (when (consp (operation-forced operation))
- (cerror "Continue nonetheless."
- "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.")
- (setf (operation-forced operation)
- (mapcar #'coerce-name (operation-forced operation))))
- (flatten-tree
- (while-collecting (collect)
- (do-traverse operation c #'collect))))
-
(defun flatten-tree (l)
;; You collected things into a list.
;; Most elements are just things to collect again.
@@ -1629,6 +1689,19 @@
(dolist (x l) (r x))))
(r* l))))
+(defmethod traverse ((operation operation) (c component))
+ ;; cerror'ing a feature that seems to have NEVER EVER worked
+ ;; ever since danb created it in his 2003-03-16 commit e0d02781.
+ ;; It was both fixed and disabled in the 1.700 rewrite.
+ (when (consp (operation-forced operation))
+ (cerror "Continue nonetheless."
+ "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.")
+ (setf (operation-forced operation)
+ (mapcar #'coerce-name (operation-forced operation))))
+ (flatten-tree
+ (while-collecting (collect)
+ (do-traverse operation c #'collect))))
+
(defmethod perform ((operation operation) (c source-file))
(sysdef-error
"~@<required method PERFORM not implemented ~
@@ -1901,15 +1974,15 @@
(let ((operate-docstring
"Operate does three things:
-1. It creates an instance of `operation-class` using any keyword parameters
+1. It creates an instance of OPERATION-CLASS using any keyword parameters
as initargs.
-2. It finds the asdf-system specified by `system` (possibly loading
+2. It finds the asdf-system specified by SYSTEM (possibly loading
it from disk).
-3. It then calls `traverse` with the operation and system as arguments
+3. It then calls TRAVERSE with the operation and system as arguments
-The traverse operation is wrapped in `with-compilation-unit` and error
-handling code. If a `version` argument is supplied, then operate also
-ensures that the system found satisfies it using the `version-satisfies`
+The traverse operation is wrapped in WITH-COMPILATION-UNIT and error
+handling code. If a VERSION argument is supplied, then operate also
+ensures that the system found satisfies it using the VERSION-SATISFIES
method.
Note that dependencies may cause the operation to invoke other
@@ -1958,12 +2031,12 @@
;; the pathname of a system as follows:
;; 1. the one supplied,
;; 2. derived from *load-pathname* via load-pathname
- ;; 3. taken from the *default-pathname-defaults* via current-directory
+ ;; 3. taken from the *default-pathname-defaults* via default-directory
(let* ((file-pathname (load-pathname))
(directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
(or (and pathname-supplied-p (merge-pathnames* pathname directory-pathname))
file-pathname
- (current-directory))))
+ (default-directory))))
(defmacro defsystem (name &body options)
(destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
@@ -2173,9 +2246,9 @@
;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01
(defun run-shell-command (control-string &rest args)
- "Interpolate `args` into `control-string` as if by `format`, and
+ "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
synchronously execute the result using a Bourne-compatible shell, with
-output to `*verbose-out*`. Returns the shell's exit code."
+output to *VERBOSE-OUT*. Returns the shell's exit code."
(let ((command (apply #'format nil control-string args)))
(asdf-message "; $ ~A~%" command)
@@ -2511,16 +2584,38 @@
(setf *output-translations* '())
(values))
-(defparameter *wild-path*
- (make-pathname :directory '(:relative :wild-inferiors)
- :name :wild :type :wild :version :wild))
-
(defparameter *wild-asd*
(make-pathname :directory '(:relative :wild-inferiors)
:name :wild :type "asd" :version :newest))
-(defun wilden (path)
- (merge-pathnames* *wild-path* path))
+
+(declaim (ftype (function (t &optional boolean) (or null pathname))
+ resolve-location))
+
+(defun resolve-relative-location-component (super x &optional wildenp)
+ (let* ((r (etypecase x
+ (pathname x)
+ (string x)
+ (cons
+ (let ((car (resolve-relative-location-component super (car x) nil)))
+ (if (null (cdr x))
+ car
+ (let ((cdr (resolve-relative-location-component
+ (merge-pathnames* car super) (cdr x) wildenp)))
+ (merge-pathnames* cdr car)))))
+ ((eql :default-directory)
+ (relativize-pathname-directory (default-directory)))
+ ((eql :implementation) (implementation-identifier))
+ ((eql :implementation-type) (string-downcase (implementation-type)))
+ #-(and (or win32 windows mswindows mingw32) (not cygwin))
+ ((eql :uid) (princ-to-string (get-uid)))))
+ (d (if (pathnamep x) r (ensure-directory-pathname r)))
+ (s (if (and wildenp (not (pathnamep x)))
+ (wilden d)
+ d)))
+ (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
+ (error "pathname ~S is not relative to ~S" s super))
+ (merge-pathnames* s super)))
(defun resolve-absolute-location-component (x wildenp)
(let* ((r
@@ -2542,7 +2637,7 @@
((eql :home) (user-homedir))
((eql :user-cache) (resolve-location *user-cache* nil))
((eql :system-cache) (resolve-location *system-cache* nil))
- ((eql :current-directory) (current-directory))))
+ ((eql :default-directory) (default-directory))))
(s (if (and wildenp (not (pathnamep x)))
(wilden r)
r)))
@@ -2550,31 +2645,6 @@
(error "Not an absolute pathname ~S" s))
s))
-(defun resolve-relative-location-component (super x &optional wildenp)
- (let* ((r (etypecase x
- (pathname x)
- (string x)
- (cons
- (let ((car (resolve-relative-location-component super (car x) nil)))
- (if (null (cdr x))
- car
- (let ((cdr (resolve-relative-location-component
- (merge-pathnames* car super) (cdr x) wildenp)))
- (merge-pathnames* cdr car)))))
- ((eql :current-directory)
- (relativize-pathname-directory (current-directory)))
- ((eql :implementation) (implementation-identifier))
- ((eql :implementation-type) (string-downcase (implementation-type)))
- #-(and (or win32 windows mswindows mingw32) (not cygwin))
- ((eql :uid) (princ-to-string (get-uid)))))
- (d (if (pathnamep x) r (ensure-directory-pathname r)))
- (s (if (and wildenp (not (pathnamep x)))
- (wilden d)
- d)))
- (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
- (error "pathname ~S is not relative to ~S" s super))
- (merge-pathnames* s super)))
-
(defun resolve-location (x &optional wildenp)
(if (atom x)
(resolve-absolute-location-component x wildenp)
@@ -2705,6 +2775,11 @@
(getenv "ASDF_OUTPUT_TRANSLATIONS"))
(defgeneric process-output-translations (spec &key inherit collect))
+(declaim (ftype (function (t &key (:collect (or symbol function))) t)
+ inherit-output-translations))
+(declaim (ftype (function (t &key (:collect (or symbol function)) (:inherit list)) t)
+ process-output-translations-directive))
+
(defmethod process-output-translations ((x symbol) &key
(inherit *default-output-translations*)
collect)
@@ -2832,32 +2907,6 @@
(translate-pathname p absolute-source destination)))
:finally (return p)))))
-(defun first-char (s)
- (and (stringp s) (plusp (length s)) (char s 0)))
-
-(defun last-char (s)
- (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
-
-(defun directorize-pathname-host-device (pathname)
- (let* ((root (pathname-root pathname))
- (wild-root (wilden root))
- (absolute-pathname (merge-pathnames* pathname root))
- (foo (make-pathname :directory '(:absolute "FOO") :defaults root))
- (separator (last-char (namestring foo)))
- (root-namestring (namestring root))
- (root-string
- (substitute-if #\/
- (lambda (x) (or (eql x #\:)
- (eql x separator)))
- root-namestring)))
- (multiple-value-bind (relative path filename)
- (component-name-to-pathname-components root-string t)
- (declare (ignore relative filename))
- (let ((new-base
- (make-pathname :defaults root
- :directory `(:absolute , at path))))
- (translate-pathname absolute-pathname wild-root (wilden new-base))))))
-
(defmethod output-files :around (operation component)
"Translate output files, unless asked not to"
(declare (ignorable operation component))
@@ -3000,11 +3049,13 @@
;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
;; Using ack 1.2 exclusions
-(defvar *default-exclusions*
+(defvar *default-source-registry-exclusions*
'(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst"
".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
"_sgbak" "autom4te.cache" "cover_db" "_build"))
+(defvar *source-registry-exclusions* *default-source-registry-exclusions*)
+
(defvar *source-registry* ()
"Either NIL (for uninitialized), or a list of one element,
said element itself being a list of directory pathnames where to look for .asd files")
@@ -3026,34 +3077,6 @@
(setf *source-registry* '())
(values))
-(defun probe-asd (name defaults)
- (block nil
- (when (directory-pathname-p defaults)
- (let ((file
- (make-pathname
- :defaults defaults :version :newest :case :local
- :name name
- :type "asd")))
- (when (probe-file file)
- (return file)))
- #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
- (let ((shortcut
- (make-pathname
- :defaults defaults :version :newest :case :local
- :name (concatenate 'string name ".asd")
- :type "lnk")))
- (when (probe-file shortcut)
- (let ((target (parse-windows-shortcut shortcut)))
- (when target
- (return (pathname target)))))))))
-
-(defun sysdef-source-registry-search (system)
- (ensure-source-registry)
- (loop :with name = (coerce-name system)
- :for defaults :in (source-registry)
- :for file = (probe-asd name defaults)
- :when file :return file))
-
(defun validate-source-registry-directive (directive)
(unless
(or (member directive '(:default-registry (:default-registry)) :test 'equal)
@@ -3062,7 +3085,7 @@
((:include :directory :tree)
(and (length=n-p rest 1)
(typep (car rest) '(or pathname string null))))
- ((:exclude)
+ ((:exclude :also-exclude)
(every #'stringp rest))
(null rest))))
(error "Invalid directive ~S~%" directive))
@@ -3188,6 +3211,11 @@
(getenv "CL_SOURCE_REGISTRY"))
(defgeneric process-source-registry (spec &key inherit register))
+(declaim (ftype (function (t &key (:register (or symbol function))) t)
+ inherit-source-registry))
+(declaim (ftype (function (t &key (:register (or symbol function)) (:inherit list)) t)
+ process-source-registry-directive))
+
(defmethod process-source-registry ((x symbol) &key inherit register)
(process-source-registry (funcall x) :inherit inherit :register register))
(defmethod process-source-registry ((pathname pathname) &key inherit register)
@@ -3207,7 +3235,7 @@
(declare (ignorable x))
(inherit-source-registry inherit :register register))
(defmethod process-source-registry ((form cons) &key inherit register)
- (let ((*default-exclusions* *default-exclusions*))
+ (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
(dolist (directive (cdr (validate-source-registry-form form)))
(process-source-registry-directive directive :inherit inherit :register register))))
@@ -3228,15 +3256,18 @@
((:tree)
(destructuring-bind (pathname) rest
(when pathname
- (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *default-exclusions*))))
+ (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *source-registry-exclusions*))))
((:exclude)
- (setf *default-exclusions* rest))
+ (setf *source-registry-exclusions* rest))
+ ((:also-exclude)
+ (appendf *source-registry-exclusions* rest))
((:default-registry)
(inherit-source-registry '(default-source-registry) :register register))
((:inherit-configuration)
(inherit-source-registry inherit :register register))
((:ignore-inherited-configuration)
- nil))))
+ nil)))
+ nil)
(defun flatten-source-registry (&optional parameter)
(remove-duplicates
@@ -3271,6 +3302,13 @@
(source-registry)
(initialize-source-registry)))
+(defun sysdef-source-registry-search (system)
+ (ensure-source-registry)
+ (loop :with name = (coerce-name system)
+ :for defaults :in (source-registry)
+ :for file = (probe-asd name defaults)
+ :when file :return file))
+
;;;; -----------------------------------------------------------------
;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL
;;;;
@@ -3323,8 +3361,7 @@
(setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*)))
(pushnew :asdf *features*)
-;; this is a release candidate for ASDF 2.0
-(pushnew :asdf2 *features*)
+(pushnew :asdf2 *features*) ;; this is a release candidate for ASDF 2.0
(provide :asdf)
More information about the cmucl-commit
mailing list