[Openmcl-cvs-notifications] r13768 - /trunk/source/tools/asdf.lisp
rme at clozure.com
rme at clozure.com
Tue Jun 1 20:12:11 UTC 2010
Author: rme
Date: Tue Jun 1 14:12:11 2010
New Revision: 13768
Log:
Import ASDF 2.000 release from upstream.
Modified:
trunk/source/tools/asdf.lisp
Modified: trunk/source/tools/asdf.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/tools/asdf.lisp (original)
+++ trunk/source/tools/asdf.lisp Tue Jun 1 14:12:11 2010
@@ -49,6 +49,9 @@
=
(cl:in-package :cl-user)
=
+#|(declaim (optimize (speed 2) (debug 2) (safety 3))
+#+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))|#
+
#+ecl (require :cmp)
=
;;;; Create packages in a way that is compatible with hot-upgrade.
@@ -67,7 +70,7 @@
:test 'equalp :key 'car))
(let* ((asdf-version
;; the 1+ helps the version bumping script discriminate
- (subseq "VERSION:1.719" (1+ (length "VERSION"))))
+ (subseq "VERSION:2.000" (1+ (length "VERSION"))))
(existing-asdf (find-package :asdf))
(vername '#:*asdf-version*)
(versym (and existing-asdf
@@ -77,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
@@ -324,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))))))
=
@@ -333,7 +337,7 @@
(defun asdf-version ()
"Exported interface to the version of ASDF currently installed. A string.
You can compare this string with e.g.:
-(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"1.704\")."
+(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.000\")."
*asdf-version*)
=
(defvar *resolve-symlinks* t
@@ -452,11 +456,11 @@
=
(defgeneric traverse (operation component)
(:documentation
-"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`."))
+"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."))
=
=
;;;; ---------------------------------------------------------------------=
----
@@ -476,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-d=
efaults*))
"MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED p=
athname
@@ -490,7 +492,7 @@
(let* ((specified (pathname specified))
(defaults (pathname defaults))
(directory (pathname-directory specified))
- (directory (if (stringp directory) `(:absolute ,directory) direct=
ory))
+ #-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 defau=
lts))))
@@ -513,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 direct=
ory))
+ directory)
(unspecific-handler defaults)))
#+gcl
(t
@@ -533,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 se=
quence 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 retur=
ned,
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=
\")."
@@ -590,7 +600,7 @@
(last-comp (car (last components))))
(multiple-value-bind (relative components)
(if (equal (first components) "")
- (if (and (plusp (length s)) (eql (char s 0) #\/))
+ (if (equal (first-char s) #\/)
(values :absolute (cdr components))
(values :relative nil))
(values :relative components))
@@ -613,17 +623,13 @@
: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)
#+sbcl
(sb-ext:posix-getenv x)
#+clozure
- (ccl::getenv x)
+ (ccl:getenv x)
#+clisp
(ext:getenv x)
#+cmu
@@ -638,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.
-
-Note that this does _not_ check to see that `pathname` points to an
+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
actually-existing directory."
(flet ((check-one (x)
(member x '(nil :unspecific "") :test 'equal)))
@@ -728,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)
@@ -755,8 +759,42 @@
: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
@@ -769,6 +807,15 @@
;; run-time. fortunately, inheritance means we only need this kludge he=
re in
;; 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-err=
or)
((format-control :initarg :format-control :reader format-control)
@@ -889,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 =3D (component-name c)
:for previous =3D (gethash name (module-components-by-name module))
@@ -906,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.
@@ -934,7 +980,7 @@
(let ((pathname
(merge-pathnames*
(component-relative-pathname component)
- (component-parent-pathname component))))
+ (pathname-directory-pathname (component-parent-pathname compo=
nent)))))
(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)
@@ -1008,9 +1054,9 @@
(gethash (coerce-name name) *defined-systems*))
=
(defun map-systems (fn)
- "Apply `fn` to each defined system.
-
-`fn` should be a function of one argument. It will be
+ "Apply FN to each defined system.
+
+FN should be a function of one argument. It will be
called with an object of type asdf:system."
(maphash (lambda (_ datum)
(declare (ignore _))
@@ -1023,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-fi=
nd-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)))
@@ -1048,6 +1102,27 @@
This is for backward compatibilily.
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))
@@ -1067,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 ()
@@ -1166,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
@@ -1597,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 (li=
st 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.
@@ -1625,6 +1688,19 @@
(r* (l)
(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 (li=
st 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
@@ -1898,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
-
-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`
+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
method.
=
Note that dependencies may cause the operation to invoke other
@@ -1944,26 +2020,23 @@
;;;; ---------------------------------------------------------------------=
----
;;;; Defsystem
=
+(defun load-pathname ()
+ (let ((pn (or *load-pathname* *compile-file-pathname*)))
+ (if *resolve-symlinks*
+ (and pn (resolve-symlinks pn))
+ pn)))
+
(defun determine-system-pathname (pathname pathname-supplied-p)
- ;; called from the defsystem macro.
- ;; the pathname of a system is either
+ ;; The defsystem macro calls us to determine
+ ;; the pathname of a system as follows:
;; 1. the one supplied,
- ;; 2. derived from the *load-truename* (see below), or
- ;; 3. taken from *default-pathname-defaults*
- ;;
- ;; if using *load-truename*, then we also deal with whether or not
- ;; to resolve symbolic links. If not resolving symlinks, then we use
- ;; *load-pathname* instead of *load-truename* since in some
- ;; implementations, the latter has *already resolved it.
- (let ((file-pathname
- (when (or *load-pathname* *compile-file-pathname*)
- (pathname-directory-pathname
- (if *resolve-symlinks*
- (resolve-symlinks (or *load-truename* *compile-file-truena=
me*))
- *load-pathname*)))))
- (or (and pathname-supplied-p (merge-pathnames* pathname file-pathname))
+ ;; 2. derived from *load-pathname* via load-pathname
+ ;; 3. taken from the *default-pathname-defaults* via default-directory
+ (let* ((file-pathname (load-pathname))
+ (directory-pathname (and file-pathname (pathname-directory-pathna=
me file-pathname))))
+ (or (and pathname-supplied-p (merge-pathnames* pathname directory-path=
name))
file-pathname
- (current-directory))))
+ (default-directory))))
=
(defmacro defsystem (name &body options)
(destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
@@ -1984,7 +2057,7 @@
(t
(register-system (quote ,name)
(make-instance ',class :name ',name))))
- (%set-system-source-file *load-truename*
+ (%set-system-source-file (load-pathname)
(cdr (system-registered-p ',name))))
(parse-component-form
nil (list*
@@ -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)
=
@@ -2446,10 +2519,15 @@
(error "One and only one form allowed for ~A. Got: ~S~%" description=
forms))
(funcall validator (car forms))))
=
+(defun hidden-file-p (pathname)
+ (equal (first-char (pathname-name pathname)) #\.))
+
(defun validate-configuration-directory (directory tag validator)
(let ((files (sort (ignore-errors
- (directory (make-pathname :name :wild :type :wild :=
defaults directory)
- #+sbcl :resolve-symlinks #+sbcl nil))
+ (remove-if
+ 'hidden-file-p
+ (directory (make-pathname :name :wild :type "conf"=
:defaults directory)
+ #+sbcl :resolve-symlinks #+sbcl nil)))
#'string< :key #'namestring)))
`(,tag
,@(loop :for file :in files :append
@@ -2506,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) wild=
enp)))
+ (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 su=
per))))
+ (error "pathname ~S is not relative to ~S" s super))
+ (merge-pathnames* s super)))
=
(defun resolve-absolute-location-component (x wildenp)
(let* ((r
@@ -2537,37 +2637,13 @@
((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)))
(unless (absolute-pathname-p s)
(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) wild=
enp)))
- (merge-pathnames* cdr car)))))
- ((eql :current-directory)
- (relativize-pathname-directory (current-directory)))
- ((eql :implementation) (implementation-identifier))
- ((eql :implementation-type) (string-downcase (implementation=
-type)))
- ((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 su=
per))))
- (error "pathname ~S is not relative to ~S" s super))
- (merge-pathnames* s super)))
=
(defun resolve-location (x &optional wildenp)
(if (atom x)
@@ -2674,8 +2750,8 @@
;; Some implementations have precompiled ASDF systems,
;; so we must disable translations for implementation paths.
#+sbcl (,(getenv "SBCL_HOME") ())
- #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; only needed if=
LPNs are resolved manually.
- #+clozure (,(wilden (ccl::ccl-directory)) ()) ; not needed: no precomp=
iled ASDF system
+ #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no=
precompiled ASDF system
+ #+clozure (,(wilden (truename #p"ccl:")) ()) ; not needed: no precompi=
led ASDF system
;; All-import, here is where we want user stuff to be:
:inherit-configuration
;; These are for convenience, and can be overridden by the user:
@@ -2699,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)) (:inheri=
t list)) t)
+ process-output-translations-directive))
+
(defmethod process-output-translations ((x symbol) &key
(inherit *default-output-translati=
ons*)
collect)
@@ -2826,29 +2907,6 @@
(translate-pathname p absolute-source destination)))
:finally (return p)))))
=
-(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))
@@ -2991,10 +3049,12 @@
;;;; 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,
@@ -3016,34 +3076,6 @@
with a different configuration, so the configuration would be re-read then=
."
(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 =3D (coerce-name system)
- :for defaults :in (source-registry)
- :for file =3D (probe-asd name defaults)
- :when file :return file))
=
(defun validate-source-registry-directive (directive)
(unless
@@ -3053,7 +3085,7 @@
((:include :directory :tree)
(and (length=3Dn-p rest 1)
(typep (car rest) '(or pathname string null))))
- ((:exclude)
+ ((:exclude :also-exclude)
(every #'stringp rest))
(null rest))))
(error "Invalid directive ~S~%" directive))
@@ -3139,7 +3171,8 @@
(defun wrapping-source-registry ()
`(:source-registry
#+sbcl (:tree ,(getenv "SBCL_HOME"))
- :inherit-configuration))
+ :inherit-configuration
+ #+cmu (:tree #p"modules:")))
(defun default-source-registry ()
(flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
`(:source-registry
@@ -3178,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)) (:inher=
it 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 regis=
ter)
@@ -3197,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 :regis=
ter register))))
=
@@ -3218,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 regis=
ter))
((:inherit-configuration)
(inherit-source-registry inherit :register register))
((:ignore-inherited-configuration)
- nil))))
+ nil)))
+ nil)
=
(defun flatten-source-registry (&optional parameter)
(remove-duplicates
@@ -3261,6 +3302,13 @@
(source-registry)
(initialize-source-registry)))
=
+(defun sysdef-source-registry-search (system)
+ (ensure-source-registry)
+ (loop :with name =3D (coerce-name system)
+ :for defaults :in (source-registry)
+ :for file =3D (probe-asd name defaults)
+ :when file :return file))
+
;;;; -----------------------------------------------------------------
;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL
;;;;
@@ -3271,16 +3319,16 @@
((style-warning #'muffle-warning)
(missing-component (constantly nil))
(error (lambda (e)
- (format *error-output* "ASDF could not load ~A because ~=
A.~%"
+ (format *error-output* "ASDF could not load ~(~A~) becau=
se ~A.~%"
name e))))
(let* ((*verbose-out* (make-broadcast-stream))
- (system (find-system name nil)))
+ (system (find-system (string-downcase name) nil)))
(when system
- (load-system name)
+ (load-system system)
t))))
(pushnew 'module-provide-asdf
#+abcl sys::*module-provider-functions*
- #+clozure ccl::*module-provider-functions*
+ #+clozure ccl:*module-provider-functions*
#+cmu ext:*module-provider-functions*
#+ecl si:*module-provider-functions*
#+sbcl sb-ext:*module-provider-functions*))
@@ -3313,7 +3361,6 @@
(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*)
=
(provide :asdf)
More information about the Openmcl-cvs-notifications
mailing list