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

Raymond Toy rtoy at common-lisp.net
Wed Jun 8 15:42:22 UTC 2011


    Date: Wednesday, June 8, 2011 @ 08:42:22
  Author: rtoy
    Path: /project/cmucl/cvsroot/src/contrib/asdf

Modified: asdf.lisp

Update to release 2.016.


-----------+
 asdf.lisp | 1221 ++++++++++++++++++++++++++++++++++++------------------------
 1 file changed, 747 insertions(+), 474 deletions(-)


Index: src/contrib/asdf/asdf.lisp
diff -u src/contrib/asdf/asdf.lisp:1.14 src/contrib/asdf/asdf.lisp:1.15
--- src/contrib/asdf/asdf.lisp:1.14	Tue Mar 29 21:27:50 2011
+++ src/contrib/asdf/asdf.lisp	Wed Jun  8 08:42:22 2011
@@ -1,5 +1,5 @@
 ;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
-;;; This is ASDF 2.014.1: Another System Definition Facility.
+;;; This is ASDF 2.016: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
 ;;; please mail to <asdf-devel at common-lisp.net>.
@@ -19,7 +19,7 @@
 ;;;  http://www.opensource.org/licenses/mit-license.html on or about
 ;;;  Monday; July 13, 2009)
 ;;;
