Changeset 13656

Timestamp:

10/21/11 20:59:01 (12 years ago)

Author:

Mark Evenson

Message:

Upgrade to ASDF 2.0.17.022

Location:

branches/1.0.x/abcl

Files:

• doc/asdf/asdf.texinfo (modified) (8 diffs)
• src/org/armedbear/lisp/asdf.lisp (modified) (49 diffs)

branches/1.0.x/abcl/doc/asdf/asdf.texinfo

@@ -518 +518 @@
 
 @section Configuring where ASDF stores object files
-@findex clear-output-locations
+@findex clear-output-translations
 
 ASDF lets you configure where object files will be stored.
@@ -596 +596 @@
 @node Using ASDF, Defining systems with defsystem, Configuring ASDF, Top
 @comment  node-name,  next,  previous,  up
+
+
+@section Resetting Configuration
+
+When you dump and restore an image, or when you tweak your configuration,
+you may want to reset the ASDF configuration.
+For that you may use the following function:
+
+@defun clear-configuration
+   undoes any ASDF configuration,
+   regarding source-registry or output-translations.
+@end defun
+
+If you use SBCL, CMUCL or SCL, you may use this snippet
+so that the ASDF configuration be cleared automatically as you dump an image:
+
+@example
+#+(or cmu sbcl scl)
+(pushnew 'clear-configuration
+         #+(or cmu scl) ext:*before-save-initializations*
+         #+sbcl sb-ext:*save-hooks*)
+@end example
+
+For compatibility with all Lisp implementations, however,
+you might want instead your build script to explicitly call
+@code{(asdf:clear-configuration)} at an appropriate moment before dumping.
+
 
 @chapter Using ASDF
@@ -1211 +1238 @@
 * Operations::
 * Components::
+* Functions::
 @end menu
 
@@ -1411 +1439 @@
 CL stream @code{*standard-output*}, as the Lisp compiler and loader do.
 
-@node Components,  , Operations, The object model of ASDF
+@node Components, Functions, Operations, The object model of ASDF
 @comment  node-name,  next,  previous,  up
 @section Components
@@ -1574 +1602 @@
 (this-op {(other-op required-components)}+)
 
-required-components := component-name
+simple-component-name := string
+                      |  symbol
+
+required-components := simple-component-name
                      | (required-components required-components)
 
-component-name := string
-                | (:version string minimum-version-object)
+component-name := simple-component-name
+                | (:version simple-component-name minimum-version-object)
 @end verbatim
 
@@ -1788 +1819 @@
     )
 @end lisp
+
+@node Functions,  , Components, The object model of ASDF
+@comment  node-name,  next,  previous,  up
+@section Functions
+@findex version-satisfies
+
+@deffn version-satisfies @var{version} @var{version-spec}
+Does @var{version} satisfy the @var{version-spec}.  A generic function.
+ASDF provides built-in methods for @var{version} being a
+@code{component} or @code{string}.  @var{version-spec} should be a
+string.
+
+In the wild, we typically see version numbering only on components of
+type @code{system}.
+
+For more information about how @code{version-satisfies} interprets
+version strings and specifications, @pxref{The defsystem grammar} and
+@ref{Common attributes of components}.
+@end deffn
 
 @node Controlling where ASDF searches for systems, Controlling where ASDF saves compiled files, The object model of ASDF, Top
@@ -2775 +2825 @@
 @chapter Miscellaneous additional functionality
 
-@emph{FIXME:  Add discussion of @code{run-shell-command}?  Others?}
-
 ASDF includes several additional features that are generally
