[cmucl-cvs] CMUCL commit: src/contrib/asdf (asdf.lisp)

Raymond Toy rtoy at common-lisp.net
Wed Oct 6 23:26:55 UTC 2010


    Date: Wednesday, October 6, 2010 @ 19:26:55
  Author: rtoy
    Path: /project/cmucl/cvsroot/src/contrib/asdf

Modified: asdf.lisp

Update to revision 2.009.


-----------+
 asdf.lisp |  231 ++++++++++++++++++++++++++++++++----------------------------
 1 file changed, 124 insertions(+), 107 deletions(-)


Index: src/contrib/asdf/asdf.lisp
diff -u src/contrib/asdf/asdf.lisp:1.8 src/contrib/asdf/asdf.lisp:1.9
--- src/contrib/asdf/asdf.lisp:1.8	Fri Sep 17 19:25:58 2010
+++ src/contrib/asdf/asdf.lisp	Wed Oct  6 19:26:55 2010
@@ -47,7 +47,7 @@
 
 #+xcvb (module ())
 
-(cl:in-package :cl)
+(cl:in-package :cl-user)
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   ;;; make package if it doesn't exist yet.
@@ -55,7 +55,7 @@
   (unless (find-package :asdf)
     (make-package :asdf :use '(:cl)))
   ;;; Implementation-dependent tweaks
-  ;; (declaim (optimize (speed 2) (debug 2) (safety 3)) ; NO: rely on the implementation defaults.
+  ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults.
   #+allegro
   (setf excl::*autoload-package-name-alist*
         (remove "asdf" excl::*autoload-package-name-alist*
@@ -72,7 +72,7 @@
   (defvar *asdf-version* nil)
   (defvar *upgraded-p* nil)
   (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate
-          (subseq "VERSION:2.008" (1+ (length "VERSION")))) ; same as 2.128
+          (subseq "VERSION:2.009" (1+ (length "VERSION")))) ; same as 2.134
          (existing-asdf (fboundp 'find-system))
          (existing-version *asdf-version*)
          (already-there (equal asdf-version existing-version)))
@@ -82,36 +82,30 @@
                 "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
                 existing-version asdf-version))
       (labels
-          ((rename-away (package)
-             (loop :with name = (package-name package)
-               :for i :from 1 :for new = (format nil "~A.~D" name i)
-               :unless (find-package new) :do
-               (rename-package-name package name new)))
-           (rename-package-name (package old new)
-             (let* ((old-names (cons (package-name package)
-                                     (package-nicknames package)))
-                    (new-names (subst new old old-names :test 'equal))
-                    (new-name (car new-names))
-                    (new-nicknames (cdr new-names)))
-               (rename-package package new-name new-nicknames)))
+          ((unlink-package (package)
+             (let ((u (find-package package)))
+               (when u
+                 (ensure-unintern u
+                   (loop :for s :being :each :present-symbol :in u :collect s))
+                 (loop :for p :in (package-used-by-list u) :do
+                   (unuse-package u p))
+                 (delete-package u))))
            (ensure-exists (name nicknames use)
-             (let* ((previous
-                     (remove-duplicates
-                      (remove-if
-                       #'null
-                       (mapcar #'find-package (cons name nicknames)))
-                      :from-end t)))
-               (cond
-                 (previous
-                  ;; do away with packages with conflicting (nick)names
-                  (map () #'rename-away (cdr previous))
-                  ;; reuse previous package with same name
-                  (let ((p (car previous)))
+             (let ((previous
+                    (remove-duplicates
+                     (mapcar #'find-package (cons name nicknames))
+                     :from-end t)))
+               ;; do away with packages with conflicting (nick)names
+               (map () #'unlink-package (cdr previous))
+               ;; reuse previous package with same name
+               (let ((p (car previous)))
+                 (cond
+                   (p
                     (rename-package p name nicknames)
                     (ensure-use p use)
-                    p))
-                 (t
-                  (make-package name :nicknames nicknames :use use)))))
+                    p)
+                   (t
+                    (make-package name :nicknames nicknames :use use))))))
            (find-sym (symbol package)
              (find-symbol (string symbol) package))
            (intern* (symbol package)
@@ -176,9 +170,7 @@
                    :shadow ',shadow
                    :unintern ',(append #-(or gcl ecl) redefined-functions unintern)
                    :fmakunbound ',(append fmakunbound))))
-          (let ((u (find-package :asdf-utilities)))
-            (when u
-              (ensure-unintern u (loop :for s :being :each :present-symbol :in u :collect s))))
+          (unlink-package :asdf-utilities)
           (pkgdcl
            :asdf
            :use (:common-lisp)
@@ -186,7 +178,7 @@
            (#:perform #:explain #:output-files #:operation-done-p
             #:perform-with-restarts #:component-relative-pathname
             #:system-source-file #:operate #:find-component #:find-system
-            #:apply-output-translations #:translate-pathname*)
+            #:apply-output-translations #:translate-pathname* #:resolve-location)
            :unintern
            (#:*asdf-revision* #:around #:asdf-method-combination
             #:split #:make-collector)
@@ -331,12 +323,19 @@
          (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p)))))
    (when (find-class 'module nil)
      (eval
-      '(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))))))
+      '(progn
+         (defmethod update-instance-for-redefined-class :after
+             ((m module) added deleted plist &key)
+           (declare (ignorable deleted plist))
+           (when *asdf-verbose* (format *trace-output* "Updating ~A~%" m))
+           (when (member 'components-by-name added)
+             (compute-module-components-by-name m)))
+         (defmethod update-instance-for-redefined-class :after
+             ((s system) added deleted plist &key)
+           (declare (ignorable deleted plist))
+           (when *asdf-verbose* (format *trace-output* "Updating ~A~%" s))
+           (when (member 'source-file added)
+             (%set-system-source-file (probe-asd (component-name s) (component-pathname s)) s)))))))
 
 ;;;; -------------------------------------------------------------------------
 ;;;; User-visible parameters
@@ -970,15 +969,13 @@
 ;;;; methods: components
 
 (defmethod print-object ((c missing-component) s)
-  (format s "~@<component ~S not found~
-             ~@[ in ~A~]~@:>"
+  (format s "~@<component ~S not found~@[ in ~A~]~@:>"
           (missing-requires c)
           (when (missing-parent c)
             (component-name (missing-parent c)))))
 
 (defmethod print-object ((c missing-component-of-version) s)
-  (format s "~@<component ~S does not match version ~A~
-              ~@[ in ~A~]~@:>"
+  (format s "~@<component ~S does not match version ~A~@[ in ~A~]~@:>"
           (missing-requires c)
           (missing-version c)
           (when (missing-parent c)
@@ -1202,8 +1199,7 @@
                             (let* ((*print-circle* nil)
                                    (message
                                     (format nil
-                                            "~@<While searching for system ~S: ~S evaluated ~
-to ~S 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 ()
@@ -1288,17 +1284,22 @@
   (setf (gethash (coerce-name name) *defined-systems*)
         (cons (get-universal-time) system)))
 
-(defun* sysdef-find-asdf (system)
-  (let ((name (coerce-name system)))
-    (when (equal name "asdf")
-      (let* ((registered (cdr (gethash name *defined-systems*)))
-             (asdf (or registered
+(defun* find-system-fallback (requested fallback &optional source-file)
+  (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 "asdf"
-                        :source-file (or *compile-file-truename* *load-truename*)))))
-        (unless registered
-          (register-system "asdf" asdf))
-        (throw 'find-system asdf)))))
+                        'system :name fallback
+                        :source-file source-file))))
+      (unless registered
+        (register-system fallback system))
+      (throw 'find-system system))))
+
+(defun* sysdef-find-asdf (name)
+  (find-system-fallback name "asdf"))
 
 
 ;;;; -------------------------------------------------------------------------
@@ -1784,8 +1785,7 @@
 
 (defmethod perform ((operation operation) (c source-file))
   (sysdef-error
-   "~@<required method PERFORM not implemented ~
-    for operation ~A, component ~A~@:>"
+   "~@<required method PERFORM not implemented for operation ~A, component ~A~@:>"
    (class-of operation) (class-of c)))
 
 (defmethod perform ((operation operation) (c module))
@@ -1898,11 +1898,11 @@
 (defclass load-op (basic-load-op) ())
 
 (defmethod perform ((o load-op) (c cl-source-file))
-  #-ecl (mapcar #'load (input-files o c))
-  #+ecl (loop :for i :in (input-files o c)
-          :unless (string= (pathname-type i) "fas")
-          :collect (let ((output (compile-file-pathname (lispize-pathname i))))
-                     (load output))))
+  (map () #'load
+       #-ecl (input-files o c)
+       #+ecl (loop :for i :in (input-files o c)
+               :unless (string= (pathname-type i) "fas")
+               :collect (compile-file-pathname (lispize-pathname i)))))
 
 (defmethod perform-with-restarts (operation component)
   (perform operation component))
@@ -2065,8 +2065,7 @@
               (accept ()
                 :report
                 (lambda (s)
-                  (format s "~@<Continue, treating ~A as ~
-                                   having been successful.~@:>"
+                  (format s "~@<Continue, treating ~A as having been successful.~@:>"
                           (operation-description op component)))
                 (setf (gethash (type-of op)
                                (component-operation-times component))
@@ -2109,21 +2108,24 @@
   "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for
 details."
   (declare (ignore force verbose version))
-  (apply #'operate 'load-op system args))
+  (apply #'operate 'load-op system args)
+  t)
 
 (defun* compile-system (system &rest args &key force verbose version
                        &allow-other-keys)
   "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE
 for details."
   (declare (ignore force verbose version))
-  (apply #'operate 'compile-op system args))
+  (apply #'operate 'compile-op system args)
+  t)
 
 (defun* test-system (system &rest args &key force verbose version
                     &allow-other-keys)
   "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for
 details."
   (declare (ignore force verbose version))
-  (apply #'operate 'test-op system args))
+  (apply #'operate 'test-op system args)
+  t)
 
 ;;;; -------------------------------------------------------------------------
 ;;;; Defsystem
@@ -2542,8 +2544,7 @@
                             "No architecture feature found in ~a."
                             *architecture-features*))
           (version (maybe-warn (lisp-version-string)
-                               "Don't know how to get Lisp ~
-                                          implementation version.")))
+                               "Don't know how to get Lisp implementation version.")))
       (substitute-if
        #\_ (lambda (x) (find x " /:\\(){}[]$#`'\""))
        (format nil "~(~@{~a~^-~}~)" lisp version os arch)))))
@@ -2692,19 +2693,24 @@
   (make-pathname :directory '(:relative :wild-inferiors)
                  :name :wild :type "asd" :version :newest))
 
-(declaim (ftype (function (t &optional boolean) (values (or null pathname) &optional))
+(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean))
+                          (values (or null pathname) &optional))
                 resolve-location))
 
-(defun* resolve-relative-location-component (super x &optional wildenp)
+(defun* resolve-relative-location-component (super x &key directory wilden)
   (let* ((r (etypecase x
               (pathname x)
               (string x)
               (cons
-               (let ((car (resolve-relative-location-component super (car x) nil)))
+               (return-from resolve-relative-location-component
                  (if (null (cdr x))
-                     car
-                     (let ((cdr (resolve-relative-location-component
-                                 (merge-pathnames* car super) (cdr x) wildenp)))
+                     (resolve-relative-location-component
+                      super (car x) :directory directory :wilden wilden)
+                     (let* ((car (resolve-relative-location-component
+                                  super (car x) :directory t :wilden nil))
+                            (cdr (resolve-relative-location-component
+                                  (merge-pathnames* car super) (cdr x)
+                                  :directory directory :wilden wilden)))
                        (merge-pathnames* cdr car)))))
               ((eql :default-directory)
                (relativize-pathname-directory (default-directory)))
@@ -2712,49 +2718,55 @@
               ((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)))
+         (d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r)))
+         (s (if (or (pathnamep x) (not wilden)) d (wilden 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)
+(defun* resolve-absolute-location-component (x &key directory wilden)
   (let* ((r
           (etypecase x
             (pathname x)
-            (string (ensure-directory-pathname x))
+            (string (if directory (ensure-directory-pathname x) (parse-namestring x)))
             (cons
-             (let ((car (resolve-absolute-location-component (car x) nil)))
+             (return-from resolve-absolute-location-component
                (if (null (cdr x))
-                   car
-                   (let ((cdr (resolve-relative-location-component
-                               car (cdr x) wildenp)))
-                     (merge-pathnames* cdr car)))))
+                   (resolve-absolute-location-component
+                    (car x) :directory directory :wilden wilden)
+                   (let* ((car (resolve-absolute-location-component
+                                (car x) :directory t :wilden nil))
+                          (cdr (resolve-relative-location-component
+                                car (cdr x) :directory directory :wilden wilden)))
+                     (merge-pathnames* cdr car))))) ; XXX why is this not just "cdr" ?
             ((eql :root)
              ;; special magic! we encode such paths as relative pathnames,
              ;; but it means "relative to the root of the source pathname's host and device".
              (return-from resolve-absolute-location-component
-               (make-pathname :directory '(:relative))))
+               (let ((p (make-pathname :directory '(:relative))))
+                 (if wilden (wilden p) p))))
             ((eql :home) (user-homedir))
-            ((eql :user-cache) (resolve-location *user-cache* nil))
-            ((eql :system-cache) (resolve-location *system-cache* nil))
+            ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
+            ((eql :system-cache) (resolve-location *system-cache* :directory t :wilden nil))
             ((eql :default-directory) (default-directory))))
-         (s (if (and wildenp (not (pathnamep x)))
+         (s (if (and wilden (not (pathnamep x)))
                 (wilden r)
                 r)))
     (unless (absolute-pathname-p s)
       (error "Not an absolute pathname ~S" s))
     s))
 
-(defun* resolve-location (x &optional wildenp)
+(defun* resolve-location (x &key directory wilden)
   (if (atom x)
-      (resolve-absolute-location-component x wildenp)
-      (loop :with path = (resolve-absolute-location-component (car x) nil)
+      (resolve-absolute-location-component x :directory directory :wilden wilden)
+      (loop :with path = (resolve-absolute-location-component
+                          (car x) :directory (and (or directory (cdr x)) t)
+                          :wilden (and wilden (null (cdr x))))
         :for (component . morep) :on (cdr x)
+        :for dir = (and (or morep directory) t)
+        :for wild = (and wilden (not morep))
         :do (setf path (resolve-relative-location-component
-                        path component (and wildenp (not morep))))
+                        path component :directory dir :wilden wild))
         :finally (return path))))
 
 (defun* location-designator-p (x)
@@ -2775,7 +2787,7 @@
   (unless
       (or (member directive '(:inherit-configuration
                               :ignore-inherited-configuration
-                              :enable-user-cache :disable-cache))
+                              :enable-user-cache :disable-cache nil))
           (and (consp directive)
                (or (and (length=n-p directive 2)
                         (or (and (eq (first directive) :include)
@@ -2852,9 +2864,9 @@
   `(:output-translations
     ;; Some implementations have precompiled ASDF systems,
     ;; so we must disable translations for implementation paths.
-    #+sbcl (,(getenv "SBCL_HOME") ())
+    #+sbcl ,(let ((h (getenv "SBCL_HOME"))) (when (plusp (length h)) `(,h ())))
     #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system
-    #+clozure (,(wilden (truename #p"ccl:")) ()) ; not needed: no precompiled ASDF system
+    #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ; not needed: no precompiled 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:
@@ -2920,7 +2932,7 @@
          (process-output-translations-directive '(t t) :collect collect))
         ((:inherit-configuration)
          (inherit-output-translations inherit :collect collect))
-        ((:ignore-inherited-configuration)
+        ((:ignore-inherited-configuration nil)
          nil))
       (let ((src (first directive))
             (dst (second directive)))
@@ -2929,7 +2941,7 @@
               (process-output-translations (pathname dst) :inherit nil :collect collect))
             (when src
               (let ((trusrc (or (eql src t)
-                                (let ((loc (resolve-location src t)))
+                                (let ((loc (resolve-location src :directory t :wilden t)))
                                   (if (absolute-pathname-p loc) (truenamize loc) loc)))))
                 (cond
                   ((location-function-p dst)
@@ -2942,7 +2954,7 @@
                    (funcall collect (list trusrc t)))
                   (t
                    (let* ((trudst (make-pathname
-                                   :defaults (if dst (resolve-location dst t) trusrc)))
+                                   :defaults (if dst (resolve-location dst :directory t :wilden t) trusrc)))
                           (wilddst (make-pathname
                                     :name :wild :type :wild :version :wild
                                     :defaults trudst)))
@@ -3088,8 +3100,10 @@
          (merge-pathnames* (make-pathname :directory '(:relative ".fasls"))
                            (user-homedir)))
      (include-per-user-information nil)
-     (map-all-source-files 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)
+    (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)))
          (mapped-files (make-pathname
@@ -3116,6 +3130,8 @@
 ;;;; Jesse Hager: The Windows Shortcut File Format.
 ;;;; http://www.wotsit.org/list.asp?fc=13
 
+#+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
+(progn
 (defparameter *link-initial-dword* 76)
 (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
 
@@ -3182,7 +3198,7 @@
                     (read-sequence buffer s)
                     (map 'string #'code-char buffer)))))))
       (end-of-file ()
-        nil))))
+        nil)))))
 
 ;;;; -----------------------------------------------------------------
 ;;;; Source Registry Configuration, by Francois-Rene Rideau
@@ -3225,7 +3241,7 @@
             (case kw
               ((:include :directory :tree)
                (and (length=n-p rest 1)
-                    (typep (car rest) '(or pathname string null))))
+                    (location-designator-p (first rest))))
               ((:exclude :also-exclude)
                (every #'stringp rest))
               (null rest))))
@@ -3389,15 +3405,16 @@
     (ecase kw
       ((:include)
        (destructuring-bind (pathname) rest
-         (process-source-registry (pathname pathname) :inherit nil :register register)))
+         (process-source-registry (resolve-location pathname) :inherit nil :register register)))
       ((:directory)
        (destructuring-bind (pathname) rest
          (when pathname
-           (funcall register (ensure-directory-pathname pathname)))))
+           (funcall register (resolve-location pathname :directory t)))))
       ((:tree)
        (destructuring-bind (pathname) rest
          (when pathname
-           (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *source-registry-exclusions*))))
+           (funcall register (resolve-location pathname :directory t)
+                    :recurse t :exclude *source-registry-exclusions*))))
       ((:exclude)
        (setf *source-registry-exclusions* rest))
       ((:also-exclude)




More information about the cmucl-cvs mailing list