-;;; Copyright (c) 2001-2010 Daniel Barlow and contributors
+;;; Copyright (c) 2001-2011 Daniel Barlow and contributors
 ;;;
 ;;; Permission is hereby granted, free of charge, to any person obtaining
 ;;; a copy of this software and associated documentation files (the
@@ -49,41 +49,28 @@
 
 (cl:in-package #-genera :common-lisp-user #+genera :future-common-lisp-user)
 
+#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
+(error "ASDF is not supported on your implementation. Please help us with it.")
+
 #+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  ;;; make package if it doesn't exist yet.
-  ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
-  (unless (find-package :asdf)
-    (make-package :asdf :use '(:common-lisp)))
   ;;; Implementation-dependent tweaks
   ;; (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*
-                :test 'equalp :key 'car))
+                :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below
   #+(and ecl (not ecl-bytecmp)) (require :cmp)
   #+(and (or win32 windows mswindows mingw32) (not cygwin)) (pushnew :asdf-windows *features*)
-  #+(or unix cygwin) (pushnew :asdf-unix *features*))
+  #+(or unix cygwin) (pushnew :asdf-unix *features*)
+  ;;; make package if it doesn't exist yet.
+  ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
+  (unless (find-package :asdf)
+    (make-package :asdf :use '(:common-lisp))))
 
 (in-package :asdf)
 
-;;; Strip out formating that is not supported on Genera.
-(defmacro compatfmt (format)
-  #-genera format
-  #+genera
-  (let ((r '(("~@<" . "")
-	     ("; ~@;" . "; ")
-	     ("~3i~_" . "")
-	     ("~@:>" . "")
-	     ("~:>" . ""))))
-    (dolist (i r)
-      (loop :for found = (search (car i) format) :while found :do
-        (setf format (concatenate 'simple-string (subseq format 0 found)
-                                  (cdr i)
-                                  (subseq format (+ found (length (car i))))))))
-    format))
-
 ;;;; Create packages in a way that is compatible with hot-upgrade.
 ;;;; See https://bugs.launchpad.net/asdf/+bug/485687
 ;;;; See more near the end of the file.
@@ -91,6 +78,26 @@
 (eval-when (:load-toplevel :compile-toplevel :execute)
   (defvar *asdf-version* nil)
   (defvar *upgraded-p* nil)
+  (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12.
+  (defun find-symbol* (s p)
+    (find-symbol (string s) p))
+  ;; Strip out formatting that is not supported on Genera.
+  ;; Has to be inside the eval-when to make Lispworks happy (!)
+  (defmacro compatfmt (format)
+    #-genera format
+    #+genera
+    (loop :for (unsupported . replacement) :in
+      '(("~@<" . "")
+        ("; ~@;" . "; ")
+        ("~3i~_" . "")
+        ("~@:>" . "")
+        ("~:>" . "")) :do
+      (loop :for found = (search unsupported format) :while found :do
+        (setf format
+              (concatenate 'simple-string
+                           (subseq format 0 found) replacement
+                           (subseq format (+ found (length unsupported)))))))
+    format)
   (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).
@@ -99,18 +106,18 @@
          ;; "2.345.6" would be a development version in the official upstream
          ;; "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.014.1")
-         (existing-asdf (fboundp 'find-system))
+         (asdf-version "2.016")
+         (existing-asdf (find-class 'component nil))
          (existing-version *asdf-version*)
          (already-there (equal asdf-version existing-version)))
     (unless (and existing-asdf already-there)
-      (when existing-asdf
+      (when (and existing-asdf *asdf-verbose*)
         (format *trace-output*
-		(compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
-		existing-version asdf-version))
+                (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
+                existing-version asdf-version))
       (labels
           ((present-symbol-p (symbol package)
-             (member (nth-value 1 (find-sym symbol package)) '(:internal :external)))
+             (member (nth-value 1 (find-symbol* symbol package)) '(:internal :external)))
            (present-symbols (package)
              ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera
              (let (l)
@@ -140,14 +147,12 @@
                     p)
                    (t
                     (make-package name :nicknames nicknames :use use))))))
-           (find-sym (symbol package)
-             (find-symbol (string symbol) package))
            (intern* (symbol package)
              (intern (string symbol) package))
            (remove-symbol (symbol package)
-             (let ((sym (find-sym symbol package)))
+             (let ((sym (find-symbol* symbol package)))
                (when sym
-                 (unexport sym package)
+                 #-cormanlisp (unexport sym package)
                  (unintern sym package)
                  sym)))
            (ensure-unintern (package symbols)
@@ -156,19 +161,19 @@
                :for removed = (remove-symbol sym package)
                :when removed :do
                (loop :for p :in packages :do
-                 (when (eq removed (find-sym sym p))
+                 (when (eq removed (find-symbol* sym p))
                    (unintern removed p)))))
            (ensure-shadow (package symbols)
              (shadow symbols package))
            (ensure-use (package use)
              (dolist (used (reverse use))
                (do-external-symbols (sym used)
-                 (unless (eq sym (find-sym sym package))
+                 (unless (eq sym (find-symbol* sym package))
                    (remove-symbol sym package)))
                (use-package used package)))
            (ensure-fmakunbound (package symbols)
              (loop :for name :in symbols
-               :for sym = (find-sym name package)
+               :for sym = (find-symbol* name package)
                :when sym :do (fmakunbound sym)))
            (ensure-export (package export)
              (let ((formerly-exported-symbols nil)
@@ -184,7 +189,7 @@
                (loop :for user :in (package-used-by-list package)
                  :for shadowing = (package-shadowing-symbols user) :do
                  (loop :for new :in newly-exported-symbols
-                   :for old = (find-sym new user)
+                   :for old = (find-symbol* new user)
                    :when (and old (not (member old shadowing)))
                    :do (unintern old user)))
                (loop :for x :in newly-exported-symbols :do
@@ -213,7 +218,7 @@
             #:perform-with-restarts #:component-relative-pathname
             #:system-source-file #:operate #:find-component #:find-system
             #:apply-output-translations #:translate-pathname* #:resolve-location
-            #:compile-file*)
+            #:compile-file* #:source-file-type)
            :unintern
            (#:*asdf-revision* #:around #:asdf-method-combination
             #:split #:make-collector
@@ -225,7 +230,8 @@
             #:inherit-source-registry #:process-source-registry-directive)
            :export
            (#:defsystem #:oos #:operate #:find-system #:run-shell-command
-            #:system-definition-pathname #:find-component ; miscellaneous
+            #:system-definition-pathname #:with-system-definitions
+            #:search-for-system-definition #:find-component ; miscellaneous
             #:compile-system #:load-system #:test-system #:clear-system
             #:compile-op #:load-op #:load-source-op
             #:test-op
@@ -233,12 +239,15 @@
             #:feature                 ; sort-of operation
             #:version                 ; metaphorically sort-of an operation
             #:version-satisfies
+            #:upgrade-asdf
+            #:implementation-identifier #:implementation-type
 
             #:input-files #:output-files #:output-file #:perform ; operation methods
             #:operation-done-p #:explain
 
             #:component #:source-file
             #:c-source-file #:cl-source-file #:java-source-file
+            #:cl-source-file.cl #:cl-source-file.lsp
             #:static-file
             #:doc-file
             #:html-file
@@ -349,7 +358,7 @@
             #:subdirectories
             #:truenamize
             #:while-collecting)))
-	#+genera (import 'scl:boolean :asdf)
+        #+genera (import 'scl:boolean :asdf)
         (setf *asdf-version* asdf-version
               *upgraded-p* (if existing-version
                                (cons existing-version *upgraded-p*)
@@ -361,7 +370,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) \"2.013\")."
+(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")."
   *asdf-version*)
 
 (defvar *resolve-symlinks* t
@@ -382,8 +391,6 @@
 
 (defvar *verbose-out* nil)
 
-(defvar *asdf-verbose* t)
-
 (defparameter +asdf-methods+
   '(perform-with-restarts perform explain output-files operation-done-p))
 
@@ -396,6 +403,41 @@
     (setf excl:*warn-on-nested-reader-conditionals* nil)))
 
 ;;;; -------------------------------------------------------------------------
+;;;; Resolve forward references
+
+(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
+                circular-dependency-components
+                condition-arguments condition-form
+                condition-format condition-location
+                coerce-name)
+         #-cormanlisp
+         (ftype (function (t t) t) (setf module-components-by-name)))
+
+;;;; -------------------------------------------------------------------------
+;;;; Compatibility with Corman Lisp
+#+cormanlisp
+(progn
+  (deftype logical-pathname () nil)
+  (defun make-broadcast-stream () *error-output*)
+  (defun file-namestring (p)
+    (setf p (pathname p))
+    (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))
+  (defparameter *count* 3)
+  (defun dbg (&rest x)
+    (format *error-output* "~S~%" x)))
+#+cormanlisp
+(defun maybe-break ()
+  (decf *count*)
+  (unless (plusp *count*)
+    (setf *count* 3)
+    (break)))
+
+;;;; -------------------------------------------------------------------------
 ;;;; General Purpose Utilities
 
 (macrolet
@@ -403,8 +445,9 @@
        `(defmacro ,def* (name formals &rest rest)
           `(progn
              #+(or ecl gcl) (fmakunbound ',name)
-             ,(when (and #+ecl (symbolp name))
-                `(declaim (notinline ,name))) ; fails for setf functions on ecl
+             #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
+             ,(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
+                `(declaim (notinline ,name)))
              (,',def ,name ,formals , at rest)))))
   (defdef defgeneric* defgeneric)
   (defdef defun* defun))
@@ -512,7 +555,8 @@
 and NIL NAME, TYPE and VERSION components"
   (when pathname
     (make-pathname :name nil :type nil :version nil
-                   :directory (merge-pathname-directory-components '(:relative :back) (pathname-directory pathname))
+                   :directory (merge-pathname-directory-components
+                               '(:relative :back) (pathname-directory pathname))
                    :defaults pathname)))
 
 
@@ -528,10 +572,10 @@
 (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))
+  (apply 'format *verbose-out* format-string format-args))
 
 (defun* split-string (string &key max (separator '(#\Space #\Tab)))
   "Split STRING into a list of components separated by
@@ -539,10 +583,10 @@
 If MAX is specified, then no more than max(1,MAX) components will be returned,
 starting the separation from the end, e.g. when called with arguments
  \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
-  (block nil
+  (catch nil
     (let ((list nil) (words 0) (end (length string)))
       (flet ((separatorp (char) (find char separator))
-             (done () (return (cons (subseq string 0 end) list))))
+             (done () (throw nil (cons (subseq string 0 end) list))))
         (loop
           :for start = (if (and max (>= words (1- max)))
                            (done)
@@ -622,10 +666,20 @@
 
 (defun* getenv (x)
   (declare (ignorable x))
-  #+(or abcl clisp) (ext:getenv x)
+  #+(or abcl clisp xcl) (ext:getenv x)
   #+allegro (sys:getenv x)
   #+clozure (ccl:getenv x)
   #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
+  #+cormanlisp
+  (let* ((buffer (ct:malloc 1))
+         (cname (ct:lisp-string-to-c-string x))
+         (needed-size (win:getenvironmentvariable cname buffer 0))
+         (buffer1 (ct:malloc (1+ needed-size))))
+    (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
+               nil
+               (ct:c-string-to-lisp-string buffer1))
+      (ct:free buffer)
+      (ct:free buffer1)))
   #+ecl (si:getenv x)
   #+gcl (system:getenv x)
   #+genera nil
@@ -635,8 +689,8 @@
             (unless (ccl:%null-ptr-p value)
               (ccl:%get-cstring value))))
   #+sbcl (sb-ext:posix-getenv x)
-  #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl sbcl scl)
-  (error "getenv not available on your implementation"))
+  #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
+  (error "~S is not supported on your implementation" 'getenv))
 
 (defun* directory-pathname-p (pathname)
   "Does PATHNAME represent a directory?
@@ -712,6 +766,7 @@
                   '(ffi:clines "#include <sys/types.h>" "#include <unistd.h>"))
   (defun* get-uid ()
     #+allegro (excl.osi:getuid)
+    #+ccl (ccl::getuid)
     #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid")
                   :for f = (ignore-errors (read-from-string s))
                   :when f :return (funcall f))
@@ -720,7 +775,7 @@
                    '(ffi:c-inline () () :int "getuid()" :one-liner t)
                    '(ext::getuid))
     #+sbcl (sb-unix:unix-getuid)
-    #-(or allegro clisp cmu ecl sbcl scl)
+    #-(or allegro ccl clisp cmu ecl sbcl scl)
     (let ((uid-string
            (with-output-to-string (*verbose-out*)
              (run-shell-command "id -ur"))))
@@ -732,22 +787,21 @@
 (defun* pathname-root (pathname)
   (make-pathname :directory '(:absolute)
                  :name nil :type nil :version nil
-                 :defaults pathname ;; host device, and on scl scheme scheme-specific-part port username password
+                 :defaults pathname ;; host device, and on scl, *some*
+                 ;; scheme-specific parts: port username password, not others:
                  . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
 
-(defun* find-symbol* (s p)
-  (find-symbol (string s) p))
-
 (defun* probe-file* (p)
   "when given a pathname P, probes the filesystem for a file or directory
 with given pathname and if it exists return its truename."
   (etypecase p
-   (null nil)
-   (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) `(ignore-errors (,it p)))
-                     '(ignore-errors (truename p)))))))
+    (null nil)
+    (string (probe-file* (parse-namestring p)))
+    (pathname (unless (wild-pathname-p p)
+                #.(or #+(or allegro clozure cmu cormanlisp ecl sbcl scl) '(probe-file p)
+                      #+clisp (aif (find-symbol* '#:probe-pathname :ext)
+                                   `(ignore-errors (,it p)))
+                      '(ignore-errors (truename p)))))))
 
 (defun* truenamize (p)
   "Resolve as much of a pathname as possible"
@@ -788,16 +842,32 @@
                 path
                 (excl:pathname-resolve-symbolic-links path)))
 
+(defun* resolve-symlinks* (path)
+  (if *resolve-symlinks*
+      (and path (resolve-symlinks path))
+      path))
+
+(defun ensure-pathname-absolute (path)
+  (cond
+    ((absolute-pathname-p path) path)
+    ((stringp path) (ensure-pathname-absolute (pathname path)))
+    ((not (pathnamep path)) (error "not a valid pathname designator ~S" path))
+    (t (let ((resolved (resolve-symlinks path)))
+         (assert (absolute-pathname-p resolved))
+         resolved))))
+
 (defun* default-directory ()
   (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
 
 (defun* lispize-pathname (input-file)
   (make-pathname :type "lisp" :defaults input-file))
 
+(defparameter *wild* #-cormanlisp :wild #+cormanlisp "*")
 (defparameter *wild-file*
-  (make-pathname :name :wild :type :wild :version :wild :directory nil))
+  (make-pathname :name *wild* :type *wild*
+                 :version (or #-(or abcl xcl) *wild*) :directory nil))
 (defparameter *wild-directory*
-  (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil))
+  (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*
@@ -834,27 +904,27 @@
 #+scl
 (defun* directorize-pathname-host-device (pathname)
   (let ((scheme (ext:pathname-scheme pathname))
-	(host (pathname-host pathname))
-	(port (ext:pathname-port pathname))
-	(directory (pathname-directory pathname)))
+        (host (pathname-host pathname))
+        (port (ext:pathname-port pathname))
+        (directory (pathname-directory pathname)))
     (flet ((not-unspecific (component)
-	     (and (not (eq component :unspecific)) component)))
+             (and (not (eq component :unspecific)) component)))
       (cond ((or (not-unspecific port)
-		 (and (not-unspecific host) (plusp (length host)))
-		 (not-unspecific scheme))
-	     (let ((prefix ""))
-	       (when (not-unspecific port)
-		 (setf prefix (format nil ":~D" port)))
-	       (when (and (not-unspecific host) (plusp (length host)))
-		 (setf prefix (concatenate 'string host prefix)))
-	       (setf prefix (concatenate 'string ":" prefix))
-	       (when (not-unspecific scheme)
-	       (setf prefix (concatenate 'string scheme prefix)))
-	       (assert (and directory (eq (first directory) :absolute)))
-	       (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
-			      :defaults pathname)))
-	    (t
-	     pathname)))))
+                 (and (not-unspecific host) (plusp (length host)))
+                 (not-unspecific scheme))
+             (let ((prefix ""))
+               (when (not-unspecific port)
+                 (setf prefix (format nil ":~D" port)))
+               (when (and (not-unspecific host) (plusp (length host)))
+                 (setf prefix (concatenate 'string host prefix)))
+               (setf prefix (concatenate 'string ":" prefix))
+               (when (not-unspecific scheme)
+               (setf prefix (concatenate 'string scheme prefix)))
+               (assert (and directory (eq (first directory) :absolute)))
+               (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
+                              :defaults pathname)))
+            (t
+             pathname)))))
 
 ;;;; -------------------------------------------------------------------------
 ;;;; ASDF Interface, in terms of generic functions.
@@ -891,6 +961,9 @@
 
 (defgeneric* (setf component-property) (new-value component property))
 
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defgeneric* (setf module-components-by-name) (new-value module)))
+
 (defgeneric* version-satisfies (component version))
 
 (defgeneric* find-component (base path)
@@ -967,12 +1040,12 @@
 (when *upgraded-p*
    (when (find-class 'module nil)
      (eval
-      `(defmethod update-instance-for-redefined-class :after
+      '(defmethod update-instance-for-redefined-class :after
            ((m module) added deleted plist &key)
          (declare (ignorable deleted plist))
-         (when (or *asdf-verbose* *load-verbose*)
+         (when *asdf-verbose*
            (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%")
-			 m ,(asdf-version)))
+                         m (asdf-version)))
          (when (member 'components-by-name added)
            (compute-module-components-by-name m))
          (when (typep m 'system)
@@ -994,44 +1067,31 @@
   ;; 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
-                circular-dependency-components
-                condition-arguments condition-form
-                condition-format condition-location
-                coerce-name)
-         (ftype (function (t t) t) (setf module-components-by-name)))
-
-
 (define-condition formatted-system-definition-error (system-definition-error)
   ((format-control :initarg :format-control :reader format-control)
    (format-arguments :initarg :format-arguments :reader format-arguments))
   (:report (lambda (c s)
-               (apply #'format s (format-control c) (format-arguments c)))))
+               (apply 'format s (format-control c) (format-arguments c)))))
 
 (define-condition load-system-definition-error (system-definition-error)
   ((name :initarg :name :reader error-name)
    (pathname :initarg :pathname :reader error-pathname)
    (condition :initarg :condition :reader error-condition))
   (:report (lambda (c s)
-	     (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>")
-		     (error-name c) (error-pathname c) (error-condition c)))))
+             (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>")
+                     (error-name c) (error-pathname c) (error-condition c)))))
 
 (define-condition circular-dependency (system-definition-error)
   ((components :initarg :components :reader circular-dependency-components))
   (:report (lambda (c s)
-	     (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
-		     (circular-dependency-components c)))))
+             (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
+                     (circular-dependency-components c)))))
 
 (define-condition duplicate-names (system-definition-error)
   ((name :initarg :name :reader duplicate-names-name))
   (:report (lambda (c s)
-	     (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>")
-		     (duplicate-names-name c)))))
+             (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>")
+                     (duplicate-names-name c)))))
 
 (define-condition missing-component (system-definition-error)
   ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
@@ -1073,8 +1133,11 @@
   ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
 
 (defclass component ()
-  ((name :accessor component-name :initarg :name :documentation
+  ((name :accessor component-name :initarg :name :type string :documentation
          "Component name: designator for a string composed of portable pathname characters")
+   ;; We might want to constrain version with
+   ;; :type (and string (satisfies parse-version))
+   ;; but we cannot until we fix all systems that don't use it correctly!
    (version :accessor component-version :initarg :version)
    (description :accessor component-description :initarg :description)
    (long-description :accessor component-long-description :initarg :long-description)
@@ -1154,7 +1217,7 @@
           (missing-requires c)
           (missing-version c)
           (when (missing-parent c)
-            (component-name (missing-parent c)))))
+            (coerce-name (missing-parent c)))))
 
 (defmethod component-system ((component component))
   (aif (component-parent component)
@@ -1244,21 +1307,41 @@
 
 (defmethod version-satisfies ((c component) version)
   (unless (and version (slot-boundp c 'version))
+    (when version
+      (warn "Requested version ~S but component ~S has no version" version c))
     (return-from version-satisfies t))
   (version-satisfies (component-version c) version))
 
+(defun parse-version (string &optional on-error)
+  "Parse a version string as a series of natural integers separated by dots.
+Return a (non-null) list of integers if the string is valid, NIL otherwise.
+If on-error is error, warn, or designates a function of compatible signature,
+the function is called with an explanation of what is wrong with the argument.
+NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3"
+  (and
+   (or (stringp string)
+       (when on-error
+         (funcall on-error "~S: ~S is not a string"
+                  'parse-version string)) nil)
+   (or (loop :for prev = nil :then c :for c :across string
+         :always (or (digit-char-p c)
+                     (and (eql c #\.) prev (not (eql prev #\.))))
+         :finally (return (and c (digit-char-p c))))
+       (when on-error
+         (funcall on-error "~S: ~S doesn't follow asdf version numbering convention"
+                  'parse-version string)) nil)
+   (mapcar #'parse-integer (split-string string :separator "."))))
+
 (defmethod version-satisfies ((cver string) version)
-  (let ((x (mapcar #'parse-integer
-                   (split-string cver :separator ".")))
-        (y (mapcar #'parse-integer
-                   (split-string version :separator "."))))
+  (let ((x (parse-version cver 'warn))
+        (y (parse-version version 'warn)))
     (labels ((bigger (x y)
                (cond ((not y) t)
                      ((not x) nil)
                      ((> (car x) (car y)) t)
                      ((= (car x) (car y))
                       (bigger (cdr x) (cdr y))))))
-      (and (= (car x) (car y))
+      (and x y (= (car x) (car y))
            (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
 
 ;;;; -------------------------------------------------------------------------
@@ -1284,12 +1367,21 @@
 (defun* system-registered-p (name)
   (gethash (coerce-name name) *defined-systems*))
 
+(defun* register-system (system)
+  (check-type system system)
+  (let ((name (component-name system)))
+    (check-type name string)
+    (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system)
+    (unless (eq system (cdr (gethash name *defined-systems*)))
+      (setf (gethash name *defined-systems*)
+            (cons (get-universal-time) system)))))
+
 (defun* clear-system (name)
   "Clear the entry for a system in the database of systems previously loaded.
 Note that this does NOT in any way cause the code of the system to be unloaded."
-  ;; 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
-  ;; to global data structures.
+  ;; 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 to global data structures.
   (remhash (coerce-name name) *defined-systems*))
 
 (defun* map-systems (fn)
@@ -1308,16 +1400,14 @@
 ;;; convention that functions in this list are prefixed SYSDEF-
 
 (defparameter *system-definition-search-functions*
-  '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf))
+  '(sysdef-central-registry-search
+    sysdef-source-registry-search
+    sysdef-find-asdf))
 
-(defun* system-definition-pathname (system)
+(defun* search-for-system-definition (system)
   (let ((system-name (coerce-name system)))
-    (or
-     (some #'(lambda (x) (funcall x system-name))
-           *system-definition-search-functions*)
-     (let ((system-pair (system-registered-p system-name)))
-       (and system-pair
-            (system-source-file (cdr system-pair)))))))
+    (some #'(lambda (x) (funcall x system-name))
+          (cons 'find-system-if-being-defined *system-definition-search-functions*))))
 
 (defvar *central-registry* nil
 "A list of 'system directory designators' ASDF uses to find systems.
@@ -1381,8 +1471,8 @@
                             (push dir to-remove))
                           (coerce-entry-to-directory ()
                             :report (lambda (s)
-				      (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>")
-					      (ensure-directory-pathname defaults) dir))
+                                      (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>")
+                                              (ensure-directory-pathname defaults) dir))
                             (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
         ;; cleanup
         (dolist (dir to-remove)
@@ -1414,72 +1504,98 @@
   ;; and we can survive and we will continue the planning
   ;; as if the file were very old.
   ;; (or should we treat the case in a different, special way?)
-  (or (and pathname (probe-file* pathname) (file-write-date pathname))
+  (or (and pathname (probe-file* pathname) (ignore-errors (file-write-date pathname)))
       (progn
         (when (and pathname *asdf-verbose*)
           (warn (compatfmt "~@<Missing FILE-WRITE-DATE for ~S, treating it as zero.~@:>")
                 pathname))
         0)))
 
+(defmethod find-system ((name null) &optional (error-p t))
+  (when error-p
+    (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
+
 (defmethod find-system (name &optional (error-p t))
   (find-system (coerce-name name) error-p))
 
-(defun load-sysdef (name pathname)
+(defvar *systems-being-defined* nil
+  "A hash-table of systems currently being defined keyed by name, or NIL")
+
+(defun* find-system-if-being-defined (name)
+  (when *systems-being-defined*
+    (gethash (coerce-name name) *systems-being-defined*)))
+
+(defun* call-with-system-definitions (thunk)
+  (if *systems-being-defined*
+      (funcall thunk)
+      (let ((*systems-being-defined* (make-hash-table :test 'equal)))
+        (funcall thunk))))
+
+(defmacro with-system-definitions (() &body body)
+  `(call-with-system-definitions #'(lambda () , at body)))
+
+(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 (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
-			   pathname package)
-             (load pathname)))
-      (delete-package package))))
+  (with-system-definitions ()
+    (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 (compatfmt "~&~@<; ~@;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
+  (with-system-definitions ()
     (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)
+           (previous (cdr in-memory))
+           (previous (and (typep previous 'system) previous))
+           (previous-time (car in-memory))
+           (found (search-for-system-definition name))
+           (found-system (and (typep found 'system) found))
+           (pathname (or (and (typep found '(or pathname string)) (pathname found))
+                         (and found-system (system-source-file found-system))
+                         (and previous (system-source-file previous)))))
+      (setf pathname (resolve-symlinks* pathname))
+      (when (and pathname (not (absolute-pathname-p pathname)))
+        (setf pathname (ensure-pathname-absolute pathname))
+        (when found-system
+          (%set-system-source-file pathname found-system)))
+      (when (and previous (not (#-cormanlisp equal #+cormanlisp equalp
+                                             (system-source-file previous) pathname)))
+        (%set-system-source-file pathname previous)
+        (setf previous-time nil))
+      (when (and found-system (not previous))
+        (register-system found-system))
+      (when (and pathname
+                 (or (not previous-time)
                      ;; 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))
+                     (< previous-time (safe-file-write-date pathname) (get-universal-time))))
+        (load-sysdef name pathname))
       (let ((in-memory (system-registered-p name))) ; try again after loading from disk
         (cond
           (in-memory
-           (when on-disk
-             (setf (car in-memory) (safe-file-write-date on-disk)))
+           (when pathname
+             (setf (car in-memory) (safe-file-write-date pathname)))
            (cdr in-memory))
           (error-p
            (error 'missing-component :requires name)))))))
 
-(defun* register-system (name system)
-  (setf name (coerce-name name))
-  (assert (equal name (component-name system)))
-  (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system)
-  (setf (gethash name *defined-systems*) (cons (get-universal-time) system)))
-
 (defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
   (setf fallback (coerce-name fallback)
-        source-file (or source-file
-                        (if *resolve-symlinks*
-                            (or *compile-file-truename* *load-truename*)
-                            (or *compile-file-pathname* *load-pathname*)))
         requested (coerce-name requested))
   (when (equal requested fallback)
-    (let* ((registered (cdr (gethash fallback *defined-systems*)))
-           (system (or registered
-                       (apply 'make-instance 'system
-                              :name fallback :source-file source-file keys))))
-      (unless registered
-        (register-system fallback system))
-      (throw 'find-system system))))
+    (let ((registered (cdr (gethash fallback *defined-systems*))))
+      (or registered
+          (apply 'make-instance 'system
+                 :name fallback :source-file source-file keys)))))
 
 (defun* sysdef-find-asdf (name)
   ;; Bug: :version *asdf-version* won't be updated when ASDF is updated.
@@ -1523,6 +1639,10 @@
 
 (defclass cl-source-file (source-file)
   ((type :initform "lisp")))
+(defclass cl-source-file.cl (cl-source-file)
+  ((type :initform "cl")))
+(defclass cl-source-file.lsp (cl-source-file)
+  ((type :initform "lsp")))
 (defclass c-source-file (source-file)
   ((type :initform "c")))
 (defclass java-source-file (source-file)
@@ -1572,12 +1692,13 @@
               (values filename type))
              (t
               (split-name-type filename)))
-         (make-pathname :directory `(,relative , at path) :name name :type type
-                        :defaults (or defaults *default-pathname-defaults*)))))))
+         (apply 'make-pathname :directory (cons relative path) :name name :type type
+                (when defaults `(:defaults ,defaults))))))))
 
 (defun* merge-component-name-type (name &key type defaults)
   ;; For backwards compatibility only, for people using internals.
-  ;; Will be removed in a future release, e.g. 2.014.
+  ;; Will be removed in a future release, e.g. 2.016.
+  (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.")
   (coerce-pathname name :type type :defaults defaults))
 
 (defmethod component-relative-pathname ((component component))
@@ -1593,15 +1714,14 @@
 ;;; one of these is instantiated whenever #'operate is called
 
 (defclass operation ()
-  (
-   ;; as of danb's 2003-03-16 commit e0d02781, :force can be:
-   ;; T to force the inside of existing system,
+  (;; as of danb's 2003-03-16 commit e0d02781, :force can be:
+   ;; T to force the inside of the specified system,
    ;;   but not recurse to other systems we depend on.
    ;; :ALL (or any other atom) to force all systems
    ;;   including other systems we depend on.
    ;; (SYSTEM1 SYSTEM2 ... SYSTEMN)
    ;;   to force systems named in a given list
-   ;; However, but this feature never worked before ASDF 1.700 and is currently cerror'ed out.
+   ;; However, but this feature has only ever worked but starting with ASDF 2.014.5
    (forced :initform nil :initarg :force :accessor operation-forced)
    (original-initargs :initform nil :initarg :original-initargs
                       :accessor operation-original-initargs)
@@ -1643,13 +1763,13 @@
                 (not (eql c dep-c)))
            (when (eql force-p t)
              (setf (getf args :force) nil))
-           (apply #'make-instance dep-o
+           (apply 'make-instance dep-o
                   :parent o
                   :original-initargs args args))
           ((subtypep (type-of o) dep-o)
            o)
           (t
-           (apply #'make-instance dep-o
+           (apply 'make-instance dep-o
                   :parent o :original-initargs args args)))))
 
 
@@ -1681,11 +1801,13 @@
     (gethash node (operation-visiting-nodes (operation-ancestor o)))))
 
 (defmethod component-depends-on ((op-spec symbol) (c component))
+  ;; Note: we go from op-spec to operation via make-instance
+  ;; to allow for specialization through defmethod's, even though
+  ;; it's a detour in the default case below.
   (component-depends-on (make-instance op-spec) c))
 
 (defmethod component-depends-on ((o operation) (c component))
-  (cdr (assoc (class-name (class-of o))
-              (component-in-order-to c))))
+  (cdr (assoc (type-of o) (component-in-order-to c))))
 
 (defmethod component-self-dependencies ((o operation) (c component))
   (let ((all-deps (component-depends-on o c)))
@@ -1802,13 +1924,13 @@
                              required-op required-c required-v))
       (retry ()
         :report (lambda (s)
-		  (format s "~@<Retry loading component ~3i~_~S.~@:>" required-c))
+                  (format s "~@<Retry loading ~3i~_~A.~@:>" required-c))
         :test
         (lambda (c)
-	  (or (null c)
-	      (and (typep c 'missing-dependency)
-		   (equalp (missing-requires c)
-			   required-c))))))))
+          (or (null c)
+              (and (typep c 'missing-dependency)
+                   (equalp (missing-requires c)
+                           required-c))))))))
 
 (defun* do-dep (operation c collect op dep)
   ;; type of arguments uncertain:
@@ -1855,11 +1977,11 @@
   (funcall collect x))
 
 (defmethod do-traverse ((operation operation) (c component) collect)
-  (let ((flag nil)) ;; return value: must we rebuild this and its dependencies?
+  (let ((*forcing* *forcing*)
+        (flag nil)) ;; return value: must we rebuild this and its dependencies?
     (labels
         ((update-flag (x)
-           (when x
-             (setf flag t)))
+           (orf flag x))
          (dep (op comp)
            (update-flag (do-dep operation c collect op comp))))
       ;; Have we been visited yet? If so, just process the result.
@@ -1873,6 +1995,13 @@
       (setf (visiting-component operation c) t)
       (unwind-protect
            (progn
+             (let ((f (operation-forced
+                       (operation-ancestor operation))))
+               (when (and f (or (not (consp f)) ;; T or :ALL
+                                (and (typep c 'system) ;; list of names of systems to force
+                                     (member (component-name c) f
+                                             :test #'string=))))
+                 (setf *forcing* t)))
              ;; first we check and do all the dependencies for the module.
              ;; Operations planned in this loop will show up
              ;; in the results, and are consumed below.
@@ -1912,22 +2041,13 @@
                                          :try-next)
                                      (not at-least-one))
                             (error error)))))))
-               (update-flag
-                (or
-                 *forcing*
-                 (not (operation-done-p operation c))
+               (update-flag (or *forcing* (not (operation-done-p operation c))))
                  ;; For sub-operations, check whether
                  ;; the original ancestor operation was forced,
                  ;; or names us amongst an explicit list of things to force...
                  ;; except that this check doesn't distinguish
                  ;; between all the things with a given name. Sigh.
                  ;; BROKEN!
-                 (let ((f (operation-forced
-                           (operation-ancestor operation))))
-                   (and f (or (not (consp f)) ;; T or :ALL
-                              (and (typep c 'system) ;; list of names of systems to force
-                                   (member (component-name c) f
-                                           :test #'string=)))))))
                (when flag
                  (let ((do-first (cdr (assoc (class-name (class-of operation))
                                              (component-do-first c)))))
@@ -1956,12 +2076,7 @@
       (r* l))))
 
 (defmethod traverse ((operation operation) (c component))
-  ;; cerror'ing a feature that seems to have NEVER EVER worked
-  ;; ever since danb created it in his 2003-03-16 commit e0d02781.
-  ;; It was both fixed and disabled in the 1.700 rewrite.
   (when (consp (operation-forced operation))
-    (cerror "Continue nonetheless."
-            "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.")
     (setf (operation-forced operation)
           (mapcar #'coerce-name (operation-forced operation))))
   (flatten-tree
@@ -1979,11 +2094,12 @@
   nil)
 
 (defmethod explain ((operation operation) (component component))
-  (asdf-message "~&;;; ~A~%" (operation-description operation component)))
+  (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%")
+                (operation-description operation component)))
 
 (defmethod operation-description (operation component)
-  (format nil (compatfmt "~@<~A on component ~S~@:>")
-	  (class-of operation) (component-find-path component)))
+  (format nil (compatfmt "~@<~A on ~A~@:>")
+          (class-of operation) component))
 
 ;;;; -------------------------------------------------------------------------
 ;;;; compile-op
@@ -2030,13 +2146,8 @@
     (multiple-value-bind (output warnings-p failure-p)
         (apply *compile-op-compile-file-function* source-file :output-file output-file
                (compile-op-flags operation))
-      (when warnings-p
-        (case (operation-on-warnings operation)
-          (:warn (warn
-                  (compatfmt "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>")
-                  operation c))
-          (:error (error 'compile-warned :component c :operation operation))
-          (:ignore nil)))
+      (unless output
+        (error 'compile-error :component c :operation operation))
       (when failure-p
         (case (operation-on-failure operation)
           (:warn (warn
@@ -2044,8 +2155,13 @@
                   operation c))
           (:error (error 'compile-failed :component c :operation operation))
           (:ignore nil)))
-      (unless output
-        (error 'compile-error :component c :operation operation)))))
+      (when warnings-p
+        (case (operation-on-warnings operation)
+          (:warn (warn
+                  (compatfmt "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>")
+                  operation c))
+          (:error (error 'compile-warned :component c :operation operation))
+          (:ignore nil))))))
 
 (defmethod output-files ((operation compile-op) (c cl-source-file))
   (declare (ignorable operation))
@@ -2067,7 +2183,12 @@
 
 (defmethod operation-description ((operation compile-op) component)
   (declare (ignorable operation))
-  (format nil "compiling component ~S" (component-find-path component)))
+  (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") component))
+
+(defmethod operation-description ((operation compile-op) (component module))
+  (declare (ignorable operation))
+  (format nil (compatfmt "~@<compiled ~3i~_~A~@:>") component))
+
 
 ;;;; -------------------------------------------------------------------------
 ;;;; load-op
@@ -2080,6 +2201,7 @@
   (map () #'load (input-files o c)))
 
 (defmethod perform-with-restarts (operation component)
+  ;;(when *asdf-verbose* (explain operation component)) ; TOO verbose, especially as the default.
   (perform operation component))
 
 (defmethod perform-with-restarts ((o load-op) (c cl-source-file))
@@ -2094,7 +2216,7 @@
        (setf state :success))
       (:failed-load
        (setf state :recompiled)
-       (perform (make-instance 'compile-op) c))
+       (perform (make-sub-operation c o c 'compile-op) c))
       (t
        (with-simple-restart
            (try-recompiling "Recompile ~a and try loading it again"
@@ -2142,9 +2264,18 @@
 
 (defmethod operation-description ((operation load-op) component)
   (declare (ignorable operation))
-  (format nil (compatfmt "~@<Loading component: ~3i~_~S~@:>")
-	  (component-find-path component)))
+  (format nil (compatfmt "~@<loading ~3i~_~A~@:>")
+          component))
+
+(defmethod operation-description ((operation load-op) (component cl-source-file))
+  (declare (ignorable operation))
+  (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>")
+          component))
 
+(defmethod operation-description ((operation load-op) (component module))
+  (declare (ignorable operation))
+  (format nil (compatfmt "~@<loaded ~3i~_~A~@:>")
+          component))
 
 ;;;; -------------------------------------------------------------------------
 ;;;; load-source-op
@@ -2166,16 +2297,12 @@
   (declare (ignorable operation c))
   nil)
 
-;;; FIXME: we simply copy load-op's dependencies.  this is Just Not Right.
+;;; FIXME: We simply copy load-op's dependencies.  This is Just Not Right.
 (defmethod component-depends-on ((o load-source-op) (c component))
   (declare (ignorable o))
-  (let ((what-would-load-op-do (cdr (assoc 'load-op
-                                           (component-in-order-to c)))))
-    (mapcar #'(lambda (dep)
-                (if (eq (car dep) 'load-op)
-                    (cons 'load-source-op (cdr dep))
-                    dep))
-            what-would-load-op-do)))
+  (loop :with what-would-load-op-do = (component-depends-on 'load-op c)
+    :for (op . co) :in what-would-load-op-do
+    :when (eq op 'load-op) :collect (cons 'load-source-op co)))
 
 (defmethod operation-done-p ((o load-source-op) (c source-file))
   (declare (ignorable o))
@@ -2186,8 +2313,12 @@
 
 (defmethod operation-description ((operation load-source-op) component)
   (declare (ignorable operation))
-  (format nil (compatfmt "~@<Loading component: ~3i~_~S~@:>")
-	  (component-find-path component)))
+  (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>")
+          component))
+
+(defmethod operation-description ((operation load-source-op) (component module))
+  (declare (ignorable operation))
+  (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") component))
 
 
 ;;;; -------------------------------------------------------------------------
@@ -2213,48 +2344,93 @@
 ;;;; Invoking Operations
 
 (defgeneric* operate (operation-class system &key &allow-other-keys))
+(defgeneric* perform-plan (plan &key))
+
+;;;; Try to upgrade of ASDF. If a different version was used, return T.
+;;;; We need do that before we operate on anything that depends on ASDF.
+(defun* upgrade-asdf ()
+  (let ((version (asdf:asdf-version)))
+    (handler-bind (((or style-warning warning) #'muffle-warning))
+      (operate 'load-op :asdf :verbose nil))
+    (let ((new-version (asdf:asdf-version)))
+      (block nil
+        (cond
+          ((equal version new-version)
+           (return nil))
+          ((version-satisfies new-version version)
+           (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
+                         version new-version))
+          ((version-satisfies version new-version)
+           (warn (compatfmt "~&~@<Downgraded ASDF from version ~A to version ~A~@:>~%")
+                 version new-version))
+          (t
+           (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
+                         version new-version)))
+        (let ((asdf (find-system :asdf)))
+          ;; invalidate all systems but ASDF itself
+          (setf *defined-systems* (make-defined-systems-table))
+          (register-system asdf)
+          t)))))
+
+(defmethod perform-plan ((steps list) &key)
+  (let ((*package* *package*)
+        (*readtable* *readtable*))
+    (with-compilation-unit ()
+      (loop :for (op . component) :in steps :do
+        (loop
+          (restart-case
+              (progn
+                (perform-with-restarts op component)
+                (return))
+            (retry ()
+              :report
+              (lambda (s)
+                (format s (compatfmt "~@<Retry ~A.~@:>")
+                        (operation-description op component))))
+            (accept ()
+              :report
+              (lambda (s)
+                (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
+                        (operation-description op component)))
+              (setf (gethash (type-of op)
+                             (component-operation-times component))
+                    (get-universal-time))
+              (return))))))))
 
 (defmethod operate (operation-class system &rest args
                     &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force
                     &allow-other-keys)
   (declare (ignore force))
-  (let* ((*package* *package*)
-         (*readtable* *readtable*)
-         (op (apply #'make-instance operation-class
-                    :original-initargs args
-                    args))
-         (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
-         (system (if (typep system 'component) system (find-system system))))
-    (unless (version-satisfies system version)
-      (error 'missing-component-of-version :requires system :version version))
-    (let ((steps (traverse op system)))
-      (with-compilation-unit ()
-        (loop :for (op . component) :in steps :do
-          (loop
-            (restart-case
-                (progn
-                  (perform-with-restarts op component)
-                  (return))
-              (retry ()
-                :report
-                (lambda (s)
-		  (format s (compatfmt "~@<Retry ~A.~@:>")
-			  (operation-description op component))))
-              (accept ()
-                :report
-                (lambda (s)
-		  (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
-			  (operation-description op component)))
-                (setf (gethash (type-of op)
-                               (component-operation-times component))
-                      (get-universal-time))
-                (return))))))
-      (values op steps))))
+  (with-system-definitions ()
+    (let* ((op (apply 'make-instance operation-class
+                      :original-initargs args
+                      args))
+           (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
+           (system (etypecase system
+                     (system system)
+                     ((or string symbol) (find-system system)))))
+      (unless (version-satisfies system version)
+        (error 'missing-component-of-version :requires system :version version))
+      (let ((steps (traverse op system)))
+        (when (and (not (equal '("asdf") (component-find-path system)))
+                   (find '("asdf") (mapcar 'cdr steps)
+                         :test 'equal :key 'component-find-path)
+                   (upgrade-asdf))
+          ;; If we needed to upgrade ASDF to achieve our goal,
+          ;; then do it specially as the first thing, then
+          ;; invalidate all existing system
+          ;; retry the whole thing with the new OPERATE function,
+          ;; which on some implementations
+          ;; has a new symbol shadowing the current one.
+          (return-from operate
+            (apply (find-symbol* 'operate :asdf) operation-class system args)))
+        (perform-plan steps)
+        (values op steps)))))
 
 (defun* oos (operation-class system &rest args &key force verbose version
             &allow-other-keys)
   (declare (ignore force verbose version))
-  (apply #'operate operation-class system args))
+  (apply 'operate operation-class system args))
 
 (let ((operate-docstring
   "Operate does three things:
@@ -2281,12 +2457,11 @@
   (setf (documentation 'operate 'function)
         operate-docstring))
 
-(defun* load-system (system &rest args &key force verbose version
-                    &allow-other-keys)
-  "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for
-details."
+(defun* load-system (system &rest args &key force verbose version &allow-other-keys)
+  "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
@@ -2294,7 +2469,7 @@
   "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
@@ -2302,17 +2477,14 @@
   "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
 
 (defun* load-pathname ()
-  (let ((pn (or *load-pathname* *compile-file-pathname*)))
-    (if *resolve-symlinks*
-        (and pn (resolve-symlinks pn))
-        pn)))
+  (resolve-symlinks* (or *load-pathname* *compile-file-pathname*)))
 
 (defun* determine-system-pathname (pathname pathname-supplied-p)
   ;; The defsystem macro calls us to determine
@@ -2328,45 +2500,18 @@
         directory-pathname
         (default-directory))))
 
-(defmacro defsystem (name &body options)
-  (setf name (coerce-name name))
-  (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
-                            defsystem-depends-on &allow-other-keys)
-      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
-         ;; to reuse options (e.g. pathname) from
-         ,@(loop :for system :in defsystem-depends-on
-             :collect `(load-system ',(coerce-name system)))
-         (let ((s (system-registered-p ',name)))
-           (cond ((and s (eq (type-of (cdr s)) ',class))
-                  (setf (car s) (get-universal-time)))
-                 (s
-                  (change-class (cdr s) ',class))
-                 (t
-                  (register-system (quote ,name)
-                                   (make-instance ',class :name ',name))))
-           (%set-system-source-file (load-pathname)
-                                    (cdr (system-registered-p ',name))))
-         (parse-component-form
-          nil (list*
-               :module (coerce-name ',name)
-               :pathname
-               ,(determine-system-pathname pathname pathname-arg-p)
-               ',component-options))))))
-
 (defun* class-for-type (parent type)
   (or (loop :for symbol :in (list
                              type
                              (find-symbol* type *package*)
                              (find-symbol* type :asdf))
         :for class = (and symbol (find-class symbol nil))
-        :when (and class (subtypep class 'component))
+        :when (and class
+                   (#-cormanlisp subtypep #+cormanlisp cl::subclassp
+                                 class (find-class 'component)))
         :return class)
       (and (eq type :file)
-           (or (module-default-component-class parent)
+           (or (and parent (module-default-component-class parent))
                (find-class *default-component-class*)))
       (sysdef-error "don't recognize component type ~A" type)))
 
@@ -2458,6 +2603,7 @@
               perform explain output-files operation-done-p
               weakly-depends-on
               depends-on serial in-order-to
+              (version nil versionp)
               ;; list ends
               &allow-other-keys) options
     (declare (ignorable perform explain output-files operation-done-p))
@@ -2471,6 +2617,11 @@
                        (class-for-type parent type))))
       (error 'duplicate-names :name name))
 
+    (when versionp
+      (unless (parse-version version nil)
+        (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>")
+              version name parent)))
+
     (let* ((other-args (remove-keys
                         '(components pathname default-component-class
                           perform explain output-files operation-done-p
@@ -2484,7 +2635,7 @@
         (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on)))
       (when *serial-depends-on*
         (push *serial-depends-on* depends-on))
-      (apply #'reinitialize-instance ret
+      (apply 'reinitialize-instance ret
              :name (coerce-name name)
              :pathname pathname
              :parent parent
@@ -2517,6 +2668,40 @@
       (%refresh-component-inline-methods ret rest)
       ret)))
 
+(defun* do-defsystem (name &rest options
+                           &key (pathname nil pathname-arg-p) (class 'system)
+                           defsystem-depends-on &allow-other-keys)
+  ;; The system must be registered before we parse the body,
+  ;; otherwise we recur when trying to find an existing system
+  ;; of the same name to reuse options (e.g. pathname) from.
+  ;; To avoid infinite recursion in cases where you defsystem a system
+  ;; that is registered to a different location to find-system,
+  ;; we also need to remember it in a special variable *systems-being-defined*.
+  (with-system-definitions ()
+    (let* ((name (coerce-name name))
+           (registered (system-registered-p name))
+           (system (cdr (or registered
+                            (register-system (make-instance 'system :name name)))))
+           (component-options (remove-keys '(:class) options)))
+      (%set-system-source-file (load-pathname) system)
+      (setf (gethash name *systems-being-defined*) system)
+      (when registered
+        (setf (car registered) (get-universal-time)))
+      (map () 'load-system defsystem-depends-on)
+      ;; We change-class (when necessary) AFTER we load the defsystem-dep's
+      ;; since the class might not be defined as part of those.
+      (let ((class (class-for-type nil class)))
+        (unless (eq (type-of system) class)
+          (change-class system class)))
+      (parse-component-form
+       nil (list*
+            :module name
+            :pathname (determine-system-pathname pathname pathname-arg-p)
+            component-options)))))
+
+(defmacro defsystem (name &body options)
+  `(apply 'do-defsystem ',name ',options))
+
 ;;;; ---------------------------------------------------------------------------
 ;;;; run-shell-command
 ;;;;
@@ -2534,7 +2719,7 @@
   "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."
-  (let ((command (apply #'format nil control-string args)))
+  (let ((command (apply 'format nil control-string args)))
     (asdf-message "; $ ~A~%" command)
 
     #+abcl
@@ -2552,8 +2737,8 @@
       (asdf-message "~{~&; ~a~%~}~%" stdout)
       exit-code)
 
-    #+clisp                     ;XXX not exactly *verbose-out*, I know
-    (or (ext:run-shell-command  command :output :terminal :wait t) 0)
+    #+clisp                    ;XXX not exactly *verbose-out*, I know
+    (or (ext:run-shell-command command :output (and *verbose-out* :terminal) :wait t) 0)
 
     #+clozure
     (nth-value 1
@@ -2578,7 +2763,7 @@
 
     #+sbcl
     (sb-ext:process-exit-code
-     (apply #'sb-ext:run-program
+     (apply 'sb-ext:run-program
             #+win32 "sh" #-win32 "/bin/sh"
             (list  "-c" command)
             :input nil :output *verbose-out*
@@ -2591,12 +2776,28 @@
       (list  "-c" command)
       :input nil :output *verbose-out*))
 
-    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl)
+    #+xcl
+    (ext:run-shell-command command)
+
+    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl xcl)
     (error "RUN-SHELL-COMMAND not implemented for this Lisp")))
 
 ;;;; ---------------------------------------------------------------------------
 ;;;; system-relative-pathname
 
+(defun* system-definition-pathname (x)
+  ;; As of 2.014.8, we mean to make this function obsolete,
+  ;; but that won't happen until all clients have been updated.
+  ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
+  "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
+It used to expose ASDF internals with subtle differences with respect to
+user expectations, that have been refactored away since.
+We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
+for a mostly compatible replacement that we're supporting,
+or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
+if that's whay you mean." ;;)
+  (system-source-file x))
+
 (defmethod system-source-file ((system-name string))
   (system-source-file (find-system system-name)))
 (defmethod system-source-file ((system-name symbol))
@@ -2644,10 +2845,10 @@
     (:ccl :clozure)
     (:corman :cormanlisp)
     (:lw :lispworks)
-    :clisp :cmu :ecl :gcl :sbcl :scl :symbolics))
+    :clisp :cmu :ecl :gcl :sbcl :scl :symbolics :xcl))
 
 (defparameter *os-features*
-  '((:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows
+  '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows
     (:solaris :sunos)
     (:linux :linux-target) ;; for GCL at least, must appear before :bsd.
     (:macosx :darwin :darwin-target :apple)
@@ -2656,54 +2857,48 @@
     :genera))
 
 (defparameter *architecture-features*
-  '((:amd64 :x86-64 :x86_64 :x8664-target)
+  '((:x64 :amd64 :x86-64 :x86_64 :x8664-target #+(and clisp word-size=64) :pc386)
     (:x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
-    :hppa64
-    :hppa
-    (:ppc64 :ppc64-target)
-    (:ppc32 :ppc32-target :ppc :powerpc)
-    :sparc64
-    (:sparc32 :sparc)
+    :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)
+    :mipsel :mipseb :mips
+    :alpha
     :imach))
 
 (defun* lisp-version-string ()
   (let ((s (lisp-implementation-version)))
-    (declare (ignorable s))
-    #+allegro (format nil
-                      "~A~A~A~A"
-                      excl::*common-lisp-version-number*
-                      ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
-                      (if (eq excl:*current-case-mode*
-                              :case-sensitive-lower) "M" "A")
-                      ;; Note if not using International ACL
-                      ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
-                      (excl:ics-target-case
-                       (:-ics "8")
-                       (:+ics ""))
-                      (if (member :64bit *features*) "-64bit" ""))
-    #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
-    #+clisp (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
-    #+clozure (format nil "~d.~d-f~d" ; shorten for windows
-                      ccl::*openmcl-major-version*
-                      ccl::*openmcl-minor-version*
-                      (logand ccl::fasl-version #xFF))
-    #+cmu (substitute #\- #\/ s)
-    #+ecl (format nil "~A~@[-~A~]" s
-                  (let ((vcs-id (ext:lisp-implementation-vcs-id)))
-                    (when (>= (length vcs-id) 8)
-                      (subseq vcs-id 0 8))))
-    #+gcl (subseq s (1+ (position #\space s)))
-    #+genera (multiple-value-bind (major minor) (sct:get-system-version "System")
-               (format nil "~D.~D" major minor))
-    #+lispworks (format nil "~A~@[~A~]" s
-                        (when (member :lispworks-64bit *features*) "-64bit"))
-    ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version
-    #+mcl (subseq s 8) ; strip the leading "Version "
-    #+(or cormanlisp sbcl scl) s
-    #-(or allegro armedbear clisp clozure cmu cormanlisp
-          ecl gcl genera lispworks mcl sbcl scl) s))
+    (or
+     #+allegro (format nil
+                       "~A~A~A"
+                       excl::*common-lisp-version-number*
+                       ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
+                       (if (eq excl:*current-case-mode*
+                               :case-sensitive-lower) "M" "A")
+                       ;; Note if not using International ACL
+                       ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
+                       (excl:ics-target-case
+                        (:-ics "8")
+                        (:+ics ""))) ; redundant? (if (member :64bit *features*) "-64bit" ""))
+     #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
+     #+clisp (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
+     #+clozure (format nil "~d.~d-f~d" ; shorten for windows
+                       ccl::*openmcl-major-version*
+                       ccl::*openmcl-minor-version*
+                       (logand ccl::fasl-version #xFF))
+     #+cmu (substitute #\- #\/ s)
+     #+ecl (format nil "~A~@[-~A~]" s
+                   (let ((vcs-id (ext:lisp-implementation-vcs-id)))
+                     (when (>= (length vcs-id) 8)
+                       (subseq vcs-id 0 8))))
+     #+gcl (subseq s (1+ (position #\space s)))
+     #+genera (multiple-value-bind (major minor) (sct:get-system-version "System")
+                (format nil "~D.~D" major minor))
+     ;; #+lispworks (format nil "~A~@[~A~]" s (when (member :lispworks-64bit *features*) "-64bit")     #+mcl (subseq s 8) ; strip the leading "Version "
+     ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version
+     s)))
 
 (defun* first-feature (features)
   (labels
@@ -2728,7 +2923,7 @@
   (labels
       ((maybe-warn (value fstring &rest args)
          (cond (value)
-               (t (apply #'warn fstring args)
+               (t (apply 'warn fstring args)
                   "unknown"))))
     (let ((lisp (maybe-warn (implementation-type)
                             (compatfmt "~@<No implementation feature found in ~a.~@:>")
@@ -2753,8 +2948,19 @@
   #+asdf-unix #\:
   #-asdf-unix #\;)
 
+;; Note: ASDF may expect user-homedir-pathname to provide the pathname of
+;; the current user's home directory, while MCL by default provides the
+;; directory from which MCL was started.
+;; See http://code.google.com/p/mcl/wiki/Portability
+#.(or #+mcl ;; the #$ doesn't work on other implementations, even inside #+mcl
+      `(defun current-user-homedir-pathname ()
+         ,(read-from-string "(ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))")))
+
 (defun* user-homedir ()
-  (truenamize (pathname-directory-pathname (user-homedir-pathname))))
+  (truenamize
+   (pathname-directory-pathname
+    #+mcl (current-user-homedir-pathname)
+    #-mcl (user-homedir-pathname))))
 
 (defun* try-directory-subpath (x sub &key type)
   (let* ((p (and x (ensure-directory-pathname x)))
@@ -2763,29 +2969,34 @@
          (ts (and sp (probe-file* sp))))
     (and ts (values sp ts))))
 (defun* user-configuration-directories ()
-  (remove-if
-   #'null
-   (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
-     `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/")
-       ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")
-           :for dir :in (split-string dirs :separator ":")
-           :collect (try dir "common-lisp/"))
-       #+asdf-windows
-        ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/")
-            ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
-           ,(try (getenv "APPDATA") "common-lisp/config/"))
-       ,(try (user-homedir) ".config/common-lisp/")))))
+  (let ((dirs
+         (flet ((try (x sub) (try-directory-subpath x sub)))
+           `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/")
+             ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")
+                 :for dir :in (split-string dirs :separator ":")
+                 :collect (try dir "common-lisp/"))
+             #+asdf-windows
+             ,@`(,(try (or #+lispworks (sys:get-folder-path :local-appdata)
+                           (getenv "LOCALAPPDATA"))
+                       "common-lisp/config/")
+                 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
+                 ,(try (or #+lispworks (sys:get-folder-path :appdata)
+                           (getenv "APPDATA"))
+                           "common-lisp/config/"))
+             ,(try (user-homedir) ".config/common-lisp/")))))
+    (remove-duplicates (remove-if #'null dirs) :from-end t :test 'equal)))
 (defun* system-configuration-directories ()
   (remove-if
    #'null
-   (append
-    #+asdf-windows
-    (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
-      `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")
-           ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
-        ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
-    #+asdf-unix
-    (list #p"/etc/common-lisp/"))))
+   `(#+asdf-windows
+     ,(flet ((try (x sub) (try-directory-subpath x sub)))
+        ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
+        (try (or #+lispworks (sys:get-folder-path :common-appdata)
+                 (getenv "ALLUSERSAPPDATA")
+                 (try (getenv "ALLUSERSPROFILE") "Application Data/"))
+             "common-lisp/config/"))
+     #+asdf-unix #p"/etc/common-lisp/")))
+
 (defun* in-first-directory (dirs x)
   (loop :for dir :in dirs
     :thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir))))))
@@ -2845,7 +3056,7 @@
   (let ((forms (read-file-forms file)))
     (unless (length=n-p forms 1)
       (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%")
-	     description forms))
+             description forms))
     (funcall validator (car forms) :location file)))
 
 (defun* hidden-file-p (pathname)
@@ -2857,7 +3068,8 @@
                              #+clozure '(: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))))))
+                             #+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
@@ -2903,7 +3115,11 @@
     (or
      (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation)
      #+asdf-windows
-     (try (getenv "APPDATA") "common-lisp" "cache" :implementation)
+     (try (or #+lispworks (sys:get-folder-path :local-appdata)
+              (getenv "LOCALAPPDATA")
+              #+lispworks (sys:get-folder-path :appdata)
+              (getenv "APPDATA"))
+          "common-lisp" "cache" :implementation)
      '(:home ".cache" "common-lisp" :implementation))))
 (defvar *system-cache*
   ;; No good default, plus there's a security problem
@@ -3002,7 +3218,10 @@
                                    :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))
+            ((eql :system-cache)
+             (warn "Using the :system-cache is deprecated. ~%~
+Please remove it from your ASDF configuration")
+             (resolve-location *system-cache* :directory t :wilden nil))
             ((eql :default-directory) (default-directory))))
          (s (if (and wilden (not (pathnamep x)))
                 (wilden r)
@@ -3101,7 +3320,7 @@
           ((equal "" s)
            (when inherit
              (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
-		    string))
+                    string))
            (setf inherit t)
            (push :inherit-configuration directives))
           (t
@@ -3110,7 +3329,7 @@
         (when (> start end)
           (when source
             (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
-		   string))
+                   string))
           (unless inherit
             (push :ignore-inherited-configuration directives))
           (return `(:output-translations ,@(nreverse directives)))))))))
@@ -3128,8 +3347,9 @@
     ;; so we must disable translations for implementation paths.
     #+sbcl ,(let ((h (getenv "SBCL_HOME")))
                  (when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ())))
-    #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; 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
+    ;; The below two are not needed: no precompiled ASDF system there
+    ;; #+ecl (,(translate-logical-pathname "SYS:**;*.*") ())
+    ;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ()))
     ;; All-import, here is where we want user stuff to be:
     :inherit-configuration
     ;; These are for convenience, and can be overridden by the user:
@@ -3142,7 +3362,7 @@
 (defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/"))
 
 (defun* user-output-translations-pathname ()
-  (in-user-configuration-directory *output-translations-file* ))
+  (in-user-configuration-directory *output-translations-file*))
 (defun* system-output-translations-pathname ()
   (in-system-configuration-directory *output-translations-file*))
 (defun* user-output-translations-directory-pathname ()
@@ -3216,8 +3436,9 @@
                   ((eq dst t)
                    (funcall collect (list trusrc t)))
                   (t
-                   (let* ((trudst (make-pathname
-                                   :defaults (if dst (resolve-location dst :directory t :wilden t) trusrc)))
+                   (let* ((trudst (if dst
+                                      (resolve-location dst :directory t :wilden t)
+                                      trusrc))
                           (wilddst (merge-pathnames* *wild-file* trudst)))
                      (funcall collect (list wilddst t))
                      (funcall collect (list trusrc trudst)))))))))))
@@ -3271,6 +3492,7 @@
 
 (defun* apply-output-translations (path)
   (etypecase path
+    #+cormanlisp (t (truenamize path))
     (logical-pathname
      path)
     ((or pathname string)
@@ -3300,7 +3522,8 @@
    t))
 
 (defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
-  (or output-file
+  (if (absolute-pathname-p output-file)
+      (apply 'compile-file-pathname (lispize-pathname input-file) keys)
       (apply-output-translations
        (apply 'compile-file-pathname
               (truenamize (lispize-pathname input-file))
@@ -3316,7 +3539,7 @@
     (delete-file x)))
 
 (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)))
+  (let* ((output-file (apply 'compile-file-pathname* input-file :output-file output-file keys))
          (tmp-file (tmpize-pathname output-file))
          (status :error))
     (multiple-value-bind (output-truename warnings-p failure-p)
@@ -3383,7 +3606,7 @@
     (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")))
          (mapped-files (if map-all-source-files *wild-file*
-                           (make-pathname :name :wild :version :wild :type fasl-type)))
+                           (make-pathname :type fasl-type :defaults *wild-file*)))
          (destination-directory
           (if centralize-lisp-binaries
               `(,default-toplevel-directory
@@ -3417,8 +3640,7 @@
       :do (write-char (code-char code) out))))
 
 (defun* read-little-endian (s &optional (bytes 4))
-  (loop
-    :for i :from 0 :below bytes
+  (loop :for i :from 0 :below bytes
     :sum (ash (read-byte s) (* 8 i))))
 
 (defun* parse-file-location-info (s)
@@ -3485,64 +3707,62 @@
     ;; "~.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.
+    "debian")) ;; debian often builds stuff under the debian directory... BAD.
 
 (defvar *source-registry-exclusions* *default-source-registry-exclusions*)
 
-(defvar *source-registry* ()
-  "Either NIL (for uninitialized), or a list of one element,
-said element itself being a list of directory pathnames where to look for .asd files")
-
-(defun* source-registry ()
-  (car *source-registry*))
-
-(defun* (setf source-registry) (new-value)
-  (setf *source-registry* (list new-value))
-  new-value)
+(defvar *source-registry* nil
+  "Either NIL (for uninitialized), or an equal hash-table, mapping
+system names to pathnames of .asd files")
 
 (defun* source-registry-initialized-p ()
-  (and *source-registry* t))
+  (typep *source-registry* 'hash-table))
 
 (defun* clear-source-registry ()
   "Undoes any initialization of the source registry.
 You might want to call that before you dump an image that would be resumed
 with a different configuration, so the configuration would be re-read then."
-  (setf *source-registry* '())
+  (setf *source-registry* nil)
   (values))
 
 (defparameter *wild-asd*
-  (make-pathname :directory nil :name :wild :type "asd" :version :newest))
+  (make-pathname :directory nil :name *wild* :type "asd" :version :newest))
 
-(defun directory-has-asd-files-p (directory)
+(defun directory-asd-files (directory)
   (ignore-errors
-    (and (directory* (merge-pathnames* *wild-asd* directory)) t)))
+    (directory* (merge-pathnames* *wild-asd* directory))))
 
 (defun subdirectories (directory)
   (let* ((directory (ensure-directory-pathname directory))
-         #-(or cormanlisp genera)
+         #-(or abcl cormanlisp genera xcl)
          (wild (merge-pathnames*
-                #-(or abcl allegro cmu lispworks scl)
+                #-(or abcl allegro cmu lispworks scl xcl)
                 *wild-directory*
-                #+(or abcl allegro cmu lispworks scl) "*.*"
+                #+(or abcl allegro cmu lispworks scl xcl) "*.*"
                 directory))
          (dirs
-          #-(or cormanlisp genera)
+          #-(or abcl cormanlisp genera xcl)
           (ignore-errors
             (directory* wild . #.(or #+clozure '(:directories t :files nil)
                                      #+mcl '(:directories t))))
+          #+(or abcl xcl) (system:list-directory directory)
           #+cormanlisp (cl::directory-subdirs directory)
           #+genera (fs:directory-list directory))
-         #+(or abcl allegro cmu genera lispworks scl)
-         (dirs (remove-if-not #+abcl #'extensions:probe-directory
-                              #+allegro #'excl:probe-directory
-                              #+lispworks #'lw:file-directory-p
-                              #+genera #'(lambda (x) (getf (cdr x) :directory))
-                              #-(or abcl allegro genera lispworks) #'directory-pathname-p
-                              dirs))
-         #+genera
-         (dirs (mapcar #'(lambda (x) (ensure-directory-pathname (first x))) dirs)))
+         #+(or abcl allegro cmu genera lispworks scl xcl)
+         (dirs (loop :for x :in dirs
+                 :for d = #+(or abcl xcl) (extensions:probe-directory x)
+                          #+allegro (excl:probe-directory x)
+                          #+(or cmu scl) (directory-pathname-p x)
+                          #+genera (getf (cdr x) :directory)
+                          #+lispworks (lw:file-directory-p x)
+                 :when d :collect #+(or abcl allegro xcl) d
+                                  #+genera (ensure-directory-pathname (first x))
+                                  #+(or cmu lispworks scl) x)))
     dirs))
 
+(defun collect-asds-in-directory (directory collect)
+  (map () collect (directory-asd-files directory)))
+
 (defun collect-sub*directories (directory collectp recursep collector)
   (when (funcall collectp directory)
     (funcall collector directory))
@@ -3550,15 +3770,15 @@
     (when (funcall recursep subdir)
       (collect-sub*directories subdir collectp recursep collector))))
 
-(defun collect-sub*directories-with-asd
+(defun collect-sub*directories-asd-files
     (directory &key
      (exclude *default-source-registry-exclusions*)
      collect)
   (collect-sub*directories
    directory
-   #'directory-has-asd-files-p
+   (constantly t)
    #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal)))
-   collect))
+   #'(lambda (dir) (collect-asds-in-directory dir collect))))
 
 (defun* validate-source-registry-directive (directive)
   (or (member directive '(:default-registry))
@@ -3603,17 +3823,21 @@
       :with end = (length string)
       :for pos = (position *inter-directory-separator* string :start start) :do
       (let ((s (subseq string start (or pos end))))
-        (cond
-         ((equal "" s) ; empty element: inherit
-          (when inherit
-            (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
-		   string))
-          (setf inherit t)
-          (push ':inherit-configuration directives))
-         ((ends-with s "//")
-          (push `(:tree ,(subseq s 0 (1- (length s)))) directives))
-         (t
-          (push `(:directory ,s) directives)))
+        (flet ((check (dir)
+                 (unless (absolute-pathname-p dir)
+                   (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
+                 dir))
+          (cond
+            ((equal "" s) ; empty element: inherit
+             (when inherit
+               (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
+                      string))
+             (setf inherit t)
+             (push ':inherit-configuration directives))
+            ((ends-with s "//") ;; TODO: allow for doubling of separator even outside Unix?
+             (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
+            (t
+             (push `(:directory ,(check s)) directives))))
         (cond
           (pos
            (setf start (1+ pos)))
@@ -3624,8 +3848,8 @@
 
 (defun* register-asd-directory (directory &key recurse exclude collect)
   (if (not recurse)
-      (funcall collect directory)
-      (collect-sub*directories-with-asd
+      (collect-asds-in-directory directory collect)
+      (collect-sub*directories-asd-files
        directory :exclude exclude :collect collect)))
 
 (defparameter *default-source-registries*
@@ -3645,30 +3869,27 @@
     :inherit-configuration
     #+cmu (:tree #p"modules:")))
 (defun* default-source-registry ()
-  (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
+  (flet ((try (x sub) (try-directory-subpath x sub)))
     `(:source-registry
-      #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir)))
+      #+sbcl (:directory ,(try (user-homedir) ".sbcl/systems/"))
       (:directory ,(default-directory))
-      ,@(let*
-         #+asdf-unix
-         ((datahome
-           (or (getenv "XDG_DATA_HOME")
-               (try (user-homedir) ".local/share/")))
-          (datadirs
-           (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share"))
-          (dirs (cons datahome (split-string datadirs :separator ":"))))
-         #+asdf-windows
-         ((datahome (getenv "APPDATA"))
-          (datadir
-           #+lispworks (sys:get-folder-path :local-appdata)
-           #-lispworks (try (getenv "ALLUSERSPROFILE")
-                            "Application Data"))
-          (dirs (list datahome datadir)))
-         #-(or asdf-unix asdf-windows)
-         ((dirs ()))
-         (loop :for dir :in dirs
-           :collect `(:directory ,(try dir "common-lisp/systems/"))
-           :collect `(:tree ,(try dir "common-lisp/source/"))))
+      ,@(loop :for dir :in
+          `(#+asdf-unix
+            ,@`(,(or (getenv "XDG_DATA_HOME")
+                     (try (user-homedir) ".local/share/"))
+                ,@(split-string (or (getenv "XDG_DATA_DIRS")
+                                    "/usr/local/share:/usr/share")
+                                :separator ":"))
+            #+asdf-windows
+            ,@`(,(or #+lispworks (sys:get-folder-path :local-appdata)
+                     (getenv "LOCALAPPDATA"))
+                ,(or #+lispworks (sys:get-folder-path :appdata)
+                     (getenv "APPDATA"))
+                ,(or #+lispworks (sys:get-folder-path :common-appdata)
+                     (getenv "ALLUSERSAPPDATA")
+                     (try (getenv "ALLUSERSPROFILE") "Application Data/"))))
+          :collect `(:directory ,(try dir "common-lisp/systems/"))
+          :collect `(:tree ,(try dir "common-lisp/source/")))
       :inherit-configuration)))
 (defun* user-source-registry ()
   (in-user-configuration-directory *source-registry-file*))
@@ -3757,19 +3978,34 @@
 
 ;; Will read the configuration and initialize all internal variables,
 ;; and return the new configuration.
-(defun* compute-source-registry (&optional parameter)
-  (while-collecting (collect)
-    (dolist (entry (flatten-source-registry parameter))
-      (destructuring-bind (directory &key recurse exclude) entry
+(defun* compute-source-registry (&optional parameter (registry *source-registry*))
+  (dolist (entry (flatten-source-registry parameter))
+    (destructuring-bind (directory &key recurse exclude) entry
+      (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
         (register-asd-directory
-         directory
-         :recurse recurse :exclude exclude :collect #'collect)))))
+         directory :recurse recurse :exclude exclude :collect
+         #'(lambda (asd)
+             (let ((name (pathname-name asd)))
+               (cond
+                 ((gethash name registry) ; already shadowed by something else
+                  nil)
+                 ((gethash name h) ; conflict at current level
+                  (when *asdf-verbose*
+                    (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
+                                found several entries for ~A - picking ~S over ~S~:>")
+                          directory recurse name (gethash name h) asd)))
+                 (t
+                  (setf (gethash name registry) asd)
+                  (setf (gethash name h) asd))))))
+        h)))
+  (values))
 
 (defvar *source-registry-parameter* nil)
 
 (defun* initialize-source-registry (&optional (parameter *source-registry-parameter*))
-  (setf *source-registry-parameter* parameter
-        (source-registry) (compute-source-registry parameter)))
+  (setf *source-registry-parameter* parameter)
+  (setf *source-registry* (make-hash-table :test 'equal))
+  (compute-source-registry parameter))
 
 ;; Checks an initial variable to see whether the state is initialized
 ;; or cleared. In the former case, return current configuration; in
@@ -3780,24 +4016,60 @@
 ;; you may override the configuration explicitly by calling
 ;; initialize-source-registry directly with your parameter.
 (defun* ensure-source-registry (&optional parameter)
-  (if (source-registry-initialized-p)
-      (source-registry)
-      (initialize-source-registry parameter)))
+  (unless (source-registry-initialized-p)
+    (initialize-source-registry parameter))
+  (values))
 
 (defun* sysdef-source-registry-search (system)
   (ensure-source-registry)
-  (loop :with name = (coerce-name system)
-    :for defaults :in (source-registry)
-    :for file = (probe-asd name defaults)
-    :when file :return file))
+  (values (gethash (coerce-name system) *source-registry*)))
 
 (defun* clear-configuration ()
   (clear-source-registry)
   (clear-output-translations))
 
+
+;;; ECL support for COMPILE-OP / LOAD-OP
+;;;
+;;; In ECL, these operations produce both FASL files and the
+;;; object files that they are built from. Having both of them allows
+;;; us to later on reuse the object files for bundles, libraries,
+;;; standalone executables, etc.
+;;;
+;;; This has to be in asdf.lisp and not asdf-ecl.lisp, or else it becomes
+;;; a problem for asdf on ECL to compile asdf-ecl.lisp after loading asdf.lisp.
+;;;
+#+ecl
+(progn
+  (setf *compile-op-compile-file-function*
+        (lambda (input-file &rest keys &key output-file &allow-other-keys)
+          (declare (ignore output-file))
+          (multiple-value-bind (object-file flags1 flags2)
+              (apply 'compile-file* input-file :system-p t keys)
+            (values (and object-file
+                         (c::build-fasl (compile-file-pathname object-file :type :fasl)
+                                        :lisp-files (list object-file))
+                         object-file)
+                    flags1
+                    flags2))))
+
+  (defmethod output-files ((operation compile-op) (c cl-source-file))
+    (declare (ignorable operation))
+    (let ((p (lispize-pathname (component-pathname c))))
+      (list (compile-file-pathname p :type :object)
+            (compile-file-pathname p :type :fasl))))
+
+  (defmethod perform ((o load-op) (c cl-source-file))
+    (map () #'load
+         (loop :for i :in (input-files o c)
+           :unless (string= (pathname-type i) "fas")
+           :collect (compile-file-pathname (lispize-pathname i))))))
+
 ;;;; -----------------------------------------------------------------
 ;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL and SBCL
 ;;;;
+(defvar *require-asdf-operator* 'load-op)
+
 (defun* module-provide-asdf (name)
   (handler-bind
       ((style-warning #'muffle-warning)
@@ -3806,9 +4078,10 @@
                   (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%")
                           name e))))
     (let ((*verbose-out* (make-broadcast-stream))
-           (system (find-system (string-downcase name) nil)))
+          (system (find-system (string-downcase name) nil)))
       (when system
-        (load-system system)))))
+        (operate *require-asdf-operator* system :verbose nil)
+        t))))
 
 #+(or abcl clisp clozure cmu ecl sbcl)
 (let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom))))




More information about the cmucl-cvs mailing list