-useful for system definition and development. These include:
+useful for system definition and development.
+
+@section Controlling file compilation
+
+When declaring a component (system, module, file),
+you can specify a keyword argument @code{:around-compile some-symbol}.
+If left unspecified, the value will be inherited from the parent component if any,
+or with a default of @code{nil} if no value is specified in any transitive parent.
+
+The argument must be a either fbound symbol or @code{nil}.
+@code{nil} means the normal compile-file function will be called.
+A symbol means the function fbound to it will be called with a single argument,
+a thunk that calls the compile-file function;
+the function you specify must then funcall that thunk
+inside whatever wrapping you want.
+
+Using this hook, you may achieve such effects as:
+locally renaming packages,
+binding @var{*readtables*} and other syntax-controlling variables,
+handling warnings and other conditions,
+proclaiming consistent optimization settings,
+saving code coverage information,
+maintaining meta-data about compilation timings,
+setting gensym counters and PRNG seeds and other sources of non-determinism,
+overriding the source-location and/or timestamping systems,
+checking that some compile-time side-effects were properly balanced,
+etc.
+
+
+@section Miscellaneous Exported Functions
 
 @defun coerce-pathname name @&key type defaults
@@ -2872 +2949 @@
 look at the beginning of @file{asdf.lisp} to see what it does.
 @end defun
