Changeset 15207

Timestamp:

Feb 13, 2012, 6:09:49 PM (9 years ago)

Author:

rme

Message:

Update to ASDF 2.20.

File:

• trunk/source/tools/asdf.lisp (modified) (87 diffs)

trunk/source/tools/asdf.lisp

@@ -1 @@
-;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
-;;; This is ASDF 2.017: Another System Definition Facility.
+;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
+;;; This is ASDF 2.20: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
@@ -57 +57 @@
 (eval-when (:compile-toplevel :load-toplevel :execute)
   ;;; Implementation-dependent tweaks
-  ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults.
+  ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; NO: trust implementation defaults.
   #+allegro
   (setf excl::*autoload-package-name-alist*
         (remove "asdf" excl::*autoload-package-name-alist*
                 :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below
-  #+(and ecl (not ecl-bytecmp)) (require :cmp)
+  #+ecl (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t))
+  #+ecl (unless (use-ecl-byte-compiler-p) (require :cmp))
   #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011
   (when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 fails to fully compile ASDF at all
@@ -68 +69 @@
                  (< system::*gcl-minor-version* 7)))
     (pushnew :gcl-pre2.7 *features*))
-  #+(and (or win32 windows mswindows mingw32) (not cygwin)) (pushnew :asdf-windows *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.
@@ -89 +88 @@
   ;; Strip out formatting that is not supported on Genera.
   ;; Has to be inside the eval-when to make Lispworks happy (!)
+  (defun strcat (&rest strings)
+    (apply 'concatenate 'string strings))
   (defmacro compatfmt (format)
     #-(or gcl genera) format
     #+(or gcl genera)
     (loop :for (unsupported . replacement) :in
-      `(("~3i~_" . "")
-        #+genera
-        ,@(("~@<" . "")
-           ("; ~@;" . "; ")
-           ("~@:>" . "")
-           ("~:>" . ""))) :do
+      (append
+       '(("~3i~_" . ""))
+       #+genera '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :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)))))))
+        (setf format (strcat (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.
@@ -113 +109 @@
          ;; "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.017")
+         (asdf-version "2.20")
          (existing-asdf (find-class 'component nil))
          (existing-version *asdf-version*)
@@ -191 +187 @@
                      (push sym formerly-exported-symbols)))
                (loop :for sym :in export :do
-                 (unless (member sym bothly-exported-symbols :test 'string-equal)
+                 (unless (member sym bothly-exported-symbols :test 'equal)
                    (push sym newly-exported-symbols)))
                (loop :for user :in (package-used-by-list package)
@@ -201 +197 @@
                (loop :for x :in newly-exported-symbols :do
                  (export (intern* x package)))))
-           (ensure-package (name &key nicknames use unintern fmakunbound
-                                 shadow export redefined-functions)
+           (ensure-package (name &key nicknames use unintern
+                                 shadow export redefined-functions)
              (let* ((p (ensure-exists name nicknames use)))
                (ensure-unintern p unintern)
                (ensure-shadow p shadow)
                (ensure-export p export)
-               (ensure-fmakunbound p (append fmakunbound redefined-functions))
+               (ensure-fmakunbound p redefined-functions)
                p)))
         (macrolet
             ((pkgdcl (name &key nicknames use export
-                           redefined-functions unintern fmakunbound shadow)
+                           redefined-functions unintern shadow)
                  `(ensure-package
                    ',name :nicknames ',nicknames :use ',use :export ',export
                    :shadow ',shadow
                    :unintern ',unintern
-                   :redefined-functions ',redefined-functions
-                   :fmakunbound ',fmakunbound)))
+                   :redefined-functions ',redefined-functions)))
           (pkgdcl
            :asdf
@@ -227 +222 @@
             #:system-source-file #:operate #:find-component #:find-system
             #:apply-output-translations #:translate-pathname* #:resolve-location
+            #:system-relative-pathname
+            #:inherit-source-registry #:process-source-registry
+            #:process-source-registry-directive
             #:compile-file* #:source-file-type)
            :unintern
            (#:*asdf-revision* #:around #:asdf-method-combination
-            #:split #:make-collector
+            #:split #:make-collector #:do-dep #:do-one-dep
+            #:resolve-relative-location-component #:resolve-absolute-location-component
             #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function
-           :fmakunbound
-           (#:system-source-file
-            #:component-relative-pathname #:system-relative-pathname
-            #:process-source-registry
-            #:inherit-source-registry #:process-source-registry-directive)
            :export
-           (#:defsystem #:oos #:operate #:find-system #:run-shell-command
+           (#:defsystem #:oos #:operate #:find-system #:locate-system #:run-shell-command
             #: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
-            #:operation               ; operations
-            #:feature                 ; sort-of operation
-            #:version                 ; metaphorically sort-of an operation
-            #:version-satisfies
+            #:search-for-system-definition #:find-component #:component-find-path
+            #:compile-system #:load-system #:load-systems #:test-system #:clear-system
+            #:operation #:compile-op #:load-op #:load-source-op #:test-op
+            #:feature #:version #:version-satisfies
             #:upgrade-asdf
             #:implementation-identifier #:implementation-type
-
-            #:input-files #:output-files #:output-file #:perform ; operation methods
+            #:input-files #:output-files #:output-file #:perform
             #:operation-done-p #:explain
 
@@ -299 +288 @@
             #:*compile-file-failure-behaviour*
             #:*resolve-symlinks*
+            #:*require-asdf-operator*
             #:*asdf-verbose*
+            #:*verbose-out*
 
             #:asdf-version
@@ -341 +332 @@
             #:system-registered-p
             #:asdf-message
+            #:user-output-translations-pathname
+            #:system-output-translations-pathname
+            #:user-output-translations-directory-pathname
+            #:system-output-translations-directory-pathname
+            #:user-source-registry
+            #:system-source-registry
+            #:user-source-registry-directory
+            #:system-source-registry-directory
 
             ;; Utilities
             #:absolute-pathname-p
             ;; #:aif #:it
-            ;; #:appendf
+            ;; #:appendf #:orf
             #:coerce-name
             #:directory-pathname-p
@@ -353 +352 @@
             ;; #:length=n-p
             ;; #:find-symbol*
-            #:merge-pathnames*
-            #:coerce-pathname
+            #:merge-pathnames* #:coerce-pathname #:subpathname
             #:pathname-directory-pathname
             #:read-file-forms
@@ -417 +415 @@
                 condition-format condition-location
                 coerce-name)
+         (ftype (function (&optional t) (values)) initialize-source-registry)
          #-(or cormanlisp gcl-pre2.7)
          (ftype (function (t t) t) (setf module-components-by-name)))
@@ -425 +424 @@
 (progn
   (deftype logical-pathname () nil)
-  (defun* make-broadcast-stream () *error-output*)
-  (defun* file-namestring (p)
+  (defun make-broadcast-stream () *error-output*)
+  (defun file-namestring (p)
     (setf p (pathname p))
     (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
@@ -526 +525 @@
               :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
 
+(defun* ununspecific (x)
+  (if (eq x :unspecific) nil x))
+
 (defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
   "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
@@ -544 +546 @@
          (type (or (pathname-type specified) (pathname-type defaults)))
          (version (or (pathname-version specified) (pathname-version defaults))))
-    (labels ((ununspecific (x)
-               (if (eq x :unspecific) nil x))
-             (unspecific-handler (p)
+    (labels ((unspecific-handler (p)
                (if (typep p 'logical-pathname) #'ununspecific #'identity)))
       (multiple-value-bind (host device directory unspecific-handler)
@@ -676 +676 @@
 (defun* getenv (x)
   (declare (ignorable x))
-  #+(or abcl clisp xcl) (ext:getenv x)
+  #+(or abcl clisp ecl xcl) (ext:getenv x)
   #+allegro (sys:getenv x)
   #+clozure (ccl:getenv x)
@@ -690 +690 @@
       (ct:free buffer)
       (ct:free buffer1)))
-  #+ecl (si:getenv x)
   #+gcl (system:getenv x)
   #+genera nil
@@ -898 +897 @@
         (port (ext:pathname-port pathname))
         (directory (pathname-directory pathname)))
-    (flet ((not-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)))))
+    (if (or (ununspecific port)
+            (and (ununspecific host) (plusp (length host)))
+            (ununspecific scheme))
+        (let ((prefix ""))
+          (when (ununspecific port)
+            (setf prefix (format nil ":~D" port)))
+          (when (and (ununspecific host) (plusp (length host)))
+            (setf prefix (strcat host prefix)))
+          (setf prefix (strcat ":" prefix))
+          (when (ununspecific scheme)
+            (setf prefix (strcat scheme prefix)))
+          (assert (and directory (eq (first directory) :absolute)))
+          (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
+                         :defaults pathname)))
+    pathname))
 
 ;;;; -------------------------------------------------------------------------
@@ -923 +919 @@
 (defgeneric* perform (operation component))
 (defgeneric* operation-done-p (operation component))
+(defgeneric* mark-operation-done (operation component))
 (defgeneric* explain (operation component))
 (defgeneric* output-files (operation component))
@@ -1167 +1164 @@
    ;; it to default in funky ways if not supplied
    (relative-pathname :initarg :pathname)
+   ;; the absolute-pathname is computed based on relative-pathname...
    (absolute-pathname)
    (operation-times :initform (make-hash-table)
                     :accessor component-operation-times)
+   (around-compile :initarg :around-compile)
    ;; XXX we should provide some atomic interface for updating the
    ;; component properties
@@ -1280 +1279 @@
   new-value)
 
-(defclass system (module)
+(defclass proto-system () ; slots to keep when resetting a system
+  ;; To preserve identity for all objects, we'd need keep the components slots
+  ;; but also to modify parse-component-form to reset the recycled objects.
+  ((name) #|(components) (components-by-names)|#))
+
+(defclass system (module proto-system)
   (;; description and long-description are now available for all component's,
    ;; but now also inherited from component, but we add the legacy accessor
@@ -1289 +1293 @@
    (licence :accessor system-licence :initarg :licence
             :accessor system-license :initarg :license)
-   (source-file :reader system-source-file :initarg :source-file
+   (source-file :reader %system-source-file :initarg :source-file ; for CLISP upgrade
                 :writer %set-system-source-file)
    (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
@@ -1341 +1345 @@
            (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
 
+;;;; -----------------------------------------------------------------
+;;;; Windows shortcut support.  Based on:
+;;;;
+;;;; Jesse Hager: The Windows Shortcut File Format.
+;;;; http://www.wotsit.org/list.asp?fc=13
+
+#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera.
+(progn
+(defparameter *link-initial-dword* 76)
+(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
+
+(defun* read-null-terminated-string (s)
+  (with-output-to-string (out)
+    (loop :for code = (read-byte s)
+      :until (zerop code)
+      :do (write-char (code-char code) out))))
+
+(defun* read-little-endian (s &optional (bytes 4))
+  (loop :for i :from 0 :below bytes
+    :sum (ash (read-byte s) (* 8 i))))
+
+(defun* parse-file-location-info (s)
+  (let ((start (file-position s))
+        (total-length (read-little-endian s))
+        (end-of-header (read-little-endian s))
+        (fli-flags (read-little-endian s))
+        (local-volume-offset (read-little-endian s))
+        (local-offset (read-little-endian s))
+        (network-volume-offset (read-little-endian s))
+        (remaining-offset (read-little-endian s)))
+    (declare (ignore total-length end-of-header local-volume-offset))
+    (unless (zerop fli-flags)
+      (cond
+        ((logbitp 0 fli-flags)
+          (file-position s (+ start local-offset)))
+        ((logbitp 1 fli-flags)
+          (file-position s (+ start
+                              network-volume-offset
+                              #x14))))
+      (strcat (read-null-terminated-string s)
+              (progn
+                (file-position s (+ start remaining-offset))
+                (read-null-terminated-string s))))))
+
+(defun* parse-windows-shortcut (pathname)
+  (with-open-file (s pathname :element-type '(unsigned-byte 8))
+    (handler-case
+        (when (and (= (read-little-endian s) *link-initial-dword*)
+                   (let ((header (make-array (length *link-guid*))))
+                     (read-sequence header s)
+                     (equalp header *link-guid*)))
+          (let ((flags (read-little-endian s)))
+            (file-position s 76)        ;skip rest of header
+            (when (logbitp 0 flags)
+              ;; skip shell item id list
+              (let ((length (read-little-endian s 2)))
+                (file-position s (+ length (file-position s)))))
+            (cond
+              ((logbitp 1 flags)
+                (parse-file-location-info s))
+              (t
+                (when (logbitp 2 flags)
+                  ;; skip description string
+                  (let ((length (read-little-endian s 2)))
+                    (file-position s (+ length (file-position s)))))
+                (when (logbitp 3 flags)
+                  ;; finally, our pathname
+                  (let* ((length (read-little-endian s 2))
+                         (buffer (make-array length)))
+                    (read-sequence buffer s)
+                    (map 'string #'code-char buffer)))))))
+      (end-of-file ()
+        nil)))))
+
 ;;;; -------------------------------------------------------------------------
 ;;;; Finding systems
@@ -1396 +1474 @@
 ;;; 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))
+(defvar *system-definition-search-functions* '())
+
+(setf *system-definition-search-functions*
+      (append
+       ;; Remove known-incompatible sysdef functions from ancient sbcl asdf.
+       (remove 'contrib-sysdef-search *system-definition-search-functions*)
+       ;; Tuck our defaults at the end of the list if they were absent.
+       ;; This is imperfect, in case they were removed on purpose,
+       ;; but then it will be the responsibility of whoever does that
+       ;; to upgrade asdf before he does such a thing rather than after.
+       (remove-if #'(lambda (x) (member x *system-definition-search-functions*))
+                  '(sysdef-central-registry-search
+                    sysdef-source-registry-search
+                    sysdef-find-asdf))))
 
 (defun* search-for-system-definition (system)
-  (let ((system-name (coerce-name system)))
-    (some #'(lambda (x) (funcall x system-name))
-          (cons 'find-system-if-being-defined *system-definition-search-functions*))))
+  (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name)))
+        (cons 'find-system-if-being-defined
+              *system-definition-search-functions*)))
 
 (defvar *central-registry* nil
@@ -1420 +1508 @@
 Going forward, we recommend new users should be using the source-registry.
 ")
+
+(defun* featurep (x &optional (features *features*))
+  (cond
+    ((atom x)
+     (and (member x features) t))
+    ((eq :not (car x))
+     (assert (null (cddr x)))
+     (not (featurep (cadr x) features)))
+    ((eq :or (car x))
+     (some #'(lambda (x) (featurep x features)) (cdr x)))
+    ((eq :and (car x))
+     (every #'(lambda (x) (featurep x features)) (cdr x)))
+    (t
+     (error "Malformed feature specification ~S" x))))
+
+(defun* os-unix-p ()
+  (featurep '(:or :unix :cygwin :darwin)))
+
+(defun* os-windows-p ()
+  (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32))))
 
 (defun* probe-asd (name defaults)
@@ -1429 +1537 @@
         (when (probe-file* file)
           (return file)))
-      #+(and asdf-windows (not clisp))
-      (let ((shortcut
-             (make-pathname
-              :defaults defaults :version :newest :case :local
-              :name (concatenate 'string name ".asd")
-              :type "lnk")))
-        (when (probe-file* shortcut)
-          (let ((target (parse-windows-shortcut shortcut)))
-            (when target
-              (return (pathname target)))))))))
+      #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!)
+      (when (os-windows-p)
+        (let ((shortcut
+               (make-pathname
+                :defaults defaults :version :newest :case :local
+                :name (strcat name ".asd")
+                :type "lnk")))
+          (when (probe-file* shortcut)
+            (let ((target (parse-windows-shortcut shortcut)))
+              (when target
+                (return (pathname target))))))))))
 
 (defun* sysdef-central-registry-search (system)
@@ -1507 +1616 @@
 
 (defmethod find-system ((name null) &optional (error-p t))
+  (declare (ignorable name))
   (when error-p
     (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
@@ -1526 +1636 @@
         (funcall thunk))))
 
-(defmacro with-system-definitions (() &body body)
+(defmacro with-system-definitions ((&optional) &body body)
   `(call-with-system-definitions #'(lambda () ,@body)))
 
@@ -1539 +1649 @@
                                   :name name :pathname pathname
                                   :condition condition))))
-             (let ((*package* package))
+             (let ((*package* package)
+                   (*default-pathname-defaults*
+                    (pathname-directory-pathname pathname)))
                (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
                              pathname package)
@@ -1545 +1657 @@
         (delete-package package)))))
 
-(defmethod find-system ((name string) &optional (error-p t))
-  (with-system-definitions ()
-    (let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
-           (previous (cdr in-memory))
-           (previous (and (typep previous 'system) previous))
-           (previous-time (car in-memory))
+(defun* locate-system (name)
+  "Given a system NAME designator, try to locate where to load the system from.
+Returns four values: FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
+FOUNDP is true when a new was found, either a new unregistered one or a previously registered one.
+FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is
+PATHNAME when not null is a path from where to load the system, associated with FOUND-SYSTEM, or with the PREVIOUS system.
+PREVIOUS when not null is a previously loaded SYSTEM object of same name.
+PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded."
+  (let* ((name (coerce-name name))
+         (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
+         (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)))))
+         (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))))
+         (foundp (and (or found-system pathname previous) t)))
+    (check-type found (or null pathname system))
+    (when foundp
       (setf pathname (resolve-symlinks* pathname))
       (when (and pathname (not (absolute-pathname-p pathname)))
@@ -1565 +1687 @@
         (%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.
-                     (< 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 pathname
-             (setf (car in-memory) (safe-file-write-date pathname)))
-           (cdr in-memory))
-          (error-p
-           (error 'missing-component :requires name)))))))
+      (values foundp found-system pathname previous previous-time))))
+
+(defmethod find-system ((name string) &optional (error-p t))
+  (with-system-definitions ()
+    (loop
+      (restart-case
+          (multiple-value-bind (foundp found-system pathname previous previous-time)
+              (locate-system name)
+            (declare (ignore foundp))
+            (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.
+                           (< 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 if needed
+              (return
+                (cond
+                  (in-memory
+                   (when pathname
+                     (setf (car in-memory) (safe-file-write-date pathname)))
+                   (cdr in-memory))
+                  (error-p
+                   (error 'missing-component :requires name))))))
+        (reinitialize-source-registry-and-retry ()
+          :report (lambda (s)
+                    (format s "~@<Retry finding system ~A after reinitializing the source-registry.~@:>" name))
+          (initialize-source-registry))))))
 
 (defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
@@ -1703 +1839 @@
    :defaults (component-parent-pathname component)))
 
+(defun* subpathname (pathname subpath &key type)
+  (and pathname (merge-pathnames* (coerce-pathname subpath :type type)
+                                  (pathname-directory-pathname pathname))))
+
+(defun subpathname* (pathname subpath &key type)
+  (and pathname
+       (subpathname (ensure-directory-pathname pathname) subpath :type type)))
+
 ;;;; -------------------------------------------------------------------------
 ;;;; Operations
@@ -1805 +1949 @@
 
 (defmethod component-self-dependencies ((o operation) (c component))
-  (let ((all-deps (component-depends-on o c)))
-    (remove-if-not #'(lambda (x)
-                       (member (component-name c) (cdr x) :test #'string=))
-                   all-deps)))
+  (remove-if-not
+   #'(lambda (x) (member (component-name c) (cdr x) :test #'string=))
+   (component-depends-on o c)))
 
 (defmethod input-files ((operation operation) (c component))
@@ -1852 +1995 @@
          (and op-time (>= op-time (latest-in))))
         ((not in-files)
-         ;; an operation without output-files and no input-files
+         ;; an operation with output-files and no input-files
          ;; is probably meant for its side-effects on the file-system,
          ;; assumed to have to be done everytime.
@@ -1894 +2037 @@
 (defgeneric* do-traverse (operation component collect))
 
-(defun* %do-one-dep (operation c collect required-op required-c required-v)
-  ;; collects a partial plan that results from performing required-op
-  ;; on required-c, possibly with a required-vERSION
-  (let* ((dep-c (or (let ((d (find-component (component-parent c) required-c)))
-                      (and d (version-satisfies d required-v) d))
-                    (if required-v
-                        (error 'missing-dependency-of-version
-                               :required-by c
-                               :version required-v
-                               :requires required-c)
-                        (error 'missing-dependency
-                               :required-by c
-                               :requires required-c))))
-         (op (make-sub-operation c operation dep-c required-op)))
-    (do-traverse op dep-c collect)))
-
-(defun* do-one-dep (operation c collect required-op required-c required-v)
-  ;; this function is a thin, error-handling wrapper around %do-one-dep.
-  ;; Collects a partial plan per that function.
+(defun* resolve-dependency-name (component name &optional version)
   (loop
     (restart-case
-        (return (%do-one-dep operation c collect
-                             required-op required-c required-v))
+        (return
+          (let ((comp (find-component (component-parent component) name)))
+            (unless comp
+              (error 'missing-dependency
+                     :required-by component
+                     :requires name))
+            (when version
+              (unless (version-satisfies comp version)
+                (error 'missing-dependency-of-version
+                       :required-by component
+                       :version version
+                       :requires name)))
+            comp))
       (retry ()
         :report (lambda (s)
-                  (format s "~@<Retry loading ~3i~_~A.~@:>" required-c))
+                  (format s "~@<Retry loading ~3i~_~A.~@:>" name))
         :test
         (lambda (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:
-  ;; op seems to at least potentially be a symbol, rather than an operation
-  ;; dep is a list of component names
-  (cond ((eq op 'feature)
-         (if (member (car dep) *features*)
+                   (eq (missing-required-by c) component)
+                   (equal (missing-requires c) name))))))))
+
+(defun* resolve-dependency-spec (component dep-spec)
+  (cond
+    ((atom dep-spec)
+     (resolve-dependency-name component dep-spec))
+    ;; Structured dependencies --- this parses keywords.
+    ;; The keywords could conceivably be broken out and cleanly (extensibly)
+    ;; processed by EQL methods. But for now, here's what we've got.
+    ((eq :version (first dep-spec))
+     ;; https://bugs.launchpad.net/asdf/+bug/527788
+     (resolve-dependency-name component (second dep-spec) (third dep-spec)))
+    ((eq :feature (first dep-spec))
+     ;; This particular subform is not documented and
+     ;; has always been broken in the past.
+     ;; Therefore no one uses it, and I'm cerroring it out,
+     ;; after fixing it
+     ;; See https://bugs.launchpad.net/asdf/+bug/518467
+     (cerror "Continue nonetheless."
+             "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.")
+     (when (find (second dep-spec) *features* :test 'string-equal)
+       (resolve-dependency-name component (third dep-spec))))
+    (t
+     (error (compatfmt "~@<Bad dependency ~s.  Dependencies must be (:version <name> <version>), (:feature <feature> <name>), or <name>.~@:>") dep-spec))))
+
+(defun* do-one-dep (op c collect dep-op dep-c)
+  ;; Collects a partial plan for performing dep-op on dep-c
+  ;; as dependencies of a larger plan involving op and c.
+  ;; Returns t if this should force recompilation of those who depend on us.
+  ;; dep-op is an operation class name (not an operation object),
+  ;; whereas dep-c is a component object.n
+  (do-traverse (make-sub-operation c op dep-c dep-op) dep-c collect))
+
+(defun* do-dep (op c collect dep-op-spec dep-c-specs)
+  ;; Collects a partial plan for performing dep-op-spec on each of dep-c-specs
+  ;; as dependencies of a larger plan involving op and c.
+  ;; Returns t if this should force recompilation of those who depend on us.
+  ;; dep-op-spec is either an operation class name (not an operation object),
+  ;; or the magic symbol asdf:feature.
+  ;; If dep-op-spec is asdf:feature, then the first dep-c-specs is a keyword,
+  ;; and the plan will succeed if that keyword is present in *feature*,
+  ;; or fail if it isn't
+  ;; (at which point c's :if-component-dep-fails will kick in).
+  ;; If dep-op-spec is an operation class name,
+  ;; then dep-c-specs specifies a list of sibling component of c,
+  ;; as per resolve-dependency-spec, such that operating op on c
+  ;; depends on operating dep-op-spec on each of them.
+  (cond ((eq dep-op-spec 'feature)
+         (if (member (car dep-c-specs) *features*)
              nil
              (error 'missing-dependency
                     :required-by c
-                    :requires (car dep))))
+                    :requires (list :feature (car dep-c-specs)))))
         (t
          (let ((flag nil))
-           (flet ((dep (op comp ver)
-                    (when (do-one-dep operation c collect
-                                      op comp ver)
-                      (setf flag t))))
-             (dolist (d dep)
-               (if (atom d)
-                   (dep op d nil)
-                   ;; structured dependencies --- this parses keywords
-                   ;; the keywords could be broken out and cleanly (extensibly)
-                   ;; processed by EQL methods
-                   (cond ((eq :version (first d))
-                          ;; https://bugs.launchpad.net/asdf/+bug/527788
-                          (dep op (second d) (third d)))
-                         ;; This particular subform is not documented and
-                         ;; has always been broken in the past.
-                         ;; Therefore no one uses it, and I'm cerroring it out,
-                         ;; after fixing it
-                         ;; See https://bugs.launchpad.net/asdf/+bug/518467
-                         ((eq :feature (first d))
-                          (cerror "Continue nonetheless."
-                                  "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.")
-                          (when (find (second d) *features* :test 'string-equal)
-                            (dep op (third d) nil)))
-                         (t
-                          (error (compatfmt "~@<Bad dependency ~a.  Dependencies must be (:version <version>), (:feature <feature> [version]), or a name.~@:>") d))))))
+           (dolist (d dep-c-specs)
+             (when (do-one-dep op c collect dep-op-spec
+                               (resolve-dependency-spec c d))
+               (setf flag t)))
            flag))))
 
@@ -2024 +2180 @@
                                 (update-flag
                                  (do-traverse operation kid #'internal-collect))
+                              #-genera
                               (missing-dependency (condition)
                                 (when (eq (module-if-component-dep-fails c)
@@ -2088 +2245 @@
   nil)
 
+(defmethod mark-operation-done ((operation operation) (c component))
+  (setf (gethash (type-of operation) (component-operation-times c))
+    (reduce #'max
+            (cons (get-universal-time)
+                  (mapcar #'safe-file-write-date (input-files operation c))))))
+
+(defmethod perform-with-restarts (operation component)
+  ;; TOO verbose, especially as the default. Add your own :before method
+  ;; to perform-with-restart or perform if you want that:
+  #|(when *asdf-verbose* (explain operation component))|#
+  (perform operation component))
+
+(defmethod perform-with-restarts :around (operation component)
+  (loop
+    (restart-case
+        (return (call-next-method))
+      (retry ()
+        :report
+        (lambda (s)
+          (format s (compatfmt "~@<Retry ~A.~@:>")
+                  (operation-description operation component))))
+      (accept ()
+        :report
+        (lambda (s)
+          (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
+                  (operation-description operation component)))
+        (mark-operation-done operation component)
+        (return)))))
+
 (defmethod explain ((operation operation) (component component))
   (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%")
@@ -2114 +2300 @@
     (first files)))
 
+(defun* ensure-all-directories-exist (pathnames)
+   (loop :for pn :in pathnames
+     :for pathname = (if (typep pn 'logical-pathname)
+                         (translate-logical-pathname pn)
+                         pn)
+     :do (ensure-directories-exist pathname)))
+
 (defmethod perform :before ((operation compile-op) (c source-file))
-   (loop :for file :in (asdf:output-files operation c)
-     :for pathname = (if (typep file 'logical-pathname)
-                         (translate-logical-pathname file)
-                         file)
-     :do (ensure-directories-exist pathname)))
+  (ensure-all-directories-exist (asdf:output-files operation c)))
 
 (defmethod perform :after ((operation operation) (c component))
-  (setf (gethash (type-of operation) (component-operation-times c))
-        (get-universal-time)))
+  (mark-operation-done operation c))
+
+(defgeneric* around-compile-hook (component))
+(defgeneric* call-with-around-compile-hook (component thunk))
+
+(defmethod around-compile-hook ((c component))
+  (cond
+    ((slot-boundp c 'around-compile)
+     (slot-value c 'around-compile))
+    ((component-parent c)
+     (around-compile-hook (component-parent c)))))
+
+(defun ensure-function (fun &key (package :asdf))
+  (etypecase fun
+    ((or symbol function) fun)
+    (cons (eval `(function ,fun)))
+    (string (eval `(function ,(with-standard-io-syntax
+                               (let ((*package* (find-package package)))
+                                 (read-from-string fun))))))))
+
+(defmethod call-with-around-compile-hook ((c component) thunk)
+  (let ((hook (around-compile-hook c)))
+    (if hook
+        (funcall (ensure-function hook) thunk)
+        (funcall thunk))))
 
 (defvar *compile-op-compile-file-function* 'compile-file*
@@ -2139 +2351 @@
         (*compile-file-failure-behaviour* (operation-on-failure operation)))
     (multiple-value-bind (output warnings-p failure-p)
-        (apply *compile-op-compile-file-function* source-file
-               :output-file output-file (compile-op-flags operation))
+        (call-with-around-compile-hook
+         c #'(lambda ()
+               (apply *compile-op-compile-file-function* source-file
+                      :output-file output-file (compile-op-flags operation))))
       (unless output
         (error 'compile-error :component c :operation operation))
@@ -2192 +2406 @@
 (defclass load-op (basic-load-op) ())
 
+(defmethod perform-with-restarts ((o load-op) (c cl-source-file))
+  (loop
+    (restart-case
+        (return (call-next-method))
+      (try-recompiling ()
+        :report (lambda (s)
+                  (format s "Recompile ~a and try loading it again"
+                          (component-name c)))
+        (perform (make-sub-operation c o c 'compile-op) c)))))
+
 (defmethod perform ((o load-op) (c cl-source-file))
   (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))
-  (declare (ignorable o))
-  (loop :with state = :initial
-    :until (or (eq state :success)
-               (eq state :failure)) :do
-    (case state
-      (:recompiled
-       (setf state :failure)
-       (call-next-method)
-       (setf state :success))
-      (:failed-load
-       (setf state :recompiled)
-       (perform (make-sub-operation c o c 'compile-op) c))
-      (t
-       (with-simple-restart
-           (try-recompiling "Recompile ~a and try loading it again"
-                            (component-name c))
-         (setf state :failed-load)
-         (call-next-method)
-         (setf state :success))))))
-
-(defmethod perform-with-restarts ((o compile-op) (c cl-source-file))
-  (loop :with state = :initial
-    :until (or (eq state :success)
-               (eq state :failure)) :do
-    (case state
-      (:recompiled
-       (setf state :failure)
-       (call-next-method)
-       (setf state :success))
-      (:failed-compile
-       (setf state :recompiled)
-       (perform-with-restarts o c))
-      (t
-       (with-simple-restart
-           (try-recompiling "Try recompiling ~a"
-                            (component-name c))
-         (setf state :failed-compile)
-         (call-next-method)
-         (setf state :success))))))
 
 (defmethod perform ((operation load-op) (c static-file))
@@ -2281 +2460 @@
   (let ((source (component-pathname c)))
     (setf (component-property c 'last-loaded-as-source)
-          (and (load source)
+          (and (call-with-around-compile-hook c #'(lambda () (load source)))
                (get-universal-time)))))
 
@@ -2341 +2520 @@
 (defgeneric* perform-plan (plan &key))
 
+;;;; Separating this into a different function makes it more forward-compatible
+(defun* cleanup-upgraded-asdf (old-version)
+  (let ((new-version (asdf:asdf-version)))
+    (unless (equal old-version new-version)
+      (cond
+        ((version-satisfies new-version old-version)
+         (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
+                       old-version new-version))
+        ((version-satisfies old-version new-version)
+         (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%")
+               old-version new-version))
+        (t
+         (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
+                       old-version new-version)))
+      (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf)))
+        ;; Invalidate all systems but ASDF itself.
+        (setf *defined-systems* (make-defined-systems-table))
+        (register-system asdf)
+        ;; If we're in the middle of something, restart it.
+        (when *systems-being-defined*
+          (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name)))
+            (clrhash *systems-being-defined*)
+            (dolist (s l) (find-system s nil))))
+        t))))
+
 ;;;; 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.
@@ -2347 +2551 @@
     (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 (funcall (find-symbol* 'find-system :asdf) :asdf)))
-          ;; invalidate all systems but ASDF itself
-          (setf *defined-systems* (make-defined-systems-table))
-          (register-system asdf)
-          t)))))
+    (cleanup-upgraded-asdf version)))
 
 (defmethod perform-plan ((steps list) &key)
@@ -2372 +2558 @@
     (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))))))))
+        (perform-with-restarts op component)))))
 
 (defmethod operate (operation-class system &rest args
@@ -2447 +2615 @@
   (setf (documentation 'oos 'function)
         (format nil
-                "Short for _operate on system_ and an alias for the OPERATE function. ~&~&~a"
+                "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a"
                 operate-docstring))
   (setf (documentation 'operate 'function)
@@ -2458 +2626 @@
   (apply 'operate 'load-op system args)
   t)
+
+(defun* load-systems (&rest systems)
+  (map () 'load-system systems))
 
 (defun* compile-system (system &rest args &key force verbose version
@@ -2481 +2652 @@
   (resolve-symlinks* (or *load-pathname* *compile-file-pathname*)))
 
-(defun* determine-system-pathname (pathname pathname-supplied-p)
+(defun* determine-system-pathname (pathname)
   ;; The defsystem macro calls us to determine
   ;; the pathname of a system as follows:
@@ -2489 +2660 @@
   (let* ((file-pathname (load-pathname))
          (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
-    (or (and pathname-supplied-p
-             (merge-pathnames* (coerce-pathname pathname :type :directory)
-                               directory-pathname))
+    (or (and pathname (subpathname directory-pathname pathname :type :directory))
         directory-pathname
         (default-directory))))
@@ -2517 +2686 @@
         (progn
           (aif (assoc op2 (cdr first-op-tree))
-               (if (find c (cdr it))
+               (if (find c (cdr it) :test #'equal)
                    nil
                    (setf (cdr it) (cons c (cdr it))))
@@ -2539 +2708 @@
 
 (defun* sysdef-error-component (msg type name value)
-  (sysdef-error (concatenate 'string msg
-                             (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
+  (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
                 type name value))
 
@@ -2617 +2785 @@
               version name parent)))
 
-    (let* ((other-args (remove-keys
-                        '(components pathname default-component-class
-                          perform explain output-files operation-done-p
-                          weakly-depends-on
-                          depends-on serial in-order-to)
-                        rest))
-           (ret
-            (or (find-component parent name)
-                (make-instance (class-for-type parent type)))))
+    (let* ((args (list* :name (coerce-name name)
+                        :pathname pathname
+                        :parent parent
+                        (remove-keys
+                         '(components pathname default-component-class
+                           perform explain output-files operation-done-p
+                           weakly-depends-on depends-on serial in-order-to)
+                         rest)))
+           (ret (find-component parent name)))
       (when weakly-depends-on
-        (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on)))
+        (appendf depends-on (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on)))
       (when *serial-depends-on*
         (push *serial-depends-on* depends-on))
-      (apply 'reinitialize-instance ret
-             :name (coerce-name name)
-             :pathname pathname
-             :parent parent
-             other-args)
+      (if ret ; preserve identity
+          (apply 'reinitialize-instance ret args)
+          (setf ret (apply 'make-instance (class-for-type parent type) args)))
       (component-pathname ret) ; eagerly compute the absolute pathname
       (when (typep ret 'module)
@@ -2661 +2827 @@
             (union-of-dependencies
              do-first
-             `((compile-op (load-op ,@depends-on)))))
+             `((compile-op (load-op ,@depends-on)))))
 
       (%refresh-component-inline-methods ret rest)
       ret)))
 
+(defun* reset-system (system &rest keys &key &allow-other-keys)
+  (change-class (change-class system 'proto-system) 'system)
+  (apply 'reinitialize-instance system keys))
+
 (defun* do-defsystem (name &rest options
-                           &key (pathname nil pathname-arg-p) (class 'system)
+                           &key pathname (class 'system)
                            defsystem-depends-on &allow-other-keys)
   ;; The system must be registered before we parse the body,
@@ -2678 +2848 @@
     (let* ((name (coerce-name name))
            (registered (system-registered-p name))
-           (system (cdr (or registered
-                            (register-system (make-instance 'system :name name)))))
+           (registered! (if registered
+                            (rplaca registered (get-universal-time))
+                            (register-system (make-instance 'system :name name))))
+           (system (reset-system (cdr registered!)
+                                :name name :source-file (load-pathname)))
            (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)
+      (apply 'load-systems 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.
@@ -2694 +2864 @@
        nil (list*
             :module name
-            :pathname (determine-system-pathname pathname pathname-arg-p)
+            :pathname (determine-system-pathname pathname)
             component-options)))))
 
@@ -2707 +2877 @@
 ;;;; If the docstring is ambiguous, send a bug report.
 ;;;;
+;;;; WARNING! The function below is mostly dysfunctional.
+;;;; For instance, it will probably run fine on most implementations on Unix,
+;;;; which will hopefully use the shell /bin/sh (which we force in some cases)
+;;;; which is hopefully reasonably compatible with a POSIX *or* Bourne shell.
+;;;; But behavior on Windows may vary wildly between implementations,
+;;;; either relying on your having installed a POSIX sh, or going through
+;;;; the CMD.EXE interpreter, for a totally different meaning, depending on
+;;;; what is easily expressible in said implementation.
+;;;;
 ;;;; We probably should move this functionality to its own system and deprecate
 ;;;; use of it from the asdf package. However, this would break unspecified
@@ -2712 +2891 @@
 ;;;; it, and even after it's been deprecated, we will support it for a few
 ;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01
+;;;;
+;;;; As a suggested replacement which is portable to all ASDF-supported
+;;;; implementations and operating systems except Genera, I recommend
+;;;; xcvb-driver's xcvb-driver:run-program/process-output-stream and its
+;;;; derivatives such as xcvb-driver:run-program/for-side-effects.
 
 (defun* run-shell-command (control-string &rest args)
@@ -2727 +2911 @@
     (multiple-value-bind (stdout stderr exit-code)
         (excl.osi:command-output
-         (format nil "~a -c \"~a\""
-                 #+mswindows "sh" #-mswindows "/bin/sh" command)
+         #-mswindows (vector "/bin/sh" "/bin/sh" "-c" command)
+         #+mswindows command ; BEWARE!
          :input nil :whole nil
          #+mswindows :show-window #+mswindows :hide)
-      (asdf-message "~{~&; ~a~%~}~%" stderr)
-      (asdf-message "~{~&; ~a~%~}~%" stdout)
+      (asdf-message "~{~&~a~%~}~%" stderr)
+      (asdf-message "~{~&~a~%~}~%" stdout)
       exit-code)
 
-    #+clisp                    ;XXX not exactly *verbose-out*, I know
-    (or (ext:run-shell-command command :output (and *verbose-out* :terminal) :wait t) 0)
+    #+clisp
+    ;; CLISP returns NIL for exit status zero.
+    (if *verbose-out*
+        (let* ((new-command (format nil "( ~A ) ; r=$? ; echo ; echo ASDF-EXIT-STATUS $r"
+                                    command))
+               (outstream (ext:run-shell-command new-command :output :stream :wait t)))
+            (multiple-value-bind (retval out-lines)
+                (unwind-protect
+                     (parse-clisp-shell-output outstream)
+                  (ignore-errors (close outstream)))
+              (asdf-message "~{~&~a~%~}~%" out-lines)
+              retval))
+        ;; there will be no output, just grab up the exit status
+        (or (ext:run-shell-command command :output nil :wait t) 0))
 
     #+clozure
     (nth-value 1
                (ccl:external-process-status
-                (ccl:run-program "/bin/sh" (list "-c" command)
-                                 :input nil :output *verbose-out*
-                                 :wait t)))
+                (ccl:run-program
+                 (cond
+                   ((os-unix-p) "/bin/sh")
+                   ((os-windows-p) (strcat "CMD /C " command)) ; BEWARE!
+                   (t (error "Unsupported OS")))
+                 (if (os-unix-p) (list "-c" command) '())
+                 :input nil :output *verbose-out* :wait t)))
 
     #+(or cmu scl)
@@ -2749 +2949 @@
      (ext:run-program
       "/bin/sh"
-      (list  "-c" command)
+      (list "-c" command)
       :input nil :output *verbose-out*))
 
+    #+cormanlisp
+    (win32:system command)
+
     #+ecl ;; courtesy of Juan Jose Garcia Ripoll
-    (si:system command)
+    (ext:system command)
 
     #+gcl
@@ -2759 +2962 @@
 
     #+lispworks
-    (system:call-system-showing-output
-     command
-     :shell-type "/bin/sh"
-     :show-cmd nil
-     :prefix ""
-     :output-stream *verbose-out*)
+    (apply 'system:call-system-showing-output command
+           :show-cmd nil :prefix "" :output-stream *verbose-out*
+           (when (os-unix-p) '(:shell-type "/bin/sh")))
 
     #+mcl
@@ -2782 +2982 @@
     #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl sbcl scl xcl)
     (error "RUN-SHELL-COMMAND not implemented for this Lisp")))
+
+#+clisp
+(defun* parse-clisp-shell-output (stream)
+  "Helper function for running shell commands under clisp.  Parses a specially-
+crafted output string to recover the exit status of the shell command and a
+list of lines of output."
+  (loop :with status-prefix = "ASDF-EXIT-STATUS "
+    :with prefix-length = (length status-prefix)
+    :with exit-status = -1 :with lines = ()
+    :for line = (read-line stream nil nil)
+    :while line :do (push line lines) :finally
+    (let* ((last (car lines))
+           (status (and last (>= (length last) prefix-length)
+                        (string-equal last status-prefix :end1 prefix-length)
+                        (parse-integer last :start prefix-length :junk-allowed t))))
+      (when status
+        (setf exit-status status)
+        (pop lines) (when (equal "" (car lines)) (pop lines)))
+      (return (values exit-status (reverse lines))))))
 
 ;;;; ---------------------------------------------------------------------------
@@ -2799 +3018 @@
   (system-source-file x))
 
+(defmethod system-source-file ((system system))
+  (%system-source-file system))
 (defmethod system-source-file ((system-name string))
-  (system-source-file (find-system system-name)))
+  (%system-source-file (find-system system-name)))
 (defmethod system-source-file ((system-name symbol))
-  (system-source-file (find-system system-name)))
+  (%system-source-file (find-system system-name)))
 
 (defun* system-source-directory (system-designator)
@@ -2826 +3047 @@
 
 (defun* system-relative-pathname (system name &key type)
-  (merge-pathnames*
-   (coerce-pathname name :type type)
-   (system-source-directory system)))
+  (subpathname (system-source-directory system) name :type type))
 
 
@@ -2836 +3055 @@
 ;;; produce a string to identify current implementation.
 ;;; Initially stolen from SLIME's SWANK, rewritten since.
-;;; The (car '(...)) idiom avoids unreachable code warnings.
-
-(defparameter *implementation-type*
-  (car '(#+abcl :abcl #+allegro :acl
-         #+clozure :ccl #+clisp :clisp #+cormanlisp :corman #+cmu :cmu
-         #+ecl :ecl #+gcl :gcl #+lispworks :lw #+mcl :mcl
-         #+sbcl :sbcl #+scl :scl #+symbolics :symbolic #+xcl :xcl)))
-
-(defparameter *operating-system*
-  (car '(#+cygwin :cygwin #+(or windows mswindows win32 mingw32) :win
-         #+(or linux linux-target) :linux ;; for GCL at least, must appear before :bsd.
-         #+(or macosx darwin darwin-target apple) :macosx ; also before :bsd
-         #+(or solaris sunos) :solaris
-         #+(or freebsd netbsd openbsd bsd) :bsd
-         #+unix :unix
-         #+genera :genera)))
-
-(defparameter *architecture*
-  (car '(#+(or amd64 x86-64 x86_64 x8664-target (and word-size=64 pc386)) :x64
-         #+(or x86 i386 i486 i586 i686 pentium3 pentium4 pc386 iapx386 x8632-target) :x86
-         #+hppa64 :hppa64 #+hppa :hppa
-         #+(or ppc64 ppc64-target) :ppc64
-         #+(or ppc32 ppc32-target ppc powerpc) :ppc32
-         #+sparc64 :sparc64 #+(or sparc32 sparc) :sparc32
-         #+(or arm arm-target) :arm
-         #+(or java java-1.4 java-1.5 java-1.6 java-1.7) :java
-         #+mipsel :mispel #+mipseb :mipseb #+mips :mips
-         #+alpha :alpha #+imach :imach)))
-
-(defparameter *lisp-version-string*
+;;; We're back to runtime checking, for the sake of e.g. ABCL.
+
+(defun* first-feature (features)
+  (dolist (x features)
+    (multiple-value-bind (val feature)
+        (if (consp x) (values (first x) (cons :or (rest x))) (values x x))
+      (when (featurep feature) (return val)))))
+
+(defun implementation-type ()
+  (first-feature
+   '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) :cmu
+     :ecl :gcl (:lw :lispworks) :mcl :sbcl :scl :symbolics :xcl)))
+
+(defun operating-system ()
+  (first-feature
+   '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
+     (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd
+     (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd
+     (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix
+     :genera)))
+
+(defun architecture ()
+  (first-feature
+   '((:x64 :amd64 :x86-64 :x86_64 :x8664-target (:and :word-size=64 :pc386))
+     (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
+     (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc)
+     :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc)
+     :mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach
+     ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI,
+     ;; we may have to segregate the code still by architecture.
+     (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7))))
+
+#+clozure
+(defun* ccl-fasl-version ()
+  ;; the fasl version is target-dependent from CCL 1.8 on.
+  (or (and (fboundp 'ccl::target-fasl-version)
+           (funcall 'ccl::target-fasl-version))
+      (and (boundp 'ccl::fasl-version)
+           (symbol-value 'ccl::fasl-version))
+      (error "Can't determine fasl version.")))
+
+(defun lisp-version-string ()
   (let ((s (lisp-implementation-version)))
-    (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")))
-     #+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:target-fasl-version) #xFF))
-     #+cmu (substitute #\- #\/ s)
-     #+ecl (format nil "~A~@[-~A~]" s
-                   (let ((vcs-id (ext:lisp-implementation-vcs-id)))
-                     (subseq vcs-id 0 (min (length vcs-id) 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))
-     #+mcl (subseq s 8) ; strip the leading "Version "
-     s)))
-
-(defun* implementation-type ()
-  *implementation-type*)
+    (car ; as opposed to OR, this idiom prevents some unreachable code warning
+     (list
+      #+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")))
+      #+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)
+      #+scl (format nil "~A~A" s
+                    ;; ANSI upper case vs lower case.
+                    (ecase ext:*case-mode* (:upper "") (:lower "l")))
+      #+ecl (format nil "~A~@[-~A~]" s
+                    (let ((vcs-id (ext:lisp-implementation-vcs-id)))
+                      (subseq vcs-id 0 (min (length vcs-id) 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))
+      #+mcl (subseq s 8) ; strip the leading "Version "
+      s))))
 
 (defun* implementation-identifier ()
@@ -2902 +3134 @@
    #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
    (format nil "~(~a~@{~@[-~a~]~}~)"
-           (or *implementation-type* (lisp-implementation-type))
-           (or *lisp-version-string* (lisp-implementation-version))
-           (or *operating-system* (software-type))
-           (or *architecture* (machine-type)))))
+           (or (implementation-type) (lisp-implementation-type))
+           (or (lisp-version-string) (lisp-implementation-version))
+           (or (operating-system) (software-type))
+           (or (architecture) (machine-type)))))
 
 
@@ -2911 +3143 @@
 ;;; Generic support for configuration files
 
-(defparameter *inter-directory-separator*
-  #+asdf-unix #\:
-  #-asdf-unix #\;)
+(defun inter-directory-separator ()
+  (if (os-unix-p) #\: #\;))
 
 (defun* user-homedir ()
@@ -2921 +3152 @@
     #-mcl (user-homedir-pathname))))
 
-(defun* try-directory-subpath (x sub &key type)
-  (let* ((p (and x (ensure-directory-pathname x)))
-         (tp (and p (probe-file* p)))
-         (sp (and tp (merge-pathnames* (coerce-pathname sub :type type) p)))
-         (ts (and sp (probe-file* sp))))
-    (and ts (values sp ts))))
+(defun* ensure-absolute-pathname* (x fmt &rest args)
+  (and (plusp (length x))
+       (or (absolute-pathname-p x)
+           (cerror "ignore relative pathname"
+                   "Invalid relative pathname ~A~@[ ~?~]" x fmt args))
+       x))
+(defun* split-absolute-pathnames (x fmt &rest args)
+  (loop :for dir :in (split-string
+                      x :separator (string (inter-directory-separator)))
+    :do (apply 'ensure-absolute-pathname* dir fmt args)
+    :collect dir))
+(defun getenv-absolute-pathname (x &aux (s (getenv x)))
+  (ensure-absolute-pathname* s "from (getenv ~S)" x))
+(defun getenv-absolute-pathnames (x &aux (s (getenv x)))
+  (split-absolute-pathnames s "from (getenv ~S) = ~S" x s))
+
 (defun* user-configuration-directories ()
   (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/")
+         `(,@(when (os-unix-p)
+               (cons
+                (subpathname* (getenv-absolute-pathname "XDG_CONFIG_HOME") "common-lisp/")
+                (loop :for dir :in (getenv-absolute-pathnames "XDG_CONFIG_DIRS")
+                  :collect (subpathname* dir "common-lisp/"))))
+           ,@(when (os-windows-p)
+               `(,(subpathname* (or #+lispworks (sys:get-folder-path :local-appdata)
+                                    (getenv-absolute-pathname "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)))
+                 ,(subpathname* (or #+lispworks (sys:get-folder-path :appdata)
+                                    (getenv-absolute-pathname "APPDATA"))
+                                "common-lisp/config/")))
+           ,(subpathname (user-homedir) ".config/common-lisp/"))))
+    (remove-duplicates (remove-if-not #'absolute-pathname-p dirs)
+                       :from-end t :test 'equal)))
+
 (defun* system-configuration-directories ()
-  (remove-if
-   #'null
-   `(#+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))))))
-(defun* in-user-configuration-directory (x)
-  (in-first-directory (user-configuration-directories) x))
-(defun* in-system-configuration-directory (x)
-  (in-first-directory (system-configuration-directories) x))
+  (cond
+    ((os-unix-p) '(#p"/etc/common-lisp/"))
+    ((os-windows-p)
+     (aif
+      ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
+      (subpathname* (or #+lispworks (sys:get-folder-path :common-appdata)
+                        (getenv-absolute-pathname "ALLUSERSAPPDATA")
+                        (subpathname* (getenv-absolute-pathname "ALLUSERSPROFILE") "Application Data/"))
+                    "common-lisp/config/")
+      (list it)))))
+
+(defun* in-first-directory (dirs x &key (direction :input))
+  (loop :with fun = (ecase direction
+                      ((nil :input :probe) 'probe-file*)
+                      ((:output :io) 'identity))
+    :for dir :in dirs
+    :thereis (and dir (funcall fun (merge-pathnames* x (ensure-directory-pathname dir))))))
+
+(defun* in-user-configuration-directory (x &key (direction :input))
+  (in-first-directory (user-configuration-directories) x :direction direction))
+(defun* in-system-configuration-directory (x &key (direction :input))
+  (in-first-directory (system-configuration-directories) x :direction direction))
 
 (defun* configuration-inheritance-directive-p (x)
@@ -3072 +3319 @@
   (flet ((try (x &rest sub) (and x `(,x ,@sub))))
     (or
-     (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation)
-     #+asdf-windows
-     (try (or #+lispworks (sys:get-folder-path :local-appdata)
-              (getenv "LOCALAPPDATA")
-              #+lispworks (sys:get-folder-path :appdata)
-              (getenv "APPDATA"))
-          "common-lisp" "cache" :implementation)
+     (try (getenv-absolute-pathname "XDG_CACHE_HOME") "common-lisp" :implementation)
+     (when (os-windows-p)
+       (try (or #+lispworks (sys:get-folder-path :local-appdata)
+                (getenv-absolute-pathname "LOCALAPPDATA")
+                #+lispworks (sys:get-folder-path :appdata)
+                (getenv-absolute-pathname "APPDATA"))
+            "common-lisp" "cache" :implementation))
      '(:home ".cache" "common-lisp" :implementation))))
 
@@ -3205 +3452 @@
            (typep c '(or string pathname
                       (member :default-directory :*/ :**/ :*.*.*
-                        :implementation :implementation-type
-                        #+asdf-unix :uid)))))
+                        :implementation :implementation-type)))))
     (or (typep x 'boolean)
         (absolute-component-p x)
@@ -3213 +3459 @@
 (defun* location-function-p (x)
   (and
-   (consp x)
    (length=n-p x 2)
-   (or (and (equal (first x) :function)
-            (typep (second x) 'symbol))
-       (and (equal (first x) 'lambda)
-            (cddr x)
-            (length=n-p (second x) 2)))))
+   (eq (car x) :function)
+   (or (symbolp (cadr x))
+       (and (consp (cadr x))
+            (eq (caadr x) 'lambda)
+            (length=n-p (cadadr x) 2)))))
 
 (defun* validate-output-translations-directive (directive)
@@ -3266 +3511 @@
       :with end = (length string)
       :with source = nil
-      :for i = (or (position *inter-directory-separator* string :start start) end) :do
+      :with separator = (inter-directory-separator)
+      :for i = (or (position separator string :start start) end) :do
       (let ((s (subseq string start i)))
         (cond
@@ -3316 +3562 @@
 (defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/"))
 
-(defun* user-output-translations-pathname ()
-  (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 ()
-  (in-user-configuration-directory *output-translations-directory*))
-(defun* system-output-translations-directory-pathname ()
-  (in-system-configuration-directory *output-translations-directory*))
+(defun* user-output-translations-pathname (&key (direction :input))
+  (in-user-configuration-directory *output-translations-file* :direction direction))
+(defun* system-output-translations-pathname (&key (direction :input))
+  (in-system-configuration-directory *output-translations-file* :direction direction))
+(defun* user-output-translations-directory-pathname (&key (direction :input))
+  (in-user-configuration-directory *output-translations-directory* :direction direction))
+(defun* system-output-translations-directory-pathname (&key (direction :input))
+  (in-system-configuration-directory *output-translations-directory* :direction direction))
 (defun* environment-output-translations ()
   (getenv "ASDF_OUTPUT_TRANSLATIONS"))
@@ -3446 +3692 @@
 
 (defun* apply-output-translations (path)
+  #+cormanlisp (truenamize path) #-cormanlisp
   (etypecase path
-    #+cormanlisp (t (truenamize path))
     (logical-pathname
      path)
@@ -3468 +3714 @@
 (defmethod output-files :around (operation component)
   "Translate output files, unless asked not to"
-  (declare (ignorable operation component))
+  operation component ;; hush genera, not convinced by declare ignorable(!)
   (values
    (multiple-value-bind (files fixedp) (call-next-method)
@@ -3488 +3734 @@
 (defun* tmpize-pathname (x)
   (make-pathname
-   :name (format nil "ASDF-TMP-~A" (pathname-name x))
+   :name (strcat "ASDF-TMP-" (pathname-name x))
    :defaults x))
 
@@ -3552 +3798 @@
      (centralize-lisp-binaries nil)
      (default-toplevel-directory
-         ;; Use ".cache/common-lisp" instead ???
-         (merge-pathnames* (make-pathname :directory '(:relative ".fasls"))
-                           (user-homedir)))
+         (subpathname (user-homedir) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
      (include-per-user-information nil)
      (map-all-source-files (or #+(or ecl clisp) t nil))
@@ -3580 +3824 @@
 
 ;;;; -----------------------------------------------------------------
-;;;; Windows shortcut support.  Based on:
-;;;;
-;;;; Jesse Hager: The Windows Shortcut File Format.
-;;;; http://www.wotsit.org/list.asp?fc=13
-
-#+(and asdf-windows (not clisp))
-(progn
-(defparameter *link-initial-dword* 76)
-(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
-
-(defun* read-null-terminated-string (s)
-  (with-output-to-string (out)
-    (loop :for code = (read-byte s)
-      :until (zerop code)
-      :do (write-char (code-char code) out))))
-
-(defun* read-little-endian (s &optional (bytes 4))
-  (loop :for i :from 0 :below bytes
-    :sum (ash (read-byte s) (* 8 i))))
-
-(defun* parse-file-location-info (s)
-  (let ((start (file-position s))
-        (total-length (read-little-endian s))
-        (end-of-header (read-little-endian s))
-        (fli-flags (read-little-endian s))
-        (local-volume-offset (read-little-endian s))
-        (local-offset (read-little-endian s))
-        (network-volume-offset (read-little-endian s))
-        (remaining-offset (read-little-endian s)))
-    (declare (ignore total-length end-of-header local-volume-offset))
-    (unless (zerop fli-flags)
-      (cond
-        ((logbitp 0 fli-flags)
-          (file-position s (+ start local-offset)))
-        ((logbitp 1 fli-flags)
-          (file-position s (+ start
-                              network-volume-offset
-                              #x14))))
-      (concatenate 'string
-        (read-null-terminated-string s)
-        (progn
-          (file-position s (+ start remaining-offset))
-          (read-null-terminated-string s))))))
-
-(defun* parse-windows-shortcut (pathname)
-  (with-open-file (s pathname :element-type '(unsigned-byte 8))
-    (handler-case
-        (when (and (= (read-little-endian s) *link-initial-dword*)
-                   (let ((header (make-array (length *link-guid*))))
-                     (read-sequence header s)
-                     (equalp header *link-guid*)))
-          (let ((flags (read-little-endian s)))
-            (file-position s 76)        ;skip rest of header
-            (when (logbitp 0 flags)
-              ;; skip shell item id list
-              (let ((length (read-little-endian s 2)))
-                (file-position s (+ length (file-position s)))))
-            (cond
-              ((logbitp 1 flags)
-                (parse-file-location-info s))
-              (t
-                (when (logbitp 2 flags)
-                  ;; skip description string
-                  (let ((length (read-little-endian s 2)))
-                    (file-position s (+ length (file-position s)))))
-                (when (logbitp 3 flags)
-                  ;; finally, our pathname
-                  (let* ((length (read-little-endian s 2))
-                         (buffer (make-array length)))
-                    (read-sequence buffer s)
-                    (map 'string #'code-char buffer)))))))
-      (end-of-file ()
-        nil)))))
-
-;;;; -----------------------------------------------------------------
 ;;;; Source Registry Configuration, by Francois-Rene Rideau
 ;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
@@ -3696 +3865 @@
         :for p = (or (and (typep f 'logical-pathname) f)
                      (let* ((u (ignore-errors (funcall merger f))))
+                       ;; The first u avoids a cumbersome (truename u) error
                        (and u (equal (ignore-errors (truename u)) f) u)))
         :when p :collect p)
@@ -3709 +3879 @@
      directory entries
      #'(lambda (f)
-         (make-pathname :defaults directory :version (pathname-version f)
-                        :name (pathname-name f) :type (pathname-type f))))))
+         (make-pathname :defaults directory
+                        :name (pathname-name f) :type (ununspecific (pathname-type f))
+                        :version (ununspecific (pathname-version f)))))))
 
 (defun* directory-asd-files (directory)
@@ -3719 +3890 @@
          #-(or abcl cormanlisp genera xcl)
          (wild (merge-pathnames*
-                #-(or abcl allegro cmu lispworks scl xcl)
+                #-(or abcl allegro cmu lispworks sbcl scl xcl)
                 *wild-directory*
-                #+(or abcl allegro cmu lispworks scl xcl) "*.*"
+                #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
                 directory))
          (dirs
@@ -3731 +3902 @@
           #+cormanlisp (cl::directory-subdirs directory)
           #+genera (fs:directory-list directory))
-         #+(or abcl allegro cmu genera lispworks scl xcl)
+         #+(or abcl allegro cmu genera lispworks sbcl 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)
+                          #+(or cmu sbcl 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)))
+                                  #+(or cmu lispworks sbcl scl) x)))
     (filter-logical-directory-results
      directory dirs
@@ -3814 +3985 @@
       :with start = 0
       :with end = (length string)
-      :for pos = (position *inter-directory-separator* string :start start) :do
+      :with separator = (inter-directory-separator)
+      :for pos = (position separator string :start start) :do
       (let ((s (subseq string start (or pos end))))
         (flet ((check (dir)
@@ -3860 +4032 @@
     #+sbcl (:tree ,(truenamize (getenv "SBCL_HOME")))
     :inherit-configuration
-    #+cmu (:tree #p"modules:")))
+    #+cmu (:tree #p"modules:")
+    #+scl (:tree #p"file://modules/")))
 (defun* default-source-registry ()
-  (flet ((try (x sub) (try-directory-subpath x sub)))
-    `(:source-registry
-      #+sbcl (:directory ,(try (user-homedir) ".sbcl/systems/"))
-      (:directory ,(default-directory))
+  `(:source-registry
+    #+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/"))
+    (:directory ,(default-directory))
       ,@(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*))
-(defun* system-source-registry ()
-  (in-system-configuration-directory *source-registry-file*))
-(defun* user-source-registry-directory ()
-  (in-user-configuration-directory *source-registry-directory*))
-(defun* system-source-registry-directory ()
-  (in-system-configuration-directory *source-registry-directory*))
+          `(,@(when (os-unix-p)
+                `(,(or (getenv-absolute-pathname "XDG_DATA_HOME")
+                       (subpathname (user-homedir) ".local/share/"))
+                  ,@(or (getenv-absolute-pathnames "XDG_DATA_DIRS")
+                        '("/usr/local/share" "/usr/share"))))
+            ,@(when (os-windows-p)
+                `(,(or #+lispworks (sys:get-folder-path :local-appdata)
+                       (getenv-absolute-pathname "LOCALAPPDATA"))
+                  ,(or #+lispworks (sys:get-folder-path :appdata)
+                       (getenv-absolute-pathname "APPDATA"))
+                  ,(or #+lispworks (sys:get-folder-path :common-appdata)
+                       (getenv-absolute-pathname "ALLUSERSAPPDATA")
+                       (subpathname* (getenv-absolute-pathname "ALLUSERSPROFILE") "Application Data/")))))
+          :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
+          :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
+      :inherit-configuration))
+(defun* user-source-registry (&key (direction :input))
+  (in-user-configuration-directory *source-registry-file* :direction direction))
+(defun* system-source-registry (&key (direction :input))
+  (in-system-configuration-directory *source-registry-file* :direction direction))
+(defun* user-source-registry-directory (&key (direction :input))
+  (in-user-configuration-directory *source-registry-directory* :direction direction))
+(defun* system-source-registry-directory (&key (direction :input))
+  (in-system-configuration-directory *source-registry-directory* :direction direction))
 (defun* environment-source-registry ()
   (getenv "CL_SOURCE_REGISTRY"))
@@ -3966 +4137 @@
           ,@*default-source-registries*)
         :register #'(lambda (directory &key recurse exclude)
-                      (collect (list directory :recurse recurse :exclude exclude)))))
-     :test 'equal :from-end t)))
-
-;; Will read the configuration and initialize all internal variables,
-;; and return the new configuration.
+                      (collect (list directory :recurse recurse :exclude exclude))))))
+   :test 'equal :from-end t))
+
+;; Will read the configuration and initialize all internal variables.
 (defun* compute-source-registry (&optional parameter (registry *source-registry*))
   (dolist (entry (flatten-source-registry parameter))
@@ -4042 +4212 @@
 #+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))))
+  (setf *compile-op-compile-file-function* 'ecl-compile-file)
+
+  (defun ecl-compile-file (input-file &rest keys &key &allow-other-keys)
+    (if (use-ecl-byte-compiler-p)
+        (apply 'compile-file* input-file keys)
+        (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))))
+    (let* ((p (lispize-pathname (component-pathname c)))
+           (f (compile-file-pathname p :type :fasl)))
+      (if (use-ecl-byte-compiler-p)
+          (list f)
+          (list (compile-file-pathname p :type :object) f))))
 
   (defmethod perform ((o load-op) (c cl-source-file))
@@ -4064 +4238 @@
          (loop :for i :in (input-files o c)
            :unless (string= (pathname-type i) "fas")
-           :collect (compile-file-pathname (lispize-pathname i))))))
+               :collect (compile-file-pathname (lispize-pathname i))))))
 
 ;;;; -----------------------------------------------------------------
@@ -4074 +4248 @@
   (handler-bind
       ((style-warning #'muffle-warning)
+       #-genera
        (missing-component (constantly nil))
        (error #'(lambda (e)
@@ -4091 +4266 @@
             #+clisp ,x
             #+clozure ccl:*module-provider-functions*
-            #+cmu ext:*module-provider-functions*
-            #+ecl si:*module-provider-functions*
+            #+(or cmu ecl) ext:*module-provider-functions*
             #+sbcl sb-ext:*module-provider-functions*))))