Date: Thursday, November 4, 2010 @ 10:04:11 Author: rtoy Path: /project/cmucl/cvsroot/src/contrib/asdf
Modified: asdf.lisp
Update to 2.010.
-----------+ asdf.lisp | 232 +++++++++++++++++++++++++++++++++++++++--------------------- 1 file changed, 152 insertions(+), 80 deletions(-)
Index: src/contrib/asdf/asdf.lisp diff -u src/contrib/asdf/asdf.lisp:1.9 src/contrib/asdf/asdf.lisp:1.10 --- src/contrib/asdf/asdf.lisp:1.9 Wed Oct 6 19:26:55 2010 +++ src/contrib/asdf/asdf.lisp Thu Nov 4 10:04:10 2010 @@ -71,14 +71,13 @@ (eval-when (:load-toplevel :compile-toplevel :execute) (defvar *asdf-version* nil) (defvar *upgraded-p* nil) - (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate - (subseq "VERSION:2.009" (1+ (length "VERSION")))) ; same as 2.134 + (let* ((asdf-version "2.010") ;; same as 2.146 (existing-asdf (fboundp 'find-system)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) (unless (and existing-asdf already-there) (when existing-asdf - (format *trace-output* + (format *error-output* "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%" existing-version asdf-version)) (labels @@ -170,9 +169,9 @@ :shadow ',shadow :unintern ',(append #-(or gcl ecl) redefined-functions unintern) :fmakunbound ',(append fmakunbound)))) - (unlink-package :asdf-utilities) (pkgdcl :asdf + :nicknames (:asdf-utilities) ;; DEPRECATED! Do not use, for backward compatibility only. :use (:common-lisp) :redefined-functions (#:perform #:explain #:output-files #:operation-done-p @@ -305,6 +304,7 @@ #:split-string #:component-name-to-pathname-components #:split-name-type + #:subdirectories #:truenamize #:while-collecting))) (setf *asdf-version* asdf-version @@ -533,7 +533,18 @@ (let* ((specified (pathname specified)) (defaults (pathname defaults)) (directory (pathname-directory specified)) - #-(or sbcl cmu) (directory (if (stringp directory) `(:absolute ,directory) directory)) + (directory + (cond + #-(or sbcl cmu) + ((stringp directory) `(:absolute ,directory) directory) + #+gcl + ((and (consp directory) (stringp (first directory))) + `(:absolute ,@directory)) + ((or (null directory) + (and (consp directory) (member (first directory) '(:absolute :relative)))) + directory) + (t + (error "Unrecognized directory component ~S in pathname ~S" directory specified)))) (name (or (pathname-name specified) (pathname-name defaults))) (type (or (pathname-type specified) (pathname-type defaults))) (version (or (pathname-version specified) (pathname-version defaults)))) @@ -542,7 +553,7 @@ (unspecific-handler (p) (if (typep p 'logical-pathname) #'ununspecific #'identity))) (multiple-value-bind (host device directory unspecific-handler) - (#-gcl ecase #+gcl case (first directory) + (ecase (first directory) ((nil) (values (pathname-host defaults) (pathname-device defaults) @@ -559,13 +570,6 @@ (if (pathname-directory defaults) (append (pathname-directory defaults) (cdr directory)) directory) - (unspecific-handler defaults))) - #+gcl - (t - (assert (stringp (first directory))) - (values (pathname-host defaults) - (pathname-device defaults) - (append (pathname-directory defaults) directory) (unspecific-handler defaults)))) (make-pathname :host host :device device :directory directory :name (funcall unspecific-handler name) @@ -620,7 +624,7 @@ (values filename unspecific) (values name type)))))
-(defun* component-name-to-pathname-components (s &optional force-directory) +(defun* component-name-to-pathname-components (s &key force-directory force-relative) "Splits the path string S, returning three values: A flag that is either :absolute or :relative, indicating how the rest of the values are to be interpreted. @@ -637,12 +641,17 @@ e.g., (:file "foo/bar"), which will be unpacked to relative pathnames." (check-type s string) + (when (find #: s) + (error "a portable ASDF pathname designator cannot include a #: character: ~S" s)) (let* ((components (split-string s :separator "/")) (last-comp (car (last components)))) (multiple-value-bind (relative components) (if (equal (first components) "") (if (equal (first-char s) #/) - (values :absolute (cdr components)) + (progn + (when force-relative + (error "absolute pathname designator not allowed: ~S" s)) + (values :absolute (cdr components))) (values :relative nil)) (values :relative components)) (setf components (remove "" components :test #'equal)) @@ -686,11 +695,14 @@
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))) - (and (check-one (pathname-name pathname)) - (check-one (pathname-type pathname)) - t))) + (when pathname + (let ((pathname (pathname pathname))) + (flet ((check-one (x) + (member x '(nil :unspecific "") :test 'equal))) + (and (not (wild-pathname-p pathname)) + (check-one (pathname-name pathname)) + (check-one (pathname-type pathname)) + t)))))
(defun* ensure-directory-pathname (pathspec) "Converts the non-wild pathname designator PATHSPEC to directory form." @@ -700,7 +712,7 @@ ((not (pathnamep pathspec)) (error "Invalid pathname designator ~S" pathspec)) ((wild-pathname-p pathspec) - (error "Can't reliably convert wild pathnames.")) + (error "Can't reliably convert wild pathname ~S" pathspec)) ((directory-pathname-p pathspec) pathspec) (t @@ -773,7 +785,7 @@ (string (probe-file* (parse-namestring p))) (pathname (unless (wild-pathname-p p) #.(or #+(or allegro clozure cmu ecl sbcl scl) '(probe-file p) - #+clisp (aif (find-symbol (string :probe-pathname) :ext) `(,it p)) + #+clisp (aif (find-symbol (string :probe-pathname) :ext) `(ignore-errors (,it p))) '(ignore-errors (truename p)))))))
(defun* truenamize (p) @@ -839,7 +851,7 @@ (eql x separator))) root-namestring))) (multiple-value-bind (relative path filename) - (component-name-to-pathname-components root-string t) + (component-name-to-pathname-components root-string :force-directory t) (declare (ignore relative filename)) (let ((new-base (make-pathname :defaults root @@ -921,13 +933,29 @@ ((name :accessor component-name :initarg :name :documentation "Component name: designator for a string composed of portable pathname characters") (version :accessor component-version :initarg :version) - (in-order-to :initform nil :initarg :in-order-to - :accessor component-in-order-to) ;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to? ;; POIU is a parallel (multi-process build) extension of ASDF. See ;; http://www.cliki.net/poiu (load-dependencies :accessor component-load-dependencies :initform nil) - ;; XXX crap name, but it's an official API name! + ;; In the ASDF object model, dependencies exist between *actions* + ;; (an action is a pair of operation and component). They are represented + ;; alists of operations to dependencies (other actions) in each component. + ;; There are two kinds of dependencies, each stored in its own slot: + ;; in-order-to and do-first dependencies. These two kinds are related to + ;; the fact that some actions modify the filesystem, + ;; whereas other actions modify the current image, and + ;; this implies a difference in how to interpret timestamps. + ;; in-order-to dependencies will trigger re-performing the action + ;; when the timestamp of some dependency + ;; makes the timestamp of current action out-of-date; + ;; do-first dependencies do not trigger such re-performing. + ;; Therefore, a FASL must be recompiled if it is obsoleted + ;; by any of its FASL dependencies (in-order-to); but + ;; it needn't be recompiled just because one of these dependencies + ;; hasn't yet been loaded in the current image (do-first). + ;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52! + (in-order-to :initform nil :initarg :in-order-to + :accessor component-in-order-to) (do-first :initform nil :initarg :do-first :accessor component-do-first) ;; methods defined using the "inline" style inside a defsystem form: @@ -1060,7 +1088,8 @@ (licence :accessor system-licence :initarg :licence :accessor system-license :initarg :license) (source-file :reader system-source-file :initarg :source-file - :writer %set-system-source-file))) + :writer %set-system-source-file) + (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
;;;; ------------------------------------------------------------------------- ;;;; version-satisfies @@ -1284,22 +1313,21 @@ (setf (gethash (coerce-name name) *defined-systems*) (cons (get-universal-time) system)))
-(defun* find-system-fallback (requested fallback &optional source-file) +(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys) (setf fallback (coerce-name fallback) source-file (or source-file *compile-file-truename* *load-truename*) requested (coerce-name requested)) (when (equal requested fallback) (let* ((registered (cdr (gethash fallback *defined-systems*))) (system (or registered - (make-instance - 'system :name fallback - :source-file source-file)))) + (apply 'make-instance 'system + :name fallback :source-file source-file keys)))) (unless registered (register-system fallback system)) (throw 'find-system system))))
(defun* sysdef-find-asdf (name) - (find-system-fallback name "asdf")) + (find-system-fallback name "asdf")) ;; :version *asdf-version* wouldn't be updated when ASDF is updated.
;;;; ------------------------------------------------------------------------- @@ -1370,7 +1398,8 @@ (merge-component-name-type (string-downcase name) :type type :defaults defaults)) (string (multiple-value-bind (relative path filename) - (component-name-to-pathname-components name (eq type :directory)) + (component-name-to-pathname-components name :force-directory (eq type :directory) + :force-relative t) (multiple-value-bind (name type) (cond ((or (eq type :directory) (null filename)) @@ -1600,8 +1629,8 @@ (do-traverse op dep-c collect)))
(defun* do-one-dep (operation c collect required-op required-c required-v) - ;; this function is a thin, error-handling wrapper around - ;; %do-one-dep. Returns a partial plan per that function. + ;; this function is a thin, error-handling wrapper around %do-one-dep. + ;; Collects a partial plan per that function. (loop (restart-case (return (%do-one-dep operation c collect @@ -1612,13 +1641,6 @@ (component-find-path required-c))) :test (lambda (c) - #| - (print (list :c1 c (typep c 'missing-dependency))) - (when (typep c 'missing-dependency) - (print (list :c2 (missing-requires c) required-c - (equalp (missing-requires c) - required-c)))) - |# (or (null c) (and (typep c 'missing-dependency) (equalp (missing-requires c) @@ -1832,7 +1854,8 @@ (setf (gethash (type-of operation) (component-operation-times c)) (get-universal-time)))
-(declaim (ftype (function ((or pathname string) &rest t &key &allow-other-keys) +(declaim (ftype (function ((or pathname string) + &rest t &key (:output-file t) &allow-other-keys) (values t t t)) compile-file*))
@@ -2152,7 +2175,7 @@ (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system) defsystem-depends-on &allow-other-keys) options - (let ((component-options (remove-keys '(:defsystem-depends-on :class) options))) + (let ((component-options (remove-keys '(:class) options))) `(progn ;; system must be registered before we parse the body, otherwise ;; we recur when trying to find an existing system of the same name @@ -2457,23 +2480,33 @@ ;;; Initially stolen from SLIME's SWANK, hacked since.
(defparameter *implementation-features* - '(:allegro :lispworks :sbcl :clozure :digitool :cmu :clisp - :corman :cormanlisp :armedbear :gcl :ecl :scl)) + '((:acl :allegro) + (:lw :lispworks) + (:digitool) ; before clozure, so it won't get preempted by ccl + (:ccl :clozure) + (:corman :cormanlisp) + (:abcl :armedbear) + :sbcl :cmu :clisp :gcl :ecl :scl))
(defparameter *os-features* - '((:windows :mswindows :win32 :mingw32) + '((:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows (:solaris :sunos) - :linux ;; for GCL at least, must appear before :bsd. - :macosx :darwin :apple + (:linux :linux-target) ;; for GCL at least, must appear before :bsd. + (:macosx :darwin :darwin-target :apple) :freebsd :netbsd :openbsd :bsd :unix))
(defparameter *architecture-features* - '((:x86-64 :amd64 :x86_64 :x8664-target) - (:x86 :i686 :i586 :pentium3 :i486 :i386 :pc386 :iapx386 :x8632-target :pentium4) - :hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc - :java-1.4 :java-1.5 :java-1.6 :java-1.7)) - + '((:amd64 :x86-64 :x86_64 :x8664-target) + (:x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target) + :hppa64 + :hppa + (:ppc64 :ppc64-target) + (:ppc32 :ppc32-target :ppc :powerpc) + :sparc64 + (:sparc32 :sparc) + (:arm :arm-target) + (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))
(defun* lisp-version-string () (let ((s (lisp-implementation-version))) @@ -2492,7 +2525,7 @@ (if (member :64bit *features*) "-64bit" "")) #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) #+clisp (subseq s 0 (position #\space s)) - #+clozure (format nil "~d.~d-fasl~d" + #+clozure (format nil "~d.~d-f~d" ; shorten for windows ccl::*openmcl-major-version* ccl::*openmcl-minor-version* (logand ccl::fasl-version #xFF)) @@ -2689,10 +2722,6 @@ (setf *output-translations* '()) (values))
-(defparameter *wild-asd* - (make-pathname :directory '(:relative :wild-inferiors) - :name :wild :type "asd" :version :newest)) - (declaim (ftype (function (t &key (:directory boolean) (:wilden boolean)) (values (or null pathname) &optional)) resolve-location)) @@ -2872,7 +2901,7 @@ ;; These are for convenience, and can be overridden by the user: #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*")) #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) - ;; If we want to enable the user cache by default, here would be the place: + ;; We enable the user cache by default, and here is the place we do: :enable-user-cache))
(defparameter *output-translations-file* #p"asdf-output-translations.conf") @@ -3051,8 +3080,8 @@ (when (and x (probe-file x)) (delete-file x)))
-(defun* compile-file* (input-file &rest keys &key &allow-other-keys) - (let* ((output-file (apply 'compile-file-pathname* input-file keys)) +(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys) + (let* ((output-file (or output-file (apply 'compile-file-pathname* input-file keys))) (tmp-file (tmpize-pathname output-file)) (status :error)) (multiple-value-bind (output-truename warnings-p failure-p) @@ -3102,7 +3131,8 @@ (include-per-user-information nil) (map-all-source-files (or #+(or ecl clisp) t nil)) (source-to-target-mappings nil)) - (when (and (null map-all-source-files) #-(or ecl clisp) nil) + #+(or ecl clisp) + (when (null map-all-source-files) (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP")) (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp"))) (wild-inferiors (make-pathname :directory '(:relative :wild-inferiors))) @@ -3206,7 +3236,8 @@
;; Using ack 1.2 exclusions (defvar *default-source-registry-exclusions* - '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst" + '(".bzr" ".cdv" + ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs" "_sgbak" "autom4te.cache" "cover_db" "_build" "debian")) ;; debian often build stuff under the debian directory... BAD. @@ -3234,6 +3265,61 @@ (setf *source-registry* '()) (values))
+(defparameter *wild-asd* + (make-pathname :directory nil :name :wild :type "asd" :version :newest)) + +(defun directory-has-asd-files-p (directory) + (and (ignore-errors + (directory (merge-pathnames* *wild-asd* directory) + #+sbcl #+sbcl :resolve-symlinks nil + #+ccl #+ccl :follow-links nil + #+clisp #+clisp :circle t)) + t)) + +(defun subdirectories (directory) + (let* ((directory (ensure-directory-pathname directory)) + #-cormanlisp + (wild (merge-pathnames* + #-(or abcl allegro lispworks scl) + (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil) + #+(or abcl allegro lispworks scl) "*.*" + directory)) + (dirs + #-cormanlisp + (ignore-errors + (directory wild . + #.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil) + #+ccl '(:follow-links nil :directories t :files nil) + #+clisp '(:circle t :if-does-not-exist :ignore) + #+(or cmu scl) '(:follow-links nil :truenamep nil) + #+digitool '(:directories t) + #+sbcl '(:resolve-symlinks nil)))) + #+cormanlisp (cl::directory-subdirs directory)) + #+(or abcl allegro lispworks scl) + (dirs (remove-if-not #+abcl #'extensions:probe-directory + #+allegro #'excl:probe-directory + #+lispworks #'lw:file-directory-p + #-(or abcl allegro lispworks) #'directory-pathname-p + dirs))) + dirs)) + +(defun collect-sub*directories (directory collectp recursep collector) + (when (funcall collectp directory) + (funcall collector directory)) + (dolist (subdir (subdirectories directory)) + (when (funcall recursep subdir) + (collect-sub*directories subdir collectp recursep collector)))) + +(defun collect-sub*directories-with-asd + (directory &key + (exclude *default-source-registry-exclusions*) + collect) + (collect-sub*directories + directory + #'directory-has-asd-files-p + #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal))) + collect)) + (defun* validate-source-registry-directive (directive) (unless (or (member directive '(:default-registry (:default-registry)) :test 'equal) @@ -3297,22 +3383,8 @@ (defun* register-asd-directory (directory &key recurse exclude collect) (if (not recurse) (funcall collect directory) - (let* ((files - (handler-case - (directory (merge-pathnames* *wild-asd* directory) - #+sbcl #+sbcl :resolve-symlinks nil - #+clisp #+clisp :circle t) - (error (c) - (warn "Error while scanning system definitions under directory ~S:~%~A" - directory c) - nil))) - (dirs (remove-duplicates (mapcar #'pathname-directory-pathname files) - :test #'equal :from-end t))) - (loop - :for dir :in dirs - :unless (loop :for x :in exclude - :thereis (find x (pathname-directory dir) :test #'equal)) - :do (funcall collect dir))))) + (collect-sub*directories-with-asd + directory :exclude exclude :collect collect)))
(defparameter *default-source-registries* '(environment-source-registry