+
+@defun run-shell-command
+
+This function is obsolete and present only for the sake of backwards-compatibility:
+``If it's not backwards, it's not compatible''. We strongly discourage its use.
+Its current behavior is only well-defined on Unix platforms
+(which includes MacOS X and cygwin). On Windows, anything goes.
+
+Instead we recommend the use of such a function as
+@code{xcvb-driver:run-program/process-output-stream}
+from the @code{xcvb-driver} system that is distributed with XCVB:
+@url{http://common-lisp.net/project/xcvb}.
+It's only alternative that supports
+as many implementations and operating systems as ASDF does,
+and provides well-defined behavior outside Unix (i.e. on Windows).
+(The only unsupported exception is Genera, since on it
+@code{run-shell-command} doesn't make sense anyway on that platform).
+
+This function takes as arguments a @code{format} control-string
+and arguments to be passed to @code{format} after this control-string
+to produce a string.
+This string is a command that will be evaluated with a POSIX shell if possible;
+yet, on Windows, some implementations will use CMD.EXE,
+while others (like SBCL) will make an attempt at invoking a POSIX shell
+(and fail if it is not present).
+@end defun
+
 
 @node Getting the latest version, FAQ, Miscellaneous additional functionality, Top

branches/1.0.x/abcl/src/org/armedbear/lisp/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.017.22: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
@@ -62 +62 @@
         (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 (unless (member :ecl-bytecmp *features*) (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 +68 @@
                  (< 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.
@@ -113 +111 @@
          ;; "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.017.22")
          (existing-asdf (find-class 'component nil))
          (existing-version *asdf-version*)
@@ -201 +199 @@
                (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 +224 @@
             #: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
@@ -232 +232 @@
             #:split #:make-collector
             #: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
@@ -299 +294 @@
             #:*compile-file-failure-behaviour*
             #:*resolve-symlinks*
+            #:*require-asdf-operator*
             #:*asdf-verbose*
+            #:*verbose-out*
 
             #:asdf-version
@@ -676 +673 @@
 (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 +687 @@
       (ct:free buffer)
       (ct:free buffer1)))
-  #+ecl (si:getenv x)
   #+gcl (system:getenv x)
   #+genera nil
@@ -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
    (properties :accessor component-properties :initarg :properties
                :initform nil)))
+
+;;; I believe that the following could probably be more efficiently done
+;;; by a primary method that invokes SHARED-INITIALIZE in a way that would
+;;; appropriately pass the slots to have their initforms re-applied, but I
+;;; do not know how to write such a method. [2011/09/02:rpg]
+(defmethod reinitialize-instance :after ((obj component) &rest initargs
+                                         &key (version nil version-suppliedp)
+                                              (description nil description-suppliedp)
+                                              (long-description nil
+                                                                long-description-suppliedp)
+                                              (load-dependencies nil
+                                                                 ld-suppliedp)
+                                              in-order-to
+                                              do-first
+                                              inline-methods
+                                              parent
+                                              properties)
+  "We reuse component objects from previously-existing systems, so we need to
+make sure we clear them thoroughly."
+  (declare (ignore initargs load-dependencies
+                   long-description description version))
+  ;; this is a cache and should be cleared
+  (slot-makunbound obj 'absolute-pathname)
+  ;; component operation times are no longer valid when the component changes
+  (clrhash (component-operation-times obj))
+  (unless version-suppliedp (slot-makunbound obj 'version))
+  (unless description-suppliedp
+    (slot-makunbound obj 'description))
+  (unless long-description-suppliedp
+    (slot-makunbound obj 'long-description))
+  ;; replicate the logic of the initforms...
+  (unless ld-suppliedp
+    (setf (component-load-dependencies obj) nil))
+  (setf (component-in-order-to obj) in-order-to
+        (component-do-first obj) do-first
+        (component-inline-methods obj) inline-methods
+        (slot-value obj 'parent) parent
+        (slot-value obj 'properties) properties))
+
 
 (defun* component-find-path (component)
@@ -1247 +1285 @@
     :accessor module-default-component-class)))
 
+;;; see comment with REINITIALIZE-INSTANCE method on COMPONENT
+;;; [2011/09/02:rpg]
+(defmethod reinitialize-instance :after ((obj module) &rest initargs &key)
+  "Clear MODULE's slots so it can be reused."
+  (slot-makunbound obj 'components-by-name)
+  ;; this may be a more elegant approach than in the
+  ;; COMPONENT method [2011/09/02:rpg]
+  (loop :for (initarg slot-name default) :in
+        `((:components components nil)
+          (:if-component-dep-fails if-component-dep-fails :fail)
+          (:default-component-class default-component-class
+              ,*default-component-class*))
+        :unless (member initarg initargs)
+        :do (setf (slot-value obj slot-name) default)))
+
 (defun* component-parent-pathname (component)
   ;; No default anymore (in particular, no *default-pathname-defaults*).
@@ -1289 +1342 @@
    (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)))
+
+;;; see comment with REINITIALIZE-INSTANCE method on COMPONENT
+;;; [2011/09/02:rpg]
+(defmethod reinitialize-instance :after ((obj system) &rest initargs &key)
+  "Clear SYSTEM's slots so it can be reused."
+  ;; note that SYSTEM-SOURCE-FILE is very specially handled,
+  ;; by DO-DEFSYSTEM, so we need to *PRESERVE* its value and
+  ;; not squash it.  SYSTEM COMPONENTS are handled very specially,
+  ;; because they are always, effectively, reused, since the system component
+  ;; is made early in DO-DEFSYSTEM, instead of being made later, in
+  ;; PARSE-COMPONENT-FORM [2011/09/02:rpg]
+  (loop :for (initarg slot-name) :in
+        `((:author author)
+          (:maintainer maintainer)
+          (:licence licence)
+          (:defsystem-depends-on defsystem-depends-on))
+        :unless (member initarg initargs)
+        :do (slot-makunbound obj slot-name)))
 
 ;;;; -------------------------------------------------------------------------
@@ -1341 +1412 @@
            (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
+
+#-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)))))
+
 ;;;; -------------------------------------------------------------------------
 ;;;; Finding systems
@@ -1421 +1567 @@
 ")
 
+(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)
   (block nil
@@ -1429 +1595 @@
         (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)))))))))
+      #-clisp
+      (when (os-windows-p)
+        (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))))))))))
 
 (defun* sysdef-central-registry-search (system)
@@ -1539 +1706 @@
                                   :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)
@@ -1852 +2021 @@
          (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 +2063 @@
 (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))))
 
@@ -2088 +2270 @@
   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 +2325 @@
     (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)))))
+
+(defmethod call-with-around-compile-hook ((c component) thunk)
+  (let ((hook (around-compile-hook c)))
+    (if hook
+        (funcall hook thunk)
+        (funcall thunk))))
 
 (defvar *compile-op-compile-file-function* 'compile-file*
@@ -2139 +2368 @@
         (*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 +2423 @@
 (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 +2477 @@
   (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)))))
 
@@ -2372 +2568 @@
     (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
@@ -2623 +2801 @@
                           depends-on serial in-order-to)
                         rest))
