Index: /trunk/source/tools/asdf.lisp
===================================================================
--- /trunk/source/tools/asdf.lisp	(revision 14553)
+++ /trunk/source/tools/asdf.lisp	(revision 14554)
@@ -75,9 +75,11 @@
   (defvar *upgraded-p* nil)
   (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
+         ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version
+         ;; can help you do these changes in synch (look at the source for documentation).
          ;; "2.345" would be an official release
          ;; "2.345.6" would be a development version in the official upstream
-         ;; "2.345.0.7" would be your local modification of an official release
-         ;; "2.345.6.7" would be your local modification of a development version
-         (asdf-version "2.011")
+         ;; "2.345.0.7" would be your seventh local modification of official release 2.345
+         ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
+         (asdf-version "2.012")
          (existing-asdf (fboundp 'find-system))
          (existing-version *asdf-version*)
@@ -497,5 +499,5 @@
          ;; See CLHS make-pathname and 19.2.2.2.3.
          ;; We only use it on implementations that support it.
-         (or #+(or ccl ecl gcl lispworks sbcl) :unspecific)))
+         (or #+(or ccl gcl lispworks sbcl) :unspecific)))
     (destructuring-bind (name &optional (type unspecific))
         (split-string filename :max 2 :separator ".")
@@ -714,7 +716,12 @@
   (make-pathname :type "lisp" :defaults input-file))
 
+(defparameter *wild-file*
+  (make-pathname :name :wild :type :wild :version :wild :directory nil))
+(defparameter *wild-directory*
+  (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil))
+(defparameter *wild-inferiors*
+  (make-pathname :directory '(:relative :wild-inferiors) :name nil :type nil :version nil))
 (defparameter *wild-path*
-  (make-pathname :directory '(:relative :wild-inferiors)
-                 :name :wild :type :wild :version :wild))
+  (merge-pathnames *wild-file* *wild-inferiors*))
 
 (defun* wilden (path)
@@ -866,6 +873,10 @@
          (when (member 'components-by-name added)
            (compute-module-components-by-name m))
-         (when (and (typep m 'system) (member 'source-file added))
-           (%set-system-source-file (probe-asd (component-name m) (component-pathname m)) m))))))
+         (when (typep m 'system)
+           (when (member 'source-file added)
+             (%set-system-source-file
+              (probe-asd (component-name m) (component-pathname m)) m)
+             (when (equal (component-name m) "asdf")
+               (setf (component-version m) *asdf-version*))))))))
 
 ;;;; -------------------------------------------------------------------------
@@ -939,4 +950,19 @@
 (define-condition compile-failed (compile-error) ())
 (define-condition compile-warned (compile-error) ())
+
+(define-condition invalid-configuration ()
+  ((form :reader condition-form :initarg :form)
+   (location :reader condition-location :initarg :location)
+   (format :reader condition-format :initarg :format)
+   (arguments :reader condition-arguments :initarg :arguments :initform nil))
+  (:report (lambda (c s)
+             (format s "~@<~? (will be skipped)~@:>"
+                     (condition-format c)
+                     (list* (condition-form c) (condition-location c)
+                            (condition-arguments c))))))
+(define-condition invalid-source-registry (invalid-configuration warning)
+  ((format :initform "~@<invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~>")))
+(define-condition invalid-output-translation (invalid-configuration warning)
+  ((format :initform "~@<invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~>")))
 
 (defclass component ()
@@ -1152,9 +1178,6 @@
   ;; There is no "unload" operation in Common Lisp, and a general such operation
   ;; cannot be portably written, considering how much CL relies on side-effects
-  ;; of global data structures.
-  ;; Note that this does a setf gethash instead of a remhash
-  ;; this way there remains a hint in the *defined-systems* table
-  ;; that the system was loaded at some point.
-  (setf (gethash (coerce-name name) *defined-systems*) nil))
+  ;; to global data structures.
+  (remhash (coerce-name name) *defined-systems*))
 
 (defun* map-systems (fn)
@@ -1290,25 +1313,32 @@
   (find-system (coerce-name name) error-p))
 
+(defun load-sysdef (name pathname)
+  ;; Tries to load system definition with canonical NAME from PATHNAME.
+  (let ((package (make-temporary-package)))
+    (unwind-protect
+         (handler-bind
+             ((error (lambda (condition)
+                       (error 'load-system-definition-error
+                              :name name :pathname pathname
+                              :condition condition))))
+           (let ((*package* package))
+             (asdf-message
+              "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%"
+              pathname package)
+             (load pathname)))
+      (delete-package package))))
+
 (defmethod find-system ((name string) &optional (error-p t))
   (catch 'find-system
-    (let* ((in-memory (system-registered-p name))
+    (let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
            (on-disk (system-definition-pathname name)))
       (when (and on-disk
                  (or (not in-memory)
-                     (< (car in-memory) (safe-file-write-date on-disk))))
-        (let ((package (make-temporary-package)))
-          (unwind-protect
-               (handler-bind
-                   ((error (lambda (condition)
-                             (error 'load-system-definition-error
-                                    :name name :pathname on-disk
-                                    :condition condition))))
-                 (let ((*package* package))
-                   (asdf-message
-                    "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%"
-                    on-disk *package*)
-                   (load on-disk)))
-            (delete-package package))))
-      (let ((in-memory (system-registered-p name)))
+                     ;; don't reload if it's already been loaded,
+                     ;; or its filestamp is in the future which means some clock is skewed
+                     ;; and trying to load might cause an infinite loop.
+                     (< (car in-memory) (safe-file-write-date on-disk) (get-universal-time))))
+        (load-sysdef name on-disk))
+      (let ((in-memory (system-registered-p name))) ; try again after loading from disk
         (cond
           (in-memory
@@ -1341,5 +1371,6 @@
 
 (defun* sysdef-find-asdf (name)
-  (find-system-fallback name "asdf")) ;; :version *asdf-version* wouldn't be updated when ASDF is updated.
+  ;; Bug: :version *asdf-version* won't be updated when ASDF is updated.
+  (find-system-fallback name "asdf" :version *asdf-version*))
 
 
@@ -1651,6 +1682,5 @@
       (retry ()
         :report (lambda (s)
-                  (format s "~@<Retry loading component ~S.~@:>"
-                          (component-find-path required-c)))
+                  (format s "~@<Retry loading component ~S.~@:>" required-c))
         :test
         (lambda (c)
@@ -2409,5 +2439,5 @@
 
     #+clisp                     ;XXX not exactly *verbose-out*, I know
-    (ext:run-shell-command  command :output :terminal :wait t)
+    (or (ext:run-shell-command  command :output :terminal :wait t) 0)
 
     #+clozure
@@ -2587,5 +2617,6 @@
           (os   (maybe-warn (first-feature *os-features*)
                             "No os feature found in ~a." *os-features*))
-          (arch (maybe-warn (first-feature *architecture-features*)
+          (arch #+clisp "" #-clisp
+                (maybe-warn (first-feature *architecture-features*)
                             "No architecture feature found in ~a."
                             *architecture-features*))
@@ -2595,5 +2626,4 @@
        #\_ (lambda (x) (find x " /:\\(){}[]$#`'\""))
        (format nil "~(~@{~a~^-~}~)" lisp version os arch)))))
-
 
 
@@ -2650,38 +2680,86 @@
         (and (length=n-p x 1) (member (car x) kw)))))
 
+(defun* report-invalid-form (reporter &rest args)
+  (etypecase reporter
+    (null
+     (apply 'error 'invalid-configuration args))
+    (function
+     (apply reporter args))
+    ((or symbol string)
+     (apply 'error reporter args))
+    (cons
+     (apply 'apply (append reporter args)))))
+
+(defvar *ignored-configuration-form* nil)
+
 (defun* validate-configuration-form (form tag directive-validator
-                                    &optional (description tag))
+                                    &key location invalid-form-reporter)
   (unless (and (consp form) (eq (car form) tag))
-    (error "Error: Form doesn't specify ~A ~S~%" description form))
-  (loop :with inherit = 0
-    :for directive :in (cdr form) :do
-    (if (configuration-inheritance-directive-p directive)
-        (incf inherit)
-        (funcall directive-validator directive))
+    (setf *ignored-configuration-form* t)
+    (report-invalid-form invalid-form-reporter :form form :location location)
+    (return-from validate-configuration-form nil))
+  (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag)
+    :for directive :in (cdr form)
+    :when (cond
+            ((configuration-inheritance-directive-p directive)
+             (incf inherit) t)
+            ((eq directive :ignore-invalid-entries)
+             (setf ignore-invalid-p t) t)
+            ((funcall directive-validator directive)
+             t)
+            (ignore-invalid-p
+             nil)
+            (t
+             (setf *ignored-configuration-form* t)
+             (report-invalid-form invalid-form-reporter :form directive :location location)
+             nil))
+    :do (push directive x)
     :finally
     (unless (= inherit 1)
-      (error "One and only one of ~S or ~S is required"
-             :inherit-configuration :ignore-inherited-configuration)))
-  form)
-
-(defun* validate-configuration-file (file validator description)
+      (report-invalid-form invalid-form-reporter
+             :arguments (list "One and only one of ~S or ~S is required"
+                              :inherit-configuration :ignore-inherited-configuration)))
+    (return (nreverse x))))
+
+(defun* validate-configuration-file (file validator &key description)
   (let ((forms (read-file-forms file)))
     (unless (length=n-p forms 1)
       (error "One and only one form allowed for ~A. Got: ~S~%" description forms))
-    (funcall validator (car forms))))
+    (funcall validator (car forms) :location file)))
 
 (defun* hidden-file-p (pathname)
   (equal (first-char (pathname-name pathname)) #\.))
 
-(defun* validate-configuration-directory (directory tag validator)
+(defun* directory* (pathname-spec &rest keys &key &allow-other-keys)
+  (apply 'directory pathname-spec
+         (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
+                             #+ccl '(:follow-links nil)
+                             #+clisp '(:circle t :if-does-not-exist :ignore)
+                             #+(or cmu scl) '(:follow-links nil :truenamep nil)
+                             #+sbcl (when (find-symbol "RESOLVE-SYMLINKS" "SB-IMPL") '(:resolve-symlinks nil))))))
+
+(defun* validate-configuration-directory (directory tag validator &key invalid-form-reporter)
+  "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will
+be applied to the results to yield a configuration form.  Current
+values of TAG include :source-registry and :output-translations."
   (let ((files (sort (ignore-errors
                        (remove-if
                         'hidden-file-p
-                        (directory (make-pathname :name :wild :type "conf" :defaults directory)
-                                   #+sbcl :resolve-symlinks #+sbcl nil)))
+                        (directory* (make-pathname :name :wild :type "conf" :defaults directory))))
                      #'string< :key #'namestring)))
     `(,tag
       ,@(loop :for file :in files :append
-          (mapcar validator (read-file-forms file)))
+          (loop :with ignore-invalid-p = nil
+            :for form :in (read-file-forms file)
+            :when (eq form :ignore-invalid-entries)
+              :do (setf ignore-invalid-p t)
+            :else
+              :when (funcall validator form)
+                :collect form
+              :else
+                :when ignore-invalid-p
+                  :do (setf *ignored-configuration-form* t)
+                :else
+                  :do (report-invalid-form invalid-form-reporter :form form :location file)))
       :inherit-configuration)))
 
@@ -2723,5 +2801,6 @@
                                ((eql t) -1)
                                (pathname
-                                (length (pathname-directory (car x)))))))))
+                                (let ((directory (pathname-directory (car x))))
+                                  (if (listp directory) (length directory) 0))))))))
   new-value)
 
@@ -2757,4 +2836,7 @@
               ((eql :default-directory)
                (relativize-pathname-directory (default-directory)))
+              ((eql :*/) *wild-directory*)
+              ((eql :**/) *wild-inferiors*)
+              ((eql :*.*.*) *wild-file*)
               ((eql :implementation) (implementation-identifier))
               ((eql :implementation-type) (string-downcase (implementation-type)))
@@ -2766,4 +2848,9 @@
       (error "pathname ~S is not relative to ~S" s super))
     (merge-pathnames* s super)))
+
+(defvar *here-directory* nil
+  "This special variable is bound to the currect directory during calls to
+PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here
+directive.")
 
 (defun* resolve-absolute-location-component (x &key directory wilden)
@@ -2789,4 +2876,9 @@
                  (if wilden (wilden p) p))))
             ((eql :home) (user-homedir))
+            ((eql :here)
+             (resolve-location (or *here-directory*
+                                   ;; give semantics in the case of use interactively
+                                   :default-directory)
+                          :directory t :wilden nil))
             ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
             ((eql :system-cache) (resolve-location *system-cache* :directory t :wilden nil))
@@ -2813,6 +2905,15 @@
 
 (defun* location-designator-p (x)
-  (flet ((componentp (c) (typep c '(or string pathname keyword))))
-    (or (typep x 'boolean) (componentp x) (and (consp x) (every #'componentp x)))))
+  (flet ((absolute-component-p (c)
+           (typep c '(or string pathname
+                      (member :root :home :here :user-cache :system-cache :default-directory))))
+         (relative-component-p (c)
+           (typep c '(or string pathname
+                      (member :default-directory :*/ :**/ :*.*.*
+                        :implementation :implementation-type
+                        #-(and (or win32 windows mswindows mingw32) (not cygwin)) :uid)))))
+    (or (typep x 'boolean)
+        (absolute-component-p x)
+        (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x))))))
 
 (defun* location-function-p (x)
@@ -2827,36 +2928,32 @@
 
 (defun* validate-output-translations-directive (directive)
-  (unless
-      (or (member directive '(:inherit-configuration
-                              :ignore-inherited-configuration
-                              :enable-user-cache :disable-cache nil))
-          (and (consp directive)
-               (or (and (length=n-p directive 2)
-                        (or (and (eq (first directive) :include)
-                                 (typep (second directive) '(or string pathname null)))
-                            (and (location-designator-p (first directive))
-                                 (or (location-designator-p (second directive))
-                                     (location-function-p (second directive))))))
-                   (and (length=n-p directive 1)
-                        (location-designator-p (first directive))))))
-    (error "Invalid directive ~S~%" directive))
-  directive)
-
-(defun* validate-output-translations-form (form)
+  (or (member directive '(:enable-user-cache :disable-cache nil))
+      (and (consp directive)
+           (or (and (length=n-p directive 2)
+                    (or (and (eq (first directive) :include)
+                             (typep (second directive) '(or string pathname null)))
+                        (and (location-designator-p (first directive))
+                             (or (location-designator-p (second directive))
+                                 (location-function-p (second directive))))))
+               (and (length=n-p directive 1)
+                    (location-designator-p (first directive)))))))
+
+(defun* validate-output-translations-form (form &key location)
   (validate-configuration-form
    form
    :output-translations
    'validate-output-translations-directive
-   "output translations"))
+   :location location :invalid-form-reporter 'invalid-output-translation))
 
 (defun* validate-output-translations-file (file)
   (validate-configuration-file
-   file 'validate-output-translations-form "output translations"))
+   file 'validate-output-translations-form :description "output translations"))
 
 (defun* validate-output-translations-directory (directory)
   (validate-configuration-directory
-   directory :output-translations 'validate-output-translations-directive))
-
-(defun* parse-output-translations-string (string)
+   directory :output-translations 'validate-output-translations-directive
+   :invalid-form-reporter 'invalid-output-translation))
+
+(defun* parse-output-translations-string (string &key location)
   (cond
     ((or (null string) (equal string ""))
@@ -2865,7 +2962,7 @@
      (error "environment string isn't: ~S" string))
     ((eql (char string 0) #\")
-     (parse-output-translations-string (read-from-string string)))
+     (parse-output-translations-string (read-from-string string) :location location))
     ((eql (char string 0) #\()
-     (validate-output-translations-form (read-from-string string)))
+     (validate-output-translations-form (read-from-string string) :location location))
     (t
      (loop
@@ -2975,5 +3072,5 @@
         ((:inherit-configuration)
          (inherit-output-translations inherit :collect collect))
-        ((:ignore-inherited-configuration nil)
+        ((:ignore-inherited-configuration :ignore-invalid-entries nil)
          nil))
       (let ((src (first directive))
@@ -2998,7 +3095,5 @@
                    (let* ((trudst (make-pathname
                                    :defaults (if dst (resolve-location dst :directory t :wilden t) trusrc)))
-                          (wilddst (make-pathname
-                                    :name :wild :type :wild :version :wild
-                                    :defaults trudst)))
+                          (wilddst (merge-pathnames* *wild-file* trudst)))
                      (funcall collect (list wilddst t))
                      (funcall collect (list trusrc trudst)))))))))))
@@ -3161,8 +3256,6 @@
     (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
-                        :name :wild :version :wild
-                        :type (if map-all-source-files :wild fasl-type)))
+         (mapped-files (if map-all-source-files *wild-file*
+                           (make-pathname :name :wild :version :wild :type fasl-type)))
          (destination-directory
           (if centralize-lisp-binaries
@@ -3170,10 +3263,10 @@
                 ,@(when include-per-user-information
                         (cdr (pathname-directory (user-homedir))))
-                :implementation ,wild-inferiors)
-              `(:root ,wild-inferiors :implementation))))
+                :implementation ,*wild-inferiors*)
+              `(:root ,*wild-inferiors* :implementation))))
     (initialize-output-translations
      `(:output-translations
        ,@source-to-target-mappings
-       ((:root ,wild-inferiors ,mapped-files)
+       ((:root ,*wild-inferiors* ,mapped-files)
         (,@destination-directory ,mapped-files))
        (t t)
@@ -3295,10 +3388,7 @@
 
 (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))
+  (ignore-errors
+    (directory* (merge-pathnames* *wild-asd* directory))
+    t))
 
 (defun subdirectories (directory)
@@ -3307,5 +3397,5 @@
          (wild (merge-pathnames*
                 #-(or abcl allegro lispworks scl)
-                (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil)
+                *wild-directory*
                 #+(or abcl allegro lispworks scl) "*.*"
                 directory))
@@ -3313,11 +3403,6 @@
           #-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))))
+            (directory* wild . #.(or #+ccl '(:directories t :files nil)
+                                     #+digitool '(:directories t))))
           #+cormanlisp (cl::directory-subdirs directory))
          #+(or abcl allegro lispworks scl)
@@ -3347,30 +3432,31 @@
 
 (defun* validate-source-registry-directive (directive)
-  (unless
-      (or (member directive '(:default-registry (:default-registry)) :test 'equal)
-          (destructuring-bind (kw &rest rest) directive
-            (case kw
-              ((:include :directory :tree)
-               (and (length=n-p rest 1)
-                    (location-designator-p (first rest))))
-              ((:exclude :also-exclude)
-               (every #'stringp rest))
-              (null rest))))
-    (error "Invalid directive ~S~%" directive))
-  directive)
-
-(defun* validate-source-registry-form (form)
+  (or (member directive '(:default-registry))
+      (and (consp directive)
+           (let ((rest (rest directive)))
+             (case (first directive)
+               ((:include :directory :tree)
+                (and (length=n-p rest 1)
+                     (location-designator-p (first rest))))
+               ((:exclude :also-exclude)
+                (every #'stringp rest))
+               ((:default-registry)
+                (null rest)))))))
+
+(defun* validate-source-registry-form (form &key location)
   (validate-configuration-form
-   form :source-registry 'validate-source-registry-directive "a source registry"))
+   form :source-registry 'validate-source-registry-directive
+   :location location :invalid-form-reporter 'invalid-source-registry))
 
 (defun* validate-source-registry-file (file)
   (validate-configuration-file
-   file 'validate-source-registry-form "a source registry"))
+   file 'validate-source-registry-form :description "a source registry"))
 
 (defun* validate-source-registry-directory (directory)
   (validate-configuration-directory
-   directory :source-registry 'validate-source-registry-directive))
-
-(defun* parse-source-registry-string (string)
+   directory :source-registry 'validate-source-registry-directive
+   :invalid-form-reporter 'invalid-source-registry))
+
+(defun* parse-source-registry-string (string &key location)
   (cond
     ((or (null string) (equal string ""))
@@ -3379,5 +3465,5 @@
      (error "environment string isn't: ~S" string))
     ((find (char string 0) "\"(")
-     (validate-source-registry-form (read-from-string string)))
+     (validate-source-registry-form (read-from-string string) :location location))
     (t
      (loop
@@ -3476,9 +3562,11 @@
   (cond
     ((directory-pathname-p pathname)
-     (process-source-registry (validate-source-registry-directory pathname)
-                              :inherit inherit :register register))
+     (let ((*here-directory* (truenamize pathname)))
+       (process-source-registry (validate-source-registry-directory pathname)
+                                :inherit inherit :register register)))
     ((probe-file pathname)
-     (process-source-registry (validate-source-registry-file pathname)
-                              :inherit inherit :register register))
+     (let ((*here-directory* (pathname-directory-pathname pathname)))
+       (process-source-registry (validate-source-registry-file pathname)
+                                :inherit inherit :register register)))
     (t
      (inherit-source-registry inherit :register register))))
@@ -3528,11 +3616,12 @@
   (remove-duplicates
    (while-collecting (collect)
-     (inherit-source-registry
-      `(wrapping-source-registry
-        ,parameter
-        ,@*default-source-registries*)
-      :register (lambda (directory &key recurse exclude)
-                  (collect (list directory :recurse recurse :exclude exclude)))))
-   :test 'equal :from-end t))
+     (let ((*default-pathname-defaults* (default-directory)))
+       (inherit-source-registry
+        `(wrapping-source-registry
+          ,parameter
+          ,@*default-source-registries*)
+        :register (lambda (directory &key recurse exclude)
+                    (collect (list directory :recurse recurse :exclude exclude)))))
+     :test 'equal :from-end t)))
 
 ;; Will read the configuration and initialize all internal variables,
@@ -3618,4 +3707,9 @@
       (when system-p (appendf (compile-op-flags op) (list :system-p system-p))))))
 
+;;; If a previous version of ASDF failed to read some configuration, try again.
+(when *ignored-configuration-form*
+  (clear-configuration)
+  (setf *ignored-configuration-form* nil))
+
 ;;;; -----------------------------------------------------------------
 ;;;; Done!