-           (ret
-            (or (find-component parent name)
-                (make-instance (class-for-type parent type)))))
+           (ret (find-component parent name)))
       (when weakly-depends-on
         (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
-             :name (coerce-name name)
-             :pathname pathname
-             :parent parent
-             other-args)
+      (if ret
+          (apply 'reinitialize-instance ret
+                 :name (coerce-name name)
+                 :pathname pathname
+                 :parent parent
+                 other-args)
+          (setf ret
+                (apply 'make-instance (class-for-type parent type)
+                       :name (coerce-name name)
+                       :pathname pathname
+                       :parent parent
+                       other-args)))
       (component-pathname ret) ; eagerly compute the absolute pathname
       (when (typep ret 'module)
@@ -2661 +2844 @@
             (union-of-dependencies
              do-first
-       `((compile-op (load-op ,@depends-on)))))
+             `((compile-op (load-op ,@depends-on)))))
 
       (%refresh-component-inline-methods ret rest)
@@ -2707 +2890 @@
 ;;;; 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 +2904 @@
 ;;;; 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 +2924 @@
     (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) (format nil "CMD /C ~A" command)) ; BEWARE!
+                   (t (error "Unsupported OS")))
+                 (if (os-unix-p) (list "-c" command) '())
+                 :input nil :output *verbose-out* :wait t)))
 
     #+(or cmu scl)
@@ -2749 +2962 @@
      (ext:run-program
       "/bin/sh"
-      (list  "-c" command)
+      (list "-c" command)
       :input nil :output *verbose-out*))
 
     #+ecl ;; courtesy of Juan Jose Garcia Ripoll
-    (si:system command)
+    (ext:system command)
 
     #+gcl
@@ -2759 +2972 @@
 
     #+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 +2992 @@
     #-(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 +3028 @@
   (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)
@@ -2867 +3098 @@
 (defparameter *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::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)))
+    (car
+     (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)
+      #+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 ()
@@ -2902 +3134 @@
    #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
    (format nil "~(~a~@{~@[-~a~]~}~)"
-     (or *implementation-type* (lisp-implementation-type))
+           (or *implementation-type* (lisp-implementation-type))
            (or *lisp-version-string* (lisp-implementation-version))
            (or *operating-system* (software-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 ()
@@ -2934 +3165 @@
                  :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/"))
+             ,@(when (os-windows-p)
+                 `(,(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
-   `(#+asdf-windows
-     ,(flet ((try (x sub) (try-directory-subpath x sub)))
+  (cond
+    ((os-unix-p) '(#p"/etc/common-lisp/"))
+    ((os-windows-p)
+     (aif
+      (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)
@@ -2954 +3186 @@
                  (try (getenv "ALLUSERSPROFILE") "Application Data/"))
              "common-lisp/config/"))
-     #+asdf-unix #p"/etc/common-lisp/")))
+      (list it)))))
 
 (defun* in-first-directory (dirs x)
@@ -3073 +3305 @@
     (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)
+     (when (os-windows-p)
+       (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))))
 
@@ -3205 +3437 @@
            (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)
@@ -3266 +3497 @@
       :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
@@ -3578 +3810 @@
        (t t)
        :ignore-inherited-configuration))))
-
-;;;; -----------------------------------------------------------------
-;;;; 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)))))
 
 ;;;; -----------------------------------------------------------------
@@ -3814 +3971 @@
       :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)
@@ -3867 +4025 @@
       (: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/"))))
+          `(,@(when (os-unix-p)
+                `(,(or (getenv "XDG_DATA_HOME")
+                       (try (user-homedir) ".local/share/"))
+                  ,@(split-string (or (getenv "XDG_DATA_DIRS")
+                                      "/usr/local/share:/usr/share")
+                                  :separator ":")))
+            ,@(when (os-windows-p)
+                `(,(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/")))
@@ -4042 +4200 @@
 #+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 use-ecl-byte-compiler-p ()
+    (member :ecl-bytecmp *features*))
+
+  (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 +4229 @@
          (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))))))
 
 ;;;; -----------------------------------------------------------------
@@ -4091 +4256 @@
             #+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*))))