From rme at clozure.com  Fri Feb  1 14:53:10 2013
From: rme at clozure.com (rme at clozure.com)
Date: Fri, 01 Feb 2013 20:53:10 -0000
Subject: [Openmcl-cvs-notifications] r15631 - /trunk/source/tools/asdf.lisp
Message-ID: <20130201205311.B7743703880@setf.clozure.com>

Author: rme
Date: Fri Feb  1 14:53:10 2013
New Revision: 15631

Log:
ASDF 2.27 from upstream.

Modified:
    trunk/source/tools/asdf.lisp

Modified: trunk/source/tools/asdf.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/tools/asdf.lisp (original)
+++ trunk/source/tools/asdf.lisp Fri Feb  1 14:53:10 2013
@@ -1,5 +1,5 @@
-;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: u=
tf-8 -*-
-;;; This is ASDF 2.26: Another System Definition Facility.
+;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
+;;; This is ASDF 2.27: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
 ;;; please mail to <asdf-devel at common-lisp.net>.
@@ -47,425 +47,855 @@
 =

 #+xcvb (module ())
 =

-(cl:in-package :common-lisp-user)
-#+genera (in-package :future-common-lisp-user)
+(in-package :cl-user)
+
+#+cmu
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (declaim (optimize (speed 1) (safety 3) (debug 3)))
+  (setf ext:*gc-verbose* nil))
+
+#+(or abcl clisp cmu ecl xcl)
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (unless (member :asdf3 *features*)
+    (let* ((existing-version
+             (when (find-package :asdf)
+               (or (symbol-value (find-symbol (string :*asdf-version*) :as=
df))
+                   (let ((ver (symbol-value (find-symbol (string :*asdf-re=
vision*) :asdf))))
+                     (etypecase ver
+                       (string ver)
+                       (cons (format nil "~{~D~^.~}" ver))
+                       (null "1.0"))))))
+           (first-dot (when existing-version (position #\. existing-versio=
n)))
+           (second-dot (when first-dot (position #\. existing-version :sta=
rt (1+ first-dot))))
+           (existing-major-minor (subseq existing-version 0 second-dot))
+           (existing-version-number (and existing-version (read-from-strin=
g existing-major-minor)))
+           (away (format nil "~A-~A" :asdf existing-version)))
+      (when (and existing-version (< existing-version-number
+                                     #+abcl 2.25 #+clisp 2.27 #+cmu 2.018 =
#+ecl 2.21 #+xcl 2.27))
+        (rename-package :asdf away)
+        (when *load-verbose*
+          (format t "; First thing, renamed package ~A away to ~A~%" :asdf=
 away))))))
+
+;;;; ---------------------------------------------------------------------=
------
+;;;; Handle ASDF package upgrade, including implementation-dependent magic.
+;;
+;; See https://bugs.launchpad.net/asdf/+bug/485687
+;;
+;; CAUTION: we must handle the first few packages specially for hot-upgrad=
e.
+;; asdf/package will be frozen as of ASDF 3
+;; to forever export the same exact symbols.
+;; Any other symbol must be import-from'ed
+;; and reexported in a different package
+;; (alternatively the package may be dropped & replaced by one with a new =
name).
+
+(defpackage :asdf/package
+  (:use :common-lisp)
+  (:export
+   #:find-package* #:find-symbol* #:symbol-call
+   #:intern* #:unintern* #:export* #:make-symbol*
+   #:symbol-shadowing-p #:home-package-p #:rehome-symbol
+   #:symbol-package-name #:standard-common-lisp-symbol-p
+   #:reify-package #:unreify-package #:reify-symbol #:unreify-symbol
+   #:nuke-symbol-in-package #:nuke-symbol
+   #:ensure-package-unused #:delete-package*
+   #:fresh-package-name #:rename-package-away #:package-names #:packages-f=
rom-names
+   #:package-definition-form #:parse-define-package-form
+   #:ensure-package #:define-package))
+
+(in-package :asdf/package)
+
+;;;; General purpose package utilities
+
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (defun find-package* (package-designator &optional (error t))
+    (let ((package (find-package package-designator)))
+      (cond
+        (package package)
+        (error (error "No package named ~S" (string package-designator)))
+        (t nil))))
+  (defun find-symbol* (name package-designator &optional (error t))
+    "Find a symbol in a package of given string'ified NAME;
+unless CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax
+by letting you supply a symbol or keyword for the name;
+also works well when the package is not present.
+If optional ERROR argument is NIL, return NIL instead of an error
+when the symbol is not found."
+    (block nil
+      (let ((package (find-package* package-designator error)))
+        (when package ;; package error handled by find-package* already
+          (multiple-value-bind (symbol status) (find-symbol (string name) =
package)
+            (cond
+              (status (return (values symbol status)))
+              (error (error "There is no symbol ~S in package ~S" name (pa=
ckage-name package))))))
+        (values nil nil))))
+  (defun symbol-call (package name &rest args)
+    "Call a function associated with symbol of given name in given package,
+with given ARGS. Useful when the call is read before the package is loaded,
+or when loading the package is optional."
+    (apply (find-symbol* name package) args))
+  (defun intern* (name package-designator &optional (error t))
+    (intern (string name) (find-package* package-designator error)))
+  (defun export* (name package-designator)
+    (let* ((package (find-package* package-designator))
+           (symbol (intern* name package)))
+      (export (or symbol (list symbol)) package)))
+  (defun make-symbol* (name)
+    (etypecase name
+      (string (make-symbol name))
+      (symbol (copy-symbol name))))
+  (defun unintern* (name package-designator &optional (error t))
+    (block nil
+      (let ((package (find-package* package-designator error)))
+        (when package
+          (multiple-value-bind (symbol status) (find-symbol* name package =
error)
+            (cond
+              (status (unintern symbol package)
+                      (return (values symbol status)))
+              (error (error "symbol ~A not present in package ~A"
+                            (string symbol) (package-name package))))))
+        (values nil nil))))
+  (defun symbol-shadowing-p (symbol package)
+    (and (member symbol (package-shadowing-symbols package)) t))
+  (defun home-package-p (symbol package)
+    (and package (let ((sp (symbol-package symbol)))
+                   (and sp (let ((pp (find-package* package)))
+                             (and pp (eq sp pp))))))))
+
+
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (defun symbol-package-name (symbol)
+    (let ((package (symbol-package symbol)))
+      (and package (package-name package))))
+  (defun standard-common-lisp-symbol-p (symbol)
+    (multiple-value-bind (sym status) (find-symbol* symbol :common-lisp ni=
l)
+      (and (eq sym symbol) (eq status :external))))
+  (defun reify-package (package &optional package-context)
+    (if (eq package package-context) t
+        (etypecase package
+          (null nil)
+          ((eql (find-package :cl)) :cl)
+          (package (package-name package)))))
+  (defun unreify-package (package &optional package-context)
+    (etypecase package
+      (null nil)
+      ((eql t) package-context)
+      ((or symbol string) (find-package package))))
+  (defun reify-symbol (symbol &optional package-context)
+    (etypecase symbol
+      ((or keyword (satisfies standard-common-lisp-symbol-p)) symbol)
+      (symbol (vector (symbol-name symbol)
+                      (reify-package (symbol-package symbol) package-conte=
xt)))))
+  (defun unreify-symbol (symbol &optional package-context)
+    (etypecase symbol
+      (symbol symbol)
+      ((simple-vector 2)
+       (let* ((symbol-name (svref symbol 0))
+              (package-foo (svref symbol 1))
+              (package (unreify-package package-foo package-context)))
+         (if package (intern* symbol-name package)
+             (make-symbol* symbol-name)))))))
+
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (defvar *all-package-happiness* '())
+  (defvar *all-package-fishiness* (list t))
+  (defun record-fishy (info)
+    ;;(format t "~&FISHY: ~S~%" info)
+    (push info *all-package-fishiness*))
+  (defmacro when-package-fishiness (&body body)
+    `(when *all-package-fishiness* , at body))
+  (defmacro note-package-fishiness (&rest info)
+    `(when-package-fishiness (record-fishy (list , at info)))))
+
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  #+(or clisp clozure)
+  (defun get-setf-function-symbol (symbol)
+    #+clisp (let ((sym (get symbol 'system::setf-function)))
+              (if sym (values sym :setf-function)
+                  (let ((sym (get symbol 'system::setf-expander)))
+                    (if sym (values sym :setf-expander)
+                        (values nil nil)))))
+    #+clozure (gethash symbol ccl::%setf-function-names%))
+  #+(or clisp clozure)
+  (defun set-setf-function-symbol (new-setf-symbol symbol &optional kind)
+    #+clisp (assert (member kind '(:setf-function :setf-expander)))
+    #+clozure (assert (eq kind t))
+    #+clisp
+    (cond
+      ((null new-setf-symbol)
+       (remprop symbol 'system::setf-function)
+       (remprop symbol 'system::setf-expander))
+      ((eq kind :setf-function)
+       (setf (get symbol 'system::setf-function) new-setf-symbol))
+      ((eq kind :setf-expander)
+       (setf (get symbol 'system::setf-expander) new-setf-symbol))
+      (t (error "invalid kind of setf-function ~S for ~S to be set to ~S"
+                kind symbol new-setf-symbol)))
+    #+clozure
+    (progn
+      (gethash symbol ccl::%setf-function-names%) new-setf-symbol
+      (gethash new-setf-symbol ccl::%setf-function-name-inverses%) symbol))
+  #+(or clisp clozure)
+  (defun create-setf-function-symbol (symbol)
+    #+clisp (system::setf-symbol symbol)
+    #+clozure (ccl::construct-setf-function-name symbol))
+  (defun set-dummy-symbol (symbol reason other-symbol)
+    (setf (get symbol 'dummy-symbol) (cons reason other-symbol)))
+  (defun make-dummy-symbol (symbol)
+    (let ((dummy (copy-symbol symbol)))
+      (set-dummy-symbol dummy 'replacing symbol)
+      (set-dummy-symbol symbol 'replaced-by dummy)
+      dummy))
+  (defun dummy-symbol (symbol)
+    (get symbol 'dummy-symbol))
+  (defun get-dummy-symbol (symbol)
+    (let ((existing (dummy-symbol symbol)))
+      (if existing (values (cdr existing) (car existing))
+          (make-dummy-symbol symbol))))
+  (defun nuke-symbol-in-package (symbol package-designator)
+    (let ((package (find-package* package-designator))
+          (name (symbol-name symbol)))
+      (multiple-value-bind (sym stat) (find-symbol name package)
+        (when (and (member stat '(:internal :external)) (eq symbol sym))
+          (if (symbol-shadowing-p symbol package)
+              (shadowing-import (get-dummy-symbol symbol) package)
+              (unintern symbol package))))))
+  (defun nuke-symbol (symbol &optional (packages (list-all-packages)))
+    #+(or clisp clozure)
+    (multiple-value-bind (setf-symbol kind)
+        (get-setf-function-symbol symbol)
+      (when kind (nuke-symbol setf-symbol)))
+    (loop :for p :in packages :do (nuke-symbol-in-package symbol p)))
+  (defun rehome-symbol (symbol package-designator)
+    "Changes the home package of a symbol, also leaving it present in its =
old home if any"
+    (let* ((name (symbol-name symbol))
+           (package (find-package* package-designator))
+           (old-package (symbol-package symbol))
+           (old-status (and old-package (nth-value 1 (find-symbol name old=
-package))))
+           (shadowing (and old-package (symbol-shadowing-p symbol old-pack=
age) (make-symbol name))))
+      (multiple-value-bind (overwritten-symbol overwritten-symbol-status) =
(find-symbol name package)
+        (unless (eq package old-package)
+          (let ((overwritten-symbol-shadowing-p
+                  (and overwritten-symbol-status
+                       (symbol-shadowing-p overwritten-symbol package))))
+            (note-package-fishiness
+             :rehome-symbol name
+             (when old-package (package-name old-package)) old-status (and=
 shadowing t)
+             (package-name package) overwritten-symbol-status overwritten-=
symbol-shadowing-p)
+            (when old-package
+              (if shadowing
+                  (shadowing-import shadowing old-package))
+              (unintern symbol old-package))
+            (cond
+              (overwritten-symbol-shadowing-p
+               (shadowing-import symbol package))
+              (t
+               (when overwritten-symbol-status
+                 (unintern overwritten-symbol package))
+               (import symbol package)))
+            (if shadowing
+                (shadowing-import symbol old-package)
+                (import symbol old-package))
+            #+(or clisp clozure)
+            (multiple-value-bind (setf-symbol kind)
+                (get-setf-function-symbol symbol)
+              (when kind
+                (let* ((setf-function (fdefinition setf-symbol))
+                       (new-setf-symbol (create-setf-function-symbol symbo=
l)))
+                  (note-package-fishiness
+                   :setf-function
+                   name (package-name package)
+                   (symbol-name setf-symbol) (symbol-package-name setf-sym=
bol)
+                   (symbol-name new-setf-symbol) (symbol-package-name new-=
setf-symbol))
+                  (when (symbol-package setf-symbol)
+                    (unintern setf-symbol (symbol-package setf-symbol)))
+                  (setf (fdefinition new-setf-symbol) setf-function)
+                  (set-setf-function-symbol new-setf-symbol symbol kind))))
+            #+(or clisp clozure)
+            (multiple-value-bind (overwritten-setf foundp)
+                (get-setf-function-symbol overwritten-symbol)
+              (when foundp
+                (unintern overwritten-setf)))
+            (when (eq old-status :external)
+              (export* symbol old-package))
+            (when (eq overwritten-symbol-status :external)
+              (export* symbol package))))
+        (values overwritten-symbol overwritten-symbol-status))))
+  (defun ensure-package-unused (package)
+    (loop :for p :in (package-used-by-list package) :do
+      (unuse-package package p)))
+  (defun delete-package* (package &key nuke)
+    (let ((p (find-package package)))
+      (when p
+        (when nuke (do-symbols (s p) (when (home-package-p s p) (nuke-symb=
ol s))))
+        (ensure-package-unused p)
+        (delete-package package))))
+  (defun package-names (package)
+    (cons (package-name package) (package-nicknames package)))
+  (defun packages-from-names (names)
+    (remove-duplicates (remove nil (mapcar #'find-package names)) :from-en=
d t))
+  (defun fresh-package-name (&key (prefix :%TO-BE-DELETED)
+                               separator
+                               (index (random most-positive-fixnum)))
+    (loop :for i :from index
+          :for n =3D (format nil "~A~@[~A~D~]" prefix (and (plusp i) (or s=
eparator "")) i)
+          :thereis (and (not (find-package n)) n)))
+  (defun rename-package-away (p &rest keys &key prefix &allow-other-keys)
+    (let ((new-name
+            (apply 'fresh-package-name
+                   :prefix (or prefix (format nil "__~A__" (package-name p=
))) keys)))
+      (record-fishy (list :rename-away (package-names p) new-name))
+      (rename-package p new-name))))
+
+
+;;; Communicable representation of symbol and package information
+
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (defun package-definition-form (package-designator
+                                  &key (nicknamesp t) (usep t)
+                                    (shadowp t) (shadowing-import-p t)
+                                    (exportp t) (importp t) internp (error=
 t))
+    (let* ((package (or (find-package* package-designator error)
+                        (return-from package-definition-form nil)))
+           (name (package-name package))
+           (nicknames (package-nicknames package))
+           (use (mapcar #'package-name (package-use-list package)))
+           (shadow ())
+           (shadowing-import (make-hash-table :test 'equal))
+           (import (make-hash-table :test 'equal))
+           (export ())
+           (intern ()))
+      (when package
+        (loop :for sym :being :the :symbols :in package
+              :for status =3D (nth-value 1 (find-symbol* sym package)) :do
+                (ecase status
+                  ((nil :inherited))
+                  ((:internal :external)
+                   (let* ((name (symbol-name sym))
+                          (external (eq status :external))
+                          (home (symbol-package sym))
+                          (home-name (package-name home))
+                          (imported (not (eq home package)))
+                          (shadowing (symbol-shadowing-p sym package)))
+                     (cond
+                       ((and shadowing imported)
+                        (push name (gethash home-name shadowing-import)))
+                       (shadowing
+                        (push name shadow))
+                       (imported
+                        (push name (gethash home-name import))))
+                     (cond
+                       (external
+                        (push name export))
+                       (imported)
+                       (t (push name intern)))))))
+        (labels ((sort-names (names)
+                   (sort names #'string<))
+                 (table-keys (table)
+                   (loop :for k :being :the :hash-keys :of table :collect =
k))
+                 (when-relevant (key value)
+                   (when value (list (cons key value))))
+                 (import-options (key table)
+                   (loop :for i :in (sort-names (table-keys table))
+                         :collect `(,key ,i ,@(sort-names (gethash i table=
))))))
+          `(defpackage ,name
+             ,@(when-relevant :nicknames (and nicknamesp (sort-names nickn=
ames)))
+             (:use ,@(and usep (sort-names use)))
+             ,@(when-relevant :shadow (and shadowp (sort-names shadow)))
+             ,@(import-options :shadowing-import-from (and shadowing-impor=
t-p shadowing-import))
+             ,@(import-options :import-from (and importp import))
+             ,@(when-relevant :export (and exportp (sort-names export)))
+             ,@(when-relevant :intern (and internp (sort-names intern)))))=
))))
+
+
+;;; ensure-package, define-package
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (defun ensure-shadowing-import (name to-package from-package shadowed im=
ported)
+    (check-type name string)
+    (check-type to-package package)
+    (check-type from-package package)
+    (check-type shadowed hash-table)
+    (check-type imported hash-table)
+    (let ((import-me (find-symbol* name from-package)))
+      (multiple-value-bind (existing status) (find-symbol name to-package)
+        (cond
+          ((gethash name shadowed)
+           (unless (eq import-me existing)
+             (error "Conflicting shadowings for ~A" name)))
+          (t
+           (setf (gethash name shadowed) t)
+           (setf (gethash name imported) t)
+           (unless (or (null status)
+                       (and (member status '(:internal :external))
+                            (eq existing import-me)
+                            (symbol-shadowing-p existing to-package)))
+             (note-package-fishiness
+              :shadowing-import name
+              (package-name from-package)
+              (or (home-package-p import-me from-package) (symbol-package-=
name import-me))
+              (package-name to-package) status
+              (and status (or (home-package-p existing to-package) (symbol=
-package-name existing)))))
+           (shadowing-import import-me to-package))))))
+  (defun ensure-import (name to-package from-package shadowed imported)
+    (check-type name string)
+    (check-type to-package package)
+    (check-type from-package package)
+    (check-type shadowed hash-table)
+    (check-type imported hash-table)
+    (multiple-value-bind (import-me import-status) (find-symbol name from-=
package)
+      (when (null import-status)
+        (note-package-fishiness
+         :import-uninterned name (package-name from-package) (package-name=
 to-package))
+        (setf import-me (intern name from-package)))
+      (multiple-value-bind (existing status) (find-symbol name to-package)
+        (cond
+          ((gethash name imported)
+           (unless (eq import-me existing)
+             (error "Can't import ~S from both ~S and ~S"
+                    name (package-name (symbol-package existing)) (package=
-name from-package))))
+          ((gethash name shadowed)
+           (error "Can't both shadow ~S and import it from ~S" name (packa=
ge-name from-package)))
+          (t
+           (setf (gethash name imported) t)
+           (unless (and status (eq import-me existing))
+             (when status
+               (note-package-fishiness
+                :import name
+                (package-name from-package)
+                (or (home-package-p import-me from-package) (symbol-packag=
e-name import-me))
+                (package-name to-package) status
+                (and status (or (home-package-p existing to-package) (symb=
ol-package-name existing))))
+               (unintern* existing to-package))
+             (import import-me to-package)))))))
+  (defun ensure-inherited (name symbol to-package from-package mixp shadow=
ed imported inherited)
+    (check-type name string)
+    (check-type symbol symbol)
+    (check-type to-package package)
+    (check-type from-package package)
+    (check-type mixp (member nil t)) ; no cl:boolean on Genera
+    (check-type shadowed hash-table)
+    (check-type imported hash-table)
+    (check-type inherited hash-table)
+    (multiple-value-bind (existing status) (find-symbol name to-package)
+      (let* ((sp (symbol-package symbol))
+             (in (gethash name inherited))
+             (xp (and status (symbol-package existing))))
+        (when (null sp)
+          (note-package-fishiness
+           :import-uninterned name
+           (package-name from-package) (package-name to-package) mixp)
+          (import symbol from-package)
+          (setf sp (package-name from-package)))
+        (cond
+          ((gethash name shadowed))
+          (in
+           (unless (equal sp (first in))
+             (if mixp
+                 (ensure-shadowing-import name to-package (second in) shad=
owed imported)
+                 (error "Can't inherit ~S from ~S, it is inherited from ~S"
+                        name (package-name sp) (package-name (first in))))=
))
+          ((gethash name imported)
+           (unless (eq symbol existing)
+             (error "Can't inherit ~S from ~S, it is imported from ~S"
+                    name (package-name sp) (package-name xp))))
+          (t
+           (setf (gethash name inherited) (list sp from-package))
+           (when (and status (not (eq sp xp)))
+             (let ((shadowing (symbol-shadowing-p existing to-package)))
+               (note-package-fishiness
+                :inherited name
+                (package-name from-package)
+                (or (home-package-p symbol from-package) (symbol-package-n=
ame symbol))
+                (package-name to-package)
+                (or (home-package-p existing to-package) (symbol-package-n=
ame existing)))
+               (if shadowing (ensure-shadowing-import name to-package from=
-package shadowed imported)
+                   (unintern* existing to-package)))))))))
+  (defun ensure-mix (name symbol to-package from-package shadowed imported=
 inherited)
+    (check-type name string)
+    (check-type symbol symbol)
+    (check-type to-package package)
+    (check-type from-package package)
+    (check-type shadowed hash-table)
+    (check-type imported hash-table)
+    (check-type inherited hash-table)
+    (unless (gethash name shadowed)
+      (multiple-value-bind (existing status) (find-symbol name to-package)
+        (let* ((sp (symbol-package symbol))
+               (im (gethash name imported))
+               (in (gethash name inherited)))
+          (cond
+            ((or (null status)
+                 (and status (eq symbol existing))
+                 (and in (eq sp (first in))))
+             (ensure-inherited name symbol to-package from-package t shado=
wed imported inherited))
+            (in
+             (remhash name inherited)
+             (ensure-shadowing-import name to-package (second in) shadowed=
 imported))
+            (im
+             (error "Symbol ~S import from ~S~:[~; actually ~:[uninterned~=
;~:*from ~S~]~] conflicts with existing symbol in ~S~:[~; actually ~:[unint=
erned~;from ~:*~S~]~]"
+                    name (package-name from-package)
+                    (home-package-p symbol from-package) (symbol-package-n=
ame symbol)
+                    (package-name to-package)
+                    (home-package-p existing to-package) (symbol-package-n=
ame existing)))
+            (t
+             (ensure-inherited name symbol to-package from-package t shado=
wed imported inherited)))))))
+  (defun recycle-symbol (name recycle exported)
+    (check-type name string)
+    (check-type recycle list)
+    (check-type exported hash-table)
+    (when (gethash name exported) ;; don't bother recycling private symbols
+      (let (recycled foundp)
+        (dolist (r recycle (values recycled foundp))
+          (multiple-value-bind (symbol status) (find-symbol name r)
+            (when (and status (home-package-p symbol r))
+              (cond
+                (foundp
+                 ;; (nuke-symbol symbol)) -- even simple variable names li=
ke O or C will do that.
+                 (note-package-fishiness :recycled-duplicate name (package=
-name foundp) (package-name r)))
+                (t
+                 (setf recycled symbol foundp r)))))))))
+  (defun symbol-recycled-p (sym recycle)
+    (check-type sym symbol)
+    (check-type recycle list)
+    (member (symbol-package sym) recycle))
+  (defun ensure-symbol (name package intern recycle shadowed imported inhe=
rited exported)
+    (check-type name string)
+    (check-type package package)
+    (check-type intern (member nil t)) ; no cl:boolean on Genera
+    (check-type shadowed hash-table)
+    (check-type imported hash-table)
+    (check-type inherited hash-table)
+    (unless (or (gethash name shadowed)
+                (gethash name imported)
+                (gethash name inherited))
+      (multiple-value-bind (existing status)
+          (find-symbol name package)
+        (multiple-value-bind (recycled previous) (recycle-symbol name recy=
cle exported)
+          (cond
+            ((and status (eq existing recycled) (eq previous package)))
+            (previous
+             (rehome-symbol recycled package))
+            ((and status (eq package (symbol-package existing))))
+            (t
+             (when status
+               (note-package-fishiness
+                :ensure-symbol name
+                (reify-package (symbol-package existing) package)
+                status intern)
+               (unintern existing))
+             (when intern
+               (intern* name package))))))))
+  (declaim (ftype function ensure-exported))
+  (defun ensure-exported-to-user (name symbol to-package &optional recycle)
+    (check-type name string)
+    (check-type symbol symbol)
+    (check-type to-package package)
+    (check-type recycle list)
+    (multiple-value-bind (existing status) (find-symbol name to-package)
+      (unless (and status (eq symbol existing))
+        (let ((accessible
+                (or (null status)
+                    (let ((shadowing (symbol-shadowing-p existing to-packa=
ge))
+                          (recycled (symbol-recycled-p existing recycle)))
+                      (unless (and shadowing (not recycled))
+                        (note-package-fishiness
+                         :ensure-export name (symbol-package-name symbol)
+                         (package-name to-package)
+                         (or (home-package-p existing to-package) (symbol-=
package-name existing))
+                         status shadowing)
+                        (if (or (eq status :inherited) shadowing)
+                            (shadowing-import symbol to-package)
+                            (unintern existing to-package))
+                        t)))))
+          (when (and accessible (eq status :external))
+            (ensure-exported name symbol to-package recycle))))))
+  (defun ensure-exported (name symbol from-package &optional recycle)
+    (dolist (to-package (package-used-by-list from-package))
+      (ensure-exported-to-user name symbol to-package recycle))
+    (import symbol from-package)
+    (export* name from-package))
+  (defun ensure-export (name from-package &optional recycle)
+    (multiple-value-bind (symbol status) (find-symbol* name from-package)
+      (unless (eq status :external)
+        (ensure-exported name symbol from-package recycle))))
+  (defun ensure-package (name &key
+                                nicknames documentation use
+                                shadow shadowing-import-from
+                                import-from export intern
+                                recycle mix reexport
+                                unintern)
+    #+(or gcl2.6 genera) (declare (ignore documentation))
+    (let* ((package-name (string name))
+           (nicknames (mapcar #'string nicknames))
+           (names (cons package-name nicknames))
+           (previous (packages-from-names names))
+           (discarded (cdr previous))
+           (to-delete ())
+           (package (or (first previous) (make-package package-name :nickn=
ames nicknames)))
+           (recycle (packages-from-names recycle))
+           (use (mapcar 'find-package* use))
+           (mix (mapcar 'find-package* mix))
+           (reexport (mapcar 'find-package* reexport))
+           (shadow (mapcar 'string shadow))
+           (export (mapcar 'string export))
+           (intern (mapcar 'string intern))
+           (unintern (mapcar 'string unintern))
+           (shadowed (make-hash-table :test 'equal)) ; string to bool
+           (imported (make-hash-table :test 'equal)) ; string to bool
+           (exported (make-hash-table :test 'equal)) ; string to bool
+           ;; string to list home package and use package:
+           (inherited (make-hash-table :test 'equal)))
+      (when-package-fishiness (record-fishy package-name))
+      #-(or gcl2.6 genera)
+      (when documentation (setf (documentation package t) documentation))
+      (loop :for p :in (set-difference (package-use-list package) (append =
mix use))
+            :do (note-package-fishiness :over-use name (package-names p))
+                (unuse-package p package))
+      (loop :for p :in discarded
+            :for n =3D (remove-if #'(lambda (x) (member x names :test 'equ=
al))
+                                (package-names p))
+            :do (note-package-fishiness :nickname name (package-names p))
+                (cond (n (rename-package p (first n) (rest n)))
+                      (t (rename-package-away p)
+                         (push p to-delete))))
+      (rename-package package package-name nicknames)
+      (dolist (name unintern)
+        (multiple-value-bind (existing status) (find-symbol name package)
+          (when status
+            (unless (eq status :inherited)
+              (note-package-fishiness
+               :unintern (package-name package) name (symbol-package-name =
existing) status)
+              (unintern* name package nil)))))
+      (dolist (name export)
+        (setf (gethash name exported) t))
+      (dolist (p reexport)
+        (do-external-symbols (sym p)
+          (setf (gethash (string sym) exported) t)))
+      (do-external-symbols (sym package)
+        (let ((name (symbol-name sym)))
+          (unless (gethash name exported)
+            (note-package-fishiness
+             :over-export (package-name package) name
+             (or (home-package-p sym package) (symbol-package-name sym)))
+            (unexport sym package))))
+      (dolist (name shadow)
+        (setf (gethash name shadowed) t)
+        (multiple-value-bind (existing status) (find-symbol name package)
+          (multiple-value-bind (recycled previous) (recycle-symbol name re=
cycle exported)
+            (let ((shadowing (and status (symbol-shadowing-p existing pack=
age))))
+              (cond
+                ((eq previous package))
+                (previous
+                 (rehome-symbol recycled package))
+                ((or (member status '(nil :inherited))
+                     (home-package-p existing package)))
+                (t
+                 (let ((dummy (make-symbol name)))
+                   (note-package-fishiness
+                    :shadow-imported (package-name package) name
+                    (symbol-package-name existing) status shadowing)
+                   (shadowing-import dummy package)
+                   (import dummy package)))))))
+        (shadow name package))
+      (loop :for (p . syms) :in shadowing-import-from
+            :for pp =3D (find-package* p) :do
+              (dolist (sym syms) (ensure-shadowing-import (string sym) pac=
kage pp shadowed imported)))
+      (loop :for p :in mix
+            :for pp =3D (find-package* p) :do
+              (do-external-symbols (sym pp) (ensure-mix (symbol-name sym) =
sym package pp shadowed imported inherited)))
+      (loop :for (p . syms) :in import-from
+            :for pp =3D (find-package p) :do
+              (dolist (sym syms) (ensure-import (symbol-name sym) package =
pp shadowed imported)))
+      (dolist (p (append use mix))
+        (do-external-symbols (sym p) (ensure-inherited (string sym) sym pa=
ckage p nil shadowed imported inherited))
+        (use-package p package))
+      (loop :for name :being :the :hash-keys :of exported :do
+        (ensure-symbol name package t recycle shadowed imported inherited =
exported)
+        (ensure-export name package recycle))
+      (dolist (name intern)
+        (ensure-symbol name package t recycle shadowed imported inherited =
exported))
+      (do-symbols (sym package)
+        (ensure-symbol (symbol-name sym) package nil recycle shadowed impo=
rted inherited exported))
+      (map () 'delete-package* to-delete)
+      package)))
+
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (defun parse-define-package-form (package clauses)
+    (loop
+      :with use-p =3D nil :with recycle-p =3D nil
+      :with documentation =3D nil
+      :for (kw . args) :in clauses
+      :when (eq kw :nicknames) :append args :into nicknames :else
+        :when (eq kw :documentation)
+          :do (cond
+                (documentation (error "define-package: can't define docume=
ntation twice"))
+                ((or (atom args) (cdr args)) (error "define-package: bad d=
ocumentation"))
+                (t (setf documentation (car args)))) :else
+      :when (eq kw :use) :append args :into use :and :do (setf use-p t) :e=
lse
+        :when (eq kw :shadow) :append args :into shadow :else
+          :when (eq kw :shadowing-import-from) :collect args :into shadowi=
ng-import-from :else
+            :when (eq kw :import-from) :collect args :into import-from :el=
se
+              :when (eq kw :export) :append args :into export :else
+                :when (eq kw :intern) :append args :into intern :else
+                  :when (eq kw :recycle) :append args :into recycle :and :=
do (setf recycle-p t) :else
+                    :when (eq kw :mix) :append args :into mix :else
+                      :when (eq kw :reexport) :append args :into reexport =
:else
+                        :when (eq kw :unintern) :append args :into uninter=
n :else
+                          :do (error "unrecognized define-package keyword =
~S" kw)
+      :finally (return `(,package
+                         :nicknames ,nicknames :documentation ,documentati=
on
+                         :use ,(if use-p use '(:common-lisp))
+                         :shadow ,shadow :shadowing-import-from ,shadowing=
-import-from
+                         :import-from ,import-from :export ,export :intern=
 ,intern
+                         :recycle ,(if recycle-p recycle (cons package nic=
knames))
+                         :mix ,mix :reexport ,reexport :unintern ,unintern=
)))))
+
+(defmacro define-package (package &rest clauses)
+  (let ((ensure-form
+          `(apply 'ensure-package ',(parse-define-package-form package cla=
uses))))
+    `(progn
+       #+clisp
+       (eval-when (:compile-toplevel :load-toplevel :execute)
+         ,ensure-form)
+       #+(or clisp ecl gcl) (defpackage ,package (:use))
+       (eval-when (:compile-toplevel :load-toplevel :execute)
+         ,ensure-form))))
+
+;;;; Final tricks to keep various implementations happy.
+;; We want most such tricks in common-lisp.lisp,
+;; but these need to be done before the define-package form there,
+;; that we nevertheless want to be the very first form.
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  #+allegro ;; We need to disable autoloading BEFORE any mention of packag=
e ASDF.
+  (setf excl::*autoload-package-name-alist*
+        (remove "asdf" excl::*autoload-package-name-alist*
+                :test 'equalp :key 'car))
+  #+gcl
+  ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff,
+  ;; but can run ASDF 2.011. GCL 2.6 has even more issues.
+  (cond
+    ((or (< system::*gcl-major-version* 2)
+         (and (=3D system::*gcl-major-version* 2)
+              (< system::*gcl-minor-version* 6)))
+     (error "GCL 2.6 or later required to use ASDF"))
+    ((and (=3D system::*gcl-major-version* 2)
+          (=3D system::*gcl-minor-version* 6))
+     (pushnew 'ignorable pcl::*variable-declarations-without-argument*)
+     (pushnew :gcl2.6 *features*))
+    (t
+     (pushnew :gcl2.7 *features*))))
+;;;; ---------------------------------------------------------------------=
----
+;;;; Handle compatibility with multiple implementations.
+;;; This file is for papering over the deficiencies and peculiarities
+;;; of various Common Lisp implementations.
+;;; For implementation-specific access to the system, see os.lisp instead.
+;;; A few functions are defined here, but actually exported from utility;
+;;; from this package only common-lisp symbols are exported.
+
+(asdf/package:define-package :asdf/common-lisp
+  (:nicknames :asdf/cl)
+  (:use #-genera :common-lisp #+genera :future-common-lisp :asdf/package)
+  (:reexport :common-lisp)
+  (:recycle :asdf/common-lisp :asdf)
+  #+allegro (:intern #:*acl-warn-save*)
+  #+cormanlisp (:shadow #:user-homedir-pathname)
+  #+cormanlisp
+  (:export
+   #:logical-pathname #:translate-logical-pathname
+   #:make-broadcast-stream #:file-namestring)
+  #+gcl2.6 (:shadow #:type-of #:with-standard-io-syntax) ; causes errors w=
hen loading fasl(!)
+  #+gcl2.6 (:shadowing-import-from :system #:*load-pathname*)
+  #+genera (:shadowing-import-from :scl #:boolean)
+  #+genera (:export #:boolean #:ensure-directories-exist)
+  #+mcl (:shadow #:user-homedir-pathname))
+(in-package :asdf/common-lisp)
 =

 #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks m=
cl mkcl sbcl scl xcl)
 (error "ASDF is not supported on your implementation. Please help us port =
it.")
 =

-;;;; Create and setup packages in a way that is compatible with hot-upgrad=
e.
-;;;; See https://bugs.launchpad.net/asdf/+bug/485687
-;;;; See these two eval-when forms, and more near the end of the file.
-
-#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and=
 needs this
-
+;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; DON'T: trust impl=
ementation defaults.
+
+
+;;;; Early meta-level tweaks
+
+#+(or abcl (and allegro ics) (and (or clisp cmu ecl mkcl) unicode)
+      clozure lispworks (and sbcl sb-unicode) scl)
 (eval-when (:load-toplevel :compile-toplevel :execute)
-  ;;; Before we do anything, some implementation-dependent tweaks
-  ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; NO: trust imple=
mentation defaults.
-  #+allegro
-  (setf excl::*autoload-package-name-alist*
-        (remove "asdf" excl::*autoload-package-name-alist*
-                :test 'equalp :key 'car)) ; need that BEFORE any mention o=
f package ASDF as below
-  #+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 co=
mpile ASDF at all
-            (and (=3D system::*gcl-major-version* 2)
-                 (< system::*gcl-minor-version* 7)))
-    (pushnew :gcl-pre2.7 *features*))
-  #+(or abcl (and allegro ics) (and (or clisp cmu ecl mkcl) unicode)
-        clozure lispworks (and sbcl sb-unicode) scl)
-  (pushnew :asdf-unicode *features*)
-  ;;; make package if it doesn't exist yet.
-  ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
-  (unless (find-package :asdf)
-    (make-package :asdf :use '(:common-lisp))))
-
-(in-package :asdf)
-
+  (pushnew :asdf-unicode *features*))
+
+#+allegro
 (eval-when (:load-toplevel :compile-toplevel :execute)
-  ;;; This would belong amongst implementation-dependent tweaks above,
-  ;;; except that the defun has to be in package asdf.
-  #+ecl (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *featu=
res*) t))
-  #+ecl (unless (use-ecl-byte-compiler-p) (require :cmp))
-  #+mkcl (require :cmp)
-  #+mkcl (setq clos::*redefine-class-in-place* t) ;; Make sure we have str=
ict ANSI class redefinition semantics
-
-  ;;; Package setup, step 2.
-  (defvar *asdf-version* nil)
-  (defvar *upgraded-p* nil)
-  (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12.
-  (defun find-symbol* (s p)
-    (find-symbol (string s) p))
-  ;; Strip out formatting that is not supported on Genera.
-  ;; Has to be inside the eval-when to make Lispworks happy (!)
-  (defun strcat (&rest strings)
-    (apply 'concatenate 'string strings))
-  (defmacro compatfmt (format)
-    #-(or gcl genera) format
-    #+(or gcl genera)
-    (loop :for (unsupported . replacement) :in
-      (append
-       '(("~3i~_" . ""))
-       #+genera '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . "")=
)) :do
-      (loop :for found =3D (search unsupported format) :while found :do
-        (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.
-         ;; Please also modify asdf.asd to reflect this change. The script=
 bin/bump-version
-         ;; can help you do these changes in synch (look at the source for=
 documentation).
-         ;; Relying on its automation, the version is now redundantly pres=
ent on top of this file.
-         ;; "2.345" would be an official release
-         ;; "2.345.6" would be a development version in the official upstr=
eam
-         ;; "2.345.0.7" would be your seventh local modification of offici=
al release 2.345
-         ;; "2.345.6.7" would be your seventh local modification of develo=
pment version 2.345.6
-         (asdf-version "2.26")
-         (existing-asdf (find-class 'component nil))
-         (existing-version *asdf-version*)
-         (already-there (equal asdf-version existing-version)))
-    (unless (and existing-asdf already-there)
-      (when (and existing-asdf *asdf-verbose*)
-        (format *trace-output*
-                (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]=
to version ~A~@:>~%")
-                existing-version asdf-version))
-      (labels
-          ((present-symbol-p (symbol package)
-             (member (nth-value 1 (find-symbol* symbol package)) '(:intern=
al :external)))
-           (present-symbols (package)
-             ;; #-genera (loop :for s :being :the :present-symbols :in pac=
kage :collect s) #+genera
-             (let (l)
-               (do-symbols (s package)
-                 (when (present-symbol-p s package) (push s l)))
-               (reverse l)))
-           (unlink-package (package)
-             (let ((u (find-package package)))
-               (when u
-                 (ensure-unintern u (present-symbols u))
-                 (loop :for p :in (package-used-by-list u) :do
-                   (unuse-package u p))
-                 (delete-package u))))
-           (ensure-exists (name nicknames use)
-             (let ((previous
-                    (remove-duplicates
-                     (mapcar #'find-package (cons name nicknames))
-                     :from-end t)))
-               ;; do away with packages with conflicting (nick)names
-               (map () #'unlink-package (cdr previous))
-               ;; reuse previous package with same name
-               (let ((p (car previous)))
-                 (cond
-                   (p
-                    (rename-package p name nicknames)
-                    (ensure-use p use)
-                    p)
-                   (t
-                    (make-package name :nicknames nicknames :use use))))))
-           (intern* (symbol package)
-             (intern (string symbol) package))
-           (remove-symbol (symbol package)
-             (let ((sym (find-symbol* symbol package)))
-               (when sym
-                 #-cormanlisp (unexport sym package)
-                 (unintern sym package)
-                 sym)))
-           (ensure-unintern (package symbols)
-             (loop :with packages =3D (list-all-packages)
-               :for sym :in symbols
-               :for removed =3D (remove-symbol sym package)
-               :when removed :do
-               (loop :for p :in packages :do
-                 (when (eq removed (find-symbol* sym p))
-                   (unintern removed p)))))
-           (ensure-shadow (package symbols)
-             (shadow symbols package))
-           (ensure-use (package use)
-             (dolist (used (package-use-list package))
-               (unless (member (package-name used) use :test 'string=3D)
-                 (unuse-package used)
-                 (do-external-symbols (sym used)
-                   (when (eq sym (find-symbol* sym package))
-                     (remove-symbol sym package)))))
-             (dolist (used (reverse use))
-               (do-external-symbols (sym used)
-                 (unless (eq sym (find-symbol* sym package))
-                   (remove-symbol sym package)))
-               (use-package used package)))
-           (ensure-fmakunbound (package symbols)
-             (loop :for name :in symbols
-               :for sym =3D (find-symbol* name package)
-               :when sym :do (fmakunbound sym)))
-           (ensure-export (package export)
-             (let ((formerly-exported-symbols nil)
-                   (bothly-exported-symbols nil)
-                   (newly-exported-symbols nil))
-               (do-external-symbols (sym package)
-                 (if (member sym export :test 'string-equal)
-                     (push sym bothly-exported-symbols)
-                     (push sym formerly-exported-symbols)))
-               (loop :for sym :in export :do
-                 (unless (member sym bothly-exported-symbols :test 'equal)
-                   (push sym newly-exported-symbols)))
-               (loop :for user :in (package-used-by-list package)
-                 :for shadowing =3D (package-shadowing-symbols user) :do
-                 (loop :for new :in newly-exported-symbols
-                   :for old =3D (find-symbol* new user)
-                   :when (and old (not (member old shadowing)))
-                   :do (unintern old user)))
-               (loop :for x :in newly-exported-symbols :do
-                 (export (intern* x package)))))
-           (ensure-package (name &key nicknames use unintern
-                                 shadow export redefined-functions)
-             (let* ((p (ensure-exists name nicknames use)))
-               (ensure-unintern p (append unintern #+cmu redefined-functio=
ns))
-               (ensure-shadow p shadow)
-               (ensure-export p export)
-               #-cmu (ensure-fmakunbound p redefined-functions)
-               p)))
-        (macrolet
-            ((pkgdcl (name &key nicknames use export
-                           redefined-functions unintern shadow)
-                 `(ensure-package
-                   ',name :nicknames ',nicknames :use ',use :export ',expo=
rt
-                   :shadow ',shadow
-                   :unintern ',unintern
-                   :redefined-functions ',redefined-functions)))
-          (pkgdcl
-           :asdf
-           :use (:common-lisp)
-           :redefined-functions
-           (#:perform #:explain #:output-files #:operation-done-p
-            #:perform-with-restarts #:component-relative-pathname
-            #:system-source-file #:operate #:find-component #:find-system
-            #:apply-output-translations #:translate-pathname* #:resolve-lo=
cation
-            #: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 #:do-dep #:do-one-dep
-            #:resolve-relative-location-component #:resolve-absolute-locat=
ion-component
-            #:output-files-for-system-and-operation) ; obsolete ASDF-BINAR=
Y-LOCATION function
-           :export
-           (#:defsystem #:oos #:operate #:find-system #:locate-system #:ru=
n-shell-command
-            #:system-definition-pathname #:with-system-definitions
-            #:search-for-system-definition #:find-component #:component-fi=
nd-path
-            #:compile-system #:load-system #:load-systems
-            #:require-system #:test-system #:clear-system
-            #:operation #:compile-op #:load-op #:load-source-op #:test-op
-            #:feature #:version #:version-satisfies
-            #:upgrade-asdf
-            #:implementation-identifier #:implementation-type #:hostname
-            #:input-files #:output-files #:output-file #:perform
-            #:operation-done-p #:explain
-
-            #:component #:source-file
-            #:c-source-file #:cl-source-file #:java-source-file
-            #:cl-source-file.cl #:cl-source-file.lsp
-            #:static-file
-            #:doc-file
-            #:html-file
-            #:text-file
-            #:source-file-type
-            #:module                     ; components
-            #:system
-            #:unix-dso
-
-            #:module-components          ; component accessors
-            #:module-components-by-name
-            #:component-pathname
-            #:component-relative-pathname
-            #:component-name
-            #:component-version
-            #:component-parent
-            #:component-property
-            #:component-system
-            #:component-depends-on
-            #:component-encoding
-            #:component-external-format
-
-            #:system-description
-            #:system-long-description
-            #:system-author
-            #:system-maintainer
-            #:system-license
-            #:system-licence
-            #:system-source-file
-            #:system-source-directory
-            #:system-relative-pathname
-            #:map-systems
-
-            #:operation-description
-            #:operation-on-warnings
-            #:operation-on-failure
-            #:component-visited-p
-
-            #:*system-definition-search-functions*   ; variables
-            #:*central-registry*
-            #:*compile-file-warnings-behaviour*
-            #:*compile-file-failure-behaviour*
-            #:*resolve-symlinks*
-            #:*load-system-operation*
-            #:*asdf-verbose*
-            #:*verbose-out*
-
-            #:asdf-version
-
-            #:operation-error #:compile-failed #:compile-warned #:compile-=
error
-            #:error-name
-            #:error-pathname
-            #:load-system-definition-error
-            #:error-component #:error-operation
-            #:system-definition-error
-            #:missing-component
-            #:missing-component-of-version
-            #:missing-dependency
-            #:missing-dependency-of-version
-            #:circular-dependency        ; errors
-            #:duplicate-names
-
-            #:try-recompiling
-            #:retry
-            #:accept                     ; restarts
-            #:coerce-entry-to-directory
-            #:remove-entry-from-registry
-
-            #:*encoding-detection-hook*
-            #:*encoding-external-format-hook*
-            #:*default-encoding*
-            #:*utf-8-external-format*
-
-            #:clear-configuration
-            #:*output-translations-parameter*
-            #:initialize-output-translations
-            #:disable-output-translations
-            #:clear-output-translations
-            #:ensure-output-translations
-            #:apply-output-translations
-            #:compile-file*
-            #:compile-file-pathname*
-            #:enable-asdf-binary-locations-compatibility
-            #:*default-source-registries*
-            #:*source-registry-parameter*
-            #:initialize-source-registry
-            #:compute-source-registry
-            #:clear-source-registry
-            #:ensure-source-registry
-            #:process-source-registry
-            #:system-registered-p #:registered-systems #:loaded-systems
-            #:resolve-location
-            #: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: please use asdf-utils instead
-            #|
-            ;; #:aif #:it
-            ;; #:appendf #:orf
-            #:length=3Dn-p
-            #:remove-keys #:remove-keyword
-            #:first-char #:last-char #:string-suffix-p
-            #:coerce-name
-            #:directory-pathname-p #:ensure-directory-pathname
-            #:absolute-pathname-p #:ensure-pathname-absolute #:pathname-ro=
ot
-            #:getenv #:getenv-pathname #:getenv-pathnames
-            #:getenv-absolute-directory #:getenv-absolute-directories
-            #:probe-file*
-            #:find-symbol* #:strcat
-            #:make-pathname-component-logical #:make-pathname-logical
-            #:merge-pathnames* #:coerce-pathname #:subpathname #:subpathna=
me*
-            #:pathname-directory-pathname #:pathname-parent-directory-path=
name
-            #:read-file-forms
-            #:resolve-symlinks #:truenamize
-            #:split-string
-            #:component-name-to-pathname-components
-            #:split-name-type
-            #:subdirectories #:directory-files
-            #:while-collecting
-            #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors*
-            #:*wild-path* #:wilden
-            #:directorize-pathname-host-device|#
-            )))
-        #+genera (import 'scl:boolean :asdf)
-        (setf *asdf-version* asdf-version
-              *upgraded-p* (if existing-version
-                               (cons existing-version *upgraded-p*)
-                               *upgraded-p*))))))
-
-;;;; ---------------------------------------------------------------------=
----
-;;;; User-visible parameters
-;;;;
-(defvar *resolve-symlinks* t
-  "Determine whether or not ASDF resolves symlinks when defining systems.
-
-Defaults to T.")
-
-(defvar *compile-file-warnings-behaviour*
-  (or #+clisp :ignore :warn)
-  "How should ASDF react if it encounters a warning when compiling a file?
-Valid values are :error, :warn, and :ignore.")
-
-(defvar *compile-file-failure-behaviour*
-  (or #+sbcl :error #+clisp :ignore :warn)
-  "How should ASDF react if it encounters a failure (per the ANSI spec of =
COMPILE-FILE)
-when compiling a file?  Valid values are :error, :warn, and :ignore.
-Note that ASDF ALWAYS raises an error if it fails to create an output file=
 when compiling.")
-
-(defvar *verbose-out* nil)
-
-(defparameter +asdf-methods+
-  '(perform-with-restarts perform explain output-files operation-done-p))
-
-(defvar *load-system-operation* 'load-op
-  "Operation used by ASDF:LOAD-SYSTEM. By default, ASDF:LOAD-OP.
-You may override it with e.g. ASDF:LOAD-FASL-OP from asdf-bundle,
-or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.")
-
-(defvar *compile-op-compile-file-function* 'compile-file*
-  "Function used to compile lisp files.")
-
-
-
-#+allegro
-(eval-when (:compile-toplevel :execute)
   (defparameter *acl-warn-save*
-                (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
-                  excl:*warn-on-nested-reader-conditionals*))
+    (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
+      excl:*warn-on-nested-reader-conditionals*))
   (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
-    (setf excl:*warn-on-nested-reader-conditionals* nil)))
-
-;;;; ---------------------------------------------------------------------=
----
-;;;; Resolve forward references
-
-(declaim (ftype (function (t) t)
-                format-arguments format-control
-                error-name error-pathname error-condition
-                duplicate-names-name
-                error-component error-operation
-                module-components module-components-by-name
-                circular-dependency-components
-                condition-arguments condition-form
-                condition-format condition-location
-                coerce-name)
-         (ftype (function (&optional t) (values)) initialize-source-regist=
ry)
-         #-(or cormanlisp gcl-pre2.7)
-         (ftype (function (t t) t) (setf module-components-by-name)))
-
-;;;; ---------------------------------------------------------------------=
----
-;;;; Compatibility various implementations
+    (setf excl:*warn-on-nested-reader-conditionals* nil))
+  (setf *print-readably* nil))
+
 #+cormanlisp
 (progn
   (deftype logical-pathname () nil)
   (defun make-broadcast-stream () *error-output*)
   (defun translate-logical-pathname (x) x)
+  (defun user-homedir-pathname (&optional host)
+    (declare (ignore host))
+    (parse-namestring (format nil "~A\\" (cl:user-homedir-pathname))))
   (defun file-namestring (p)
     (setf p (pathname p))
     (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
+
+#+ecl
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (setf *load-verbose* nil)
+  (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) =
t))
+  (unless (use-ecl-byte-compiler-p) (require :cmp)))
+
+#+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, bu=
t can run ASDF 2.011
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (unless (member :ansi-cl *features*)
+    (error "ASDF only supports GCL in ANSI mode. Aborting.~%"))
+  (setf compiler::*compiler-default-type* (pathname "")
+        compiler::*lsp-ext* ""))
+
+#+gcl2.6
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (shadow 'type-of :asdf/common-lisp)
+  (shadowing-import 'system:*load-pathname* :asdf/common-lisp))
+
+#+gcl2.6
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (export 'type-of :asdf/common-lisp)
+  (export 'system:*load-pathname* :asdf/common-lisp))
+
+#+gcl2.6
+(progn ;; Doesn't support either logical-pathnames or output-translations.
+  (defvar *gcl2.6* t)
+  (deftype logical-pathname () nil)
+  (defun type-of (x) (class-name (class-of x)))
+  (defun wild-pathname-p (path) (declare (ignore path)) nil)
+  (defun translate-logical-pathname (x) x)
+  (defvar *compile-file-pathname* nil)
+  (defun pathname-match-p (in-pathname wild-pathname)
+    (declare (ignore in-wildname wild-wildname)) nil)
+  (defun translate-pathname (source from-wildname to-wildname &key)
+    (declare (ignore from-wildname to-wildname)) source)
+  (defun %print-unreadable-object (object stream type identity thunk)
+    (format stream "#<~@[~S ~]" (when type (type-of object)))
+    (funcall thunk)
+    (format stream "~@[ ~X~]>" (when identity (system:address object))))
+  (defmacro with-standard-io-syntax (&body body)
+    `(progn , at body))
+  (defmacro with-compilation-unit (options &body body)
+    (declare (ignore options)) `(progn , at body))
+  (defmacro print-unreadable-object ((object stream &key type identity) &b=
ody body)
+    `(%print-unreadable-object ,object ,stream ,type ,identity (lambda () =
, at body)))
+  (defun ensure-directories-exist (path)
+    (lisp:system (format nil "mkdir -p ~S"
+                         (namestring (make-pathname :name nil :type nil :v=
ersion nil :defaults path))))))
+
+#+genera
+(unless (fboundp 'ensure-directories-exist)
+  (defun ensure-directories-exist (path)
+    (fs:create-directories-recursively (pathname path))))
 =

 #.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl
       (read-from-string
@@ -476,7 +906,7 @@
           ;; the pathname of the current user's home directory, whereas
           ;; MCL by default provides the directory from which MCL was star=
ted.
           ;; See http://code.google.com/p/mcl/wiki/Portability
-          (defun current-user-homedir-pathname ()
+          (defun user-homedir-pathname ()
             (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))
           (defun probe-posix (posix-namestring)
             \"If a file exists for the posix namestring, return the pathna=
me\"
@@ -486,21 +916,164 @@
                 (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir))
                   (ccl::%path-from-fsref fsref is-dir))))))"))
 =

+#+mkcl
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (require :cmp)
+  (setq clos::*redefine-class-in-place* t)) ;; Make sure we have strict AN=
SI class redefinition semantics
+
+
+;;;; Looping
+(defmacro loop* (&rest rest)
+  #-genera `(loop , at rest)
+  #+genera `(lisp:loop , at rest)) ;; In genera, CL:LOOP can't destructure, s=
o we use LOOP*. Sigh.
+
+
+;;;; compatfmt: avoid fancy format directives when unsupported
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (defun remove-substrings (substrings string)
+    (let ((length (length string)) (stream nil))
+      (labels ((emit (start end)
+                 (when (and (zerop start) (=3D end length))
+                   (return-from remove-substrings string))
+                 (when (< start end)
+                   (unless stream (setf stream (make-string-output-stream)=
))
+                   (write-string string stream :start start :end end)))
+               (recurse (substrings start end)
+                 (cond
+                   ((>=3D start end))
+                   ((null substrings) (emit start end))
+                   (t (let* ((sub (first substrings))
+                             (found (search sub string :start2 start :end2=
 end))
+                             (more (rest substrings)))
+                        (cond
+                          (found
+                           (recurse more start found)
+                           (recurse substrings (+ found (length sub)) end))
+                          (t
+                           (recurse more start end))))))))
+        (recurse substrings 0 length))
+      (if stream (get-output-stream-string stream) ""))))
+
+(defmacro compatfmt (format)
+  #+(or gcl genera)
+  (remove-substrings `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>"=
 "~:>")) format)
+  #-(or gcl genera) format)
+
+
 ;;;; ---------------------------------------------------------------------=
----
-;;;; General Purpose Utilities
-
-(macrolet
-    ((defdef (def* def)
-       `(defmacro ,def* (name formals &rest rest)
-          `(progn
-             #+(or ecl (and gcl (not gcl-pre2.7))) (fmakunbound ',name)
-             #-gcl ; gcl 2.7.0 notinline functions lose secondary return v=
alues :-(
-             ,(when (and #+ecl (symbolp name)) ; fails for setf functions =
on ecl
-                `(declaim (notinline ,name)))
-             (,',def ,name ,formals , at rest)))))
-  (defdef defgeneric* defgeneric)
-  (defdef defun* defun))
-
+;;;; General Purpose Utilities for ASDF
+
+(asdf/package:define-package :asdf/utility
+  (:recycle :asdf/utility :asdf)
+  (:use :asdf/common-lisp :asdf/package)
+  ;; import and reexport a few things defined in :asdf/common-lisp
+  (:import-from :asdf/common-lisp #:compatfmt #:loop* #:remove-substrings
+   #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
+  (:export #:compatfmt #:loop* #:remove-substrings #:compatfmt
+   #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
+  (:export
+   ;; magic helper to define debugging functions:
+   #:asdf-debug #:load-asdf-debug-utility #:*asdf-debug-utility*
+   #:undefine-function #:undefine-functions #:defun* #:defgeneric* ;; (un)=
defining functions
+   #:if-let ;; basic flow control
+   #:while-collecting #:appendf #:length=3Dn-p #:remove-plist-keys #:remov=
e-plist-key ;; lists and plists
+   #:emptyp ;; sequences
+   #:strcat #:first-char #:last-char #:split-string ;; strings
+   #:string-prefix-p #:string-enclosed-p #:string-suffix-p
+   #:find-class* ;; CLOS
+   #:stamp< #:stamps< #:stamp*< #:stamp<=3D ;; stamps
+   #:earlier-stamp #:stamps-earliest #:earliest-stamp
+   #:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f
+   #:list-to-hash-set ;; hash-table
+   #:ensure-function #:access-at #:access-at-count ;; functions
+   #:call-function #:call-functions #:register-hook-function
+   #:match-condition-p #:match-any-condition-p ;; conditions
+   #:call-with-muffled-conditions #:with-muffled-conditions
+   #:load-string #:load-stream
+   #:lexicographic< #:lexicographic<=3D
+   #:parse-version #:unparse-version #:version< #:version<=3D #:version-co=
mpatible-p)) ;; version
+(in-package :asdf/utility)
+
+;;;; Defining functions in a way compatible with hot-upgrade:
+;; DEFUN* and DEFGENERIC* use FMAKUNBOUND to delete any previous fdefiniti=
on,
+;; thus replacing the function without warning or error
+;; even if the signature and/or generic-ness of the function has changed.
+;; For a generic function, this invalidates any previous DEFMETHOD.
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (defun undefine-function (function-spec)
+    (cond
+      ((symbolp function-spec)
+       #+clisp
+       (let ((f (and (fboundp function-spec) (fdefinition function-spec))))
+         (when (typep f 'clos:standard-generic-function)
+           (loop :for m :in (clos:generic-function-methods f)
+                 :do (remove-method f m))))
+       (fmakunbound function-spec))
+      ((and (consp function-spec) (eq (car function-spec) 'setf)
+            (consp (cdr function-spec)) (null (cddr function-spec)))
+       #-gcl2.6 (fmakunbound function-spec))
+      (t (error "bad function spec ~S" function-spec))))
+  (defun undefine-functions (function-spec-list)
+    (map () 'undefine-function function-spec-list))
+  (macrolet
+      ((defdef (def* def)
+         `(defmacro ,def* (name formals &rest rest)
+            (destructuring-bind (name &key (supersede t))
+                (if (or (atom name) (eq (car name) 'setf))
+                    (list name :supersede nil)
+                    name)
+              (declare (ignorable supersede))
+              `(progn
+                 ;; undefining the previous function is the portable way
+                 ;; of overriding any incompatible previous gf, except on =
CLISP.
+                 ;; We usually try to do it only for the functions that ne=
ed it,
+                 ;; which happens in asdf/upgrade - however, for ECL, we n=
eed this hammer,
+                 ;; (which causes issues in clisp)
+                 ,@(when (or #-clisp supersede #+(or ecl gcl2.7) t) ; XXX
+                     `((undefine-function ',name)))
+                 #-gcl ; gcl 2.7.0 notinline functions lose secondary retu=
rn values :-(
+                 ,@(when (and #+ecl (symbolp name)) ; fails for setf funct=
ions on ecl
+                     `((declaim (notinline ,name))))
+                 (,',def ,name ,formals , at rest))))))
+    (defdef defgeneric* defgeneric)
+    (defdef defun* defun)))
+
+
+;;; Magic debugging help. See contrib/debug.lisp
+(defvar *asdf-debug-utility*
+  '(or (ignore-errors
+        (symbol-call :asdf :system-relative-pathname :asdf-driver "contrib=
/debug.lisp"))
+    (merge-pathnames "cl/asdf/contrib/debug.lisp" (user-homedir-pathname)))
+  "form that evaluates to the pathname to your favorite debugging utilitie=
s")
+
+(defmacro asdf-debug (&rest keys)
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (load-asdf-debug-utility , at keys)))
+
+(defun* load-asdf-debug-utility (&key package utility-file)
+  (let* ((*package* (if package (find-package package) *package*))
+         (keyword (read-from-string
+                   (format nil ":DBG-~:@(~A~)" (package-name *package*)))))
+    (unless (member keyword *features*)
+      (let* ((utility-file (or utility-file *asdf-debug-utility*))
+             (file (ignore-errors (probe-file (eval utility-file)))))
+        (if file (load file)
+            (error "Failed to locate debug utility file: ~S" utility-file)=
)))))
+
+
+;;; Flow control
+(defmacro if-let (bindings &body (then-form &optional else-form)) ;; from =
alexandria
+  ;; bindings can be (var form) or ((var1 form1) ...)
+  (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
+                           (list bindings)
+                           bindings))
+         (variables (mapcar #'car binding-list)))
+    `(let ,binding-list
+       (if (and , at variables)
+           ,then-form
+           ,else-form))))
+
+;;; List manipulation
 (defmacro while-collecting ((&rest collectors) &body body)
   "COLLECTORS should be a list of names for collections.  A collector
 defines a function that, when applied to an argument inside BODY, will
@@ -519,133 +1092,47 @@
          , at body
          (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))
 =

-(defmacro aif (test then &optional else)
-  "Anaphoric version of IF, On Lisp style"
-  `(let ((it ,test)) (if it ,then ,else)))
-
-(defun* pathname-directory-pathname (pathname)
-  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
-and NIL NAME, TYPE and VERSION components"
-  (when pathname
-    (make-pathname :name nil :type nil :version nil :defaults pathname)))
-
-(defun* normalize-pathname-directory-component (directory)
-  "Given a pathname directory component, return an equivalent form that is=
 a list"
-  (cond
-    #-(or cmu sbcl scl) ;; these implementations already normalize directo=
ry components.
-    ((stringp directory) `(:absolute ,directory) directory)
-    #+gcl
-    ((and (consp directory) (stringp (first directory)))
-     `(:absolute , at directory))
-    ((or (null directory)
-         (and (consp directory) (member (first directory) '(:absolute :rel=
ative))))
-     directory)
-    (t
-     (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:=
>") directory))))
-
-(defun* merge-pathname-directory-components (specified defaults)
-  ;; Helper for merge-pathnames* that handles directory components.
-  (let ((directory (normalize-pathname-directory-component specified)))
-    (ecase (first directory)
-      ((nil) defaults)
-      (:absolute specified)
-      (:relative
-       (let ((defdir (normalize-pathname-directory-component defaults))
-             (reldir (cdr directory)))
-         (cond
-           ((null defdir)
-            directory)
-           ((not (eq :back (first reldir)))
-            (append defdir reldir))
-           (t
-            (loop :with defabs =3D (first defdir)
-              :with defrev =3D (reverse (rest defdir))
-              :while (and (eq :back (car reldir))
-                          (or (and (eq :absolute defabs) (null defrev))
-                              (stringp (car defrev))))
-              :do (pop reldir) (pop defrev)
-              :finally (return (cons defabs (append (reverse defrev) reldi=
r)))))))))))
-
-(defun* make-pathname-component-logical (x)
-  "Make a pathname component suitable for use in a logical-pathname"
-  (typecase x
-    ((eql :unspecific) nil)
-    #+clisp (string (string-upcase x))
-    #+clisp (cons (mapcar 'make-pathname-component-logical x))
-    (t x)))
-
-(defun* make-pathname-logical (pathname host)
-  "Take a PATHNAME's directory, name, type and version components,
-and make a new pathname with corresponding components and specified logica=
l HOST"
-  (make-pathname
-   :host host
-   :directory (make-pathname-component-logical (pathname-directory pathnam=
e))
-   :name (make-pathname-component-logical (pathname-name pathname))
-   :type (make-pathname-component-logical (pathname-type pathname))
-   :version (make-pathname-component-logical (pathname-version pathname))))
-
-(defun* merge-pathnames* (specified &optional (defaults *default-pathname-=
defaults*))
-  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
-if the SPECIFIED pathname does not have an absolute directory,
-then the HOST and DEVICE both come from the DEFAULTS, whereas
-if the SPECIFIED pathname does have an absolute directory,
-then the HOST and DEVICE both come from the SPECIFIED.
-Also, if either argument is NIL, then the other argument is returned unmod=
ified."
-  (when (null specified) (return-from merge-pathnames* defaults))
-  (when (null defaults) (return-from merge-pathnames* specified))
-  #+scl
-  (ext:resolve-pathname specified defaults)
-  #-scl
-  (let* ((specified (pathname specified))
-         (defaults (pathname defaults))
-         (directory (normalize-pathname-directory-component (pathname-dire=
ctory specified)))
-         (name (or (pathname-name specified) (pathname-name defaults)))
-         (type (or (pathname-type specified) (pathname-type defaults)))
-         (version (or (pathname-version specified) (pathname-version defau=
lts))))
-    (labels ((unspecific-handler (p)
-               (if (typep p 'logical-pathname) #'make-pathname-component-l=
ogical #'identity)))
-      (multiple-value-bind (host device directory unspecific-handler)
-          (ecase (first directory)
-            ((:absolute)
-             (values (pathname-host specified)
-                     (pathname-device specified)
-                     directory
-                     (unspecific-handler specified)))
-            ((nil :relative)
-             (values (pathname-host defaults)
-                     (pathname-device defaults)
-                     (merge-pathname-directory-components directory (pathn=
ame-directory defaults))
-                     (unspecific-handler defaults))))
-        (make-pathname :host host :device device :directory directory
-                       :name (funcall unspecific-handler name)
-                       :type (funcall unspecific-handler type)
-                       :version (funcall unspecific-handler version))))))
-
-(defun* pathname-parent-directory-pathname (pathname)
-  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
-and NIL NAME, TYPE and VERSION components"
-  (when pathname
-    (make-pathname :name nil :type nil :version nil
-                   :directory (merge-pathname-directory-components
-                               '(:relative :back) (pathname-directory path=
name))
-                   :defaults pathname)))
-
 (define-modify-macro appendf (&rest args)
   append "Append onto list") ;; only to be used on short lists.
 =

-(define-modify-macro orf (&rest args)
-  or "or a flag")
+(defun* length=3Dn-p (x n) ;is it that (=3D (length x) n) ?
+  (check-type n (integer 0 *))
+  (loop
+    :for l =3D x :then (cdr l)
+    :for i :downfrom n :do
+    (cond
+      ((zerop i) (return (null l)))
+      ((not (consp l)) (return nil)))))
+
+;;; remove a key from a plist, i.e. for keyword argument cleanup
+(defun* remove-plist-key (key plist)
+  "Remove a single key from a plist"
+  (loop* :for (k v) :on plist :by #'cddr
+    :unless (eq k key)
+    :append (list k v)))
+
+(defun* remove-plist-keys (keys plist)
+  "Remove a list of keys from a plist"
+  (loop* :for (k v) :on plist :by #'cddr
+    :unless (member k keys)
+    :append (list k v)))
+
+
+;;; Sequences
+(defun* emptyp (x)
+  "Predicate that is true for an empty sequence"
+  (or (null x) (and (vectorp x) (zerop (length x)))))
+
+
+;;; Strings
+(defun* strcat (&rest strings)
+  (apply 'concatenate 'string strings))
 =

 (defun* first-char (s)
   (and (stringp s) (plusp (length s)) (char s 0)))
 =

 (defun* last-char (s)
   (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
-
-
-(defun* asdf-message (format-string &rest format-args)
-  (declare (dynamic-extent format-args))
-  (apply 'format *verbose-out* format-string format-args))
 =

 (defun* split-string (string &key max (separator '(#\Space #\Tab)))
   "Split STRING into a list of components separated by
@@ -653,10 +1140,10 @@
 If MAX is specified, then no more than max(1,MAX) components will be retur=
ned,
 starting the separation from the end, e.g. when called with arguments
  \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e=
\")."
-  (catch nil
+  (block ()
     (let ((list nil) (words 0) (end (length string)))
       (flet ((separatorp (char) (find char separator))
-             (done () (throw nil (cons (subseq string 0 end) list))))
+             (done () (return (cons (subseq string 0 end) list))))
         (loop
           :for start =3D (if (and max (>=3D words (1- max)))
                            (done)
@@ -667,69 +1154,285 @@
           (incf words)
           (setf end start))))))
 =

-(defun* split-name-type (filename)
-  (let ((unspecific
-         ;; Giving :unspecific as argument to make-pathname is not portabl=
e.
-         ;; See CLHS make-pathname and 19.2.2.2.3.
-         ;; We only use it on implementations that support it,
-         #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl=
 xcl) :unspecific
-         #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) ni=
l))
-    (destructuring-bind (name &optional (type unspecific))
-        (split-string filename :max 2 :separator ".")
-      (if (equal name "")
-          (values filename unspecific)
-          (values name type)))))
-
-(defun* component-name-to-pathname-components (s &key force-directory forc=
e-relative)
-  "Splits the path string S, returning three values:
-A flag that is either :absolute or :relative, indicating
-   how the rest of the values are to be interpreted.
-A directory path --- a list of strings, suitable for
-   use with MAKE-PATHNAME when prepended with the flag
-   value.
-A filename with type extension, possibly NIL in the
-   case of a directory pathname.
-FORCE-DIRECTORY forces S to be interpreted as a directory
-pathname \(third return value will be NIL, final component
-of S will be treated as part of the directory path.
-
-The intention of this function is to support structured component names,
-e.g., \(:file \"foo/bar\"\), which will be unpacked to relative
-pathnames."
-  (check-type s string)
-  (when (find #\: s)
-    (error (compatfmt "~@<A portable ASDF pathname designator cannot inclu=
de a #\: character: ~3i~_~S~@:>") s))
-  (let* ((components (split-string s :separator "/"))
-         (last-comp (car (last components))))
-    (multiple-value-bind (relative components)
-        (if (equal (first components) "")
-            (if (equal (first-char s) #\/)
-                (progn
-                  (when force-relative
-                    (error (compatfmt "~@<Absolute pathname designator not=
 allowed: ~3i~_~S~@:>") s))
-                  (values :absolute (cdr components)))
-                (values :relative nil))
-          (values :relative components))
-      (setf components (remove-if #'(lambda (x) (member x '("" ".") :test =
#'equal)) components))
-      (setf components (substitute :back ".." components :test #'equal))
+(defun* string-prefix-p (prefix string)
+  "Does STRING begin with PREFIX?"
+  (let* ((x (string prefix))
+         (y (string string))
+         (lx (length x))
+         (ly (length y)))
+    (and (<=3D lx ly) (string=3D x y :end2 lx))))
+
+(defun* string-suffix-p (string suffix)
+  "Does STRING end with SUFFIX?"
+  (let* ((x (string string))
+         (y (string suffix))
+         (lx (length x))
+         (ly (length y)))
+    (and (<=3D ly lx) (string=3D x y :start1 (- lx ly)))))
+
+(defun* string-enclosed-p (prefix string suffix)
+  "Does STRING begin with PREFIX and end with SUFFIX?"
+  (and (string-prefix-p prefix string)
+       (string-suffix-p string suffix)))
+
+
+;;; CLOS
+(defun* find-class* (x &optional (errorp t) environment)
+  (etypecase x
+    ((or standard-class built-in-class) x)
+    #+gcl2.6 (keyword nil)
+    (symbol (find-class x errorp environment))))
+
+
+;;; stamps: a REAL or boolean where NIL=3D-infinity, T=3D+infinity
+(deftype stamp () '(or real boolean))
+(defun* stamp< (x y)
+  (etypecase x
+    (null (and y t))
+    ((eql t) nil)
+    (real (etypecase y
+            (null nil)
+            ((eql t) t)
+            (real (< x y))))))
+(defun* stamps< (list) (loop :for y :in list :for x =3D nil :then y :alway=
s (stamp< x y)))
+(defun* stamp*< (&rest list) (stamps< list))
+(defun* stamp<=3D (x y) (not (stamp< y x)))
+(defun* earlier-stamp (x y) (if (stamp< x y) x y))
+(defun* stamps-earliest (list) (reduce 'earlier-stamp list :initial-value =
t))
+(defun* earliest-stamp (&rest list) (stamps-earliest list))
+(defun* later-stamp (x y) (if (stamp< x y) y x))
+(defun* stamps-latest (list) (reduce 'later-stamp list :initial-value nil))
+(defun* latest-stamp (&rest list) (stamps-latest list))
+(define-modify-macro latest-stamp-f (&rest stamps) latest-stamp)
+
+
+;;; Hash-tables
+(defun* list-to-hash-set (list &aux (h (make-hash-table :test 'equal)))
+  (dolist (x list h) (setf (gethash x h) t)))
+
+
+;;; Function designators
+(defun* ensure-function (fun &key (package :cl))
+  "Coerce the object FUN into a function.
+
+If FUN is a FUNCTION, return it.
+If the FUN is a non-sequence literal constant, return constantly that,
+i.e. for a boolean keyword character number or pathname.
+Otherwise if FUN is a non-literally constant symbol, return its FDEFINITIO=
N.
+If FUN is a CONS, return the function that applies its CAR
+to the appended list of the rest of its CDR and the arguments.
+If FUN is a string, READ a form from it in the specified PACKAGE (default:=
 CL)
+and EVAL that in a (FUNCTION ...) context."
+  (etypecase fun
+    (function fun)
+    ((or boolean keyword character number pathname) (constantly fun))
+    ((or function symbol) fun)
+    (cons #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args))=
))
+    (string (eval `(function ,(with-standard-io-syntax
+                                (let ((*package* (find-package package)))
+                                  (read-from-string fun))))))))
+
+(defun* access-at (object at)
+  "Given an OBJECT and an AT specifier, list of successive accessors,
+call each accessor on the result of the previous calls.
+An accessor may be an integer, meaning a call to ELT,
+a keyword, meaning a call to GETF,
+NIL, meaning identity,
+a function or other symbol, meaning itself,
+or a list of a function designator and arguments, interpreted as per ENSUR=
E-FUNCTION.
+As a degenerate case, the AT specifier may be an atom of a single such acc=
essor
+instead of a list."
+  (flet ((access (object accessor)
+           (etypecase accessor
+             (function (funcall accessor object))
+             (integer (elt object accessor))
+             (keyword (getf object accessor))
+             (null object)
+             (symbol (funcall accessor object))
+             (cons (funcall (ensure-function accessor) object)))))
+    (if (listp at)
+        (dolist (accessor at object)
+          (setf object (access object accessor)))
+        (access object at))))
+
+(defun* access-at-count (at)
+  "From an AT specification, extract a COUNT of maximum number
+   of sub-objects to read as per ACCESS-AT"
+  (cond
+    ((integerp at)
+     (1+ at))
+    ((and (consp at) (integerp (first at)))
+     (1+ (first at)))))
+
+(defun* call-function (function-spec &rest arguments)
+  (apply (ensure-function function-spec) arguments))
+
+(defun* call-functions (function-specs)
+  (map () 'call-function function-specs))
+
+(defun* register-hook-function (variable hook &optional call-now-p)
+  (pushnew hook (symbol-value variable))
+  (when call-now-p (call-function hook)))
+
+
+;;; Version handling
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defun* unparse-version (version-list)
+  (format nil "~{~D~^.~}" version-list))
+
+(defun* parse-version (version-string &optional on-error)
+  "Parse a VERSION-STRING as a series of natural integers separated by dot=
s.
+Return a (non-null) list of integers if the string is valid;
+otherwise return NIL.
+
+When invalid, ON-ERROR is called as per CALL-FUNCTION before to return NIL,
+with format arguments explaining why the version is invalid.
+ON-ERROR is also called if the version is not canonical
+in that it doesn't print back to itself, but the list is returned anyway."
+  (block nil
+   (unless (stringp version-string)
+     (call-function on-error "~S: ~S is not a string" 'parse-version versi=
on-string)
+     (return))
+   (unless (loop :for prev =3D nil :then c :for c :across version-string
+                 :always (or (digit-char-p c)
+                             (and (eql c #\.) prev (not (eql prev #\.))))
+                 :finally (return (and c (digit-char-p c))))
+     (call-function on-error "~S: ~S doesn't follow asdf version numbering=
 convention"
+                    'parse-version version-string)
+     (return))
+   (let* ((version-list
+            (mapcar #'parse-integer (split-string version-string :separato=
r ".")))
+          (normalized-version (unparse-version version-list)))
+     (unless (equal version-string normalized-version)
+       (call-function on-error "~S: ~S contains leading zeros" 'parse-vers=
ion version-string))
+     version-list)))
+
+(defun* lexicographic< (< x y)
+  (cond ((null y) nil)
+        ((null x) t)
+        ((funcall < (car x) (car y)) t)
+        ((funcall < (car y) (car x)) nil)
+        (t (lexicographic< < (cdr x) (cdr y)))))
+
+(defun* lexicographic<=3D (< x y)
+  (not (lexicographic< < y x)))
+
+(defun* version< (version1 version2)
+  (let ((v1 (parse-version version1 nil))
+        (v2 (parse-version version2 nil)))
+    (lexicographic< '< v1 v2)))
+
+(defun* version<=3D (version1 version2)
+  (not (version< version2 version1)))
+
+(defun* version-compatible-p (provided-version required-version)
+  "Is the provided version a compatible substitution for the required-vers=
ion?
+If major versions differ, it's not compatible.
+If they are equal, then any later version is compatible,
+with later being determined by a lexicographical comparison of minor numbe=
rs."
+  (let ((x (parse-version provided-version nil))
+        (y (parse-version required-version nil)))
+    (and x y (=3D (car x) (car y)) (lexicographic<=3D '< (cdr y) (cdr x)))=
))
+); eval-when for version support
+
+
+;;; Condition control
+
+(defvar *uninteresting-conditions* nil
+  "Uninteresting conditions, as per MATCH-CONDITION-P")
+
+(defparameter +simple-condition-format-control-slot+
+  #+abcl 'system::format-control
+  #+allegro 'excl::format-control
+  #+clisp 'system::$format-control
+  #+clozure 'ccl::format-control
+  #+(or cmu scl) 'conditions::format-control
+  #+ecl 'si::format-control
+  #+(or gcl lispworks) 'conditions::format-string
+  #+sbcl 'sb-kernel:format-control
+  #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl) nil
+  "Name of the slot for FORMAT-CONTROL in simple-condition")
+
+(defun* match-condition-p (x condition)
+  "Compare received CONDITION to some pattern X:
+a symbol naming a condition class,
+a simple vector of length 2, arguments to find-symbol* with result as abov=
e,
+or a string describing the format-control of a simple-condition."
+  (etypecase x
+    (symbol (typep condition x))
+    ((simple-vector 2) (typep condition (find-symbol* (svref x 0) (svref x=
 1) nil)))
+    (function (funcall x condition))
+    (string (and (typep condition 'simple-condition)
+                 ;; On SBCL, it's always set and the check triggers a warn=
ing
+                 #+(or allegro clozure cmu lispworks scl)
+		 (slot-boundp condition +simple-condition-format-control-slot+)
+                 (ignore-errors (equal (simple-condition-format-control co=
ndition) x))))))
+
+(defun* match-any-condition-p (condition conditions)
+  "match CONDITION against any of the patterns of CONDITIONS supplied"
+  (loop :for x :in conditions :thereis (match-condition-p x condition)))
+
+(defun* call-with-muffled-conditions (thunk conditions)
+  (handler-bind ((t #'(lambda (c) (when (match-any-condition-p c condition=
s)
+                                    (muffle-warning c)))))
+    (funcall thunk)))
+
+(defmacro with-muffled-uninteresting-conditions ((conditions) &body body)
+  `(call-with-muffled-uninteresting-conditions #'(lambda () , at body) ,condi=
tions))
+
+
+;;;; ---------------------------------------------------------------------=
------
+;;;; Access to the Operating System
+
+(asdf/package:define-package :asdf/os
+  (:recycle :asdf/os :asdf)
+  (:use :asdf/common-lisp :asdf/package :asdf/utility)
+  (:export
+   #:featurep #:os-unix-p #:os-windows-p #:os-genera-p #:detect-os ;; feat=
ures
+   #:getenv #:getenvp ;; environment variables
+   #:implementation-identifier ;; implementation identifier
+   #:implementation-type #:*implementation-type*
+   #:operating-system #:architecture #:lisp-version-string
+   #:hostname #:getcwd #:chdir
+   ;; Windows shortcut support
+   #:read-null-terminated-string #:read-little-endian
+   #:parse-file-location-info #:parse-windows-shortcut))
+(in-package :asdf/os)
+
+;;; Features
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (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))=
))
+      ((eq :or (car x)) (some #'featurep (cdr x)))
+      ((eq :and (car x)) (every #'featurep (cdr x)))
+      (t (error "Malformed feature specification ~S" x))))
+
+  (defun* os-unix-p ()
+    (or #+abcl (featurep :unix)
+        #+(and (not abcl) (or unix cygwin darwin)) t))
+
+  (defun* os-windows-p ()
+    (or #+abcl (featurep :windows)
+        #+(and (not (or unix cygwin darwin)) (or win32 windows mswindows m=
ingw32)) t))
+
+  (defun* os-genera-p ()
+    (or #+genera t))
+
+  (defun* detect-os ()
+    (flet ((yes (yes) (pushnew yes *features*))
+           (no (no) (setf *features* (remove no *features*))))
       (cond
-        ((equal last-comp "")
-         (values relative components nil)) ; "" already removed
-        (force-directory
-         (values relative components nil))
-        (t
-         (values relative (butlast components) last-comp))))))
-
-(defun* remove-keys (key-names args)
-  (loop :for (name val) :on args :by #'cddr
-    :unless (member (symbol-name name) key-names
-                    :key #'symbol-name :test 'equal)
-    :append (list name val)))
-
-(defun* remove-keyword (key args)
-  (loop :for (k v) :on args :by #'cddr
-    :unless (eq k key)
-    :append (list k v)))
+        ((os-unix-p) (yes :os-unix) (no :os-windows) (no :genera))
+        ((os-windows-p) (yes :os-windows) (no :os-unix) (no :genera))
+        ((os-genera-p) (no :os-unix) (no :os-windows) (yes :genera))
+        (t (error "Congratulations for trying XCVB on an operating system~=
%~
+that is neither Unix, nor Windows, nor even Genera.~%Now you port it.")))))
+
+  (detect-os))
+
+;;;; Environment variables: getting them, and parsing them.
 =

 (defun* getenv (x)
   (declare (ignorable x))
@@ -754,764 +1457,170 @@
           (let ((value (_getenv name)))
             (unless (ccl:%null-ptr-p value)
               (ccl:%get-cstring value))))
-  #+mkcl (#.(or (find-symbol* 'getenv :si) (find-symbol* 'getenv :mk-ext))=
 x)
+  #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-e=
xt nil)) x)
   #+sbcl (sb-ext:posix-getenv x)
   #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks=
 mcl mkcl sbcl scl xcl)
   (error "~S is not supported on your implementation" 'getenv))
 =

-(defun* directory-pathname-p (pathname)
-  "Does PATHNAME represent a directory?
-
-A directory-pathname is a pathname _without_ a filename. The three
-ways that the filename components can be missing are for it to be NIL,
-:UNSPECIFIC or the empty string.
-
-Note that this does _not_ check to see that PATHNAME points to an
-actually-existing directory."
-  (when pathname
-    (let ((pathname (pathname pathname)))
-      (flet ((check-one (x)
-               (member x '(nil :unspecific "") :test 'equal)))
-        (and (not (wild-pathname-p pathname))
-             (check-one (pathname-name pathname))
-             (check-one (pathname-type pathname))
-             t)))))
-
-(defun* ensure-directory-pathname (pathspec)
-  "Converts the non-wild pathname designator PATHSPEC to directory form."
-  (cond
-   ((stringp pathspec)
-    (ensure-directory-pathname (pathname pathspec)))
-   ((not (pathnamep pathspec))
-    (error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec))
-   ((wild-pathname-p pathspec)
-    (error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>=
") pathspec))
-   ((directory-pathname-p pathspec)
-    pathspec)
-   (t
-    (make-pathname :directory (append (or (pathname-directory pathspec)
-                                          (list :relative))
-                                      (list (file-namestring pathspec)))
-                   :name nil :type nil :version nil
-                   :defaults pathspec))))
-
-#+genera
-(unless (fboundp 'ensure-directories-exist)
-  (defun* ensure-directories-exist (path)
-    (fs:create-directories-recursively (pathname path))))
-
-(defun* absolute-pathname-p (pathspec)
-  (and (typep pathspec '(or pathname string))
-       (eq :absolute (car (pathname-directory (pathname pathspec))))))
-
-(defun* coerce-pathname (name &key type defaults)
-  "coerce NAME into a PATHNAME.
-When given a string, portably decompose it into a relative pathname:
-#\\/ separates subdirectories. The last #\\/-separated string is as follow=
s:
-if TYPE is NIL, its last #\\. if any separates name and type from from typ=
e;
-if TYPE is a string, it is the type, and the whole string is the name;
-if TYPE is :DIRECTORY, the string is a directory component;
-if the string is empty, it's a directory.
-Any directory named .. is read as :BACK.
-Host, device and version components are taken from DEFAULTS."
-  ;; The defaults are required notably because they provide the default ho=
st
-  ;; to the below make-pathname, which may crucially matter to people using
-  ;; merge-pathnames with non-default hosts,  e.g. for logical-pathnames.
-  ;; NOTE that the host and device slots will be taken from the defaults,
-  ;; but that should only matter if you later merge relative pathnames with
-  ;; CL:MERGE-PATHNAMES instead of ASDF:MERGE-PATHNAMES*
-  (etypecase name
-    ((or null pathname)
-     name)
-    (symbol
-     (coerce-pathname (string-downcase name) :type type :defaults defaults=
))
-    (string
-     (multiple-value-bind (relative path filename)
-         (component-name-to-pathname-components name :force-directory (eq =
type :directory)
-                                                :force-relative t)
-       (multiple-value-bind (name type)
-           (cond
-             ((or (eq type :directory) (null filename))
-              (values nil nil))
-             (type
-              (values filename type))
-             (t
-              (split-name-type filename)))
-         (apply 'make-pathname :directory (cons relative path) :name name =
:type type
-                (when defaults `(:defaults ,defaults))))))))
-
-(defun* merge-component-name-type (name &key type defaults)
-  ;; For backwards compatibility only, for people using internals.
-  ;; Will be removed in a future release, e.g. 2.016.
-  (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE=
-PATHNAME.")
-  (coerce-pathname name :type type :defaults defaults))
-
-(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 typ=
e)))
-
-(defun* length=3Dn-p (x n) ;is it that (=3D (length x) n) ?
-  (check-type n (integer 0 *))
-  (loop
-    :for l =3D x :then (cdr l)
-    :for i :downfrom n :do
-    (cond
-      ((zerop i) (return (null l)))
-      ((not (consp l)) (return nil)))))
-
-(defun* string-suffix-p (s suffix)
-  (check-type s string)
-  (check-type suffix string)
-  (let ((start (- (length s) (length suffix))))
-    (and (<=3D 0 start)
-         (string-equal s suffix :start1 start))))
-
-(defun* read-file-forms (file)
-  (with-open-file (in file)
-    (loop :with eof =3D (list nil)
-     :for form =3D (read in nil eof)
-     :until (eq form eof)
-     :collect form)))
-
-(defun* pathname-root (pathname)
-  (make-pathname :directory '(:absolute)
-                 :name nil :type nil :version nil
-                 :defaults pathname ;; host device, and on scl, *some*
-                 ;; scheme-specific parts: port username password, not oth=
ers:
-                 . #.(or #+scl '(:parameters nil :query nil :fragment nil)=
)))
-
-(defun* probe-file* (p)
-  "when given a pathname P, probes the filesystem for a file or directory
-with given pathname and if it exists return its truename."
-  (etypecase p
-    (null nil)
-    (string (probe-file* (parse-namestring p)))
-    (pathname (unless (wild-pathname-p p)
-                #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks m=
kcl sbcl scl)
-                      '(probe-file p)
-                      #+clisp (aif (find-symbol* '#:probe-pathname :ext)
-                                   `(ignore-errors (,it p)))
-                      '(ignore-errors (truename p)))))))
-
-(defun* truenamize (pathname &optional (defaults *default-pathname-default=
s*))
-  "Resolve as much of a pathname as possible"
-  (block nil
-    (when (typep pathname '(or null logical-pathname)) (return pathname))
-    (let ((p (merge-pathnames* pathname defaults)))
-      (when (typep p 'logical-pathname) (return p))
-      (let ((found (probe-file* p)))
-        (when found (return found)))
-      (unless (absolute-pathname-p p)
-        (let ((true-defaults (ignore-errors (truename defaults))))
-          (when true-defaults
-            (setf p (merge-pathnames pathname true-defaults)))))
-      (unless (absolute-pathname-p p) (return p))
-      (let ((sofar (probe-file* (pathname-root p))))
-        (unless sofar (return p))
-        (flet ((solution (directories)
-                 (merge-pathnames*
-                  (make-pathname :host nil :device nil
-                                 :directory `(:relative , at directories)
-                                 :name (pathname-name p)
-                                 :type (pathname-type p)
-                                 :version (pathname-version p))
-                  sofar)))
-          (loop :with directory =3D (normalize-pathname-directory-component
-                                   (pathname-directory p))
-            :for component :in (cdr directory)
-            :for rest :on (cdr directory)
-            :for more =3D (probe-file*
-                         (merge-pathnames*
-                          (make-pathname :directory `(:relative ,component=
))
-                          sofar)) :do
-            (if more
-                (setf sofar more)
-                (return (solution rest)))
-            :finally
-            (return (solution nil))))))))
-
-(defun* resolve-symlinks (path)
-  #-allegro (truenamize path)
-  #+allegro (if (typep path 'logical-pathname)
-                path
-                (excl:pathname-resolve-symbolic-links path)))
-
-(defun* resolve-symlinks* (path)
-  (if *resolve-symlinks*
-      (and path (resolve-symlinks path))
-      path))
-
-(defun* ensure-pathname-absolute (path)
-  (cond
-    ((absolute-pathname-p path) path)
-    ((stringp path) (ensure-pathname-absolute (pathname path)))
-    ((not (pathnamep path)) (error "not a valid pathname designator ~S" pa=
th))
-    (t (let ((resolved (resolve-symlinks path)))
-         (assert (absolute-pathname-p resolved))
-         resolved))))
-
-(defun* default-directory ()
-  (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
-
-(defun* lispize-pathname (input-file)
-  (make-pathname :type "lisp" :defaults input-file))
-
-(defparameter *wild* #-cormanlisp :wild #+cormanlisp "*")
-(defparameter *wild-file*
-  (make-pathname :name *wild* :type *wild*
-                 :version (or #-(or abcl xcl) *wild*) :directory nil))
-(defparameter *wild-directory*
-  (make-pathname :directory `(:relative ,*wild*) :name nil :type nil :vers=
ion nil))
-(defparameter *wild-inferiors*
-  (make-pathname :directory '(:relative :wild-inferiors) :name nil :type n=
il :version nil))
-(defparameter *wild-path*
-  (merge-pathnames *wild-file* *wild-inferiors*))
-
-(defun* wilden (path)
-  (merge-pathnames* *wild-path* path))
-
-#-scl
-(defun* directory-separator-for-host (&optional (pathname *default-pathnam=
e-defaults*))
-  (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathna=
me)))
-    (last-char (namestring foo))))
-
-#-scl
-(defun* directorize-pathname-host-device (pathname)
-  (let* ((root (pathname-root pathname))
-         (wild-root (wilden root))
-         (absolute-pathname (merge-pathnames* pathname root))
-         (separator (directory-separator-for-host root))
-         (root-namestring (namestring root))
-         (root-string
-          (substitute-if #\/
-                         #'(lambda (x) (or (eql x #\:)
-                                           (eql x separator)))
-                         root-namestring)))
-    (multiple-value-bind (relative path filename)
-        (component-name-to-pathname-components root-string :force-director=
y t)
-      (declare (ignore relative filename))
-      (let ((new-base
-             (make-pathname :defaults root
-                            :directory `(:absolute , at path))))
-        (translate-pathname absolute-pathname wild-root (wilden new-base))=
))))
-
-#+scl
-(defun* directorize-pathname-host-device (pathname)
-  (let ((scheme (ext:pathname-scheme pathname))
-        (host (pathname-host pathname))
-        (port (ext:pathname-port pathname))
-        (directory (pathname-directory pathname)))
-    (flet ((specificp (x) (and x (not (eq x :unspecific)))))
-      (if (or (specificp port)
-              (and (specificp host) (plusp (length host)))
-              (specificp scheme))
-        (let ((prefix ""))
-          (when (specificp port)
-            (setf prefix (format nil ":~D" port)))
-          (when (and (specificp host) (plusp (length host)))
-            (setf prefix (strcat host prefix)))
-          (setf prefix (strcat ":" prefix))
-          (when (specificp scheme)
-            (setf prefix (strcat scheme prefix)))
-          (assert (and directory (eq (first directory) :absolute)))
-          (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
-                         :defaults pathname)))
-    pathname)))
-
-;;;; ---------------------------------------------------------------------=
----
-;;;; ASDF Interface, in terms of generic functions.
-(defgeneric* find-system (system &optional error-p))
-(defgeneric* perform-with-restarts (operation component))
-(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))
-(defgeneric* input-files (operation component))
-(defgeneric* component-operation-time (operation component))
-(defgeneric* operation-description (operation component)
-  (:documentation "returns a phrase that describes performing this operati=
on
-on this component, e.g. \"loading /a/b/c\".
-You can put together sentences using this phrase."))
-
-(defgeneric* system-source-file (system)
-  (:documentation "Return the source file in which system is defined."))
-
-(defgeneric* component-system (component)
-  (:documentation "Find the top-level system containing COMPONENT"))
-
-(defgeneric* component-pathname (component)
-  (:documentation "Extracts the pathname applicable for a particular compo=
nent."))
-
-(defgeneric* component-relative-pathname (component)
-  (:documentation "Returns a pathname for the component argument intended =
to be
-interpreted relative to the pathname of that component's parent.
-Despite the function's name, the return value may be an absolute
-pathname, because an absolute pathname may be interpreted relative to
-another pathname in a degenerate way."))
-
-(defgeneric* component-property (component property))
-
-(defgeneric* (setf component-property) (new-value component property))
-
-(defgeneric* component-external-format (component))
-
-(defgeneric* component-encoding (component))
-
-(eval-when (#-gcl :compile-toplevel :load-toplevel :execute)
-  (defgeneric* (setf module-components-by-name) (new-value module)))
-
-(defgeneric* version-satisfies (component version))
-
-(defgeneric* find-component (base path)
-  (:documentation "Finds the component with PATH starting from BASE module;
-if BASE is nil, then the component is assumed to be a system."))
-
-(defgeneric* source-file-type (component system))
-
-(defgeneric* operation-ancestor (operation)
-  (:documentation
-   "Recursively chase the operation's parent pointer until we get to
-the head of the tree"))
-
-(defgeneric* component-visited-p (operation component)
-  (:documentation "Returns the value stored by a call to
-VISIT-COMPONENT, if that has been called, otherwise NIL.
-This value stored will be a cons cell, the first element
-of which is a computed key, so not interesting.  The
-CDR wil be the DATA value stored by VISIT-COMPONENT; recover
-it as (cdr (component-visited-p op c)).
-  In the current form of ASDF, the DATA value retrieved is
-effectively a boolean, indicating whether some operations are
-to be performed in order to do OPERATION X COMPONENT.  If the
-data value is NIL, the combination had been explored, but no
-operations needed to be performed."))
-
-(defgeneric* visit-component (operation component data)
-  (:documentation "Record DATA as being associated with OPERATION
-and COMPONENT.  This is a side-effecting function:  the association
-will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the
-OPERATION\).
-  No evidence that DATA is ever interesting, beyond just being
-non-NIL.  Using the data field is probably very risky; if there is
-already a record for OPERATION X COMPONENT, DATA will be quietly
-discarded instead of recorded.
-  Starting with 2.006, TRAVERSE will store an integer in data,
-so that nodes can be sorted in decreasing order of traversal."))
-
-
-(defgeneric* (setf visiting-component) (new-value operation component))
-
-(defgeneric* component-visiting-p (operation component))
-
-(defgeneric* component-depends-on (operation component)
-  (:documentation
-   "Returns a list of dependencies needed by the component to perform
-    the operation.  A dependency has one of the following forms:
-
-      (<operation> <component>*), where <operation> is a class
-        designator and each <component> is a component
-        designator, which means that the component depends on
-        <operation> having been performed on each <component>; or
-
-      (FEATURE <feature>), which means that the component depends
-        on <feature>'s presence in *FEATURES*.
-
-    Methods specialized on subclasses of existing component types
-    should usually append the results of CALL-NEXT-METHOD to the
-    list."))
-
-(defgeneric* component-self-dependencies (operation component))
-
-(defgeneric* traverse (operation component)
-  (:documentation
-"Generate and return a plan for performing OPERATION on COMPONENT.
-
-The plan returned is a list of dotted-pairs. Each pair is the CONS
-of ASDF operation object and a COMPONENT object. The pairs will be
-processed in order by OPERATE."))
-
-
-;;;; ---------------------------------------------------------------------=
----
-;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+b=
ug/485687
-(when *upgraded-p*
-  (when (find-class 'module nil)
-    (eval
-     '(defmethod update-instance-for-redefined-class :after
-          ((m module) added deleted plist &key)
-        (declare (ignorable deleted plist))
-        (when *asdf-verbose*
-          (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~=
%")
-                        m (asdf-version)))
-        (when (member 'components-by-name added)
-          (compute-module-components-by-name m))
-        (when (typep m 'system)
-          (when (member 'source-file added)
-            (%set-system-source-file
-             (probe-asd (component-name m) (component-pathname m)) m)
-           (when (equal (component-name m) "asdf")
-             (setf (component-version m) *asdf-version*))))))))
-
-;;;; ---------------------------------------------------------------------=
----
-;;;; Classes, Conditions
-
-(define-condition system-definition-error (error) ()
-  ;; [this use of :report should be redundant, but unfortunately it's not.
-  ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-fun=
ction
-  ;; over print-object; this is always conditions::%print-condition for
-  ;; condition objects, which in turn does inheritance of :report options =
at
-  ;; run-time.  fortunately, inheritance means we only need this kludge he=
re in
-  ;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]
-  #+cmu (:report print-object))
-
-(define-condition formatted-system-definition-error (system-definition-err=
or)
-  ((format-control :initarg :format-control :reader format-control)
-   (format-arguments :initarg :format-arguments :reader format-arguments))
-  (:report (lambda (c s)
-               (apply 'format s (format-control c) (format-arguments c)))))
-
-(define-condition load-system-definition-error (system-definition-error)
-  ((name :initarg :name :reader error-name)
-   (pathname :initarg :pathname :reader error-pathname)
-   (condition :initarg :condition :reader error-condition))
-  (:report (lambda (c s)
-             (format s (compatfmt "~@<Error while trying to load definitio=
n for system ~A from pathname ~A: ~3i~_~A~@:>")
-                     (error-name c) (error-pathname c) (error-condition c)=
))))
-
-(define-condition circular-dependency (system-definition-error)
-  ((components :initarg :components :reader circular-dependency-components=
))
-  (:report (lambda (c s)
-             (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
-                     (circular-dependency-components c)))))
-
-(define-condition duplicate-names (system-definition-error)
-  ((name :initarg :name :reader duplicate-names-name))
-  (:report (lambda (c s)
-             (format s (compatfmt "~@<Error while defining system: multipl=
e components are given same name ~A~@:>")
-                     (duplicate-names-name c)))))
-
-(define-condition missing-component (system-definition-error)
-  ((requires :initform "(unnamed)" :reader missing-requires :initarg :requ=
ires)
-   (parent :initform nil :reader missing-parent :initarg :parent)))
-
-(define-condition missing-component-of-version (missing-component)
-  ((version :initform nil :reader missing-version :initarg :version)))
-
-(define-condition missing-dependency (missing-component)
-  ((required-by :initarg :required-by :reader missing-required-by)))
-
-(define-condition missing-dependency-of-version (missing-dependency
-                                                 missing-component-of-vers=
ion)
-  ())
-
-(define-condition operation-error (error)
-  ((component :reader error-component :initarg :component)
-   (operation :reader error-operation :initarg :operation))
-  (:report (lambda (c s)
-               (format s (compatfmt "~@<Error while invoking ~A on ~A~@:>")
-                       (error-operation c) (error-component c)))))
-(define-condition compile-error (operation-error) ())
-(define-condition compile-failed (compile-error) ())
-(define-condition compile-warned (compile-error) ())
-
-(define-condition invalid-configuration ()
-  ((form :reader condition-form :initarg :form)
-   (location :reader condition-location :initarg :location)
-   (format :reader condition-format :initarg :format)
-   (arguments :reader condition-arguments :initarg :arguments :initform ni=
l))
-  (:report (lambda (c s)
-               (format s (compatfmt "~@<~? (will be skipped)~@:>")
-                       (condition-format c)
-                       (list* (condition-form c) (condition-location c)
-                              (condition-arguments c))))))
-(define-condition invalid-source-registry (invalid-configuration warning)
-  ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~=
@{ ~@?~}~@:>"))))
-(define-condition invalid-output-translation (invalid-configuration warnin=
g)
-  ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ =
in ~S~]~@{ ~@?~}~@:>"))))
-
-(defclass component ()
-  ((name :accessor component-name :initarg :name :type string :documentati=
on
-         "Component name: designator for a string composed of portable pat=
hname characters")
-   ;; We might want to constrain version with
-   ;; :type (and string (satisfies parse-version))
-   ;; but we cannot until we fix all systems that don't use it correctly!
-   (version :accessor component-version :initarg :version)
-   (description :accessor component-description :initarg :description)
-   (long-description :accessor component-long-description :initarg :long-d=
escription)
-   ;; This one below is used by POIU - http://www.cliki.net/poiu
-   ;; a parallelizing extension of ASDF that compiles in multiple parallel
-   ;; slave processes (forked on demand) and loads in the master process.
-   ;; Maybe in the future ASDF may use it internally instead of in-order-t=
o.
-   (load-dependencies :accessor component-load-dependencies :initform nil)
-   ;; In the ASDF object model, dependencies exist between *actions*
-   ;; (an action is a pair of operation and component). They are represent=
ed
-   ;; alists of operations to dependencies (other actions) in each compone=
nt.
-   ;; There are two kinds of dependencies, each stored in its own slot:
-   ;; in-order-to and do-first dependencies. These two kinds are related to
-   ;; the fact that some actions modify the filesystem,
-   ;; whereas other actions modify the current image, and
-   ;; this implies a difference in how to interpret timestamps.
-   ;; in-order-to dependencies will trigger re-performing the action
-   ;; when the timestamp of some dependency
-   ;; makes the timestamp of current action out-of-date;
-   ;; do-first dependencies do not trigger such re-performing.
-   ;; Therefore, a FASL must be recompiled if it is obsoleted
-   ;; by any of its FASL dependencies (in-order-to); but
-   ;; it needn't be recompiled just because one of these dependencies
-   ;; hasn't yet been loaded in the current image (do-first).
-   ;; The names are crap, but they have been the official API since Dan Ba=
rlow's ASDF 1.52!
-   ;; LispWorks's defsystem has caused-by and requires for in-order-to and=
 do-first respectively.
-   ;; Maybe rename the slots in ASDF? But that's not very backwards compat=
ible.
-   ;; See our ASDF 2 paper for more complete explanations.
-   (in-order-to :initform nil :initarg :in-order-to
-                :accessor component-in-order-to)
-   (do-first :initform nil :initarg :do-first
-             :accessor component-do-first)
-   ;; methods defined using the "inline" style inside a defsystem form:
-   ;; need to store them somewhere so we can delete them when the system
-   ;; is re-evaluated
-   (inline-methods :accessor component-inline-methods :initform nil)
-   (parent :initarg :parent :initform nil :reader component-parent)
-   ;; no direct accessor for pathname, we do this as a method to allow
-   ;; 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)
-   (%encoding :accessor %component-encoding :initform nil :initarg :encodi=
ng)
-   ;; XXX we should provide some atomic interface for updating the
-   ;; component properties
-   (properties :accessor component-properties :initarg :properties
-               :initform nil)))
-
-(defun* component-find-path (component)
-  (reverse
-   (loop :for c =3D component :then (component-parent c)
-     :while c :collect (component-name c))))
-
-(defmethod print-object ((c component) stream)
-  (print-unreadable-object (c stream :type t :identity nil)
-    (format stream "~{~S~^ ~}" (component-find-path c))))
-
-
-;;;; methods: conditions
-
-(defmethod print-object ((c missing-dependency) s)
-  (format s (compatfmt "~@<~A, required by ~A~@:>")
-          (call-next-method c nil) (missing-required-by c)))
-
-(defun* sysdef-error (format &rest arguments)
-  (error 'formatted-system-definition-error :format-control
-         format :format-arguments arguments))
-
-;;;; methods: components
-
-(defmethod print-object ((c missing-component) s)
-  (format s (compatfmt "~@<Component ~S not found~@[ in ~A~]~@:>")
-          (missing-requires c)
-          (when (missing-parent c)
-            (coerce-name (missing-parent c)))))
-
-(defmethod print-object ((c missing-component-of-version) s)
-  (format s (compatfmt "~@<Component ~S does not match version ~A~@[ in ~A=
~]~@:>")
-          (missing-requires c)
-          (missing-version c)
-          (when (missing-parent c)
-            (coerce-name (missing-parent c)))))
-
-(defmethod component-system ((component component))
-  (aif (component-parent component)
-       (component-system it)
-       component))
-
-(defvar *default-component-class* 'cl-source-file)
-
-(defun* compute-module-components-by-name (module)
-  (let ((hash (make-hash-table :test 'equal)))
-    (setf (module-components-by-name module) hash)
-    (loop :for c :in (module-components module)
-      :for name =3D (component-name c)
-      :for previous =3D (gethash name (module-components-by-name module))
-      :do
-      (when previous
-        (error 'duplicate-names :name name))
-      :do (setf (gethash name (module-components-by-name module)) c))
-    hash))
-
-(defclass module (component)
-  ((components
-    :initform nil
-    :initarg :components
-    :accessor module-components)
-   (components-by-name
-    :accessor module-components-by-name)
-   ;; What to do if we can't satisfy a dependency of one of this module's
-   ;; components.  This allows a limited form of conditional processing.
-   (if-component-dep-fails
-    :initform :fail
-    :initarg :if-component-dep-fails
-    :accessor module-if-component-dep-fails)
-   (default-component-class
-    :initform nil
-    :initarg :default-component-class
-    :accessor module-default-component-class)))
-
-(defun* component-parent-pathname (component)
-  ;; No default anymore (in particular, no *default-pathname-defaults*).
-  ;; If you force component to have a NULL pathname, you better arrange
-  ;; for any of its children to explicitly provide a proper absolute pathn=
ame
-  ;; wherever a pathname is actually wanted.
-  (let ((parent (component-parent component)))
-    (when parent
-      (component-pathname parent))))
-
-(defmethod component-pathname ((component component))
-  (if (slot-boundp component 'absolute-pathname)
-      (slot-value component 'absolute-pathname)
-      (let ((pathname
-             (merge-pathnames*
-              (component-relative-pathname component)
-              (pathname-directory-pathname (component-parent-pathname comp=
onent)))))
-        (unless (or (null pathname) (absolute-pathname-p pathname))
-          (error (compatfmt "~@<Invalid relative pathname ~S for component=
 ~S~@:>")
-                 pathname (component-find-path component)))
-        (setf (slot-value component 'absolute-pathname) pathname)
-        pathname)))
-
-(defmethod component-property ((c component) property)
-  (cdr (assoc property (slot-value c 'properties) :test #'equal)))
-
-(defmethod (setf component-property) (new-value (c component) property)
-  (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
-    (if a
-        (setf (cdr a) new-value)
-        (setf (slot-value c 'properties)
-              (acons property new-value (slot-value c 'properties)))))
-  new-value)
-
-(defvar *default-encoding* :default
-  "Default encoding for source files.
-The default value :default preserves the legacy behavior.
-A future default might be :utf-8 or :autodetect
-reading emacs-style -*- coding: utf-8 -*- specifications,
-and falling back to utf-8 or latin1 if nothing is specified.")
-
-(defparameter *utf-8-external-format*
-  #+(and asdf-unicode (not clisp)) :utf-8
-  #+(and asdf-unicode clisp) charset:utf-8
-  #-asdf-unicode :default
-  "Default :external-format argument to pass to CL:OPEN and also
-CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file.
-On modern implementations, this will decode UTF-8 code points as CL charac=
ters.
-On legacy implementations, it may fall back on some 8-bit encoding,
-with non-ASCII code points being read as several CL characters;
-hopefully, if done consistently, that won't affect program behavior too mu=
ch.")
-
-(defun* always-default-encoding (pathname)
-  (declare (ignore pathname))
-  *default-encoding*)
-
-(defvar *encoding-detection-hook* #'always-default-encoding
-  "Hook for an extension to define a function to automatically detect a fi=
le's encoding")
-
-(defun* detect-encoding (pathname)
-  (funcall *encoding-detection-hook* pathname))
-
-(defmethod component-encoding ((c component))
-  (or (loop :for x =3D c :then (component-parent x)
-        :while x :thereis (%component-encoding x))
-      (detect-encoding (component-pathname c))))
-
-(defun* default-encoding-external-format (encoding)
-  (case encoding
-    (:default :default) ;; for backwards compatibility only. Explicit usag=
e discouraged.
-    (:utf-8 *utf-8-external-format*)
-    (otherwise
-     (cerror "Continue using :external-format :default" (compatfmt "~@<You=
r ASDF component is using encoding ~S but it isn't recognized. Your system =
should :defsystem-depends-on (:asdf-encodings).~:>") encoding)
-     :default)))
-
-(defvar *encoding-external-format-hook*
-  #'default-encoding-external-format
-  "Hook for an extension to define a mapping between non-default encodings
-and implementation-defined external-format's")
-
-(defun encoding-external-format (encoding)
-  (funcall *encoding-external-format-hook* encoding))
-
-(defmethod component-external-format ((c component))
-  (encoding-external-format (component-encoding c)))
-
-(defclass proto-system () ; slots to keep when resetting a system
-  ;; To preserve identity for all objects, we'd need keep the components s=
lots
-  ;; 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
-   (description :accessor system-description :initarg :description)
-   (long-description :accessor system-long-description :initarg :long-desc=
ription)
-   (author :accessor system-author :initarg :author)
-   (maintainer :accessor system-maintainer :initarg :maintainer)
-   (licence :accessor system-licence :initarg :licence
-            :accessor system-license :initarg :license)
-   (source-file :reader %system-source-file :initarg :source-file ; for CL=
ISP upgrade
-                :writer %set-system-source-file)
-   (defsystem-depends-on :reader system-defsystem-depends-on :initarg :def=
system-depends-on)))
-
-;;;; ---------------------------------------------------------------------=
----
-;;;; version-satisfies
-
-(defmethod version-satisfies ((c component) version)
-  (unless (and version (slot-boundp c 'version))
-    (when version
-      (warn "Requested version ~S but component ~S has no version" version=
 c))
-    (return-from version-satisfies t))
-  (version-satisfies (component-version c) version))
-
-(defun* asdf-version ()
-  "Exported interface to the version of ASDF currently installed. A string.
-You can compare this string with e.g.:
-(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")."
-  *asdf-version*)
-
-(defun* parse-version (string &optional on-error)
-  "Parse a version string as a series of natural integers separated by dot=
s.
-Return a (non-null) list of integers if the string is valid, NIL otherwise.
-If on-error is error, warn, or designates a function of compatible signatu=
re,
-the function is called with an explanation of what is wrong with the argum=
ent.
-NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2=
.3"
-  (and
-   (or (stringp string)
-       (when on-error
-         (funcall on-error "~S: ~S is not a string"
-                  'parse-version string)) nil)
-   (or (loop :for prev =3D nil :then c :for c :across string
-         :always (or (digit-char-p c)
-                     (and (eql c #\.) prev (not (eql prev #\.))))
-         :finally (return (and c (digit-char-p c))))
-       (when on-error
-         (funcall on-error "~S: ~S doesn't follow asdf version numbering c=
onvention"
-                  'parse-version string)) nil)
-   (mapcar #'parse-integer (split-string string :separator "."))))
-
-(defmethod version-satisfies ((cver string) version)
-  (let ((x (parse-version cver 'warn))
-        (y (parse-version version 'warn)))
-    (labels ((bigger (x y)
-               (cond ((not y) t)
-                     ((not x) nil)
-                     ((> (car x) (car y)) t)
-                     ((=3D (car x) (car y))
-                      (bigger (cdr x) (cdr y))))))
-      (and x y (=3D (car x) (car y))
-           (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
+(defun* getenvp (x)
+  "Predicate that is true if the named variable is present in the libc env=
ironment,
+then returning the non-empty string value of the variable"
+  (let ((g (getenv x))) (and (not (emptyp g)) g)))
+
+
+;;;; implementation-identifier
+;;
+;; produce a string to identify current implementation.
+;; Initially stolen from SLIME's SWANK, completely rewritten since.
+;; We're back to runtime checking, for the sake of e.g. ABCL.
+
+(defun* first-feature (feature-sets)
+  (dolist (x feature-sets)
+    (multiple-value-bind (short long feature-expr)
+        (if (consp x)
+            (values (first x) (second x) (cons :or (rest x)))
+            (values x x x))
+      (when (featurep feature-expr)
+        (return (values short long))))))
+
+(defun* implementation-type ()
+  (first-feature
+   '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp)
+     (:cmu :cmucl :cmu) :ecl :gcl
+     (:lwpe :lispworks-personal-edition) (:lw :lispworks)
+     :mcl :mkcl :sbcl :scl (:smbx :symbolics) :xcl)))
+
+(defvar *implementation-type* (implementation-type))
+
+(defun* operating-system ()
+  (first-feature
+   '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin firs=
t!
+     (: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 :x86-64 :x86_64 :x8664-target :amd64 (:and :word-size=3D64 :pc3=
86))
+     (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx38=
6 :x8632-target)
+     (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powe=
rpc)
+     :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 JN=
I,
+     ;; 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 (let ((s 'ccl::target-fasl-version))
+        (and (fboundp s) (funcall s)))
+      (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)))
+    (car ; as opposed to OR, this idiom prevents some unreachable code war=
ning
+     (list
+      #+allegro
+      (format nil "~A~@[~A~]~@[~A~]~@[~A~]"
+              excl::*common-lisp-version-number*
+              ;; M means "modern", as opposed to ANSI-compatible mode (whi=
ch I consider default)
+              (and (eq excl:*current-case-mode* :case-sensitive-lower) "M")
+              ;; Note if not using International ACL
+              ;; see http://www.franz.com/support/documentation/8.1/doc/op=
erators/excl/ics-target-case.htm
+              (excl:ics-target-case (:-ics "8"))
+              (and (member :smp *features*) "S"))
+      #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
+      #+clisp
+      (subseq s 0 (position #\space s)) ; strip build information (date, e=
tc.)
+      #+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 ()
+  (substitute-if
+   #\_ #'(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)))))
+
+
+;;;; Other system information
+
+(defun* hostname ()
+  ;; Note: untested on RMCL
+  #+(or abcl clozure cmucl ecl genera lispworks mcl mkcl sbcl scl xcl) (ma=
chine-instance)
+  #+cormanlisp "localhost" ;; is there a better way? Does it matter?
+  #+allegro (symbol-call :excl.osi :gethostname)
+  #+clisp (first (split-string (machine-instance) :separator " "))
+  #+gcl (system:gethostname))
+
+
+;;; Current directory
+#+cmu
+(defun* parse-unix-namestring* (unix-namestring)
+  (multiple-value-bind (host device directory name type version)
+      (lisp::parse-unix-namestring unix-namestring 0 (length unix-namestri=
ng))
+    (make-pathname :host (or host lisp::*unix-host*) :device device
+                   :directory directory :name name :type type :version ver=
sion)))
+
+(defun* getcwd ()
+  "Get the current working directory as per POSIX getcwd(3), as a pathname=
 object"
+  (or #+abcl (parse-namestring
+              (java:jstatic "getProperty" "java.lang.System" "user.dir") :=
ensure-directory t)
+      #+allegro (excl::current-directory)
+      #+clisp (ext:default-directory)
+      #+clozure (ccl:current-directory)
+      #+(or cmu scl) (#+cmu parse-unix-namestring* #+scl lisp::parse-unix-=
namestring
+                      (strcat (nth-value 1 (unix:unix-current-directory)) =
"/"))
+      #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type =
does it return?
+      #+ecl (ext:getcwd)
+      #+gcl (parse-namestring ;; this is a joke. Isn't there a better way?
+             (first (symbol-call :asdf/driver :run-program '("/bin/pwd") :=
output :lines)))
+      #+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canoni=
cal!
+      #+lispworks (system:current-directory)
+      #+mkcl (mk-ext:getcwd)
+      #+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/))
+      #+xcl (extensions:current-directory)
+      (error "getcwd not supported on your implementation")))
+
+(defun* chdir (x)
+  "Change current directory, as per POSIX chdir(2), to a given pathname ob=
ject"
+  (if-let (x (pathname x))
+    (or #+abcl (java:jstatic "setProperty" "java.lang.System" "user.dir" (=
namestring x))
+        #+allegro (excl:chdir x)
+        #+clisp (ext:cd x)
+        #+clozure (setf (ccl:current-directory) x)
+        #+(or cmu scl) (unix:unix-chdir (ext:unix-namestring x))
+        #+cormanlisp (unless (zerop (win32::_chdir (namestring x)))
+                       (error "Could not set current directory to ~A" x))
+        #+ecl (ext:chdir x)
+        #+genera (setf *default-pathname-defaults* x)
+        #+lispworks (hcl:change-directory x)
+        #+mkcl (mk-ext:chdir x)
+        #+sbcl (symbol-call :sb-posix :chdir (sb-ext:native-namestring x))
+        (error "chdir not supported on your implementation"))))
+
 =

 ;;;; -----------------------------------------------------------------
 ;;;; Windows shortcut support.  Based on:
@@ -1584,1770 +1693,2911 @@
                          (buffer (make-array length)))
                     (read-sequence buffer s)
                     (map 'string #'code-char buffer)))))))
-      (end-of-file ()
+      (end-of-file (c)
+        (declare (ignore c))
         nil)))))
 =

+
 ;;;; ---------------------------------------------------------------------=
----
-;;;; Finding systems
-
-(defun* make-defined-systems-table ()
-  (make-hash-table :test 'equal))
-
-(defvar *defined-systems* (make-defined-systems-table)
-  "This is a hash table whose keys are strings, being the
-names of the systems, and whose values are pairs, the first
-element of which is a universal-time indicating when the
-system definition was last updated, and the second element
-of which is a system object.")
-
-(defun* coerce-name (name)
-  (typecase name
-    (component (component-name name))
-    (symbol (string-downcase (symbol-name name)))
-    (string name)
-    (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~=
@:>") name))))
-
-(defun* system-registered-p (name)
-  (gethash (coerce-name name) *defined-systems*))
-
-(defun* registered-systems ()
-  (loop :for (() . system) :being :the :hash-values :of *defined-systems*
-    :collect (coerce-name system)))
-
-(defun* register-system (system)
-  (check-type system system)
-  (let ((name (component-name system)))
-    (check-type name string)
-    (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system)
-    (unless (eq system (cdr (gethash name *defined-systems*)))
-      (setf (gethash name *defined-systems*)
-            (cons (get-universal-time) system)))))
-
-(defun* clear-system (name)
-  "Clear the entry for a system in the database of systems previously load=
ed.
-Note that this does NOT in any way cause the code of the system to be unlo=
aded."
-  ;; There is no "unload" operation in Common Lisp, and
-  ;; a general such operation cannot be portably written,
-  ;; considering how much CL relies on side-effects to global data structu=
res.
-  (remhash (coerce-name name) *defined-systems*))
-
-(defun* map-systems (fn)
-  "Apply FN to each defined system.
-
-FN should be a function of one argument. It will be
-called with an object of type asdf:system."
-  (maphash #'(lambda (_ datum)
-               (declare (ignore _))
-               (destructuring-bind (_ . def) datum
-                 (declare (ignore _))
-                 (funcall fn def)))
-           *defined-systems*))
-
-;;; for the sake of keeping things reasonably neat, we adopt a
-;;; convention that functions in this list are prefixed SYSDEF-
-
-(defvar *system-definition-search-functions* '())
-
-(setf *system-definition-search-functions*
-      (append
-       ;; Remove known-incompatible sysdef functions from ancient sbcl asd=
f.
-       (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-functi=
ons*))
-                  '(sysdef-central-registry-search
-                    sysdef-source-registry-search
-                    sysdef-find-asdf))))
-
-(defun* search-for-system-definition (system)
-  (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
-"A list of 'system directory designators' ASDF uses to find systems.
-
-A 'system directory designator' is a pathname or an expression
-which evaluates to a pathname. For example:
-
-    (setf asdf:*central-registry*
-          (list '*default-pathname-defaults*
-                #p\"/home/me/cl/systems/\"
-                #p\"/usr/share/common-lisp/systems/\"))
-
-This is for backward compatibilily.
-Going forward, we recommend new users should be using the source-registry.
-")
-
-(defun* featurep (x &optional (features *features*))
+;;;; Portability layer around Common Lisp pathnames
+;; This layer allows for portable manipulation of pathname objects themsel=
ves,
+;; which all is necessary prior to any access the filesystem or environmen=
t.
+
+(asdf/package:define-package :asdf/pathname
+  (:recycle :asdf/pathname :asdf)
+  (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os)
+  (:export
+   ;; Making and merging pathnames, portably
+   #:normalize-pathname-directory-component #:denormalize-pathname-directo=
ry-component
+   #:merge-pathname-directory-components #:*unspecific-pathname-type* #:ma=
ke-pathname*
+   #:make-pathname-component-logical #:make-pathname-logical
+   #:merge-pathnames*
+   #:nil-pathname #:*nil-pathname* #:with-pathname-defaults
+   ;; Predicates
+   #:pathname-equal #:logical-pathname-p #:physical-pathname-p
+   #:absolute-pathname-p #:relative-pathname-p #:hidden-pathname-p #:file-=
pathname-p
+   ;; Directories
+   #:pathname-directory-pathname #:pathname-parent-directory-pathname
+   #:directory-pathname-p #:ensure-directory-pathname
+   ;; Parsing filenames
+   #:component-name-to-pathname-components
+   #:split-name-type #:parse-unix-namestring #:unix-namestring
+   #:split-unix-namestring-directory-components
+   ;; Absolute and relative pathnames
+   #:subpathname #:subpathname*
+   #:ensure-absolute-pathname
+   #:pathname-root #:pathname-host-pathname
+   #:subpathp
+   ;; Checking constraints
+   #:ensure-pathname ;; implemented in filesystem.lisp to accommodate for =
existence constraints
+   ;; Wildcard pathnames
+   #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* #:*wild-pa=
th* #:wilden
+   ;; Translate a pathname
+   #:relativize-directory-component #:relativize-pathname-directory
+   #:directory-separator-for-host #:directorize-pathname-host-device
+   #:translate-pathname*
+   #:*output-translation-function*))
+(in-package :asdf/pathname)
+
+;;; Normalizing pathnames across implementations
+
+(defun* normalize-pathname-directory-component (directory)
+  "Given a pathname directory component, return an equivalent form that is=
 a list"
+  #+gcl2.6 (setf directory (substitute :back :parent directory))
   (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)))
+    #-(or cmu sbcl scl) ;; these implementations already normalize directo=
ry components.
+    ((stringp directory) `(:absolute ,directory))
+    #+gcl2.6
+    ((and (consp directory) (eq :root (first directory)))
+     `(:absolute ,@(rest directory)))
+    ((or (null directory)
+         (and (consp directory) (member (first directory) '(:absolute :rel=
ative))))
+     directory)
+    #+gcl2.6
+    ((consp directory)
+     `(:relative , at directory))
     (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 :mingw=
32))))
-
-(defun* probe-asd (name defaults)
+     (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:=
>") directory))))
+
+(defun* denormalize-pathname-directory-component (directory-component)
+  #-gcl2.6 directory-component
+  #+gcl2.6
+  (let ((d (substitute-if :parent (lambda (x) (member x '(:up :back)))
+                          directory-component)))
+    (cond
+      ((and (consp d) (eq :relative (first d))) (rest d))
+      ((and (consp d) (eq :absolute (first d))) `(:root ,@(rest d)))
+      (t d))))
+
+(defun* merge-pathname-directory-components (specified defaults)
+  ;; Helper for merge-pathnames* that handles directory components.
+  (let ((directory (normalize-pathname-directory-component specified)))
+    (ecase (first directory)
+      ((nil) defaults)
+      (:absolute specified)
+      (:relative
+       (let ((defdir (normalize-pathname-directory-component defaults))
+             (reldir (cdr directory)))
+         (cond
+           ((null defdir)
+            directory)
+           ((not (eq :back (first reldir)))
+            (append defdir reldir))
+           (t
+            (loop :with defabs =3D (first defdir)
+              :with defrev =3D (reverse (rest defdir))
+              :while (and (eq :back (car reldir))
+                          (or (and (eq :absolute defabs) (null defrev))
+                              (stringp (car defrev))))
+              :do (pop reldir) (pop defrev)
+              :finally (return (cons defabs (append (reverse defrev) reldi=
r)))))))))))
+
+;; Giving :unspecific as :type argument to make-pathname is not portable.
+;; See CLHS make-pathname and 19.2.2.2.3.
+;; This will be :unspecific if supported, or NIL if not.
+(defparameter *unspecific-pathname-type*
+  #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :=
unspecific
+  #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil)
+
+(defun* make-pathname* (&rest keys &key (directory nil #+gcl2.6 directoryp)
+                              host (device () #+allegro devicep) name type=
 version defaults
+                              #+scl &allow-other-keys)
+  "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and
+   tries hard to make a pathname that will actually behave as documented,
+   despite the peculiarities of each implementation"
+  (declare (ignorable host device directory name type version defaults))
+  (apply 'make-pathname
+         (append
+          #+allegro (when (and devicep (null device)) `(:device :unspecifi=
c))
+          #+gcl2.6
+          (when directoryp
+            `(:directory ,(denormalize-pathname-directory-component direct=
ory)))
+          keys)))
+
+(defun* make-pathname-component-logical (x)
+  "Make a pathname component suitable for use in a logical-pathname"
+  (typecase x
+    ((eql :unspecific) nil)
+    #+clisp (string (string-upcase x))
+    #+clisp (cons (mapcar 'make-pathname-component-logical x))
+    (t x)))
+
+(defun* make-pathname-logical (pathname host)
+  "Take a PATHNAME's directory, name, type and version components,
+and make a new pathname with corresponding components and specified logica=
l HOST"
+  (make-pathname*
+   :host host
+   :directory (make-pathname-component-logical (pathname-directory pathnam=
e))
+   :name (make-pathname-component-logical (pathname-name pathname))
+   :type (make-pathname-component-logical (pathname-type pathname))
+   :version (make-pathname-component-logical (pathname-version pathname))))
+
+(defun* merge-pathnames* (specified &optional (defaults *default-pathname-=
defaults*))
+  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
+if the SPECIFIED pathname does not have an absolute directory,
+then the HOST and DEVICE both come from the DEFAULTS, whereas
+if the SPECIFIED pathname does have an absolute directory,
+then the HOST and DEVICE both come from the SPECIFIED.
+This is what users want on a modern Unix or Windows operating system,
+unlike the MERGE-PATHNAME behavior.
+Also, if either argument is NIL, then the other argument is returned unmod=
ified;
+this is unlike MERGE-PATHNAME which always merges with a pathname,
+by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL."
+  (when (null specified) (return-from merge-pathnames* defaults))
+  (when (null defaults) (return-from merge-pathnames* specified))
+  #+scl
+  (ext:resolve-pathname specified defaults)
+  #-scl
+  (let* ((specified (pathname specified))
+         (defaults (pathname defaults))
+         (directory (normalize-pathname-directory-component (pathname-dire=
ctory specified)))
+         (name (or (pathname-name specified) (pathname-name defaults)))
+         (type (or (pathname-type specified) (pathname-type defaults)))
+         (version (or (pathname-version specified) (pathname-version defau=
lts))))
+    (labels ((unspecific-handler (p)
+               (if (typep p 'logical-pathname) #'make-pathname-component-l=
ogical #'identity)))
+      (multiple-value-bind (host device directory unspecific-handler)
+          (ecase (first directory)
+            ((:absolute)
+             (values (pathname-host specified)
+                     (pathname-device specified)
+                     directory
+                     (unspecific-handler specified)))
+            ((nil :relative)
+             (values (pathname-host defaults)
+                     (pathname-device defaults)
+                     (merge-pathname-directory-components directory (pathn=
ame-directory defaults))
+                     (unspecific-handler defaults))))
+        (make-pathname* :host host :device device :directory directory
+                        :name (funcall unspecific-handler name)
+                        :type (funcall unspecific-handler type)
+                        :version (funcall unspecific-handler version))))))
+
+(defun* nil-pathname (&optional (defaults *default-pathname-defaults*))
+  "A pathname that is as neutral as possible for use as defaults
+   when merging, making or parsing pathnames"
+  ;; 19.2.2.2.1 says a NIL host can mean a default host;
+  ;; see also "valid physical pathname host" in the CLHS glossary, that su=
ggests
+  ;; strings and lists of strings or :unspecific
+  ;; But CMUCL decides to die on NIL.
+  #.`(make-pathname* :directory nil :name nil :type nil :version nil :devi=
ce nil
+                     :host (or #+cmu lisp::*unix-host*)
+                     #+scl ,@'(:scheme nil :scheme-specific-part nil
+                               :username nil :password nil :parameters nil=
 :query nil :fragment nil)
+                     ;; the default shouldn't matter, but we really want s=
omething physical
+                     :defaults defaults))
+
+(defvar *nil-pathname* (nil-pathname (translate-logical-pathname (user-hom=
edir-pathname))))
+
+(defmacro with-pathname-defaults ((&optional defaults) &body body)
+  `(let ((*default-pathname-defaults* ,(or defaults '*nil-pathname*))) , at b=
ody))
+
+
+;;; Some pathname predicates
+
+(defun* pathname-equal (p1 p2)
+  (when (stringp p1) (setf p1 (pathname p1)))
+  (when (stringp p2) (setf p2 (pathname p2)))
+  (flet ((normalize-component (x)
+           (unless (member x '(nil :unspecific :newest (:relative)) :test =
'equal)
+             x)))
+    (macrolet ((=3D? (&rest accessors)
+                 (flet ((frob (x)
+                          (reduce 'list (cons 'normalize-component accesso=
rs)
+                                  :initial-value x :from-end t)))
+                   `(equal ,(frob 'p1) ,(frob 'p2)))))
+      (or (and (null p1) (null p2))
+          (and (pathnamep p1) (pathnamep p2)
+               (and (=3D? pathname-host)
+                    (=3D? pathname-device)
+                    (=3D? normalize-pathname-directory-component pathname-=
directory)
+                    (=3D? pathname-name)
+                    (=3D? pathname-type)
+                    (=3D? pathname-version)))))))
+
+(defun* logical-pathname-p (x)
+  (typep x 'logical-pathname))
+
+(defun* physical-pathname-p (x)
+  (and (pathnamep x) (not (logical-pathname-p x))))
+
+(defun* absolute-pathname-p (pathspec)
+  "If PATHSPEC is a pathname or namestring object that parses as a pathname
+possessing an :ABSOLUTE directory component, return the (parsed) pathname.
+Otherwise return NIL"
+  (and pathspec
+       (typep pathspec '(or null pathname string))
+       (let ((pathname (pathname pathspec)))
+         (and (eq :absolute (car (normalize-pathname-directory-component
+                                  (pathname-directory pathname))))
+              pathname))))
+
+(defun* relative-pathname-p (pathspec)
+  "If PATHSPEC is a pathname or namestring object that parses as a pathname
+possessing a :RELATIVE or NIL directory component, return the (parsed) pat=
hname.
+Otherwise return NIL"
+  (and pathspec
+       (typep pathspec '(or null pathname string))
+       (let* ((pathname (pathname pathspec))
+              (directory (normalize-pathname-directory-component
+                          (pathname-directory pathname))))
+         (when (or (null directory) (eq :relative (car directory)))
+           pathname))))
+
+(defun* hidden-pathname-p (pathname)
+  "Return a boolean that is true if the pathname is hidden as per Unix sty=
le,
+i.e. its name starts with a dot."
+  (and pathname (equal (first-char (pathname-name pathname)) #\.)))
+
+(defun* file-pathname-p (pathname)
+  "Does PATHNAME represent a file, i.e. has a non-null NAME component?
+
+Accepts NIL, a string (converted through PARSE-NAMESTRING) or a PATHNAME.
+
+Note that this does _not_ check to see that PATHNAME points to an
+actually-existing file.
+
+Returns the (parsed) PATHNAME when true"
+  (when pathname
+    (let* ((pathname (pathname pathname))
+           (name (pathname-name pathname)))
+      (when (not (member name '(nil :unspecific "") :test 'equal))
+        pathname))))
+
+
+;;; Directory pathnames
+(defun* pathname-directory-pathname (pathname)
+  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
+and NIL NAME, TYPE and VERSION components"
+  (when pathname
+    (make-pathname :name nil :type nil :version nil :defaults pathname)))
+
+(defun* pathname-parent-directory-pathname (pathname)
+  "Returns a new pathname that corresponds to the parent of the current pa=
thname's directory,
+i.e. removing one level of depth in the DIRECTORY component. e.g. if pathn=
ame is
+Unix pathname /foo/bar/baz/file.type then return /foo/bar/"
+  (when pathname
+    (make-pathname* :name nil :type nil :version nil
+                    :directory (merge-pathname-directory-components
+                                '(:relative :back) (pathname-directory pat=
hname))
+                    :defaults pathname)))
+
+(defun* directory-pathname-p (pathname)
+  "Does PATHNAME represent a directory?
+
+A directory-pathname is a pathname _without_ a filename. The three
+ways that the filename components can be missing are for it to be NIL,
+:UNSPECIFIC or the empty string.
+
+Note that this does _not_ check to see that PATHNAME points to an
+actually-existing directory."
+  (when pathname
+    (let ((pathname (pathname pathname)))
+      (flet ((check-one (x)
+               (member x '(nil :unspecific "") :test 'equal)))
+        (and (not (wild-pathname-p pathname))
+             (check-one (pathname-name pathname))
+             (check-one (pathname-type pathname))
+             t)))))
+
+(defun* ensure-directory-pathname (pathspec &optional (on-error 'error))
+  "Converts the non-wild pathname designator PATHSPEC to directory form."
+  (cond
+   ((stringp pathspec)
+    (ensure-directory-pathname (pathname pathspec)))
+   ((not (pathnamep pathspec))
+    (call-function on-error (compatfmt "~@<Invalid pathname designator ~S~=
@:>") pathspec))
+   ((wild-pathname-p pathspec)
+    (call-function on-error (compatfmt "~@<Can't reliably convert wild pat=
hname ~3i~_~S~@:>") pathspec))
+   ((directory-pathname-p pathspec)
+    pathspec)
+   (t
+    (make-pathname* :directory (append (or (normalize-pathname-directory-c=
omponent
+                                            (pathname-directory pathspec))
+                                           (list :relative))
+                                       (list (file-namestring pathspec)))
+                    :name nil :type nil :version nil :defaults pathspec))))
+
+
+;;; Parsing filenames
+(defun* split-unix-namestring-directory-components
+    (unix-namestring &key ensure-directory dot-dot)
+  "Splits the path string UNIX-NAMESTRING, returning four values:
+A flag that is either :absolute or :relative, indicating
+   how the rest of the values are to be interpreted.
+A directory path --- a list of strings and keywords, suitable for
+   use with MAKE-PATHNAME when prepended with the flag value.
+   Directory components with an empty name or the name . are removed.
+   Any directory named .. is read as DOT-DOT, or :BACK if it's NIL (not :U=
P).
+A last-component, either a file-namestring including type extension,
+   or NIL in the case of a directory pathname.
+A flag that is true iff the unix-style-pathname was just
+   a file-namestring without / path specification.
+ENSURE-DIRECTORY forces the namestring to be interpreted as a directory pa=
thname:
+the third return value will be NIL, and final component of the namestring
+will be treated as part of the directory path.
+
+An empty string is thus read as meaning a pathname object with all fields =
nil.
+
+Note that : characters will NOT be interpreted as host specification.
+Absolute pathnames are only appropriate on Unix-style systems.
+
+The intention of this function is to support structured component names,
+e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathnames."
+  (check-type unix-namestring string)
+  (check-type dot-dot (member nil :back :up))
+  (if (and (not (find #\/ unix-namestring)) (not ensure-directory)
+           (plusp (length unix-namestring)))
+      (values :relative () unix-namestring t)
+      (let* ((components (split-string unix-namestring :separator "/"))
+             (last-comp (car (last components))))
+        (multiple-value-bind (relative components)
+            (if (equal (first components) "")
+                (if (equal (first-char unix-namestring) #\/)
+                    (values :absolute (cdr components))
+                    (values :relative nil))
+                (values :relative components))
+          (setf components (remove-if #'(lambda (x) (member x '("" ".") :t=
est #'equal))
+                                      components))
+          (setf components (substitute (or dot-dot :back) ".." components =
:test #'equal))
+          (cond
+            ((equal last-comp "")
+             (values relative components nil nil)) ; "" already removed fr=
om components
+            (ensure-directory
+             (values relative components nil nil))
+            (t
+             (values relative (butlast components) last-comp nil)))))))
+
+(defun* split-name-type (filename)
+  "Split a filename into two values NAME and TYPE that are returned.
+We assume filename has no directory component.
+The last . if any separates name and type from from type,
+except that if there is only one . and it is in first position,
+the whole filename is the NAME with an empty type.
+NAME is always a string.
+For an empty type, *UNSPECIFIC-PATHNAME-TYPE* is returned."
+  (check-type filename string)
+  (assert (plusp (length filename)))
+  (destructuring-bind (name &optional (type *unspecific-pathname-type*))
+      (split-string filename :max 2 :separator ".")
+    (if (equal name "")
+        (values filename *unspecific-pathname-type*)
+        (values name type))))
+
+(defun* parse-unix-namestring (name &rest keys &key type defaults dot-dot =
ensure-directory
+                                    &allow-other-keys)
+  "Coerce NAME into a PATHNAME using standard Unix syntax.
+
+Unix syntax is used whether or not the underlying system is Unix;
+on such non-Unix systems it is only usable but for relative pathnames;
+but especially to manipulate relative pathnames portably, it is of crucial
+to possess a portable pathname syntax independent of the underlying OS.
+This is what PARSE-UNIX-NAMESTRING provides, and why we use it in ASDF.
+
+When given a PATHNAME object, just return it untouched.
+When given NIL, just return NIL.
+When given a non-null SYMBOL, first downcase its name and treat it as a st=
ring.
+When given a STRING, portably decompose it into a pathname as below.
+
+#\\/ separates directory components.
+
+The last #\\/-separated substring is interpreted as follows:
+1- If TYPE is :DIRECTORY or ENSURE-DIRECTORY is true,
+ the string is made the last directory component, and NAME and TYPE are NI=
L.
+ if the string is empty, it's the empty pathname with all slots NIL.
+2- If TYPE is NIL, the substring is file-namestring, and its NAME and TYPE
+ are separated by SPLIT-NAME-TYPE.
+3- If TYPE is a string, it is the given TYPE, and the whole string is the =
NAME.
+
+Directory components with an empty name the name . are removed.
+Any directory named .. is read as DOT-DOT,
+which must be one of :BACK or :UP and defaults to :BACK.
+
+HOST, DEVICE and VERSION components are taken from DEFAULTS,
+which itself defaults to *NIL-PATHNAME*, also used if DEFAULTS in NIL.
+No host or device can be specified in the string itself,
+which makes it unsuitable for absolute pathnames outside Unix.
+
+For relative pathnames, these components (and hence the defaults) won't ma=
tter
+if you use MERGE-PATHNAMES* but will matter if you use MERGE-PATHNAMES,
+which is an important reason to always use MERGE-PATHNAMES*.
+
+Arbitrary keys are accepted, and the parse result is passed to ENSURE-PATH=
NAME
+with those keys, removing TYPE DEFAULTS and DOT-DOT.
+When you're manipulating pathnames that are supposed to make sense portably
+even though the OS may not be Unixish, we recommend you use :WANT-RELATIVE=
 T
+to throw an error if the pathname is absolute"
   (block nil
-    (when (directory-pathname-p defaults)
-      (let* ((file (probe-file* (subpathname defaults (strcat name ".asd")=
))))
-        (when file
-          (return file)))
-      #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't ha=
ve 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)
-  (let ((name (coerce-name system))
-        (to-remove nil)
-        (to-replace nil))
-    (block nil
-      (unwind-protect
-           (dolist (dir *central-registry*)
-             (let ((defaults (eval dir)))
-               (when defaults
-                 (cond ((directory-pathname-p defaults)
-                        (let ((file (probe-asd name defaults)))
-                          (when file
-                            (return file))))
-                       (t
-                        (restart-case
-                            (let* ((*print-circle* nil)
-                                   (message
-                                    (format nil
-                                            (compatfmt "~@<While searching=
 for system ~S: ~3i~_~S evaluated to ~S which is not a directory.~@:>")
-                                            system dir defaults)))
-                              (error message))
-                          (remove-entry-from-registry ()
-                            :report "Remove entry from *central-registry* =
and continue"
-                            (push dir to-remove))
-                          (coerce-entry-to-directory ()
-                            :report (lambda (s)
-                                      (format s (compatfmt "~@<Coerce entr=
y to ~a, replace ~a and continue.~@:>")
-                                              (ensure-directory-pathname d=
efaults) dir))
-                            (push (cons dir (ensure-directory-pathname def=
aults)) to-replace))))))))
-        ;; cleanup
-        (dolist (dir to-remove)
-          (setf *central-registry* (remove dir *central-registry*)))
-        (dolist (pair to-replace)
-          (let* ((current (car pair))
-                 (new (cdr pair))
-                 (position (position current *central-registry*)))
-            (setf *central-registry*
-                  (append (subseq *central-registry* 0 position)
-                          (list new)
-                          (subseq *central-registry* (1+ position))))))))))
-
-(defun* make-temporary-package ()
-  (flet ((try (counter)
-           (ignore-errors
-             (make-package (format nil "~A~D" :asdf counter)
-                           :use '(:cl :asdf)))))
-    (do* ((counter 0 (+ counter 1))
-          (package (try counter) (try counter)))
-         (package package))))
+    (check-type type (or null string (eql :directory)))
+    (when ensure-directory
+      (setf type :directory))
+    (etypecase name
+      ((or null pathname) (return name))
+      (symbol
+       (setf name (string-downcase name)))
+      (string))
+    (multiple-value-bind (relative path filename file-only)
+        (split-unix-namestring-directory-components
+         name :dot-dot dot-dot :ensure-directory (eq type :directory))
+      (multiple-value-bind (name type)
+          (cond
+            ((or (eq type :directory) (null filename))
+             (values nil nil))
+            (type
+             (values filename type))
+            (t
+             (split-name-type filename)))
+        (apply 'ensure-pathname
+               (make-pathname*
+                :directory (unless file-only (cons relative path))
+                :name name :type type
+                :defaults (or defaults *nil-pathname*))
+               (remove-plist-keys '(:type :dot-dot :defaults) keys))))))
+
+(defun* unix-namestring (pathname)
+  "Given a non-wild PATHNAME, return a Unix-style namestring for it.
+If the PATHNAME is NIL or a STRING, return it unchanged.
+
+This only considers the DIRECTORY, NAME and TYPE components of the pathnam=
e.
+This is a portable solution for representing relative pathnames,
+But unless you are running on a Unix system, it is not a general solution
+to representing native pathnames.
+
+An error is signaled if the argument is not NULL, a STRING or a PATHNAME,
+or if it is a PATHNAME but some of its components are not recognized."
+  (etypecase pathname
+    ((or null string) pathname)
+    (pathname
+     (with-output-to-string (s)
+       (flet ((err () (error "Not a valid unix-namestring ~S" pathname)))
+         (let* ((dir (normalize-pathname-directory-component (pathname-dir=
ectory pathname)))
+                (name (pathname-name pathname))
+                (type (pathname-type pathname))
+                (type (and (not (eq type :unspecific)) type)))
+           (cond
+             ((eq dir ()))
+             ((eq dir '(:relative)) (princ "./" s))
+             ((consp dir)
+              (destructuring-bind (relabs &rest dirs) dir
+                (or (member relabs '(:relative :absolute)) (err))
+                (when (eq relabs :absolute) (princ #\/ s))
+                (loop :for x :in dirs :do
+                  (cond
+                    ((member x '(:back :up)) (princ "../" s))
+                    ((equal x "") (err))
+                    ;;((member x '("." "..") :test 'equal) (err))
+                    ((stringp x) (format s "~A/" x))
+                    (t (err))))))
+             (t (err)))
+           (cond
+             (name
+              (or (and (stringp name) (or (null type) (stringp type))) (er=
r))
+              (format s "~A~@[.~A~]" name type))
+             (t
+              (or (null type) (err))))))))))
+
+;;; Absolute and relative pathnames
+(defun* subpathname (pathname subpath &key type)
+  "This function takes a PATHNAME and a SUBPATH and a TYPE.
+If SUBPATH is already a PATHNAME object (not namestring),
+and is an absolute pathname at that, it is returned unchanged;
+otherwise, SUBPATH is turned into a relative pathname with given TYPE
+as per PARSE-UNIX-NAMESTRING with :WANT-RELATIVE T :TYPE TYPE,
+then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
+  (or (and (pathnamep subpath) (absolute-pathname-p subpath))
+      (merge-pathnames* (parse-unix-namestring subpath :type type :want-re=
lative t)
+                        (pathname-directory-pathname pathname))))
+
+(defun* subpathname* (pathname subpath &key type)
+  "returns NIL if the base pathname is NIL, otherwise like SUBPATHNAME."
+  (and pathname
+       (subpathname (ensure-directory-pathname pathname) subpath :type typ=
e)))
+
+
+;;; Pathname host and its root
+(defun* pathname-root (pathname)
+  (make-pathname* :directory '(:absolute)
+                  :name nil :type nil :version nil
+                  :defaults pathname ;; host device, and on scl, *some*
+                  ;; scheme-specific parts: port username password, not ot=
hers:
+                  . #.(or #+scl '(:parameters nil :query nil :fragment nil=
))))
+
+(defun* pathname-host-pathname (pathname)
+  (make-pathname* :directory nil
+                  :name nil :type nil :version nil :device nil
+                  :defaults pathname ;; host device, and on scl, *some*
+                  ;; scheme-specific parts: port username password, not ot=
hers:
+                  . #.(or #+scl '(:parameters nil :query nil :fragment nil=
))))
+
+(defun* subpathp (maybe-subpath base-pathname)
+  (and (pathnamep maybe-subpath) (pathnamep base-pathname)
+       (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathn=
ame)
+       (directory-pathname-p base-pathname) (not (wild-pathname-p base-pat=
hname))
+       (pathname-equal (pathname-root maybe-subpath) (pathname-root base-p=
athname))
+       (with-pathname-defaults ()
+         (let ((enough (enough-namestring maybe-subpath base-pathname)))
+           (and (relative-pathname-p enough) (pathname enough))))))
+
+(defun* ensure-absolute-pathname (path &optional defaults (on-error 'error=
))
+  (cond
+    ((absolute-pathname-p path))
+    ((stringp path) (ensure-absolute-pathname (pathname path) defaults on-=
error))
+    ((not (pathnamep path)) (call-function on-error "not a valid pathname =
designator ~S" path))
+    ((let ((default-pathname (if (pathnamep defaults) defaults (call-funct=
ion defaults))))
+       (or (if (absolute-pathname-p default-pathname)
+               (absolute-pathname-p (merge-pathnames* path default-pathnam=
e))
+               (call-function on-error "Default pathname ~S is not an abso=
lute pathname"
+                              default-pathname))
+           (call-function on-error "Failed to merge ~S with ~S into an abs=
olute pathname"
+                          path default-pathname))))
+    (t (call-function on-error
+                      "Cannot ensure ~S is evaluated as an absolute pathna=
me with defaults ~S"
+                      path defaults))))
+
+
+;;; Wildcard pathnames
+(defparameter *wild* (or #+cormanlisp "*" :wild))
+(defparameter *wild-directory-component* (or #+gcl2.6 "*" :wild))
+(defparameter *wild-inferiors-component* (or #+gcl2.6 "**" :wild-inferiors=
))
+(defparameter *wild-file*
+  (make-pathname :directory nil :name *wild* :type *wild*
+                 :version (or #-(or allegro abcl xcl) *wild*)))
+(defparameter *wild-directory*
+  (make-pathname* :directory `(:relative ,*wild-directory-component*)
+                  :name nil :type nil :version nil))
+(defparameter *wild-inferiors*
+  (make-pathname* :directory `(:relative ,*wild-inferiors-component*)
+                  :name nil :type nil :version nil))
+(defparameter *wild-path*
+  (merge-pathnames* *wild-file* *wild-inferiors*))
+
+(defun* wilden (path)
+  (merge-pathnames* *wild-path* path))
+
+
+;;; Translate a pathname
+(defun relativize-directory-component (directory-component)
+  (let ((directory (normalize-pathname-directory-component directory-compo=
nent)))
+    (cond
+      ((stringp directory)
+       (list :relative directory))
+      ((eq (car directory) :absolute)
+       (cons :relative (cdr directory)))
+      (t
+       directory))))
+
+(defun* relativize-pathname-directory (pathspec)
+  (let ((p (pathname pathspec)))
+    (make-pathname*
+     :directory (relativize-directory-component (pathname-directory p))
+     :defaults p)))
+
+(defun* directory-separator-for-host (&optional (pathname *default-pathnam=
e-defaults*))
+  (let ((foo (make-pathname* :directory '(:absolute "FOO") :defaults pathn=
ame)))
+    (last-char (namestring foo))))
+
+#-scl
+(defun* directorize-pathname-host-device (pathname)
+  #+(or unix abcl)
+  (when (and #+abcl (os-unix-p) (physical-pathname-p pathname))
+    (return-from directorize-pathname-host-device pathname))
+  (let* ((root (pathname-root pathname))
+         (wild-root (wilden root))
+         (absolute-pathname (merge-pathnames* pathname root))
+         (separator (directory-separator-for-host root))
+         (root-namestring (namestring root))
+         (root-string
+          (substitute-if #\/
+                         #'(lambda (x) (or (eql x #\:)
+                                           (eql x separator)))
+                         root-namestring)))
+    (multiple-value-bind (relative path filename)
+        (split-unix-namestring-directory-components root-string :ensure-di=
rectory t)
+      (declare (ignore relative filename))
+      (let ((new-base
+             (make-pathname* :defaults root :directory `(:absolute , at path)=
)))
+        (translate-pathname absolute-pathname wild-root (wilden new-base))=
))))
+
+#+scl
+(defun* directorize-pathname-host-device (pathname)
+  (let ((scheme (ext:pathname-scheme pathname))
+        (host (pathname-host pathname))
+        (port (ext:pathname-port pathname))
+        (directory (pathname-directory pathname)))
+    (flet ((specificp (x) (and x (not (eq x :unspecific)))))
+      (if (or (specificp port)
+              (and (specificp host) (plusp (length host)))
+              (specificp scheme))
+        (let ((prefix ""))
+          (when (specificp port)
+            (setf prefix (format nil ":~D" port)))
+          (when (and (specificp host) (plusp (length host)))
+            (setf prefix (strcat host prefix)))
+          (setf prefix (strcat ":" prefix))
+          (when (specificp scheme)
+            (setf prefix (strcat scheme prefix)))
+          (assert (and directory (eq (first directory) :absolute)))
+          (make-pathname* :directory `(:absolute ,prefix ,@(rest directory=
))
+                          :defaults pathname)))
+    pathname)))
+
+(defun* (translate-pathname*) (path absolute-source destination &optional =
root source)
+  (declare (ignore source))
+  (cond
+    ((functionp destination)
+     (funcall destination path absolute-source))
+    ((eq destination t)
+     path)
+    ((not (pathnamep destination))
+     (error "Invalid destination"))
+    ((not (absolute-pathname-p destination))
+     (translate-pathname path absolute-source (merge-pathnames* destinatio=
n root)))
+    (root
+     (translate-pathname (directorize-pathname-host-device path) absolute-=
source destination))
+    (t
+     (translate-pathname path absolute-source destination))))
+
+(defvar *output-translation-function* 'identity) ; Hook for output transla=
tions
+
+
+;;;; ---------------------------------------------------------------------=
----
+;;;; Portability layer around Common Lisp filesystem access
+
+(asdf/package:define-package :asdf/filesystem
+  (:recycle :asdf/pathname :asdf)
+  (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os :asdf/pathn=
ame)
+  (:export
+   ;; Native namestrings
+   #:native-namestring #:parse-native-namestring
+   ;; Probing the filesystem
+   #:truename* #:safe-file-write-date #:probe-file*
+   #:directory* #:filter-logical-directory-results #:directory-files #:sub=
directories
+   #:collect-sub*directories
+   ;; Resolving symlinks somewhat
+   #:truenamize #:resolve-symlinks #:*resolve-symlinks* #:resolve-symlinks*
+   ;; merging with cwd
+   #:get-pathname-defaults #:call-with-current-directory #:with-current-di=
rectory
+   ;; Environment pathnames
+   #:inter-directory-separator #:split-native-pathnames-string
+   #:getenv-pathname #:getenv-pathnames
+   #:getenv-absolute-directory #:getenv-absolute-directories
+   #:lisp-implementation-directory #:lisp-implementation-pathname-p
+   ;; Simple filesystem operations
+   #:ensure-all-directories-exist
+   #:rename-file-overwriting-target
+   #:delete-file-if-exists))
+(in-package :asdf/filesystem)
+
+;;; Native namestrings, as seen by the operating system calls rather than =
Lisp
+(defun* native-namestring (x)
+  "From a non-wildcard CL pathname, a return namestring suitable for passi=
ng to the operating system"
+  (when x
+    (let ((p (pathname x)))
+      #+clozure (with-pathname-defaults () (ccl:native-translated-namestri=
ng p)) ; see ccl bug 978
+      #+(or cmu scl) (ext:unix-namestring p nil)
+      #+sbcl (sb-ext:native-namestring p)
+      #-(or clozure cmu sbcl scl)
+      (if (os-unix-p) (unix-namestring p)
+          (namestring p)))))
+
+(defun* parse-native-namestring (string &rest constraints &key ensure-dire=
ctory &allow-other-keys)
+  "From a native namestring suitable for use by the operating system, retu=
rn
+a CL pathname satisfying all the specified constraints as per ENSURE-PATHN=
AME"
+  (check-type string (or string null))
+  (let* ((pathname
+           (when string
+             (with-pathname-defaults ()
+               #+clozure (ccl:native-to-pathname string)
+               #+sbcl (sb-ext:parse-native-namestring string)
+               #-(or clozure sbcl)
+               (if (os-unix-p)
+                   (parse-unix-namestring string :ensure-directory ensure-=
directory)
+                   (parse-namestring string)))))
+         (pathname
+           (if ensure-directory
+               (and pathname (ensure-directory-pathname pathname))
+               pathname)))
+    (apply 'ensure-pathname pathname constraints)))
+
+
+;;; Probing the filesystem
+(defun* truename* (p)
+  ;; avoids both logical-pathname merging and physical resolution issues
+  (and p (handler-case (with-pathname-defaults () (truename p)) (file-erro=
r () nil))))
 =

 (defun* safe-file-write-date (pathname)
   ;; If FILE-WRITE-DATE returns NIL, it's possible that
   ;; the user or some other agent has deleted an input file.
   ;; Also, generated files will not exist at the time planning is done
-  ;; and calls operation-done-p which calls safe-file-write-date.
+  ;; and calls compute-action-stamp which calls safe-file-write-date.
   ;; So it is very possible that we can't get a valid file-write-date,
   ;; and we can survive and we will continue the planning
   ;; as if the file were very old.
   ;; (or should we treat the case in a different, special way?)
-  (or (and pathname (probe-file* pathname) (ignore-errors (file-write-date=
 pathname)))
-      (progn
-        (when (and pathname *asdf-verbose*)
-          (warn (compatfmt "~@<Missing FILE-WRITE-DATE for ~S, treating it=
 as zero.~@:>")
-                pathname))
-        0)))
-
-(defmethod find-system ((name null) &optional (error-p t))
-  (declare (ignorable name))
-  (when error-p
-    (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
-
-(defmethod find-system (name &optional (error-p t))
-  (find-system (coerce-name name) error-p))
-
-(defvar *systems-being-defined* nil
-  "A hash-table of systems currently being defined keyed by name, or NIL")
-
-(defun* find-system-if-being-defined (name)
-  (when *systems-being-defined*
-    (gethash (coerce-name name) *systems-being-defined*)))
-
-(defun* call-with-system-definitions (thunk)
-  (if *systems-being-defined*
-      (funcall thunk)
-      (let ((*systems-being-defined* (make-hash-table :test 'equal)))
-        (funcall thunk))))
-
-(defmacro with-system-definitions ((&optional) &body body)
-  `(call-with-system-definitions #'(lambda () , at body)))
-
-(defun* load-sysdef (name pathname)
-  ;; Tries to load system definition with canonical NAME from PATHNAME.
-  (with-system-definitions ()
-    (let ((package (make-temporary-package)))
-      (unwind-protect
-           (handler-bind
-               ((error #'(lambda (condition)
-                           (error 'load-system-definition-error
-                                  :name name :pathname pathname
-                                  :condition condition))))
-             (let ((*package* package)
-                   (*default-pathname-defaults*
-                    ;; resolve logical-pathnames so they won't wreak havoc=
 in parsing namestrings.
-                    (pathname-directory-pathname (translate-logical-pathna=
me pathname)))
-                   (external-format (encoding-external-format (detect-enco=
ding pathname))))
-               (asdf-message (compatfmt "~&~@<; ~@;Loading system definiti=
on from ~A into ~A~@:>~%")
-                             pathname package)
-               (load pathname :external-format external-format)))
-        (delete-package package)))))
-
-(defun* locate-system (name)
-  "Given a system NAME designator, try to locate where to load the system =
from.
-Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
-FOUNDP is true when a system 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,
-either 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 l=
oaded."
-  (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))))
-         (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)))
-        (setf pathname (ensure-pathname-absolute pathname))
-        (when found-system
-          (%set-system-source-file pathname found-system)))
-      (when (and previous (not (#-cormanlisp equal #+cormanlisp equalp
-                                             (system-source-file previous)=
 pathname)))
-        (%set-system-source-file pathname previous)
-        (setf previous-time nil))
-      (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 prev=
ious-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 mean=
s some clock is skewed
-                           ;; and trying to load might cause an infinite l=
oop.
-                           (< previous-time (safe-file-write-date pathname=
) (get-universal-time))))
-              (load-sysdef name pathname))
-            (let ((in-memory (system-registered-p name))) ; try again afte=
r 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 (compatfmt "~@<Retry finding system ~A after=
 reinitializing the source-registry.~@:>") name))
-          (initialize-source-registry))))))
-
-(defun* find-system-fallback (requested fallback &rest keys &key source-fi=
le &allow-other-keys)
-  (setf fallback (coerce-name fallback)
-        requested (coerce-name requested))
-  (when (equal requested fallback)
-    (let ((registered (cdr (gethash fallback *defined-systems*))))
-      (or registered
-          (apply 'make-instance 'system
-                 :name fallback :source-file source-file keys)))))
-
-(defun* sysdef-find-asdf (name)
-  ;; Bug: :version *asdf-version* won't be updated when ASDF is updated.
-  (find-system-fallback name "asdf" :version *asdf-version*))
-
-
-;;;; ---------------------------------------------------------------------=
----
-;;;; Finding components
-
-(defmethod find-component ((base string) path)
-  (let ((s (find-system base nil)))
-    (and s (find-component s path))))
-
-(defmethod find-component ((base symbol) path)
-  (cond
-    (base (find-component (coerce-name base) path))
-    (path (find-component path nil))
-    (t    nil)))
-
-(defmethod find-component ((base cons) path)
-  (find-component (car base) (cons (cdr base) path)))
-
-(defmethod find-component ((module module) (name string))
-  (unless (slot-boundp module 'components-by-name) ;; SBCL may miss the u-=
i-f-r-c method!!!
-    (compute-module-components-by-name module))
-  (values (gethash name (module-components-by-name module))))
-
-(defmethod find-component ((component component) (name symbol))
-  (if name
-      (find-component component (coerce-name name))
-      component))
-
-(defmethod find-component ((module module) (name cons))
-  (find-component (find-component module (car name)) (cdr name)))
-
-
-;;; component subclasses
-
-(defclass source-file (component)
-  ((type :accessor source-file-explicit-type :initarg :type :initform nil)=
))
-
-(defclass cl-source-file (source-file)
-  ((type :initform "lisp")))
-(defclass cl-source-file.cl (cl-source-file)
-  ((type :initform "cl")))
-(defclass cl-source-file.lsp (cl-source-file)
-  ((type :initform "lsp")))
-(defclass c-source-file (source-file)
-  ((type :initform "c")))
-(defclass java-source-file (source-file)
-  ((type :initform "java")))
-(defclass static-file (source-file) ())
-(defclass doc-file (static-file) ())
-(defclass html-file (doc-file)
-  ((type :initform "html")))
-
-(defmethod source-file-type ((component module) (s module))
-  (declare (ignorable component s))
-  :directory)
-(defmethod source-file-type ((component source-file) (s module))
-  (declare (ignorable s))
-  (source-file-explicit-type component))
-
-(defmethod component-relative-pathname ((component component))
-  (coerce-pathname
-   (or (slot-value component 'relative-pathname)
-       (component-name component))
-   :type (source-file-type component (component-system component))
-   :defaults (component-parent-pathname component)))
-
-;;;; ---------------------------------------------------------------------=
----
-;;;; Operations
-
-;;; one of these is instantiated whenever #'operate is called
-
-(defclass operation ()
-  (;; as of danb's 2003-03-16 commit e0d02781, :force can be:
-   ;; T to force the inside of the specified system,
-   ;;   but not recurse to other systems we depend on.
-   ;; :ALL (or any other atom) to force all systems
-   ;;   including other systems we depend on.
-   ;; (SYSTEM1 SYSTEM2 ... SYSTEMN)
-   ;;   to force systems named in a given list
-   ;; However, but this feature has only ever worked but starting with ASD=
F 2.014.5
-   (forced :initform nil :initarg :force :accessor operation-forced)
-   (forced-not :initform nil :initarg :force-not :accessor operation-force=
d-not)
-   (original-initargs :initform nil :initarg :original-initargs
-                      :accessor operation-original-initargs)
-   (visited-nodes :initform (make-hash-table :test 'equal) :accessor opera=
tion-visited-nodes)
-   (visiting-nodes :initform (make-hash-table :test 'equal) :accessor oper=
ation-visiting-nodes)
-   (parent :initform nil :initarg :parent :accessor operation-parent)))
-
-(defmethod print-object ((o operation) stream)
-  (print-unreadable-object (o stream :type t :identity t)
-    (ignore-errors
-      (prin1 (operation-original-initargs o) stream))))
-
-(defmethod shared-initialize :after ((operation operation) slot-names
-                                     &key force force-not
-                                     &allow-other-keys)
-  ;; the &allow-other-keys disables initarg validity checking
-  (declare (ignorable operation slot-names force force-not))
-  (macrolet ((frob (x) ;; normalize forced and forced-not slots
-               `(when (consp (,x operation))
-                  (setf (,x operation)
-                        (mapcar #'coerce-name (,x operation))))))
-    (frob operation-forced) (frob operation-forced-not))
-  (values))
-
-(defun* node-for (o c)
-  (cons (class-name (class-of o)) c))
-
-(defmethod operation-ancestor ((operation operation))
-  (aif (operation-parent operation)
-       (operation-ancestor it)
-       operation))
-
-
-(defun* make-sub-operation (c o dep-c dep-o)
-  "C is a component, O is an operation, DEP-C is another
-component, and DEP-O, confusingly enough, is an operation
-class specifier, not an operation."
-  (let* ((args (copy-list (operation-original-initargs o)))
-         (force-p (getf args :force)))
-    ;; note explicit comparison with T: any other non-NIL force value
-    ;; (e.g. :recursive) will pass through
-    (cond ((and (null (component-parent c))
-                (null (component-parent dep-c))
-                (not (eql c dep-c)))
-           (when (eql force-p t)
-             (setf (getf args :force) nil))
-           (apply 'make-instance dep-o
-                  :parent o
-                  :original-initargs args args))
-          ((subtypep (type-of o) dep-o)
-           o)
-          (t
-           (apply 'make-instance dep-o
-                  :parent o :original-initargs args args)))))
-
-
-(defmethod visit-component ((o operation) (c component) data)
-  (unless (component-visited-p o c)
-    (setf (gethash (node-for o c)
-                   (operation-visited-nodes (operation-ancestor o)))
-          (cons t data))))
-
-(defmethod component-visited-p ((o operation) (c component))
-  (gethash (node-for o c)
-           (operation-visited-nodes (operation-ancestor o))))
-
-(defmethod (setf visiting-component) (new-value operation component)
-  ;; MCL complains about unused lexical variables
-  (declare (ignorable operation component))
-  new-value)
-
-(defmethod (setf visiting-component) (new-value (o operation) (c component=
))
-  (let ((node (node-for o c))
-        (a (operation-ancestor o)))
-    (if new-value
-        (setf (gethash node (operation-visiting-nodes a)) t)
-        (remhash node (operation-visiting-nodes a)))
-    new-value))
-
-(defmethod component-visiting-p ((o operation) (c component))
-  (let ((node (node-for o c)))
-    (gethash node (operation-visiting-nodes (operation-ancestor o)))))
-
-(defmethod component-depends-on ((op-spec symbol) (c component))
-  ;; Note: we go from op-spec to operation via make-instance
-  ;; to allow for specialization through defmethod's, even though
-  ;; it's a detour in the default case below.
-  (component-depends-on (make-instance op-spec) c))
-
-(defmethod component-depends-on ((o operation) (c component))
-  (cdr (assoc (type-of o) (component-in-order-to c))))
-
-(defmethod component-self-dependencies ((o operation) (c component))
-  (remove-if-not
-   #'(lambda (x) (member (component-name c) (cdr x) :test #'string=3D))
-   (component-depends-on o c)))
-
-(defmethod input-files ((operation operation) (c component))
-  (let ((parent (component-parent c))
-        (self-deps (component-self-dependencies operation c)))
-    (if self-deps
-        (mapcan #'(lambda (dep)
-                    (destructuring-bind (op name) dep
-                      (output-files (make-instance op)
-                                    (find-component parent name))))
-                self-deps)
-        ;; no previous operations needed?  I guess we work with the
-        ;; original source file, then
-        (list (component-pathname c)))))
-
-(defmethod input-files ((operation operation) (c module))
-  (declare (ignorable operation c))
-  nil)
-
-(defmethod component-operation-time (o c)
-  (gethash (type-of o) (component-operation-times c)))
-
-(defmethod operation-done-p ((o operation) (c component))
-  (let ((out-files (output-files o c))
-        (in-files (input-files o c))
-        (op-time (component-operation-time o c)))
-    (flet ((earliest-out ()
-             (reduce #'min (mapcar #'safe-file-write-date out-files)))
-           (latest-in ()
-             (reduce #'max (mapcar #'safe-file-write-date in-files))))
-      (cond
-        ((and (not in-files) (not out-files))
-         ;; arbitrary decision: an operation that uses nothing to
-         ;; produce nothing probably isn't doing much.
-         ;; e.g. operations on systems, modules that have no immediate act=
ion,
-         ;; but are only meaningful through traversed dependencies
-         t)
-        ((not out-files)
-         ;; an operation without output-files is probably meant
-         ;; for its side-effects in the current image,
-         ;; assumed to be idem-potent,
-         ;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE.
-         (and op-time (>=3D op-time (latest-in))))
-        ((not in-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.
-         ;; (I don't think there is any such case in ASDF unless extended)
-         nil)
-        (t
-         ;; an operation with both input and output files is assumed
-         ;; as computing the latter from the former,
-         ;; assumed to have been done if the latter are all older
-         ;; than the former.
-         ;; e.g. COMPILE-OP of some CL-SOURCE-FILE.
-         ;; We use >=3D instead of > to play nice with generated files.
-         ;; This opens a race condition if an input file is changed
-         ;; after the output is created but within the same second
-         ;; of filesystem time; but the same race condition exists
-         ;; whenever the computation from input to output takes more
-         ;; than one second of filesystem time (or just crosses the
-         ;; second). So that's cool.
-         (and
-          (every #'probe-file* in-files)
-          (every #'probe-file* out-files)
-          (>=3D (earliest-out) (latest-in))))))))
-
-
-
-;;; For 1.700 I've done my best to refactor TRAVERSE
-;;; by splitting it up in a bunch of functions,
-;;; so as to improve the collection and use-detection algorithm. --fare
-;;; The protocol is as follows: we pass around operation, dependency,
-;;; bunch of other stuff, and a force argument. Return a force flag.
-;;; The returned flag is T if anything has changed that requires a rebuild.
-;;; The force argument is a list of components that will require a rebuild
-;;; if the flag is T, at which point whoever returns the flag has to
-;;; mark them all as forced, and whoever recurses again can use a NIL list
-;;; as a further argument.
-
-(defvar *forcing* nil
-  "This dynamically-bound variable is used to force operations in
-recursive calls to traverse.")
-
-(defgeneric* do-traverse (operation component collect))
-
-(defun* resolve-dependency-name (component name &optional version)
-  (loop
-    (restart-case
-        (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 (compatfmt "~@<Retry loading ~3i~_~A.~@:>") na=
me))
-        :test
-        (lambda (c)
-          (or (null c)
-              (and (typep c 'missing-dependency)
-                   (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 (extensibl=
y)
-    ;; 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 depen=
dencies! 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 (:vers=
ion <name> <version>), (:feature <feature> <name>), or <name>.~@:>") dep-sp=
ec))))
-
-(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 u=
s.
-  ;; 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-s=
pecs
-  ;; as dependencies of a larger plan involving op and c.
-  ;; Returns t if this should force recompilation of those who depend on u=
s.
-  ;; dep-op-spec is either an operation class name (not an operation objec=
t),
-  ;; or the magic symbol asdf:feature.
-  ;; If dep-op-spec is asdf:feature, then the first dep-c-specs is a keywo=
rd,
-  ;; 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 (list :feature (car dep-c-specs)))))
-        (t
-         (let ((flag nil))
-           (dolist (d dep-c-specs)
-             (when (do-one-dep op c collect dep-op-spec
-                               (resolve-dependency-spec c d))
-               (setf flag t)))
-           flag))))
-
-(defvar *visit-count* 0) ; counter that allows to sort nodes from operatio=
n-visited-nodes
-
-(defun* do-collect (collect x)
-  (funcall collect x))
-
-(defmethod do-traverse ((operation operation) (c component) collect)
-  (let ((*forcing* *forcing*)
-        (flag nil)) ;; return value: must we rebuild this and its dependen=
cies?
-    (labels
-        ((update-flag (x)
-           (orf flag x))
-         (dep (op comp)
-           (update-flag (do-dep operation c collect op comp))))
-      ;; Have we been visited yet? If so, just process the result.
-      (aif (component-visited-p operation c)
-           (progn
-             (update-flag (cdr it))
-             (return-from do-traverse flag)))
-      ;; dependencies
-      (when (component-visiting-p operation c)
-        (error 'circular-dependency :components (list c)))
-      (setf (visiting-component operation c) t)
-      (unwind-protect
-           (block nil
-             (when (typep c 'system) ;; systems can be forced or forced-not
-               (let ((ancestor (operation-ancestor operation)))
-                 (flet ((match? (f)
-                          (and f (or (not (consp f)) ;; T or :ALL
-                                     (member (component-name c) f :test #'=
equal)))))
-                   (cond
-                     ((match? (operation-forced ancestor))
-                      (setf *forcing* t))
-                     ((match? (operation-forced-not ancestor))
-                      (return))))))
-             ;; first we check and do all the dependencies for the module.
-             ;; Operations planned in this loop will show up
-             ;; in the results, and are consumed below.
-             (let ((*forcing* nil))
-               ;; upstream dependencies are never forced to happen just be=
cause
-               ;; the things that depend on them are....
-               (loop
-                 :for (required-op . deps) :in (component-depends-on opera=
tion c)
-                 :do (dep required-op deps)))
-             ;; constituent bits
-             (let ((module-ops
-                    (when (typep c 'module)
-                      (let ((at-least-one nil)
-                            ;; This is set based on the results of the
-                            ;; dependencies and whether we are in the
-                            ;; context of a *forcing* call...
-                            ;; inter-system dependencies do NOT trigger
-                            ;; building components
-                            (*forcing*
-                             (or *forcing*
-                                 (and flag (not (typep c 'system)))))
-                            (error nil))
-                        (while-collecting (internal-collect)
-                          (dolist (kid (module-components c))
-                            (handler-case
-                                (update-flag
-                                 (do-traverse operation kid #'internal-col=
lect))
-                              #-genera
-                              (missing-dependency (condition)
-                                (when (eq (module-if-component-dep-fails c)
-                                          :fail)
-                                  (error condition))
-                                (setf error condition))
-                              (:no-error (c)
-                                (declare (ignore c))
-                                (setf at-least-one t))))
-                          (when (and (eq (module-if-component-dep-fails c)
-                                         :try-next)
-                                     (not at-least-one))
-                            (error error)))))))
-               (update-flag (or *forcing* (not (operation-done-p operation=
 c))))
-                 ;; For sub-operations, check whether
-                 ;; the original ancestor operation was forced,
-                 ;; or names us amongst an explicit list of things to forc=
e...
-                 ;; except that this check doesn't distinguish
-                 ;; between all the things with a given name. Sigh.
-                 ;; BROKEN!
-               (when flag
-                 (let ((do-first (cdr (assoc (class-name (class-of operati=
on))
-                                             (component-do-first c)))))
-                   (loop :for (required-op . deps) :in do-first
-                     :do (do-dep operation c collect required-op deps)))
-                 (do-collect collect (vector module-ops))
-                 (do-collect collect (cons operation c)))))
-        (setf (visiting-component operation c) nil)))
-    (visit-component operation c (when flag (incf *visit-count*)))
-    flag))
-
-(defun* flatten-tree (l)
-  ;; You collected things into a list.
-  ;; Most elements are just things to collect again.
-  ;; A (simple-vector 1) indicate that you should recurse into its content=
s.
-  ;; This way, in two passes (rather than N being the depth of the tree),
-  ;; you can collect things with marginally constant-time append,
-  ;; achieving linear time collection instead of quadratic time.
-  (while-collecting (c)
-    (labels ((r (x)
-               (if (typep x '(simple-vector 1))
-                   (r* (svref x 0))
-                   (c x)))
-             (r* (l)
-               (dolist (x l) (r x))))
-      (r* l))))
-
-(defmethod traverse ((operation operation) (c component))
-  (flatten-tree
-   (while-collecting (collect)
-     (let ((*visit-count* 0))
-       (do-traverse operation c #'collect)))))
-
-(defmethod perform ((operation operation) (c source-file))
-  (sysdef-error
-   (compatfmt "~@<Required method PERFORM not implemented for operation ~A=
, component ~A~@:>")
-   (class-of operation) (class-of c)))
-
-(defmethod perform ((operation operation) (c module))
-  (declare (ignorable operation c))
-  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 su=
ccessful.~@:>")
-                  (operation-description operation component)))
-        (mark-operation-done operation component)
-        (return)))))
-
-(defmethod explain ((operation operation) (component component))
-  (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%")
-                (operation-description operation component)))
-
-(defmethod operation-description (operation component)
-  (format nil (compatfmt "~@<~A on ~A~@:>")
-          (class-of operation) component))
-
-;;;; ---------------------------------------------------------------------=
----
-;;;; compile-op
-
-(defclass compile-op (operation)
-  ((proclamations :initarg :proclamations :accessor compile-op-proclamatio=
ns :initform nil)
-   (on-warnings :initarg :on-warnings :accessor operation-on-warnings
-                :initform *compile-file-warnings-behaviour*)
-   (on-failure :initarg :on-failure :accessor operation-on-failure
-               :initform *compile-file-failure-behaviour*)
-   (flags :initarg :flags :accessor compile-op-flags
-          :initform nil)))
-
-(defun* output-file (operation component)
-  "The unique output file of performing OPERATION on COMPONENT"
-  (let ((files (output-files operation component)))
-    (assert (length=3Dn-p files 1))
-    (first files)))
-
+  (handler-case (file-write-date (translate-logical-pathname pathname)) (f=
ile-error () nil)))
+
+(defun* probe-file* (p &key truename)
+  "when given a pathname P (designated by a string as per PARSE-NAMESTRING=
),
+probes the filesystem for a file or directory with given pathname.
+If it exists, return its truename is ENSURE-PATHNAME is true,
+or the original (parsed) pathname if it is false (the default)."
+  (with-pathname-defaults () ;; avoids logical-pathname issues on some imp=
lementations
+    (etypecase p
+      (null nil)
+      (string (probe-file* (parse-namestring p) :truename truename))
+      (pathname
+       (handler-case
+           (or
+            #+allegro
+            (probe-file p :follow-symlinks truename)
+            #-(or allegro clisp gcl2.6)
+            (if truename
+                (probe-file p)
+                (and (not (wild-pathname-p p))
+                     (ignore-errors
+                      (let ((pp (translate-logical-pathname p)))
+                        #+(or cmu scl) (unix:unix-stat (ext:unix-namestrin=
g pp))
+                        #+(and lispworks unix) (system:get-file-stat pp)
+                        #+sbcl (sb-unix:unix-stat (sb-ext:native-namestrin=
g pp))
+                        #-(or cmu (and lispworks unix) sbcl scl) (file-wri=
te-date pp)))
+                     p))
+            #+(or clisp gcl2.6)
+            #.(flet ((probe (probe)
+                       `(let ((foundtrue ,probe))
+                          (cond
+                            (truename foundtrue)
+                            (foundtrue p)))))
+                #+gcl2.6
+                (probe '(or (probe-file p)
+                         (and (directory-pathname-p p)
+                          (ignore-errors
+                           (ensure-directory-pathname
+                            (truename* (subpathname
+                                        (ensure-directory-pathname p) ".")=
))))))
+                #+clisp
+                (let* ((fs (find-symbol* '#:file-stat :posix nil))
+                       (pp (find-symbol* '#:probe-pathname :ext nil))
+                       (resolve (if pp
+                                    `(ignore-errors (,pp p))
+                                    '(or (truename* p)
+                                      (truename* (ignore-errors (ensure-di=
rectory-pathname p)))))))
+                  (if fs
+                      `(if truename
+                           ,resolve
+                           (and (ignore-errors (,fs p)) p))
+                      (probe resolve)))))
+         (file-error () nil))))))
+
+(defun* directory* (pathname-spec &rest keys &key &allow-other-keys)
+  (apply 'directory pathname-spec
+         (append keys '#.(or #+allegro '(:directories-are-files nil :follo=
w-symbolic-links nil)
+                             #+clozure '(:follow-links nil)
+                             #+clisp '(:circle t :if-does-not-exist :ignor=
e)
+                             #+(or cmu scl) '(:follow-links nil :truenamep=
 nil)
+                             #+sbcl (when (find-symbol* :resolve-symlinks =
'#:sb-impl nil)
+                                      '(:resolve-symlinks nil))))))
+
+(defun* filter-logical-directory-results (directory entries merger)
+  (if (logical-pathname-p directory)
+      ;; Try hard to not resolve logical-pathname into physical pathnames;
+      ;; otherwise logical-pathname users/lovers will be disappointed.
+      ;; If directory* could use some implementation-dependent magic,
+      ;; we will have logical pathnames already; otherwise,
+      ;; we only keep pathnames for which specifying the name and
+      ;; translating the LPN commute.
+      (loop :for f :in entries
+        :for p =3D (or (and (logical-pathname-p f) f)
+                     (let* ((u (ignore-errors (funcall merger f))))
+                       ;; The first u avoids a cumbersome (truename u) err=
or.
+                       ;; At this point f should already be a truename,
+                       ;; but isn't quite in CLISP, for it doesn't have :v=
ersion :newest
+                       (and u (equal (truename* u) (truename* f)) u)))
+        :when p :collect p)
+      entries))
+
+(defun* directory-files (directory &optional (pattern *wild-file*))
+  (let ((dir (pathname directory)))
+    (when (logical-pathname-p dir)
+      ;; Because of the filtering we do below,
+      ;; logical pathnames have restrictions on wild patterns.
+      ;; Not that the results are very portable when you use these pattern=
s on physical pathnames.
+      (when (wild-pathname-p dir)
+        (error "Invalid wild pattern in logical directory ~S" directory))
+      (unless (member (pathname-directory pattern) '(() (:relative)) :test=
 'equal)
+        (error "Invalid file pattern ~S for logical directory ~S" pattern =
directory))
+      (setf pattern (make-pathname-logical pattern (pathname-host dir))))
+    (let ((entries (ignore-errors (directory* (merge-pathnames* pattern di=
r)))))
+      (filter-logical-directory-results
+       directory entries
+       #'(lambda (f)
+           (make-pathname :defaults dir
+                          :name (make-pathname-component-logical (pathname=
-name f))
+                          :type (make-pathname-component-logical (pathname=
-type f))
+                          :version (make-pathname-component-logical (pathn=
ame-version f))))))))
+
+(defun* subdirectories (directory)
+  (let* ((directory (ensure-directory-pathname directory))
+         #-(or abcl cormanlisp genera xcl)
+         (wild (merge-pathnames*
+                #-(or abcl allegro cmu lispworks sbcl scl xcl)
+                *wild-directory*
+                #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
+                directory))
+         (dirs
+          #-(or abcl cormanlisp genera xcl)
+          (ignore-errors
+            (directory* wild . #.(or #+clozure '(:directories t :files nil)
+                                     #+mcl '(:directories t))))
+          #+(or abcl xcl) (system:list-directory directory)
+          #+cormanlisp (cl::directory-subdirs directory)
+          #+genera (fs:directory-list directory))
+         #+(or abcl allegro cmu genera lispworks sbcl scl xcl)
+         (dirs (loop :for x :in dirs
+                 :for d =3D #+(or abcl xcl) (extensions:probe-directory x)
+                          #+allegro (excl:probe-directory 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 (fir=
st x))
+                                  #+(or cmu lispworks sbcl scl) x)))
+    (filter-logical-directory-results
+     directory dirs
+     (let ((prefix (or (normalize-pathname-directory-component (pathname-d=
irectory directory))
+                       '(:absolute)))) ; because allegro returns NIL for #=
p"FOO:"
+       #'(lambda (d)
+           (let ((dir (normalize-pathname-directory-component (pathname-di=
rectory d))))
+             (and (consp dir) (consp (cdr dir))
+                  (make-pathname
+                   :defaults directory :name nil :type nil :version nil
+                   :directory (append prefix (make-pathname-component-logi=
cal (last dir)))))))))))
+
+(defun* collect-sub*directories (directory collectp recursep collector)
+  (when (funcall collectp directory)
+    (funcall collector directory))
+  (dolist (subdir (subdirectories directory))
+    (when (funcall recursep subdir)
+      (collect-sub*directories subdir collectp recursep collector))))
+
+;;; Resolving symlinks somewhat
+(defun* truenamize (pathname)
+  "Resolve as much of a pathname as possible"
+  (block nil
+    (when (typep pathname '(or null logical-pathname)) (return pathname))
+    (let ((p pathname))
+      (unless (absolute-pathname-p p)
+        (setf p (or (absolute-pathname-p (ensure-absolute-pathname p 'get-=
pathname-defaults nil))
+                    (return p))))
+      (when (logical-pathname-p p) (return p))
+      (let ((found (probe-file* p :truename t)))
+        (when found (return found)))
+      (let* ((directory (normalize-pathname-directory-component (pathname-=
directory p)))
+             (up-components (reverse (rest directory)))
+             (down-components ()))
+        (assert (eq :absolute (first directory)))
+        (loop :while up-components :do
+          (if-let (parent (probe-file* (make-pathname* :directory `(:absol=
ute ,@(reverse up-components))
+                                                       :name nil :type nil=
 :version nil :defaults p)))
+            (return (merge-pathnames* (make-pathname* :directory `(:relati=
ve , at down-components)
+                                                      :defaults p)
+                                      (ensure-directory-pathname parent)))
+            (push (pop up-components) down-components))
+          :finally (return p))))))
+
+(defun* resolve-symlinks (path)
+  #-allegro (truenamize path)
+  #+allegro
+  (if (physical-pathname-p path)
+      (or (ignore-errors (excl:pathname-resolve-symbolic-links path)) path)
+      path))
+
+(defvar *resolve-symlinks* t
+  "Determine whether or not ASDF resolves symlinks when defining systems.
+Defaults to T.")
+
+(defun* resolve-symlinks* (path)
+  (if *resolve-symlinks*
+      (and path (resolve-symlinks path))
+      path))
+
+
+;;; Check pathname constraints
+
+(defun* ensure-pathname
+    (pathname &key
+              on-error
+              defaults type dot-dot
+              want-pathname
+              want-logical want-physical ensure-physical
+              want-relative want-absolute ensure-absolute ensure-subpath
+              want-non-wild want-wild wilden
+              want-file want-directory ensure-directory
+              want-existing ensure-directories-exist
+              truename resolve-symlinks truenamize
+              &aux (p pathname)) ;; mutable working copy, preserve original
+  "Coerces its argument into a PATHNAME,
+optionally doing some transformations and checking specified constraints.
+
+If the argument is NIL, then NIL is returned unless the WANT-PATHNAME cons=
traint is specified.
+
+If the argument is a STRING, it is first converted to a pathname via PARSE=
-UNIX-NAMESTRING
+reusing the keywords DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE;
+then the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE =
is true,
+and the all the checks and transformations are run.
+
+Each non-nil constraint argument can be one of the symbols T, ERROR, CERRO=
R or IGNORE.
+The boolean T is an alias for ERROR.
+ERROR means that an error will be raised if the constraint is not satisfie=
d.
+CERROR means that an continuable error will be raised if the constraint is=
 not satisfied.
+IGNORE means just return NIL instead of the pathname.
+
+The ON-ERROR argument, if not NIL, is a function designator (as per CALL-F=
UNCTION)
+that will be called with the the following arguments:
+a generic format string for ensure pathname, the pathname,
+the keyword argument corresponding to the failed check or transformation,
+a format string for the reason ENSURE-PATHNAME failed,
+and a list with arguments to that format string.
+If ON-ERROR is NIL, ERROR is used instead, which does the right thing.
+You could also pass (CERROR \"CONTINUE DESPITE FAILED CHECK\").
+
+The transformations and constraint checks are done in this order,
+which is also the order in the lambda-list:
+
+WANT-PATHNAME checks that pathname (after parsing if needed) is not null.
+Otherwise, if the pathname is NIL, ensure-pathname returns NIL.
+WANT-LOGICAL checks that pathname is a LOGICAL-PATHNAME
+WANT-PHYSICAL checks that pathname is not a LOGICAL-PATHNAME
+ENSURE-PHYSICAL ensures that pathname is physical via TRANSLATE-LOGICAL-PA=
THNAME
+WANT-RELATIVE checks that pathname has a relative directory component
+WANT-ABSOLUTE checks that pathname does have an absolute directory compone=
nt
+ENSURE-ABSOLUTE merges with the DEFAULTS, then checks again
+that the result absolute is an absolute pathname indeed.
+ENSURE-SUBPATH checks that the pathname is a subpath of the DEFAULTS.
+WANT-FILE checks that pathname has a non-nil FILE component
+WANT-DIRECTORY checks that pathname has nil FILE and TYPE components
+ENSURE-DIRECTORY uses ENSURE-DIRECTORY-PATHNAME to interpret
+any file and type components as being actually a last directory component.
+WANT-NON-WILD checks that pathname is not a wild pathname
+WANT-WILD checks that pathname is a wild pathname
+WILDEN merges the pathname with **/*.*.* if it is not wild
+WANT-EXISTING checks that a file (or directory) exists with that pathname.
+ENSURE-DIRECTORIES-EXIST creates any parent directory with ENSURE-DIRECTOR=
IES-EXIST.
+TRUENAME replaces the pathname by its truename, or errors if not possible.
+RESOLVE-SYMLINKS replaces the pathname by a variant with symlinks resolved=
 by RESOLVE-SYMLINKS.
+TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
+  (block nil
+    (flet ((report-error (keyword description &rest arguments)
+             (call-function (or on-error 'error)
+                            "Invalid pathname ~S: ~*~?"
+                            pathname keyword description arguments)))
+      (macrolet ((err (constraint &rest arguments)
+                   `(report-error ',(intern* constraint :keyword) , at argume=
nts))
+                 (check (constraint condition &rest arguments)
+                   `(when ,constraint
+                      (unless ,condition (err ,constraint , at arguments))))
+                 (transform (transform condition expr)
+                   `(when ,transform
+                      (,@(if condition `(when ,condition) '(progn))
+                       (setf p ,expr)))))
+        (etypecase p
+          ((or null pathname))
+          (string
+           (setf p (parse-unix-namestring
+                    p :defaults defaults :type type :dot-dot dot-dot
+                    :ensure-directory ensure-directory :want-relative want=
-relative))))
+        (check want-pathname (pathnamep p) "Expected a pathname, not NIL")
+        (unless (pathnamep p) (return nil))
+        (check want-logical (logical-pathname-p p) "Expected a logical pat=
hname")
+        (check want-physical (physical-pathname-p p) "Expected a physical =
pathname")
+        (transform ensure-physical () (translate-logical-pathname p))
+        (check ensure-physical (physical-pathname-p p) "Could not translat=
e to a physical pathname")
+        (check want-relative (relative-pathname-p p) "Expected a relative =
pathname")
+        (check want-absolute (absolute-pathname-p p) "Expected an absolute=
 pathname")
+        (transform ensure-absolute (not (absolute-pathname-p p)) (merge-pa=
thnames* p defaults))
+        (check ensure-absolute (absolute-pathname-p p)
+               "Could not make into an absolute pathname even after mergin=
g with ~S" defaults)
+        (check ensure-subpath (absolute-pathname-p defaults)
+               "cannot be checked to be a subpath of non-absolute pathname=
 ~S" defaults)
+        (check ensure-subpath (subpathp p defaults) "is not a sub pathname=
 of ~S" defaults)
+        (check want-file (file-pathname-p p) "Expected a file pathname")
+        (check want-directory (directory-pathname-p p) "Expected a directo=
ry pathname")
+        (transform ensure-directory (not (directory-pathname-p p)) (ensure=
-directory-pathname p))
+        (check want-non-wild (not (wild-pathname-p p)) "Expected a non-wil=
dcard pathname")
+        (check want-wild (wild-pathname-p p) "Expected a wildcard pathname=
")
+        (transform wilden (not (wild-pathname-p p)) (wilden p))
+        (when want-existing
+          (let ((existing (probe-file* p :truename truename)))
+            (if existing
+                (when truename
+                  (return existing))
+                (err want-existing "Expected an existing pathname"))))
+        (when ensure-directories-exist (ensure-directories-exist p))
+        (when truename
+          (let ((truename (truename* p)))
+            (if truename
+                (return truename)
+                (err truename "Can't get a truename for pathname"))))
+        (transform resolve-symlinks () (resolve-symlinks p))
+        (transform truenamize () (truenamize p))
+        p))))
+
+
+;;; Pathname defaults
+(defun* get-pathname-defaults (&optional (defaults *default-pathname-defau=
lts*))
+  (or (absolute-pathname-p defaults)
+      (merge-pathnames* defaults (getcwd))))
+
+(defun* call-with-current-directory (dir thunk)
+  (if dir
+      (let* ((dir (resolve-symlinks* (get-pathname-defaults (pathname-dire=
ctory-pathname dir))))
+             (*default-pathname-defaults* dir)
+             (cwd (getcwd)))
+        (chdir dir)
+        (unwind-protect
+             (funcall thunk)
+          (chdir cwd)))
+      (funcall thunk)))
+
+(defmacro with-current-directory ((&optional dir) &body body)
+  "Call BODY while the POSIX current working directory is set to DIR"
+  `(call-with-current-directory ,dir #'(lambda () , at body)))
+
+
+;;; Environment pathnames
+(defun* inter-directory-separator ()
+  (if (os-unix-p) #\: #\;))
+
+(defun* split-native-pathnames-string (string &rest constraints &key &allo=
w-other-keys)
+  (loop :for namestring :in (split-string string :separator (string (inter=
-directory-separator)))
+        :collect (apply 'parse-native-namestring namestring constraints)))
+
+(defun* getenv-pathname (x &rest constraints &key on-error &allow-other-ke=
ys)
+  (apply 'parse-native-namestring (getenvp x)
+         :on-error (or on-error
+                       `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" g=
etenv-pathname ,x))
+         constraints))
+(defun* getenv-pathnames (x &rest constraints &key on-error &allow-other-k=
eys)
+  (apply 'split-native-pathnames-string (getenvp x)
+         :on-error (or on-error
+                       `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" g=
etenv-pathnames ,x))
+         constraints))
+(defun* getenv-absolute-directory (x)
+  (getenv-pathname x :want-absolute t :ensure-directory t))
+(defun* getenv-absolute-directories (x)
+  (getenv-pathnames x :want-absolute t :ensure-directory t))
+
+(defun* lisp-implementation-directory (&key truename)
+  (declare (ignorable truename))
+  #+(or clozure ecl gcl mkcl sbcl)
+  (let ((dir
+          (ignore-errors
+           #+clozure #p"ccl:"
+           #+(or ecl mkcl) #p"SYS:"
+           #+gcl system::*system-directory*
+           #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int=
 nil))
+                     (funcall it)
+                     (getenv-pathname "SBCL_HOME" :ensure-directory t)))))
+    (if (and dir truename)
+        (truename* dir)
+        dir)))
+
+(defun* lisp-implementation-pathname-p (pathname)
+  ;; Other builtin systems are those under the implementation directory
+  (and (when pathname
+         (if-let (impdir (lisp-implementation-directory))
+           (or (subpathp pathname impdir)
+               (when *resolve-symlinks*
+                 (if-let (truename (truename* pathname))
+                   (if-let (trueimpdir (truename* impdir))
+                     (subpathp truename trueimpdir)))))))
+       t))
+
+
+;;; Simple filesystem operations
 (defun* ensure-all-directories-exist (pathnames)
    (dolist (pathname pathnames)
      (ensure-directories-exist (translate-logical-pathname pathname))))
 =

-(defmethod perform :before ((operation compile-op) (c source-file))
-  (ensure-all-directories-exist (output-files operation c)))
-
-(defmethod perform :after ((operation operation) (c component))
-  (mark-operation-done operation c))
-
-(defgeneric* around-compile-hook (component))
-(defgeneric* call-with-around-compile-hook (component thunk))
-
-(defmethod around-compile-hook ((c component))
+(defun* rename-file-overwriting-target (source target)
+  #+clisp ;; But for a bug in CLISP 2.48, we should use :if-exists :overwr=
ite and be atomic
+  (posix:copy-file source target :method :rename)
+  #-clisp
+  (rename-file source target
+               #+clozure :if-exists #+clozure :rename-and-delete))
+
+(defun* delete-file-if-exists (x)
+  (when x (handler-case (delete-file x) (file-error () nil))))
+
+
+;;;; ---------------------------------------------------------------------=
------
+;;;; Utilities related to streams
+
+(asdf/package:define-package :asdf/stream
+  (:recycle :asdf/stream)
+  (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os :asdf/pathn=
ame :asdf/filesystem)
+  (:export
+   #:*default-stream-element-type* #:*stderr* #:setup-stderr
+   #:with-safe-io-syntax #:call-with-safe-io-syntax
+   #:with-output #:output-string #:with-input
+   #:with-input-file #:call-with-input-file
+   #:finish-outputs #:format! #:safe-format!
+   #:copy-stream-to-stream #:concatenate-files
+   #:copy-stream-to-stream-line-by-line
+   #:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line
+   #:slurp-stream-forms #:slurp-stream-form
+   #:read-file-string #:read-file-lines #:read-file-forms #:read-file-form=
 #:safe-read-file-form
+   #:eval-input #:eval-thunk #:standard-eval-thunk
+   #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding
+   #:encoding-external-format #:*encoding-external-format-hook* #:default-=
encoding-external-format
+   #:*default-encoding* #:*utf-8-external-format*
+   ;; Temporary files
+   #:*temporary-directory* #:temporary-directory #:default-temporary-direc=
tory
+   #:setup-temporary-directory
+   #:call-with-temporary-file #:with-temporary-file
+   #:add-pathname-suffix #:tmpize-pathname
+   #:call-with-staging-pathname #:with-staging-pathname))
+(in-package :asdf/stream)
+
+(defvar *default-stream-element-type* (or #+(or abcl cmu cormanlisp scl xc=
l) 'character :default)
+  "default element-type for open (depends on the current CL implementation=
)")
+
+(defvar *stderr* *error-output*
+  "the original error output stream at startup")
+
+(defun setup-stderr ()
+  (setf *stderr*
+        #+allegro excl::*stderr*
+        #+clozure ccl::*stderr*
+        #-(or allegro clozure) *error-output*))
+(setup-stderr)
+
+
+;;; Safe syntax
+
+(defvar *standard-readtable* (copy-readtable nil))
+
+(defmacro with-safe-io-syntax ((&key (package :cl)) &body body)
+  "Establish safe CL reader options around the evaluation of BODY"
+  `(call-with-safe-io-syntax #'(lambda () (let ((*package* (find-package ,=
package))) , at body))))
+
+(defun* call-with-safe-io-syntax (thunk &key (package :cl))
+  (with-standard-io-syntax ()
+    (let ((*package* (find-package package))
+          (*readtable* *standard-readtable*)
+          (*read-default-float-format* 'double-float)
+          (*print-readably* nil)
+	  (*read-eval* nil))
+      (funcall thunk))))
+
+
+;;; Output to a stream or string, FORMAT-style
+
+(defun* call-with-output (output function)
+  "Calls FUNCTION with an actual stream argument,
+behaving like FORMAT with respect to how stream designators are interprete=
d:
+If OUTPUT is a stream, use it as the stream.
+If OUTPUT is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the=
 resulting string.
+If OUTPUT is T, use *STANDARD-OUTPUT* as the stream.
+If OUTPUT is a string with a fill-pointer, use it as a string-output-strea=
m.
+Otherwise, signal an error."
+  (etypecase output
+    (null
+     (with-output-to-string (stream) (funcall function stream)))
+    ((eql t)
+     (funcall function *standard-output*))
+    (stream
+     (funcall function output))
+    (string
+     (assert (fill-pointer output))
+     (with-output-to-string (stream output) (funcall function stream)))))
+
+(defmacro with-output ((output-var &optional (value output-var)) &body bod=
y)
+  "Bind OUTPUT-VAR to an output stream, coercing VALUE (default: previous =
binding of OUTPUT-VAR)
+as per FORMAT, and evaluate BODY within the scope of this binding."
+  `(call-with-output ,value #'(lambda (,output-var) , at body)))
+
+(defun* output-string (string &optional output)
+  "If the desired OUTPUT is not NIL, print the string to the output; other=
wise return the string"
+  (if output
+      (with-output (output) (princ string output))
+      string))
+
+
+;;; Input helpers
+
+(defun* call-with-input (input function)
+  "Calls FUNCTION with an actual stream argument, interpreting
+stream designators like READ, but also coercing strings to STRING-INPUT-ST=
REAM.
+If INPUT is a STREAM, use it as the stream.
+If INPUT is NIL, use a *STANDARD-INPUT* as the stream.
+If INPUT is T, use *TERMINAL-IO* as the stream.
+As an extension, if INPUT is a string, use it as a string-input-stream.
+Otherwise, signal an error."
+  (etypecase input
+    (null (funcall function *standard-input*))
+    ((eql t) (funcall function *terminal-io*))
+    (stream (funcall function input))
+    (string (with-input-from-string (stream input) (funcall function strea=
m)))))
+
+(defmacro with-input ((input-var &optional (value input-var)) &body body)
+  "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous bi=
nding of INPUT-VAR)
+as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding=
."
+  `(call-with-input ,value #'(lambda (,input-var) , at body)))
+
+(defun* call-with-input-file (pathname thunk
+                                       &key
+                                       (element-type *default-stream-eleme=
nt-type*)
+                                       (external-format :default)
+                                       (if-does-not-exist :error))
+  "Open FILE for input with given recognizes options, call THUNK with the =
resulting stream.
+Other keys are accepted but discarded."
+  #+gcl2.6 (declare (ignore external-format))
+  (with-open-file (s pathname :direction :input
+                     :element-type element-type
+                     #-gcl2.6 :external-format #-gcl2.6 external-format
+                     :if-does-not-exist if-does-not-exist)
+    (funcall thunk s)))
+
+(defmacro with-input-file ((var pathname &rest keys &key element-type exte=
rnal-format) &body body)
+  (declare (ignore element-type external-format))
+  `(call-with-input-file ,pathname #'(lambda (,var) , at body) , at keys))
+
+
+;;; Ensure output buffers are flushed
+
+(defun* finish-outputs (&rest streams)
+  "Finish output on the main output streams as well as any specified one.
+Useful for portably flushing I/O before user input or program exit."
+  ;; CCL notably buffers its stream output by default.
+  (dolist (s (append streams
+                     (list *stderr* *error-output* *standard-output* *trac=
e-output*
+                           *debug-io* *terminal-io* *debug-io* *query-io*)=
))
+    (ignore-errors (finish-output s)))
+  (values))
+
+(defun* format! (stream format &rest args)
+  "Just like format, but call finish-outputs before and after the output."
+  (finish-outputs stream)
+  (apply 'format stream format args)
+  (finish-output stream))
+
+(defun* safe-format! (stream format &rest args)
+  (with-safe-io-syntax ()
+    (ignore-errors (apply 'format! stream format args))
+    (finish-outputs stream))) ; just in case format failed
+
+
+;;; Simple Whole-Stream processing
+
+
+(defun* copy-stream-to-stream (input output &key element-type buffer-size =
linewise prefix)
+  "Copy the contents of the INPUT stream into the OUTPUT stream.
+If LINEWISE is true, then read and copy the stream line by line, with an o=
ptional PREFIX.
+Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE."
+  (with-open-stream (input input)
+    (if linewise
+        (loop* :for (line eof) =3D (multiple-value-list (read-line input n=
il nil))
+               :while line :do
+               (when prefix (princ prefix output))
+               (princ line output)
+               (unless eof (terpri output))
+               (finish-output output)
+               (when eof (return)))
+        (loop
+          :with buffer-size =3D (or buffer-size 8192)
+          :for buffer =3D (make-array (list buffer-size) :element-type (or=
 element-type 'character))
+          :for end =3D (read-sequence buffer input)
+          :until (zerop end)
+          :do (write-sequence buffer output :end end)
+              (when (< end buffer-size) (return))))))
+
+(defun* concatenate-files (inputs output)
+  (with-open-file (o output :element-type '(unsigned-byte 8)
+                            :direction :output :if-exists :rename-and-dele=
te)
+    (dolist (input inputs)
+      (with-open-file (i input :element-type '(unsigned-byte 8)
+                               :direction :input :if-does-not-exist :error)
+        (copy-stream-to-stream i o :element-type '(unsigned-byte 8))))))
+
+(defun* slurp-stream-string (input &key (element-type 'character))
+  "Read the contents of the INPUT stream as a string"
+  (with-open-stream (input input)
+    (with-output-to-string (output)
+      (copy-stream-to-stream input output :element-type element-type))))
+
+(defun* slurp-stream-lines (input &key count)
+  "Read the contents of the INPUT stream as a list of lines, return those =
lines.
+
+Read no more than COUNT lines."
+  (check-type count (or null integer))
+  (with-open-stream (input input)
+    (loop :for n :from 0
+          :for l =3D (and (or (not count) (< n count))
+                        (read-line input nil nil))
+          :while l :collect l)))
+
+(defun* slurp-stream-line (input &key (at 0))
+  "Read the contents of the INPUT stream as a list of lines,
+then return the ACCESS-AT of that list of lines using the AT specifier.
+PATH defaults to 0, i.e. return the first line.
+PATH is typically an integer, or a list of an integer and a function.
+If PATH is NIL, it will return all the lines in the file.
+
+The stream will not be read beyond the Nth lines,
+where N is the index specified by path
+if path is either an integer or a list that starts with an integer."
+  (access-at (slurp-stream-lines input :count (access-at-count at)) at))
+
+(defun* slurp-stream-forms (input &key count)
+"Read the contents of the INPUT stream as a list of forms,
+and return those forms.
+
+If COUNT is null, read to the end of the stream;
+if COUNT is an integer, stop after COUNT forms were read.
+
+BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
+  (check-type count (or null integer))
+  (loop :with eof =3D '#:eof
+        :for n :from 0
+        :for form =3D (if (and count (>=3D n count))
+                        eof
+                        (read-preserving-whitespace input nil eof))
+        :until (eq form eof) :collect form))
+
+(defun* slurp-stream-form (input &key (at 0))
+"Read the contents of the INPUT stream as a list of forms,
+then return the ACCESS-AT of these forms following the AT.
+AT defaults to 0, i.e. return the first form.
+AT is typically a list of integers.
+If AT is NIL, it will return all the forms in the file.
+
+The stream will not be read beyond the Nth form,
+where N is the index specified by path,
+if path is either an integer or a list that starts with an integer.
+
+BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
+  (access-at (slurp-stream-forms input :count (access-at-count at)) at))
+
+(defun* read-file-string (file &rest keys)
+  "Open FILE with option KEYS, read its contents as a string"
+  (apply 'call-with-input-file file 'slurp-stream-string keys))
+
+(defun* read-file-lines (file &rest keys)
+  "Open FILE with option KEYS, read its contents as a list of lines
+BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
+  (apply 'call-with-input-file file 'slurp-stream-lines keys))
+
+(defun* read-file-forms (file &rest keys &key count &allow-other-keys)
+  "Open input FILE with option KEYS (except COUNT),
+and read its contents as per SLURP-STREAM-FORMS with given COUNT.
+BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
+  (apply 'call-with-input-file file
+         #'(lambda (input) (slurp-stream-forms input :count count))
+         (remove-plist-key :count keys)))
+
+(defun* read-file-form (file &rest keys &key (at 0) &allow-other-keys)
+  "Open input FILE with option KEYS (except AT),
+and read its contents as per SLURP-STREAM-FORM with given AT specifier.
+BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
+  (apply 'call-with-input-file file
+         #'(lambda (input) (slurp-stream-form input :at at))
+         (remove-plist-key :at keys)))
+
+(defun* safe-read-file-form (pathname &rest keys &key (package :cl) &allow=
-other-keys)
+  "Reads the specified form from the top of a file using a safe standardiz=
ed syntax.
+Extracts the form using READ-FILE-FORM,
+within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
+  (with-safe-io-syntax (:package package)
+    (apply 'read-file-form pathname (remove-plist-key :package keys))))
+
+(defun* eval-input (input)
+  "Portably read and evaluate forms from INPUT, return the last values."
+  (with-input (input)
+    (loop :with results :with eof =3D'#:eof
+          :for form =3D (read input nil eof)
+          :until (eq form eof)
+          :do (setf results (multiple-value-list (eval form)))
+          :finally (return (apply 'values results)))))
+
+(defun* eval-thunk (thunk)
+  "Evaluate a THUNK of code:
+If a function, FUNCALL it without arguments.
+If a constant literal and not a sequence, return it.
+If a cons or a symbol, EVAL it.
+If a string, repeatedly read and evaluate from it, returning the last valu=
es."
+  (etypecase thunk
+    ((or boolean keyword number character pathname) thunk)
+    ((or cons symbol) (eval thunk))
+    (function (funcall thunk))
+    (string (eval-input thunk))))
+
+(defun* standard-eval-thunk (thunk &key (package :cl))
+  "Like EVAL-THUNK, but in a more standardized evaluation context."
+  ;; Note: it's "standard-" not "safe-", because evaluation is never safe.
+  (when thunk
+    (with-safe-io-syntax (:package package)
+      (let ((*read-eval* t))
+        (eval-thunk thunk)))))
+
+
+;;; Encodings
+
+(defvar *default-encoding* :default
+  "Default encoding for source files.
+The default value :default preserves the legacy behavior.
+A future default might be :utf-8 or :autodetect
+reading emacs-style -*- coding: utf-8 -*- specifications,
+and falling back to utf-8 or latin1 if nothing is specified.")
+
+(defparameter *utf-8-external-format*
+  #+(and asdf-unicode (not clisp)) :utf-8
+  #+(and asdf-unicode clisp) charset:utf-8
+  #-asdf-unicode :default
+  "Default :external-format argument to pass to CL:OPEN and also
+CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file.
+On modern implementations, this will decode UTF-8 code points as CL charac=
ters.
+On legacy implementations, it may fall back on some 8-bit encoding,
+with non-ASCII code points being read as several CL characters;
+hopefully, if done consistently, that won't affect program behavior too mu=
ch.")
+
+(defun* always-default-encoding (pathname)
+  (declare (ignore pathname))
+  *default-encoding*)
+
+(defvar *encoding-detection-hook* #'always-default-encoding
+  "Hook for an extension to define a function to automatically detect a fi=
le's encoding")
+
+(defun* detect-encoding (pathname)
+  (if (and pathname (not (directory-pathname-p pathname)) (probe-file* pat=
hname))
+      (funcall *encoding-detection-hook* pathname)
+      *default-encoding*))
+
+(defun* default-encoding-external-format (encoding)
+  (case encoding
+    (:default :default) ;; for backward-compatibility only. Explicit usage=
 discouraged.
+    (:utf-8 *utf-8-external-format*)
+    (otherwise
+     (cerror "Continue using :external-format :default" (compatfmt "~@<You=
r ASDF component is using encoding ~S but it isn't recognized. Your system =
should :defsystem-depends-on (:asdf-encodings).~:>") encoding)
+     :default)))
+
+(defvar *encoding-external-format-hook*
+  #'default-encoding-external-format
+  "Hook for an extension to define a mapping between non-default encodings
+and implementation-defined external-format's")
+
+(defun* encoding-external-format (encoding)
+  (funcall *encoding-external-format-hook* encoding))
+
+
+;;; Using temporary files
+(defun* default-temporary-directory ()
+  (or
+   (when (os-unix-p)
+     (or (getenv-pathname "TMPDIR" :ensure-directory t)
+         (parse-native-namestring "/tmp/")))
+   (when (os-windows-p)
+     (getenv-pathname "TEMP" :ensure-directory t))
+   (subpathname (user-homedir-pathname) "tmp/")))
+
+(defvar *temporary-directory* nil)
+
+(defun* temporary-directory ()
+  (or *temporary-directory* (default-temporary-directory)))
+
+(defun setup-temporary-directory ()
+  (setf *temporary-directory* (default-temporary-directory))
+  ;; basic lack fixed after gcl 2.7.0-61, but ending / required still on 2=
.7.0-64.1
+  #+(and gcl (not gcl2.6)) (setf system::*tmp-dir* *temporary-directory*))
+
+(defun* call-with-temporary-file
+    (thunk &key
+     prefix keep (direction :io)
+     (element-type *default-stream-element-type*)
+     (external-format :default))
+  #+gcl2.6 (declare (ignorable external-format))
+  (check-type direction (member :output :io))
+  (loop
+    :with prefix =3D (or prefix (format nil "~Atmp" (native-namestring (te=
mporary-directory))))
+    :for counter :from (random (ash 1 32))
+    :for pathname =3D (pathname (format nil "~A~36R" prefix counter)) :do
+     ;; TODO: on Unix, do something about umask
+     ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EX=
CL
+     ;; TODO: on Unix, use CFFI and mkstemp -- but asdf/driver is precisel=
y meant to not depend on CFFI or on anything! Grrrr.
+    (with-open-file (stream pathname
+                            :direction direction
+                            :element-type element-type
+                            #-gcl2.6 :external-format #-gcl2.6 external-fo=
rmat
+                            :if-exists nil :if-does-not-exist :create)
+      (when stream
+        (return
+          (if keep
+              (funcall thunk stream pathname)
+              (unwind-protect
+                   (funcall thunk stream pathname)
+                (ignore-errors (delete-file pathname)))))))))
+
+(defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp)
+                                (pathname (gensym "PATHNAME") pathnamep)
+                                prefix keep direction element-type externa=
l-format)
+                               &body body)
+  "Evaluate BODY where the symbols specified by keyword arguments
+STREAM and PATHNAME are bound corresponding to a newly created temporary f=
ile
+ready for I/O. Unless KEEP is specified, delete the file afterwards."
+  (check-type stream symbol)
+  (check-type pathname symbol)
+  `(flet ((think (,stream ,pathname)
+            ,@(unless pathnamep `((declare (ignore ,pathname))))
+            ,@(unless streamp `((when ,stream (close ,stream))))
+            , at body))
+     #-gcl (declare (dynamic-extent #'think))
+     (call-with-temporary-file
+      #'think
+      ,@(when direction `(:direction ,direction))
+      ,@(when prefix `(:prefix ,prefix))
+      ,@(when keep `(:keep ,keep))
+      ,@(when element-type `(:element-type ,element-type))
+      ,@(when external-format `(:external-format external-format)))))
+
+;;; Temporary pathnames
+(defun* add-pathname-suffix (pathname suffix)
+  (make-pathname :name (strcat (pathname-name pathname) suffix)
+                 :defaults pathname))
+
+(defun* tmpize-pathname (x)
+  (add-pathname-suffix x "-ASDF-TMP"))
+
+(defun* call-with-staging-pathname (pathname fun)
+  "Calls fun with a staging pathname, and atomically
+renames the staging pathname to the pathname in the end.
+Note: this protects only against failure of the program,
+not against concurrent attempts.
+For the latter case, we ought pick random suffix and atomically open it."
+  (let* ((pathname (pathname pathname))
+         (staging (tmpize-pathname pathname)))
+    (unwind-protect
+         (multiple-value-prog1
+             (funcall fun staging)
+           (rename-file-overwriting-target staging pathname))
+      (delete-file-if-exists staging))))
+
+(defmacro with-staging-pathname ((pathname-var &optional (pathname-value p=
athname-var)) &body body)
+  `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,=
@body)))
+
+
+;;;; ---------------------------------------------------------------------=
----
+;;;; Starting, Stopping, Dumping a Lisp image
+
+(asdf/package:define-package :asdf/image
+  (:recycle :asdf/image :xcvb-driver)
+  (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/pathname :asdf=
/stream :asdf/os)
+  (:export
+   #:*image-dumped-p* #:raw-command-line-arguments #:*command-line-argumen=
ts*
+   #:command-line-arguments #:raw-command-line-arguments #:setup-command-l=
ine-arguments
+   #:*lisp-interaction*
+   #:fatal-conditions #:fatal-condition-p #:handle-fatal-condition
+   #:call-with-fatal-condition-handler #:with-fatal-condition-handler
+   #:*image-restore-hook* #:*image-prelude* #:*image-entry-point*
+   #:*image-postlude* #:*image-dump-hook*
+   #:quit #:die #:raw-print-backtrace #:print-backtrace #:print-condition-=
backtrace
+   #:shell-boolean-exit
+   #:register-image-restore-hook #:register-image-dump-hook
+   #:call-image-restore-hook #:call-image-dump-hook
+   #:initialize-asdf-utilities #:restore-image #:dump-image #:create-image
+))
+(in-package :asdf/image)
+
+(defvar *lisp-interaction* t
+  "Is this an interactive Lisp environment, or is it batch processing?")
+
+(defvar *command-line-arguments* nil
+  "Command-line arguments")
+
+(defvar *image-dumped-p* nil ; may matter as to how to get to command-line=
-arguments
+  "Is this a dumped image? As a standalone executable?")
+
+(defvar *image-restore-hook* nil
+  "Functions to call (in reverse order) when the image is restored")
+
+(defvar *image-prelude* nil
+  "a form to evaluate, or string containing forms to read and evaluate
+when the image is restarted, but before the entry point is called.")
+
+(defvar *image-entry-point* nil
+  "a function with which to restart the dumped image when execution is res=
tored from it.")
+
+(defvar *image-postlude* nil
+  "a form to evaluate, or string containing forms to read and evaluate
+before the image dump hooks are called and before the image is dumped.")
+
+(defvar *image-dump-hook* nil
+  "Functions to call (in order) when before an image is dumped")
+
+(defvar *fatal-conditions* '(error)
+  "conditions that cause the Lisp image to enter the debugger if interacti=
ve,
+or to die if not interactive")
+
+
+;;; Exiting properly or im-
+(defun* quit (&optional (code 0) (finish-output t))
+  "Quits from the Lisp world, with the given exit status if provided.
+This is designed to abstract away the implementation specific quit forms."
+  (when finish-output ;; essential, for ClozureCL, and for standard compli=
ance.
+    (finish-outputs))
+  #+(or abcl xcl) (ext:quit :status code)
+  #+allegro (excl:exit code :quiet t)
+  #+clisp (ext:quit code)
+  #+clozure (ccl:quit code)
+  #+cormanlisp (win32:exitprocess code)
+  #+(or cmu scl) (unix:unix-exit code)
+  #+ecl (si:quit code)
+  #+gcl (lisp:quit code)
+  #+genera (error "You probably don't want to Halt the Machine. (code: ~S)=
" code)
+  #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignor=
e-errors-p t)
+  #+mcl (ccl:quit) ;; or should we use FFI to call libc's exit(3) ?
+  #+mkcl (mk-ext:quit :exit-code code)
+  #+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil))
+		 (quit (find-symbol* :quit :sb-ext nil)))
+	     (cond
+	       (exit `(,exit :code code :abort (not finish-output)))
+	       (quit `(,quit :unix-status code :recklessly-p (not finish-output))=
)))
+  #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl s=
bcl scl xcl)
+  (error "~S called with exit code ~S but there's no quitting on this impl=
ementation" 'quit code))
+
+(defun* die (code format &rest arguments)
+  "Die in error with some error message"
+  (with-safe-io-syntax ()
+    (ignore-errors
+     (fresh-line *stderr*)
+     (apply #'format *stderr* format arguments)
+     (format! *stderr* "~&")))
+  (quit code))
+
+(defun* raw-print-backtrace (&key (stream *debug-io*) count)
+  "Print a backtrace, directly accessing the implementation"
+  (declare (ignorable stream count))
+  #+abcl
+  (let ((*debug-io* stream)) (top-level::backtrace-command count))
+  #+allegro
+  (let ((*terminal-io* stream)
+        (*standard-output* stream)
+        (tpl:*zoom-print-circle* *print-circle*)
+        (tpl:*zoom-print-level* *print-level*)
+        (tpl:*zoom-print-length* *print-length*))
+    (tpl:do-command "zoom"
+      :from-read-eval-print-loop nil
+      :count t
+      :all t))
+  #+clisp
+  (system::print-backtrace :out stream :limit count)
+  #+(or clozure mcl)
+  (let ((*debug-io* stream))
+    (ccl:print-call-history :count count :start-frame-number 1)
+    (finish-output stream))
+  #+(or cmucl scl)
+  (let ((debug:*debug-print-level* *print-level*)
+        (debug:*debug-print-length* *print-length*))
+    (debug:backtrace most-positive-fixnum stream))
+  #+ecl
+  (si::tpl-backtrace)
+  #+lispworks
+  (let ((dbg::*debugger-stack*
+          (dbg::grab-stack nil :how-many (or count most-positive-fixnum)))
+        (*debug-io* stream)
+        (dbg:*debug-print-level* *print-level*)
+        (dbg:*debug-print-length* *print-length*))
+    (dbg:bug-backtrace nil))
+  #+sbcl
+  (sb-debug:backtrace
+   #.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream '(or count mo=
st-positive-fixnum))
+   stream))
+
+(defun* print-backtrace (&rest keys &key stream count)
+  (declare (ignore stream count))
+  (with-safe-io-syntax (:package :cl)
+    (let ((*print-readably* nil)
+          (*print-circle* t)
+          (*print-miser-width* 75)
+          (*print-length* nil)
+          (*print-level* nil)
+          (*print-pretty* t))
+      (ignore-errors (apply 'raw-print-backtrace keys)))))
+
+(defun* print-condition-backtrace (condition &key (stream *stderr*) count)
+  ;; We print the condition *after* the backtrace,
+  ;; for the sake of who sees the backtrace at a terminal.
+  ;; It is up to the caller to print the condition *before*, with some con=
text.
+  (print-backtrace :stream stream :count count)
+  (when condition
+    (safe-format! stream "~&Above backtrace due to this condition:~%~A~&"
+                  condition)))
+
+(defun fatal-condition-p (condition)
+  (match-any-condition-p condition *fatal-conditions*))
+
+(defun* handle-fatal-condition (condition)
+  "Depending on whether *LISP-INTERACTION* is set, enter debugger or die"
   (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))))
-
-;;; perform is required to check output-files to find out where to put
-;;; its answers, in case it has been overridden for site policy
-(defmethod perform ((operation compile-op) (c cl-source-file))
-  (let ((source-file (component-pathname c))
-        ;; on some implementations, there are more than one output-file,
-        ;; but the first one should always be the primary fasl that gets l=
oaded.
-        (output-file (first (output-files operation c)))
-        (*compile-file-warnings-behaviour* (operation-on-warnings operatio=
n))
-        (*compile-file-failure-behaviour* (operation-on-failure operation)=
))
-    (multiple-value-bind (output warnings-p failure-p)
-        (call-with-around-compile-hook
-         c #'(lambda (&rest flags)
-               (apply *compile-op-compile-file-function* source-file
-                      :output-file output-file
-                      :external-format (component-external-format c)
-                      (append flags (compile-op-flags operation)))))
-      (unless output
-        (error 'compile-error :component c :operation operation))
-      (when failure-p
-        (case (operation-on-failure operation)
-          (:warn (warn
-                  (compatfmt "~@<COMPILE-FILE failed while performing ~A o=
n ~A.~@:>")
-                  operation c))
-          (:error (error 'compile-failed :component c :operation operation=
))
-          (:ignore nil)))
-      (when warnings-p
-        (case (operation-on-warnings operation)
-          (:warn (warn
-                  (compatfmt "~@<COMPILE-FILE warned while performing ~A o=
n ~A.~@:>")
-                  operation c))
-          (:error (error 'compile-warned :component c :operation operation=
))
-          (:ignore nil))))))
-
-(defmethod output-files ((operation compile-op) (c cl-source-file))
-  (declare (ignorable operation))
-  (let* ((p (lispize-pathname (component-pathname c)))
-         (f (compile-file-pathname ;; fasl
-             p #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl))
-         #+mkcl (o (compile-file-pathname p :fasl-p nil))) ;; object file
-    #+ecl (if (use-ecl-byte-compiler-p)
-              (list f)
-              (list (compile-file-pathname p :type :object) f))
-    #+mkcl (list o f)
-    #-(or ecl mkcl) (list f)))
-
-(defmethod perform ((operation compile-op) (c static-file))
-  (declare (ignorable operation c))
-  nil)
-
-(defmethod output-files ((operation compile-op) (c static-file))
-  (declare (ignorable operation c))
-  nil)
-
-(defmethod input-files ((operation compile-op) (c static-file))
-  (declare (ignorable operation c))
-  nil)
-
-(defmethod operation-description ((operation compile-op) component)
-  (declare (ignorable operation))
-  (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") component))
-
-(defmethod operation-description ((operation compile-op) (component module=
))
-  (declare (ignorable operation))
-  (format nil (compatfmt "~@<compiled ~3i~_~A~@:>") component))
-
-
+    (*lisp-interaction*
+     (invoke-debugger condition))
+    (t
+     (safe-format! *stderr* "~&Fatal condition:~%~A~%" condition)
+     (print-condition-backtrace condition :stream *stderr*)
+     (die 99 "~A" condition))))
+
+(defun* call-with-fatal-condition-handler (thunk)
+  (handler-bind (((satisfies fatal-condition-p) #'handle-fatal-condition))
+    (funcall thunk)))
+
+(defmacro with-fatal-condition-handler ((&optional) &body body)
+  `(call-with-fatal-condition-handler #'(lambda () , at body)))
+
+(defun* shell-boolean-exit (x)
+  "Quit with a return code that is 0 iff argument X is true"
+  (quit (if x 0 1)))
+
+
+;;; Using image hooks
+
+(defun* register-image-restore-hook (hook &optional (call-now-p t))
+  (register-hook-function '*image-restore-hook* hook call-now-p))
+
+(defun* register-image-dump-hook (hook &optional (call-now-p nil))
+  (register-hook-function '*image-dump-hook* hook call-now-p))
+
+(defun* call-image-restore-hook ()
+  (call-functions (reverse *image-restore-hook*)))
+
+(defun* call-image-dump-hook ()
+  (call-functions *image-dump-hook*))
+
+
+;;; Proper command-line arguments
+
+(defun* raw-command-line-arguments ()
+  "Find what the actual command line for this process was."
+  #+abcl ext:*command-line-argument-list* ; Use 1.0.0 or later!
+  #+allegro (sys:command-line-arguments) ; default: :application t
+  #+clisp (coerce (ext:argv) 'list)
+  #+clozure (ccl::command-line-arguments)
+  #+(or cmu scl) extensions:*command-line-strings*
+  #+ecl (loop :for i :from 0 :below (si:argc) :collect (si:argv i))
+  #+gcl si:*command-args*
+  #+genera nil
+  #+lispworks sys:*line-arguments-list*
+  #+sbcl sb-ext:*posix-argv*
+  #+xcl system:*argv*
+  #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks sbcl scl x=
cl)
+  (error "raw-command-line-arguments not implemented yet"))
+
+(defun* command-line-arguments (&optional (arguments (raw-command-line-arg=
uments)))
+  "Extract user arguments from command-line invocation of current process.
+Assume the calling conventions of a generated script that uses --
+if we are not called from a directly executable image."
+  #+abcl arguments
+  #-abcl
+  (let* (#-(or sbcl allegro)
+	 (arguments
+	  (if (eq *image-dumped-p* :executable)
+	      arguments
+	      (member "--" arguments :test 'string-equal))))
+    (rest arguments)))
+
+(defun setup-command-line-arguments ()
+  (setf *command-line-arguments* (command-line-arguments)))
+
+(defun* restore-image (&key
+                       ((:lisp-interaction *lisp-interaction*) *lisp-inter=
action*)
+                       ((:restore-hook *image-restore-hook*) *image-restor=
e-hook*)
+                       ((:prelude *image-prelude*) *image-prelude*)
+                       ((:entry-point *image-entry-point*) *image-entry-po=
int*))
+  (with-fatal-condition-handler ()
+    (call-image-restore-hook)
+    (standard-eval-thunk *image-prelude*)
+    (let ((results (multiple-value-list
+                    (if *image-entry-point*
+                        (call-function *image-entry-point*)
+                        t))))
+      (if *lisp-interaction*
+          (apply 'values results)
+          (shell-boolean-exit (first results))))))
+
+
+;;; Dumping an image
+
+#-(or ecl mkcl)
+(defun* dump-image (filename &key output-name executable
+                             ((:postlude *image-postlude*) *image-postlude=
*)
+                             ((:dump-hook *image-dump-hook*) *image-dump-h=
ook*))
+  (declare (ignorable filename output-name executable))
+  (setf *image-dumped-p* (if executable :executable t))
+  (standard-eval-thunk *image-postlude*)
+  (call-image-dump-hook)
+  #-(or clisp clozure cmu lispworks sbcl scl)
+  (when executable
+    (error "Dumping an executable is not supported on this implementation!=
 Aborting."))
+  #+allegro
+  (progn
+    (sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure =
t) ; :new 5000000
+    (excl:dumplisp :name filename :suppress-allegro-cl-banner t))
+  #+clisp
+  (apply #'ext:saveinitmem filename
+   :quiet t
+   :start-package *package*
+   :keep-global-handlers nil
+   :executable (if executable 0 t) ;--- requires clisp 2.48 or later, stil=
l catches --clisp-x
+   (when executable
+     (list
+      ;; :parse-options nil ;--- requires a non-standard patch to clisp.
+      :norc t :script nil :init-function #'restore-image)))
+  #+clozure
+  (ccl:save-application filename :prepend-kernel t
+                        :toplevel-function (when executable #'restore-imag=
e))
+  #+(or cmu scl)
+  (progn
+   (ext:gc :full t)
+   (setf ext:*batch-mode* nil)
+   (setf ext::*gc-run-time* 0)
+   (apply 'ext:save-lisp filename #+cmu :executable #+cmu t
+          (when executable '(:init-function restore-image :process-command=
-line nil))))
+  #+gcl
+  (progn
+   (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t)
+   (si::save-system filename))
+  #+lispworks
+  (if executable
+      (lispworks:deliver 'restore-image filename 0 :interface nil)
+      (hcl:save-image filename :environment nil))
+  #+sbcl
+  (progn
+    ;;(sb-pcl::precompile-random-code-segments) ;--- it is ugly slow at co=
mpile-time (!) when the initial core is a big CLOS program. If you want it,=
 do it yourself
+   (setf sb-ext::*gc-run-time* 0)
+   (apply 'sb-ext:save-lisp-and-die filename
+    :executable t ;--- always include the runtime that goes with the core
+    (when executable (list :toplevel #'restore-image :save-runtime-options=
 t)))) ;--- only save runtime-options for standalone executables
+  #-(or allegro clisp clozure cmu gcl lispworks sbcl scl)
+  (die 98 "Can't dump ~S: asdf doesn't support image dumping with ~A.~%"
+       filename (nth-value 1 (implementation-type))))
+
+
+#+ecl
+(defun create-image (destination object-files
+                     &key kind output-name prologue-code epilogue-code =

+                       (prelude () preludep) (entry-point () entry-point-p=
) build-args)
+  ;; Is it meaningful to run these in the current environment?
+  ;; only if we also track the object files that constitute the "current" =
image,
+  ;; and otherwise simulate dump-image, including quitting at the end.
+  ;; (standard-eval-thunk *image-postlude*) (call-image-dump-hook)
+  (check-type kind (member :binary :dll :lib :static-library :program :obj=
ect :fasl :program))
+  (apply 'c::builder
+         kind (pathname destination)
+         :lisp-files object-files
+         :init-name (c::compute-init-name (or output-name destination) :ki=
nd kind)
+         :prologue-code prologue-code
+         :epilogue-code
+         `(progn
+            ,epilogue-code
+            ,@(when (eq kind :program)
+                `((setf *image-dumped-p* :executable)
+                  (restore-image ;; default behavior would be (si::top-lev=
el)
+                   ,@(when preludep `(:prelude ',prelude))
+                   ,@(when entry-point-p `(:entry-point ',entry-point))))))
+         build-args))
+
+
+;;; Some universal image restore hooks
+(map () 'register-image-restore-hook
+     '(setup-temporary-directory setup-stderr setup-command-line-arguments
+       #+abcl detect-os))
 ;;;; ---------------------------------------------------------------------=
----
-;;;; load-op
-
-(defclass basic-load-op (operation) ())
-
-(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
-       #-(or ecl mkcl)
-       (input-files o c)
-       #+(or ecl mkcl)
-       (loop :for i :in (input-files o c)
-	     :unless (string=3D (pathname-type i) "fas")
-	     :collect (compile-file-pathname (lispize-pathname i)))))
-
-(defmethod perform ((operation load-op) (c static-file))
-  (declare (ignorable operation c))
-  nil)
-
-(defmethod operation-done-p ((operation load-op) (c static-file))
-  (declare (ignorable operation c))
-  t)
-
-(defmethod output-files ((operation operation) (c component))
-  (declare (ignorable operation c))
-  nil)
-
-(defmethod component-depends-on ((operation load-op) (c component))
-  (declare (ignorable operation))
-  (cons (list 'compile-op (component-name c))
-        (call-next-method)))
-
-(defmethod operation-description ((operation load-op) component)
-  (declare (ignorable operation))
-  (format nil (compatfmt "~@<loading ~3i~_~A~@:>")
-          component))
-
-(defmethod operation-description ((operation load-op) (component cl-source=
-file))
-  (declare (ignorable operation))
-  (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>")
-          component))
-
-(defmethod operation-description ((operation load-op) (component module))
-  (declare (ignorable operation))
-  (format nil (compatfmt "~@<loaded ~3i~_~A~@:>")
-          component))
+;;;; run-program initially from xcvb-driver.
+
+(asdf/package:define-package :asdf/run-program
+  (:recycle :asdf/run-program :xcvb-driver)
+  (:use :asdf/common-lisp :asdf/utility :asdf/pathname :asdf/os :asdf/file=
system :asdf/stream)
+  (:export
+   ;;; Escaping the command invocation madness
+   #:easy-sh-character-p #:escape-sh-token #:escape-sh-command
+   #:escape-windows-token #:escape-windows-command
+   #:escape-token #:escape-command
+
+   ;;; run-program
+   #:slurp-input-stream
+   #:run-program
+   #:subprocess-error
+   #:subprocess-error-code #:subprocess-error-command #:subprocess-error-p=
rocess
+   ))
+(in-package :asdf/run-program)
+
+;;;; ----- Escaping strings for the shell -----
+
+(defun* requires-escaping-p (token &key good-chars bad-chars)
+  "Does this token require escaping, given the specification of
+either good chars that don't need escaping or bad chars that do need escap=
ing,
+as either a recognizing function or a sequence of characters."
+  (some
+   (cond
+     ((and good-chars bad-chars)
+      (error "only one of good-chars and bad-chars can be provided"))
+     ((functionp good-chars)
+      (complement good-chars))
+     ((functionp bad-chars)
+      bad-chars)
+     ((and good-chars (typep good-chars 'sequence))
+      #'(lambda (c) (not (find c good-chars))))
+     ((and bad-chars (typep bad-chars 'sequence))
+      #'(lambda (c) (find c bad-chars)))
+     (t (error "requires-escaping-p: no good-char criterion")))
+   token))
+
+(defun* escape-token (token &key stream quote good-chars bad-chars escaper)
+  "Call the ESCAPER function on TOKEN string if it needs escaping as per
+REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOKEN,
+using STREAM as output (or returning result as a string if NIL)"
+  (if (requires-escaping-p token :good-chars good-chars :bad-chars bad-cha=
rs)
+      (with-output (stream)
+        (apply escaper token stream (when quote `(:quote ,quote))))
+      (output-string token stream)))
+
+(defun* escape-windows-token-within-double-quotes (x &optional s)
+  "Escape a string token X within double-quotes
+for use within a MS Windows command-line, outputing to S."
+  (labels ((issue (c) (princ c s))
+           (issue-backslash (n) (loop :repeat n :do (issue #\\))))
+    (loop
+      :initially (issue #\") :finally (issue #\")
+      :with l =3D (length x) :with i =3D 0
+      :for i+1 =3D (1+ i) :while (< i l) :do
+      (case (char x i)
+        ((#\") (issue-backslash 1) (issue #\") (setf i i+1))
+        ((#\\)
+         (let* ((j (and (< i+1 l) (position-if-not
+                                   #'(lambda (c) (eql c #\\)) x :start i+1=
)))
+                (n (- (or j l) i)))
+           (cond
+             ((null j)
+              (issue-backslash (* 2 n)) (setf i l))
+             ((and (< j l) (eql (char x j) #\"))
+              (issue-backslash (1+ (* 2 n))) (issue #\") (setf i (1+ j)))
+             (t
+              (issue-backslash n) (setf i j)))))
+        (otherwise
+         (issue (char x i)) (setf i i+1))))))
+
+(defun* escape-windows-token (token &optional s)
+  "Escape a string TOKEN within double-quotes if needed
+for use within a MS Windows command-line, outputing to S."
+  (escape-token token :stream s :bad-chars #(#\space #\tab #\") :quote nil
+                :escaper 'escape-windows-token-within-double-quotes))
+
+(defun* escape-sh-token-within-double-quotes (x s &key (quote t))
+  "Escape a string TOKEN within double-quotes
+for use within a POSIX Bourne shell, outputing to S;
+omit the outer double-quotes if key argument :QUOTE is NIL"
+  (when quote (princ #\" s))
+  (loop :for c :across x :do
+    (when (find c "$`\\\"") (princ #\\ s))
+    (princ c s))
+  (when quote (princ #\" s)))
+
+(defun* easy-sh-character-p (x)
+  (or (alphanumericp x) (find x "+-_.,%@:/")))
+
+(defun* escape-sh-token (token &optional s)
+  "Escape a string TOKEN within double-quotes if needed
+for use within a POSIX Bourne shell, outputing to S."
+  (escape-token token :stream s :quote #\" :good-chars
+                #'easy-sh-character-p
+                :escaper 'escape-sh-token-within-double-quotes))
+
+(defun* escape-shell-token (token &optional s)
+  (cond
+    ((os-unix-p) (escape-sh-token token s))
+    ((os-windows-p) (escape-windows-token token s))))
+
+(defun* escape-command (command &optional s
+                       (escaper 'escape-shell-token))
+  "Given a COMMAND as a list of tokens, return a string of the
+spaced, escaped tokens, using ESCAPER to escape."
+  (etypecase command
+    (string (output-string command s))
+    (list (with-output (s)
+            (loop :for first =3D t :then nil :for token :in command :do
+              (unless first (princ #\space s))
+              (funcall escaper token s))))))
+
+(defun* escape-windows-command (command &optional s)
+  "Escape a list of command-line arguments into a string suitable for pars=
ing
+by CommandLineToArgv in MS Windows"
+    ;; http://msdn.microsoft.com/en-us/library/bb776391(v=3Dvs.85).aspx
+    ;; http://msdn.microsoft.com/en-us/library/17w5ykft(v=3Dvs.85).aspx
+  (escape-command command s 'escape-windows-token))
+
+(defun* escape-sh-command (command &optional s)
+  "Escape a list of command-line arguments into a string suitable for pars=
ing
+by /bin/sh in POSIX"
+  (escape-command command s 'escape-sh-token))
+
+(defun* escape-shell-command (command &optional stream)
+  "Escape a command for the current operating system's shell"
+  (escape-command command stream 'escape-shell-token))
+
+
+;;;; Slurping a stream, typically the output of another program
+
+(defgeneric* slurp-input-stream (processor input-stream &key &allow-other-=
keys))
+
+#-(or gcl2.6 genera)
+(defmethod slurp-input-stream ((function function) input-stream &key &allo=
w-other-keys)
+  (funcall function input-stream))
+
+(defmethod slurp-input-stream ((list cons) input-stream &key &allow-other-=
keys)
+  (apply (first list) (cons input-stream (rest list))))
+
+#-(or gcl2.6 genera)
+(defmethod slurp-input-stream ((output-stream stream) input-stream
+                               &key linewise prefix (element-type 'charact=
er) buffer-size &allow-other-keys)
+  (copy-stream-to-stream
+   input-stream output-stream
+   :linewise linewise :prefix prefix :element-type element-type :buffer-si=
ze buffer-size))
+
+(defmethod slurp-input-stream ((x (eql 'string)) stream &key &allow-other-=
keys)
+  (declare (ignorable x))
+  (slurp-stream-string stream))
+
+(defmethod slurp-input-stream ((x (eql :string)) stream &key &allow-other-=
keys)
+  (declare (ignorable x))
+  (slurp-stream-string stream))
+
+(defmethod slurp-input-stream ((x (eql :lines)) stream &key count &allow-o=
ther-keys)
+  (declare (ignorable x))
+  (slurp-stream-lines stream :count count))
+
+(defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0) &allow-o=
ther-keys)
+  (declare (ignorable x))
+  (slurp-stream-line stream :at at))
+
+(defmethod slurp-input-stream ((x (eql :forms)) stream &key count &allow-o=
ther-keys)
+  (declare (ignorable x))
+  (slurp-stream-forms stream :count count))
+
+(defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0) &allow-o=
ther-keys)
+  (declare (ignorable x))
+  (slurp-stream-form stream :at at))
+
+(defmethod slurp-input-stream (x stream
+                               &key linewise prefix (element-type 'charact=
er) buffer-size
+                               &allow-other-keys)
+  (declare (ignorable stream linewise prefix element-type buffer-size))
+  (cond
+    #+(or gcl2.6 genera)
+    ((functionp x) (funcall x stream))
+    #+(or gcl2.6 genera)
+    ((output-stream-p x)
+     (copy-stream-to-stream
+      input-stream output-stream
+      :linewise linewise :prefix prefix :element-type element-type :buffer=
-size buffer-size))
+    (t
+     (error "Invalid ~S destination ~S" 'slurp-input-stream x))))
+
+
+;;;; ----- Running an external program -----
+;;; Simple variant of run-program with no input, and capturing output
+;;; On some implementations, may output to a temporary file...
+
+(define-condition subprocess-error (error)
+  ((code :initform nil :initarg :code :reader subprocess-error-code)
+   (command :initform nil :initarg :command :reader subprocess-error-comma=
nd)
+   (process :initform nil :initarg :process :reader subprocess-error-proce=
ss))
+  (:report (lambda (condition stream)
+             (format stream "Subprocess~@[ ~S~]~@[ run with command ~S~] e=
xited with error~@[ code ~D~]"
+                     (subprocess-error-process condition)
+                     (subprocess-error-command condition)
+                     (subprocess-error-code condition)))))
+
+(defun* run-program (command
+                     &key output ignore-error-status force-shell
+                     (element-type *default-stream-element-type*)
+                     (external-format :default)
+                     &allow-other-keys)
+  "Run program specified by COMMAND,
+either a list of strings specifying a program and list of arguments,
+or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Window=
s);
+have its output processed by the OUTPUT processor function
+as per SLURP-INPUT-STREAM,
+or merely output to the inherited standard output if it's NIL.
+Always call a shell (rather than directly execute the command)
+if FORCE-SHELL is specified.
+Issue an error if the process wasn't successful unless IGNORE-ERROR-STATUS
+is specified.
+Return the exit status code of the process that was called.
+Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT p=
rocessor."
+  (declare (ignorable ignore-error-status element-type external-format))
+  #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sb=
cl scl xcl)
+  (error "RUN-PROGRAM not implemented for this Lisp")
+  (labels (#+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbc=
l scl)
+           (run-program (command &key pipe interactive)
+             "runs the specified command (a list of program and arguments).
+              If using a pipe, returns two values: process and stream
+              If not using a pipe, returns one values: the process result;
+              also, inherits the output stream."
+             ;; NB: these implementations have unix vs windows set at comp=
ile-time.
+	     (assert (not (and pipe interactive)))
+             (let* ((wait (not pipe))
+                    #-(and clisp os-windows)
+                    (command
+                     (etypecase command
+                       #+os-unix (string `("/bin/sh" "-c" ,command))
+                       #+os-unix (list command)
+                       #+os-windows
+                       (string
+                        ;; NB: We do NOT add cmd /c here. You might want t=
o.
+                        #+allegro command
+			;; On ClozureCL for Windows, we assume you are using
+			;; r15398 or later in 1.9 or later,
+			;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858
+			#+clozure (cons "cmd" (strcat "/c " command))
+                        ;; NB: On other Windows implementations, this is u=
tterly bogus
+                        ;; except in the most trivial cases where no quoti=
ng is needed.
+                        ;; Use at your own risk.
+                        #-(or allegro clozure) (list "cmd" "/c" command))
+                       #+os-windows
+                       (list
+                        #+(or allegro clozure) (escape-windows-command com=
mand)
+                        #-(or allegro clozure) command)))
+                    #+(and clozure os-windows) (command (list command))
+                    (process*
+                     (multiple-value-list
+                      #+allegro
+                      (excl:run-shell-command
+                       #+os-unix (coerce (cons (first command) command) 'v=
ector)
+                       #+os-windows command
+                       :input interactive :output (or (and pipe :stream) i=
nteractive) :wait wait
+                       #+os-windows :show-window #+os-windows (and pipe :h=
ide))
+                      #+clisp
+                      (flet ((run (f &rest args)
+                               (apply f `(, at args :input ,(when interactive=
 :terminal) :wait ,wait :output
+                                          ,(if pipe :stream :terminal)))))
+                        (etypecase command
+                          #+os-windows (run 'ext:run-shell-command command)
+                          (list (run 'ext:run-program (car command)
+                                     :arguments (cdr command)))))
+                      #+lispworks
+                      (system:run-shell-command
+                       (cons "/usr/bin/env" command) ; lispworks wants a f=
ull path.
+                       :input interactive :output (or (and pipe :stream) i=
nteractive)
+                       :wait wait :save-exit-status (and pipe t))
+                      #+(or clozure cmu ecl sbcl scl)
+                      (#+(or cmu ecl scl) ext:run-program
+                       #+clozure ccl:run-program
+                       #+sbcl sb-ext:run-program
+                       (car command) (cdr command)
+                       :input interactive :wait wait
+                       :output (if pipe :stream t)
+                       . #.(append
+                            #+(or clozure cmu ecl sbcl scl) '(:error t)
+                            ;; note: :external-format requires a recent SB=
CL
+                            #+sbcl '(:search t :external-format external-f=
ormat)))))
+                    (process
+                     #+(or allegro lispworks) (if pipe (third process*) (f=
irst process*))
+                     #+ecl (third process*)
+                     #-(or allegro lispworks ecl) (first process*))
+                    (stream
+                     (when pipe
+                       #+(or allegro lispworks ecl) (first process*)
+                       #+clisp (first process*)
+                       #+clozure (ccl::external-process-output process)
+                       #+(or cmu scl) (ext:process-output process)
+                       #+sbcl (sb-ext:process-output process))))
+               (values process stream)))
+           #+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbc=
l scl)
+           (process-result (process pipe)
+             (declare (ignorable pipe))
+             ;; 1- wait
+             #+(and clozure os-unix) (ccl::external-process-wait process)
+             #+(or cmu scl) (ext:process-wait process)
+             #+(and ecl os-unix) (ext:external-process-wait process)
+             #+sbcl (sb-ext:process-wait process)
+             ;; 2- extract result
+             #+allegro (if pipe (sys:reap-os-subprocess :pid process :wait=
 t) process)
+             #+clisp process
+             #+clozure (nth-value 1 (ccl:external-process-status process))
+             #+(or cmu scl) (ext:process-exit-code process)
+             #+ecl (nth-value 1 (ext:external-process-status process))
+             #+lispworks (if pipe (system:pid-exit-status process :wait t)=
 process)
+             #+sbcl (sb-ext:process-exit-code process))
+           (check-result (exit-code process)
+             #+clisp
+             (setf exit-code
+                   (typecase exit-code (integer exit-code) (null 0) (t -1)=
))
+             (unless (or ignore-error-status
+                         (equal exit-code 0))
+               (error 'subprocess-error :command command :code exit-code :=
process process))
+	     exit-code)
+           (use-run-program ()
+             #-(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl=
 xcl)
+             (let* ((interactive (eq output :interactive))
+		    (pipe (and output (not interactive))))
+               (multiple-value-bind (process stream)
+                   (run-program command :pipe pipe :interactive interactiv=
e)
+                 (if (and output (not interactive))
+                     (unwind-protect
+                          (slurp-input-stream output stream)
+                       (when stream (close stream))
+                       (check-result (process-result process pipe) process=
))
+                     (unwind-protect
+                          (check-result
+                           #+(or allegro lispworks) ; when not capturing, =
returns the exit code!
+                           process
+                           #-(or allegro lispworks) (process-result proces=
s pipe)
+                           process))))))
+           (system-command (command)
+             (etypecase command
+               (string (if (os-windows-p) (format nil "cmd /c ~A" command)=
 command))
+               (list (escape-shell-command
+                      (if (os-unix-p) (cons "exec" command) command)))))
+           (redirected-system-command (command out)
+             (format nil (if (os-unix-p) "exec > ~*~A ; ~2:*~A" "~A > ~A")
+                     (system-command command) (native-namestring out)))
+           (system (command &key interactive)
+             (declare (ignorable interactive))
+             #+(or abcl xcl) (ext:run-shell-command command)
+             #+allegro
+             (excl:run-shell-command command :input interactive :output in=
teractive :wait t)
+             #+(or clisp clozure cmu (and lispworks os-unix) sbcl scl)
+             (process-result (run-program command :pipe nil :interactive i=
nteractive) nil)
+             #+ecl (ext:system command)
+             #+cormanlisp (win32:system command)
+             #+gcl (lisp:system command)
+             #+(and lispworks os-windows)
+             (system:call-system-showing-output
+              command :show-cmd interactive :prefix "" :output-stream nil)
+             #+mcl (ccl::with-cstrs ((%command command)) (_system %command=
))
+             #+mkcl (nth-value 2
+                               (mkcl:run-program #+windows command #+windo=
ws ()
+                                                 #-windows "/bin/sh" (list=
 "-c" command)
+                                                 :input nil :output nil)))
+           (call-system (command-string &key interactive)
+             (check-result (system command-string :interactive interactive=
) nil))
+           (use-system ()
+	     (let ((interactive (eq output :interactive)))
+	       (if (and output (not interactive))
+		   (with-temporary-file (:pathname tmp :direction :output)
+		     (call-system (redirected-system-command command tmp))
+		     (with-open-file (stream tmp
+					     :direction :input
+					     :if-does-not-exist :error
+					     :element-type element-type
+                                             #-gcl2.6 :external-format #-g=
cl2.6 external-format)
+		       (slurp-input-stream output stream)))
+		   (call-system (system-command command) :interactive interactive)))))
+    (if (and (not force-shell)
+             #+(or clisp ecl) ignore-error-status
+             #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl=
 xcl) nil)
+        (use-run-program)
+        (use-system))))
 =

 ;;;; ---------------------------------------------------------------------=
----
-;;;; load-source-op
-
-(defclass load-source-op (basic-load-op) ())
-
-(defmethod perform ((o load-source-op) (c cl-source-file))
-  (declare (ignorable o))
-  (let ((source (component-pathname c)))
-    (setf (component-property c 'last-loaded-as-source)
-          (and (call-with-around-compile-hook
-                c #'(lambda () (load source :external-format (component-ex=
ternal-format c))))
-               (get-universal-time)))))
-
-(defmethod perform ((operation load-source-op) (c static-file))
-  (declare (ignorable operation c))
-  nil)
-
-(defmethod output-files ((operation load-source-op) (c component))
-  (declare (ignorable operation c))
-  nil)
-
-;;; FIXME: We simply copy load-op's dependencies.  This is Just Not Right.
-(defmethod component-depends-on ((o load-source-op) (c component))
-  (declare (ignorable o))
-  (loop :with what-would-load-op-do =3D (component-depends-on 'load-op c)
-    :for (op . co) :in what-would-load-op-do
-    :when (eq op 'load-op) :collect (cons 'load-source-op co)))
-
-(defmethod operation-done-p ((o load-source-op) (c source-file))
-  (declare (ignorable o))
-  (if (or (not (component-property c 'last-loaded-as-source))
-          (> (safe-file-write-date (component-pathname c))
-             (component-property c 'last-loaded-as-source)))
-      nil t))
-
-(defmethod operation-description ((operation load-source-op) component)
-  (declare (ignorable operation))
-  (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>")
-          component))
-
-(defmethod operation-description ((operation load-source-op) (component mo=
dule))
-  (declare (ignorable operation))
-  (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") component))
-
-
-;;;; ---------------------------------------------------------------------=
----
-;;;; test-op
-
-(defclass test-op (operation) ())
-
-(defmethod perform ((operation test-op) (c component))
-  (declare (ignorable operation c))
-  nil)
-
-(defmethod operation-done-p ((operation test-op) (c system))
-  "Testing a system is _never_ done."
-  (declare (ignorable operation c))
-  nil)
-
-(defmethod component-depends-on :around ((o test-op) (c system))
-  (declare (ignorable o))
-  (cons `(load-op ,(component-name c)) (call-next-method)))
-
-
-;;;; ---------------------------------------------------------------------=
----
-;;;; Invoking Operations
-
-(defgeneric* operate (operation-class system &key &allow-other-keys))
-(defgeneric* perform-plan (plan &key))
-
-;;;; Separating this into a different function makes it more forward-compa=
tible
-(defun* cleanup-upgraded-asdf (old-version)
-  (let ((new-version (asdf-version)))
-    (unless (equal old-version new-version)
+;;;; Support to build (compile and load) Lisp files
+
+(asdf/package:define-package :asdf/lisp-build
+  (:recycle :asdf/interface :asdf :asdf/lisp-build)
+  (:use :asdf/common-lisp :asdf/package :asdf/utility
+   :asdf/os :asdf/pathname :asdf/filesystem :asdf/stream :asdf/image)
+  (:export
+   ;; Variables
+   #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour*
+   #:*output-translation-function*
+   #:*optimization-settings* #:*previous-optimization-settings*
+   #:compile-condition #:compile-file-error #:compile-warned-error #:compi=
le-failed-error
+   #:compile-warned-warning #:compile-failed-warning
+   #:check-lisp-compile-results #:check-lisp-compile-warnings
+   #:*uninteresting-compiler-conditions* #:*uninteresting-loader-condition=
s*
+   ;; Functions & Macros
+   #:get-optimization-settings #:proclaim-optimization-settings
+   #:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditi=
ons
+   #:call-with-muffled-loader-conditions #:with-muffled-loader-conditions
+   #:reify-simple-sexp #:unreify-simple-sexp
+   #:reify-deferred-warnings #:reify-undefined-warning #:unreify-deferred-=
warnings
+   #:reset-deferred-warnings #:save-deferred-warnings #:check-deferred-war=
nings
+   #:with-saved-deferred-warnings #:warnings-file-p #:warnings-file-type #=
:*warnings-file-type*
+   #:current-lisp-file-pathname #:load-pathname
+   #:lispize-pathname #:compile-file-type #:call-around-hook
+   #:compile-file* #:compile-file-pathname*
+   #:load* #:load-from-string #:combine-fasls)
+  (:intern #:defaults #:failure-p #:warnings-p #:s #:y #:body))
+(in-package :asdf/lisp-build)
+
+(defvar *compile-file-warnings-behaviour*
+  (or #+clisp :ignore :warn)
+  "How should ASDF react if it encounters a warning when compiling a file?
+Valid values are :error, :warn, and :ignore.")
+
+(defvar *compile-file-failure-behaviour*
+  (or #+(or mkcl sbcl) :error #+clisp :ignore :warn)
+  "How should ASDF react if it encounters a failure (per the ANSI spec of =
COMPILE-FILE)
+when compiling a file, which includes any non-style-warning warning.
+Valid values are :error, :warn, and :ignore.
+Note that ASDF ALWAYS raises an error if it fails to create an output file=
 when compiling.")
+
+
+;;; Optimization settings
+
+(defvar *optimization-settings* nil)
+(defvar *previous-optimization-settings* nil)
+(defun* get-optimization-settings ()
+  "Get current compiler optimization settings, ready to PROCLAIM again"
+  (let ((settings '(speed space safety debug compilation-speed #+(or cmu s=
cl) c::brevity)))
+    #-(or clisp clozure cmu ecl sbcl scl)
+    (warn "xcvb-driver::get-optimization-settings does not support your im=
plementation. Please help me fix that.")
+    #.`(loop :for x :in settings
+         ,@(or #+clozure '(:for v :in '(ccl::*nx-speed* ccl::*nx-space* cc=
l::*nx-safety* ccl::*nx-debug* ccl::*nx-cspeed*))
+               #+ecl '(:for v :in '(c::*speed* c::*space* c::*safety* c::*=
debug*))
+               #+(or cmu scl) '(:for f :in '(c::cookie-speed c::cookie-spa=
ce c::cookie-safety c::cookie-debug c::cookie-cspeed c::cookie-brevity)))
+         :for y =3D (or #+clisp (gethash x system::*optimize*)
+                      #+(or clozure ecl) (symbol-value v)
+                      #+(or cmu scl) (funcall f c::*default-cookie*)
+                      #+sbcl (cdr (assoc x sb-c::*policy*)))
+         :when y :collect (list x y))))
+(defun* proclaim-optimization-settings ()
+  "Proclaim the optimization settings in *OPTIMIZATION-SETTINGS*"
+  (proclaim `(optimize ,@*optimization-settings*))
+  (let ((settings (get-optimization-settings)))
+    (unless (equal *previous-optimization-settings* settings)
+      (setf *previous-optimization-settings* settings))))
+
+
+;;; Condition control
+
+#+sbcl
+(progn
+  (defun sb-grovel-unknown-constant-condition-p (c)
+    (and (typep c 'sb-int:simple-style-warning)
+         (string-enclosed-p
+          "Couldn't grovel for "
+          (simple-condition-format-control c)
+          " (unknown to the C compiler).")))
+  (deftype sb-grovel-unknown-constant-condition ()
+    '(and style-warning (satisfies sb-grovel-unknown-constant-condition-p)=
)))
+
+(defvar *uninteresting-compiler-conditions*
+  (append
+   ;;#+clozure '(ccl:compiler-warning)
+   #+cmu '("Deleting unreachable code.")
+   #+sbcl
+   '(sb-c::simple-compiler-note
+     "&OPTIONAL and &KEY found in the same lambda list: ~S"
+     sb-int:package-at-variance
+     sb-kernel:uninteresting-redefinition
+     sb-kernel:undefined-alien-style-warning
+     ;; sb-ext:implicit-generic-function-warning ; Controversial. Let's al=
low it by default.
+     sb-kernel:lexical-environment-too-complex
+     sb-grovel-unknown-constant-condition ; defined above.
+     ;; BEWARE: the below four are controversial to include here.
+     sb-kernel:redefinition-with-defun
+     sb-kernel:redefinition-with-defgeneric
+     sb-kernel:redefinition-with-defmethod
+     sb-kernel::redefinition-with-defmacro) ; not exported by old SBCLs
+   '("No generic function ~S present when encountering macroexpansion of d=
efmethod. Assuming it will be an instance of standard-generic-function.")) =
;; from closer2mop
+  "Conditions that may be skipped while compiling")
+
+(defvar *uninteresting-loader-conditions*
+  (append
+   '("Overwriting already existing readtable ~S." ;; from named-readtables
+     #(#:finalizers-off-warning :asdf-finalizers)) ;; from asdf-finalizers
+   #+clisp '(clos::simple-gf-replacing-method-warning))
+  "Additional conditions that may be skipped while loading")
+
+;;;; ----- Filtering conditions while building -----
+
+(defun* call-with-muffled-compiler-conditions (thunk)
+  (call-with-muffled-conditions
+    thunk *uninteresting-compiler-conditions*))
+(defmacro with-muffled-compiler-conditions ((&optional) &body body)
+  "Run BODY where uninteresting compiler conditions are muffled"
+  `(call-with-muffled-compiler-conditions #'(lambda () , at body)))
+(defun* call-with-muffled-loader-conditions (thunk)
+  (call-with-muffled-conditions
+   thunk (append *uninteresting-compiler-conditions* *uninteresting-loader=
-conditions*)))
+(defmacro with-muffled-loader-conditions ((&optional) &body body)
+  "Run BODY where uninteresting compiler and additional loader conditions =
are muffled"
+  `(call-with-muffled-loader-conditions #'(lambda () , at body)))
+
+
+;;;; Handle warnings and failures
+(define-condition compile-condition (condition)
+  ((context-format
+    :initform nil :reader compile-condition-context-format :initarg :conte=
xt-format)
+   (context-arguments
+    :initform nil :reader compile-condition-context-arguments :initarg :co=
ntext-arguments)
+   (description
+    :initform nil :reader compile-condition-description :initarg :descript=
ion))
+  (:report (lambda (c s)
+               (format s (compatfmt "~@<~A~@[ while ~?~]~@:>")
+                       (or (compile-condition-description c) (type-of c))
+                       (compile-condition-context-format c)
+                       (compile-condition-context-arguments c)))))
+(define-condition compile-file-error (compile-condition error) ())
+(define-condition compile-warned-warning (compile-condition warning) ())
+(define-condition compile-warned-error (compile-condition error) ())
+(define-condition compile-failed-warning (compile-condition warning) ())
+(define-condition compile-failed-error (compile-condition error) ())
+
+(defun* check-lisp-compile-warnings (warnings-p failure-p
+                                                &optional context-format c=
ontext-arguments)
+  (when failure-p
+    (case *compile-file-failure-behaviour*
+      (:warn (warn 'compile-failed-warning
+                   :description "Lisp compilation failed"
+                   :context-format context-format
+                   :context-arguments context-arguments))
+      (:error (error 'compile-failed-error
+                   :description "Lisp compilation failed"
+                   :context-format context-format
+                   :context-arguments context-arguments))
+      (:ignore nil)))
+  (when warnings-p
+    (case *compile-file-warnings-behaviour*
+      (:warn (warn 'compile-warned-warning
+                   :description "Lisp compilation had style-warnings"
+                   :context-format context-format
+                   :context-arguments context-arguments))
+      (:error (error 'compile-warned-error
+                   :description "Lisp compilation had style-warnings"
+                   :context-format context-format
+                   :context-arguments context-arguments))
+      (:ignore nil))))
+
+(defun* check-lisp-compile-results (output warnings-p failure-p
+                                           &optional context-format contex=
t-arguments)
+  (unless output
+    (error 'compile-file-error :context-format context-format :context-arg=
uments context-arguments))
+  (check-lisp-compile-warnings warnings-p failure-p context-format context=
-arguments))
+
+
+;;;; Deferred-warnings treatment, originally implemented by Douglas Katzma=
n.
+;;
+;; To support an implementation, three functions must be implemented:
+;; reify-deferred-warnings unreify-deferred-warnings reset-deferred-warnin=
gs
+;; See their respective docstrings.
+
+(defun reify-simple-sexp (sexp)
+  (etypecase sexp
+    (symbol (reify-symbol sexp))
+    ((or number character simple-string pathname) sexp)
+    (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sex=
p))))))
+(defun unreify-simple-sexp (sexp)
+  (etypecase sexp
+    ((or symbol number character simple-string pathname) sexp)
+    (cons (cons (unreify-simple-sexp (car sexp)) (unreify-simple-sexp (cdr=
 sexp))))
+    ((simple-vector 2) (unreify-symbol sexp))))
+
+#+clozure
+(progn
+  (defun reify-source-note (source-note)
+    (when source-note
+      (with-accessors ((source ccl::source-note-source) (filename ccl:sour=
ce-note-filename)
+                       (start-pos ccl:source-note-start-pos) (end-pos ccl:=
source-note-end-pos)) source-note
+          (declare (ignorable source))
+          (list :filename filename :start-pos start-pos :end-pos end-pos
+                #|:source (reify-source-note source)|#))))
+  (defun unreify-source-note (source-note)
+    (when source-note
+      (destructuring-bind (&key filename start-pos end-pos source) source-=
note
+        (ccl::make-source-note :filename filename :start-pos start-pos :en=
d-pos end-pos
+                               :source (unreify-source-note source)))))
+  (defun reify-deferred-warning (deferred-warning)
+    (with-accessors ((warning-type ccl::compiler-warning-warning-type)
+                     (args ccl::compiler-warning-args)
+                     (source-note ccl:compiler-warning-source-note)
+                     (function-name ccl:compiler-warning-function-name)) d=
eferred-warning
+      (list :warning-type warning-type :function-name (reify-simple-sexp f=
unction-name)
+            :source-note (reify-source-note source-note) :args (reify-simp=
le-sexp args))))
+  (defun unreify-deferred-warning (reified-deferred-warning)
+    (destructuring-bind (&key warning-type function-name source-note args)
+        reified-deferred-warning
+      (make-condition (or (cdr (ccl::assq warning-type ccl::*compiler-whin=
ing-conditions*))
+                          'ccl::compiler-warning)
+                      :function-name (unreify-simple-sexp function-name)
+                      :source-note (unreify-source-note source-note)
+                      :warning-type warning-type
+                      :args (unreify-simple-sexp args)))))
+
+#+sbcl
+(defun reify-undefined-warning (warning)
+  ;; Extracting undefined-warnings from the compilation-unit
+  ;; To be passed through the above reify/unreify link, it must be a "simp=
le-sexp"
+  (list*
+   (sb-c::undefined-warning-kind warning)
+   (sb-c::undefined-warning-name warning)
+   (sb-c::undefined-warning-count warning)
+   (mapcar
+    #'(lambda (frob)
+        ;; the lexenv slot can be ignored for reporting purposes
+        `(:enclosing-source ,(sb-c::compiler-error-context-enclosing-sourc=
e frob)
+          :source ,(sb-c::compiler-error-context-source frob)
+          :original-source ,(sb-c::compiler-error-context-original-source =
frob)
+          :context ,(sb-c::compiler-error-context-context frob)
+          :file-name ,(sb-c::compiler-error-context-file-name frob) ; a pa=
thname
+          :file-position ,(sb-c::compiler-error-context-file-position frob=
) ; an integer
+          :original-source-path ,(sb-c::compiler-error-context-original-so=
urce-path frob)))
+    (sb-c::undefined-warning-warnings warning))))
+
+(defun reify-deferred-warnings ()
+  "return a portable S-expression, portably readable and writeable in any =
Common Lisp implementation
+using READ within a WITH-SAFE-IO-SYNTAX, that represents the warnings curr=
ently deferred by
+WITH-COMPILATION-UNIT. One of three functions required for deferred-warnin=
gs support in ASDF."
+  #+clozure
+  (mapcar 'reify-deferred-warning
+          (if-let (dw ccl::*outstanding-deferred-warnings*)
+            (let ((mdw (ccl::ensure-merged-deferred-warnings dw)))
+              (ccl::deferred-warnings.warnings mdw))))
+  #+sbcl
+  (when sb-c::*in-compilation-unit*
+    ;; Try to send nothing through the pipe if nothing needs to be accumul=
ated
+    `(,@(when sb-c::*undefined-warnings*
+          `((sb-c::*undefined-warnings*
+             ,@(mapcar #'reify-undefined-warning sb-c::*undefined-warnings=
*))))
+      ,@(loop :for what :in '(sb-c::*aborted-compilation-unit-count*
+                              sb-c::*compiler-error-count*
+                              sb-c::*compiler-warning-count*
+                              sb-c::*compiler-style-warning-count*
+                              sb-c::*compiler-note-count*)
+              :for value =3D (symbol-value what)
+              :when (plusp value)
+                :collect `(,what . ,value)))))
+
+(defun unreify-deferred-warnings (reified-deferred-warnings)
+  "given a S-expression created by REIFY-DEFERRED-WARNINGS, reinstantiate =
the corresponding
+deferred warnings as to be handled at the end of the current WITH-COMPILAT=
ION-UNIT.
+Handle any warning that has been resolved already,
+such as an undefined function that has been defined since.
+One of three functions required for deferred-warnings support in ASDF."
+  (declare (ignorable reified-deferred-warnings))
+  #+clozure
+  (let ((dw (or ccl::*outstanding-deferred-warnings*
+                (setf ccl::*outstanding-deferred-warnings* (ccl::%defer-wa=
rnings t)))))
+    (appendf (ccl::deferred-warnings.warnings dw)
+             (mapcar 'unreify-deferred-warning reified-deferred-warnings)))
+  #+sbcl
+  (dolist (item reified-deferred-warnings)
+    ;; Each item is (symbol . adjustment) where the adjustment depends on =
the symbol.
+    ;; For *undefined-warnings*, the adjustment is a list of initargs.
+    ;; For everything else, it's an integer.
+    (destructuring-bind (symbol . adjustment) item
+      (case symbol
+        ((sb-c::*undefined-warnings*)
+         (setf sb-c::*undefined-warnings*
+               (nconc (mapcan
+                       #'(lambda (stuff)
+                           (destructuring-bind (kind name count . rest) st=
uff
+                             (unless (case kind (:function (fboundp name)))
+                               (list
+                                (sb-c::make-undefined-warning
+                                 :name name
+                                 :kind kind
+                                 :count count
+                                 :warnings
+                                 (mapcar #'(lambda (x)
+                                             (apply #'sb-c::make-compiler-=
error-context x))
+                                         rest))))))
+                       adjustment)
+                      sb-c::*undefined-warnings*)))
+        (otherwise
+         (set symbol (+ (symbol-value symbol) adjustment)))))))
+
+(defun reset-deferred-warnings ()
+  "Reset the set of deferred warnings to be handled at the end of the curr=
ent WITH-COMPILATION-UNIT.
+One of three functions required for deferred-warnings support in ASDF."
+  #+clozure
+  (if-let (dw ccl::*outstanding-deferred-warnings*)
+    (let ((mdw (ccl::ensure-merged-deferred-warnings dw)))
+      (setf (ccl::deferred-warnings.warnings mdw) nil)))
+  #+sbcl
+  (when sb-c::*in-compilation-unit*
+    (setf sb-c::*undefined-warnings* nil
+          sb-c::*aborted-compilation-unit-count* 0
+          sb-c::*compiler-error-count* 0
+          sb-c::*compiler-warning-count* 0
+          sb-c::*compiler-style-warning-count* 0
+          sb-c::*compiler-note-count* 0)))
+
+(defun* save-deferred-warnings (warnings-file)
+  "Save forward reference conditions so they may be issued at a latter tim=
e,
+possibly in a different process."
+  (with-open-file (s warnings-file :direction :output :if-exists :supersed=
e)
+    (with-safe-io-syntax ()
+      (write (reify-deferred-warnings) :stream s :pretty t :readably t)
+      (terpri s)))
+  (reset-deferred-warnings))
+
+(defun* warnings-file-type (&optional implementation-type)
+  (case (or implementation-type *implementation-type*)
+    (:sbcl "sbcl-warnings")
+    ((:clozure :ccl) "ccl-warnings")))
+
+(defvar *warnings-file-type* (warnings-file-type)
+  "Type for warnings files")
+
+(defun* warnings-file-p (file &optional implementation-type)
+  (if-let (type (if implementation-type
+                    (warnings-file-type implementation-type)
+                    *warnings-file-type*))
+    (equal (pathname-type file) type)))
+
+(defun* check-deferred-warnings (files &optional context-format context-ar=
guments)
+  (let ((file-errors nil)
+        (failure-p nil)
+        (warnings-p nil))
+    (handler-bind
+        ((warning #'(lambda (c)
+                      (setf warnings-p t)
+                      (unless (typep c 'style-warning)
+                        (setf failure-p t)))))
+      (with-compilation-unit (:override t)
+        (reset-deferred-warnings)
+        (dolist (file files)
+          (unreify-deferred-warnings
+           (handler-case (safe-read-file-form file)
+             (error (c)
+               (delete-file-if-exists file)
+               (push c file-errors)
+               nil))))))
+    (dolist (error file-errors) (error error))
+    (check-lisp-compile-warnings
+     (or failure-p warnings-p) failure-p context-format context-arguments)=
))
+
+
+;;;; Deferred warnings
+#|
+Mini-guide to adding support for deferred warnings on an implementation.
+
+First, look at what such a warning looks like:
+
+(describe
+ (handler-case
+     (and (eval '(lambda () (some-undefined-function))) nil)
+   (t (c) c)))
+
+Then you can grep for the condition type in your compiler sources
+and see how to catch those that have been deferred,
+and/or read, clear and restore the deferred list.
+
+ccl::
+undefined-function-reference
+verify-deferred-warning
+report-deferred-warnings
+
+|#
+
+(defun* call-with-saved-deferred-warnings (thunk warnings-file)
+  (if warnings-file
+      (with-compilation-unit (:override t)
+        (let (#+sbcl (sb-c::*undefined-warnings* nil))
+          (multiple-value-prog1
+              (with-muffled-compiler-conditions ()
+                (funcall thunk))
+            (save-deferred-warnings warnings-file)
+            (reset-deferred-warnings))))
+      (funcall thunk)))
+
+(defmacro with-saved-deferred-warnings ((warnings-file) &body body)
+  "If WARNINGS-FILE is not nil, records the deferred-warnings around the B=
ODY
+and saves those warnings to the given file for latter use,
+possibly in a different process. Otherwise just run the BODY."
+  `(call-with-saved-deferred-warnings #'(lambda () , at body) ,warnings-file))
+
+
+;;; from ASDF
+
+(defun* current-lisp-file-pathname ()
+  (or *compile-file-pathname* *load-pathname*))
+
+(defun* load-pathname ()
+  *load-pathname*)
+
+(defun* lispize-pathname (input-file)
+  (make-pathname :type "lisp" :defaults input-file))
+
+(defun* compile-file-type (&rest keys)
+  "pathname TYPE for lisp FASt Loading files"
+  (declare (ignorable keys))
+  #-(or ecl mkcl) (load-time-value (pathname-type (compile-file-pathname "=
foo.lisp")))
+  #+(or ecl mkcl) (pathname-type (apply 'compile-file-pathname "foo" keys)=
))
+
+(defun* call-around-hook (hook function)
+  (call-function (or hook 'funcall) function))
+
+(defun* compile-file-pathname* (input-file &rest keys &key output-file &al=
low-other-keys)
+  (let* ((keys
+           (remove-plist-keys `(#+(and allegro (not (version>=3D 8 2))) :e=
xternal-format
+                            ,@(unless output-file '(:output-file))) keys)))
+    (if (absolute-pathname-p output-file)
+        ;; what cfp should be doing, w/ mp* instead of mp
+        (let* ((type (pathname-type (apply 'compile-file-type keys)))
+               (defaults (make-pathname
+                          :type type :defaults (merge-pathnames* input-fil=
e))))
+          (merge-pathnames* output-file defaults))
+        (funcall *output-translation-function*
+                 (apply 'compile-file-pathname input-file keys)))))
+
+(defun* (compile-file*) (input-file &rest keys
+                                    &key compile-check output-file warning=
s-file
+                                    #+clisp lib-file #+(or ecl mkcl) objec=
t-file
+                                    &allow-other-keys)
+  "This function provides a portable wrapper around COMPILE-FILE.
+It ensures that the OUTPUT-FILE value is only returned and
+the file only actually created if the compilation was successful,
+even though your implementation may not do that, and including
+an optional call to an user-provided consistency check function COMPILE-CH=
ECK;
+it will call this function if not NIL at the end of the compilation
+with the arguments sent to COMPILE-FILE*, except with :OUTPUT-FILE TMP-FILE
+where TMP-FILE is the name of a temporary output-file.
+It also checks two flags (with legacy british spelling from ASDF1),
+*COMPILE-FILE-FAILURE-BEHAVIOUR* and *COMPILE-FILE-WARNINGS-BEHAVIOUR*
+with appropriate implementation-dependent defaults,
+and if a failure (respectively warnings) are reported by COMPILE-FILE
+with consider it an error unless the respective behaviour flag
+is one of :SUCCESS :WARN :IGNORE.
+If WARNINGS-FILE is defined, deferred warnings are saved to that file.
+On ECL or MKCL, it creates both the linkable object and loadable fasl file=
s.
+On implementations that erroneously do not recognize standard keyword argu=
ments,
+it will filter them appropriately."
+  #+ecl (when (and object-file (equal (compile-file-type) (pathname object=
-file)))
+          (format t "Whoa, some funky ASDF upgrade switched ~S calling con=
vention for ~S and ~S~%"
+                  'compile-file* output-file object-file)
+          (rotatef output-file object-file))
+  (let* ((keywords (remove-plist-keys
+                    `(:output-file :compile-check :warnings-file
+                      #+clisp :lib-file #+(or ecl mkcl) :object-file
+                      #+gcl2.6 ,@'(:external-format :print :verbose)) keys=
))
+         (output-file
+           (or output-file
+               (apply 'compile-file-pathname* input-file :output-file outp=
ut-file keywords)))
+         #+ecl
+         (object-file
+           (unless (use-ecl-byte-compiler-p)
+             (or object-file
+                 (compile-file-pathname output-file :type :object))))
+         #+mkcl
+         (object-file
+           (or object-file
+               (compile-file-pathname output-file :fasl-p nil)))
+         (tmp-file (tmpize-pathname output-file))
+         #+clisp
+         (tmp-lib (make-pathname :type "lib" :defaults tmp-file)))
+    (multiple-value-bind (output-truename warnings-p failure-p)
+        (with-saved-deferred-warnings (warnings-file)
+          (or #-(or ecl mkcl) (apply 'compile-file input-file :output-file=
 tmp-file keywords)
+              #+ecl (apply 'compile-file input-file :output-file
+                           (if object-file
+                               (list* object-file :system-p t keywords)
+                               (list* tmp-file keywords)))
+              #+mkcl (apply 'compile-file input-file
+                            :output-file object-file :fasl-p nil keywords)=
))
       (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 ve=
rsion ~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-bei=
ng-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.
-(defun* upgrade-asdf ()
-  (let ((version (asdf-version)))
-    (handler-bind (((or style-warning warning) #'muffle-warning))
-      (operate 'load-op :asdf :verbose nil))
-    (cleanup-upgraded-asdf version)))
-
-(defmethod perform-plan ((steps list) &key)
-  (let ((*package* *package*)
-        (*readtable* *readtable*))
-    (with-compilation-unit ()
-      (loop :for (op . component) :in steps :do
-        (perform-with-restarts op component)))))
-
-(defmethod operate (operation-class system &rest args
-                    &key ((:verbose *asdf-verbose*) *asdf-verbose*) versio=
n force
-                    &allow-other-keys)
-  (declare (ignore force))
-  (with-system-definitions ()
-    (let* ((op (apply 'make-instance operation-class
-                      :original-initargs args
-                      args))
-           (*verbose-out* (if *asdf-verbose* *standard-output* (make-broad=
cast-stream)))
-           (system (etypecase system
-                     (system system)
-                     ((or string symbol) (find-system system)))))
-      (unless (version-satisfies system version)
-        (error 'missing-component-of-version :requires system :version ver=
sion))
-      (let ((steps (traverse op system)))
-        (when (and (not (equal '("asdf") (component-find-path system)))
-                   (find '("asdf") (mapcar 'cdr steps)
-                         :test 'equal :key 'component-find-path)
-                   (upgrade-asdf))
-          ;; If we needed to upgrade ASDF to achieve our goal,
-          ;; then do it specially as the first thing, then
-          ;; invalidate all existing system
-          ;; retry the whole thing with the new OPERATE function,
-          ;; which on some implementations
-          ;; has a new symbol shadowing the current one.
-          (return-from operate
-            (apply (find-symbol* 'operate :asdf) operation-class system ar=
gs)))
-        (perform-plan steps)
-        (values op steps)))))
-
-(defun* oos (operation-class system &rest args &key force verbose version
-            &allow-other-keys)
-  (declare (ignore force verbose version))
-  (apply 'operate operation-class system args))
-
-(let ((operate-docstring
-  "Operate does three things:
-
-1. It creates an instance of OPERATION-CLASS using any keyword parameters
-as initargs.
-2. It finds the  asdf-system specified by SYSTEM (possibly loading
-it from disk).
-3. It then calls TRAVERSE with the operation and system as arguments
-
-The traverse operation is wrapped in WITH-COMPILATION-UNIT and error
-handling code. If a VERSION argument is supplied, then operate also
-ensures that the system found satisfies it using the VERSION-SATISFIES
-method.
-
-Note that dependencies may cause the operation to invoke other
-operations on the system or its components: the new operations will be
-created with the same initargs as the original one.
-"))
-  (setf (documentation 'oos 'function)
-        (format nil
-                "Short for _operate on system_ and an alias for the OPERAT=
E function.~%~%~a"
-                operate-docstring))
-  (setf (documentation 'operate 'function)
-        operate-docstring))
-
-(defun* load-system (system &rest keys &key force verbose version &allow-o=
ther-keys)
-  "Shorthand for `(operate 'asdf:load-op system)`.
-See OPERATE for details."
-  (declare (ignore force verbose version))
-  (apply 'operate *load-system-operation* system keys)
-  t)
-
-(defun* load-systems (&rest systems)
-  (map () 'load-system systems))
-
-(defun component-loaded-p (c)
-  (and (gethash 'load-op (component-operation-times (find-component c nil)=
)) t))
-
-(defun loaded-systems ()
-  (remove-if-not 'component-loaded-p (registered-systems)))
-
-(defun require-system (s &rest keys &key &allow-other-keys)
-  (apply 'load-system s :force-not (loaded-systems) keys))
-
-(defun* compile-system (system &rest args &key force verbose version
-                       &allow-other-keys)
-  "Shorthand for `(asdf:operate 'asdf:compile-op system)`. See OPERATE
-for details."
-  (declare (ignore force verbose version))
-  (apply 'operate 'compile-op system args)
-  t)
-
-(defun* test-system (system &rest args &key force verbose version
-                    &allow-other-keys)
-  "Shorthand for `(asdf:operate 'asdf:test-op system)`. See OPERATE for
-details."
-  (declare (ignore force verbose version))
-  (apply 'operate 'test-op system args)
-  t)
-
-;;;; ---------------------------------------------------------------------=
----
-;;;; Defsystem
-
-(defun* load-pathname ()
-  (resolve-symlinks* (or *load-pathname* *compile-file-pathname*)))
-
-(defun* determine-system-pathname (pathname)
-  ;; The defsystem macro calls us to determine
-  ;; the pathname of a system as follows:
-  ;; 1. the one supplied,
-  ;; 2. derived from *load-pathname* via load-pathname
-  ;; 3. taken from the *default-pathname-defaults* via default-directory
-  (let* ((file-pathname (load-pathname))
-         (directory-pathname (and file-pathname (pathname-directory-pathna=
me file-pathname))))
-    (or (and pathname (subpathname directory-pathname pathname :type :dire=
ctory))
-        directory-pathname
-        (default-directory))))
-
-(defun* find-class* (x &optional (errorp t) environment)
+        ((and output-truename
+              (flet ((check-flag (flag behaviour)
+                       (or (not flag) (member behaviour '(:success :warn :=
ignore)))))
+                (and (check-flag failure-p *compile-file-failure-behaviour=
*)
+                     (check-flag warnings-p *compile-file-warnings-behavio=
ur*)))
+              (progn
+                #+(or ecl mkcl)
+                (when (and #+ecl object-file)
+                  (setf output-truename
+                        (compiler::build-fasl
+                         tmp-file #+ecl :lisp-files #+mkcl :lisp-object-fi=
les
+                                  (list object-file))))
+                (or (not compile-check)
+                    (apply compile-check input-file :output-file tmp-file =
keywords))))
+         (delete-file-if-exists output-file)
+         (when output-truename
+           #+clisp (when lib-file (rename-file-overwriting-target tmp-lib =
lib-file))
+           (rename-file-overwriting-target output-truename output-file)
+           (setf output-truename (truename output-file)))
+         #+clisp (delete-file-if-exists tmp-lib))
+        (t ;; error or failed check
+         (delete-file-if-exists output-truename)
+         (setf output-truename nil)))
+      (values output-truename warnings-p failure-p))))
+
+(defun* load* (x &rest keys &key &allow-other-keys)
   (etypecase x
-    ((or standard-class built-in-class) x)
-    (symbol (find-class x errorp environment))))
-
-(defun* class-for-type (parent type)
-  (or (loop :for symbol :in (list
-                             type
-                             (find-symbol* type *package*)
-                             (find-symbol* type :asdf))
-        :for class =3D (and symbol (find-class symbol nil))
-        :when (and class
-                   (#-cormanlisp subtypep #+cormanlisp cl::subclassp
-                                 class (find-class 'component)))
-        :return class)
-      (and (eq type :file)
-           (find-class*
-            (or (loop :for module =3D parent :then (component-parent modul=
e) :while module
-                  :thereis (module-default-component-class module))
-                *default-component-class*) nil))
-      (sysdef-error "don't recognize component type ~A" type)))
-
-(defun* maybe-add-tree (tree op1 op2 c)
-  "Add the node C at /OP1/OP2 in TREE, unless it's there already.
-Returns the new tree (which probably shares structure with the old one)"
-  (let ((first-op-tree (assoc op1 tree)))
-    (if first-op-tree
-        (progn
-          (aif (assoc op2 (cdr first-op-tree))
-               (if (find c (cdr it) :test #'equal)
-                   nil
-                   (setf (cdr it) (cons c (cdr it))))
-               (setf (cdr first-op-tree)
-                     (acons op2 (list c) (cdr first-op-tree))))
-          tree)
-        (acons op1 (list (list op2 c)) tree))))
-
-(defun* union-of-dependencies (&rest deps)
-  (let ((new-tree nil))
-    (dolist (dep deps)
-      (dolist (op-tree dep)
-        (dolist (op  (cdr op-tree))
-          (dolist (c (cdr op))
-            (setf new-tree
-                  (maybe-add-tree new-tree (car op-tree) (car op) c))))))
-    new-tree))
-
-
-(defvar *serial-depends-on* nil)
-
-(defun* sysdef-error-component (msg type name value)
-  (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~=
) ~A is ~S~@:>"))
-                type name value))
-
-(defun* check-component-input (type name weakly-depends-on
-                              depends-on components in-order-to)
-  "A partial test of the values of a component."
-  (unless (listp depends-on)
-    (sysdef-error-component ":depends-on must be a list."
-                            type name depends-on))
-  (unless (listp weakly-depends-on)
-    (sysdef-error-component ":weakly-depends-on must be a list."
-                            type name weakly-depends-on))
-  (unless (listp components)
-    (sysdef-error-component ":components must be NIL or a list of componen=
ts."
-                            type name components))
-  (unless (and (listp in-order-to) (listp (car in-order-to)))
-    (sysdef-error-component ":in-order-to must be NIL or a list of compone=
nts."
-                            type name in-order-to)))
-
-(defun* %remove-component-inline-methods (component)
-  (dolist (name +asdf-methods+)
-    (map ()
-         ;; this is inefficient as most of the stored
-         ;; methods will not be for this particular gf
-         ;; But this is hardly performance-critical
-         #'(lambda (m)
-             (remove-method (symbol-function name) m))
-         (component-inline-methods component)))
-  ;; clear methods, then add the new ones
-  (setf (component-inline-methods component) nil))
-
-(defun* %define-component-inline-methods (ret rest)
-  (dolist (name +asdf-methods+)
-    (let ((keyword (intern (symbol-name name) :keyword)))
-      (loop :for data =3D rest :then (cddr data)
-        :for key =3D (first data)
-        :for value =3D (second data)
-        :while data
-        :when (eq key keyword) :do
-        (destructuring-bind (op qual (o c) &body body) value
-          (pushnew
-           (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
-                             , at body))
-           (component-inline-methods ret)))))))
-
-(defun* %refresh-component-inline-methods (component rest)
-  (%remove-component-inline-methods component)
-  (%define-component-inline-methods component rest))
-
-(defun* parse-component-form (parent options)
-  (destructuring-bind
-        (type name &rest rest &key
-              ;; the following list of keywords is reproduced below in the
-              ;; remove-keys form.  important to keep them in sync
-              components pathname
-              perform explain output-files operation-done-p
-              weakly-depends-on depends-on serial in-order-to
-              do-first
-              (version nil versionp)
-              ;; list ends
-              &allow-other-keys) options
-    (declare (ignorable perform explain output-files operation-done-p))
-    (check-component-input type name weakly-depends-on depends-on componen=
ts in-order-to)
-
-    (when (and parent
-               (find-component parent name)
-               ;; ignore the same object when rereading the defsystem
-               (not
-                (typep (find-component parent name)
-                       (class-for-type parent type))))
-      (error 'duplicate-names :name name))
-
-    (when versionp
-      (unless (parse-version version nil)
-        (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~=
]~@:>")
-              version name parent)))
-
-    (let* ((args (list* :name (coerce-name name)
-                        :pathname pathname
-                        :parent parent
-                        (remove-keys
-                         '(components pathname
-                           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 #'(lambda (x) (find-sys=
tem x nil))) weakly-depends-on)))
-      (when *serial-depends-on*
-        (push *serial-depends-on* depends-on))
-      (if ret ; preserve identity
-          (apply 'reinitialize-instance ret args)
-          (setf ret (apply 'make-instance (class-for-type parent type) arg=
s)))
-      (component-pathname ret) ; eagerly compute the absolute pathname
-      (when (typep ret 'module)
-        (let ((*serial-depends-on* nil))
-          (setf (module-components ret)
-                (loop
-                  :for c-form :in components
-                  :for c =3D (parse-component-form ret c-form)
-                  :for name =3D (component-name c)
-                  :collect c
-                  :when serial :do (setf *serial-depends-on* name))))
-        (compute-module-components-by-name ret))
-
-      (setf (component-load-dependencies ret) depends-on) ;; Used by POIU
-
-      (setf (component-in-order-to ret)
-            (union-of-dependencies
-             in-order-to
-             `((compile-op (compile-op , at depends-on))
-               (load-op (load-op , at depends-on)))))
-      (setf (component-do-first ret)
-            (union-of-dependencies
-             do-first
-             `((compile-op (load-op , at 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 (class 'system)
-                           defsystem-depends-on &allow-other-keys)
-  ;; The system must be registered before we parse the body,
-  ;; otherwise we recur when trying to find an existing system
-  ;; of the same name to reuse options (e.g. pathname) from.
-  ;; To avoid infinite recursion in cases where you defsystem a system
-  ;; that is registered to a different location to find-system,
-  ;; we also need to remember it in a special variable *systems-being-defi=
ned*.
-  (with-system-definitions ()
-    (let* ((name (coerce-name name))
-           (registered (system-registered-p 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)))
-      (setf (gethash name *systems-being-defined*) system)
-      (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.
-      (let ((class (class-for-type nil class)))
-        (unless (eq (type-of system) class)
-          (change-class system class)))
-      (parse-component-form
-       nil (list*
-            :module name
-            :pathname (determine-system-pathname pathname)
-            component-options)))))
-
-(defmacro defsystem (name &body options)
-  `(apply 'do-defsystem ',name ',options))
+    ((or pathname string #-(or allegro clozure gcl2.6 genera) stream)
+     (apply 'load x
+            #-gcl2.6 keys #+gcl2.6 (remove-plist-key :external-format keys=
)))
+    ;; GCL 2.6, Genera can't load from a string-input-stream
+    ;; ClozureCL 1.6 can only load from file input stream
+    ;; Allegro 5, I don't remember but it must have been broken when I tes=
ted.
+    #+(or allegro clozure gcl2.6 genera)
+    (stream ;; make do this way
+     (let ((*package* *package*)
+           (*readtable* *readtable*)
+           (*load-pathname* nil)
+           (*load-truename* nil))
+       (eval-input x)))))
+
+(defun* load-from-string (string)
+  "Portably read and evaluate forms from a STRING."
+  (with-input-from-string (s string) (load* s)))
+
+;;; Links FASLs together
+(defun* combine-fasls (inputs output)
+  #-(or allegro clisp clozure cmu lispworks sbcl scl xcl)
+  (error "~A does not support ~S~%inputs ~S~%output  ~S"
+         (implementation-type) 'combine-fasls inputs output)
+  #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede)
+  #+(or allegro clisp cmu sbcl scl xcl) (concatenate-files inputs output)
+  #+lispworks
+  (let (fasls)
+    (unwind-protect
+         (progn
+           (loop :for i :in inputs
+                 :for n :from 1
+                 :for f =3D (add-pathname-suffix
+                           output (format nil "-FASL~D" n))
+                 :do #-lispworks-personal-edition (lispworks:copy-file i f)
+                     #+lispworks-personal-edition (concatenate-files (list=
 i) f)
+                     (push f fasls))
+           (ignore-errors (lispworks:delete-system :fasls-to-concatenate))
+           (eval `(scm:defsystem :fasls-to-concatenate
+                    (:default-pathname ,(pathname-directory-pathname outpu=
t))
+                    :members
+                    ,(loop :for f :in (reverse fasls)
+                           :collect `(,(namestring f) :load-only t))))
+           (scm:concatenate-system output :fasls-to-concatenate))
+      (loop :for f :in fasls :do (ignore-errors (delete-file f)))
+      (ignore-errors (lispworks:delete-system :fasls-to-concatenate)))))
 =

 ;;;; ---------------------------------------------------------------------=
------
-;;;; run-shell-command
-;;;;
-;;;; run-shell-command functions for other lisp implementations will be
-;;;; gratefully accepted, if they do the same thing.
-;;;; 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 Un=
ix,
-;;;; which will hopefully use the shell /bin/sh (which we force in some ca=
ses)
-;;;; which is hopefully reasonably compatible with a POSIX *or* Bourne she=
ll.
-;;;; 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 depr=
ecate
-;;;; use of it from the asdf package. However, this would break unspecified
-;;;; existing software, so until a clear alternative exists, we can't depr=
ecate
-;;;; 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/ and its derivatives.
-
-(defun* run-shell-command (control-string &rest args)
-  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
-synchronously execute the result using a Bourne-compatible shell, with
-output to *VERBOSE-OUT*.  Returns the shell's exit code."
-  (let ((command (apply 'format nil control-string args)))
-    (asdf-message "; $ ~A~%" command)
-
-    #+abcl
-    (ext:run-shell-command command :output *verbose-out*)
-
-    #+allegro
-    ;; will this fail if command has embedded quotes - it seems to work
-    (multiple-value-bind (stdout stderr exit-code)
-        (excl.osi:command-output
-         #-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)
-      exit-code)
-
-    #+clisp
-    ;; CLISP returns NIL for exit status zero.
-    (if *verbose-out*
-        (let* ((new-command (format nil "( ~A ) ; r=3D$? ; echo ; echo ASD=
F-EXIT-STATUS $r"
-                                    command))
-               (outstream (ext:run-shell-command new-command :output :stre=
am :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
-                 (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)
-    (ext:process-exit-code
-     (ext:run-program
-      "/bin/sh"
-      (list "-c" command)
-      :input nil :output *verbose-out*))
-
-    #+cormanlisp
-    (win32:system command)
-
-    #+ecl ;; courtesy of Juan Jose Garcia Ripoll
-    (ext:system command)
-
-    #+gcl
-    (lisp:system command)
-
-    #+lispworks
-    (apply 'system:call-system-showing-output command
-           :show-cmd nil :prefix "" :output-stream *verbose-out*
-           (when (os-unix-p) '(:shell-type "/bin/sh")))
-
-    #+mcl
-    (ccl::with-cstrs ((%command command)) (_system %command))
-
-    #+mkcl
-    ;; This has next to no chance of working on basic Windows!
-    ;; Your best hope is that Cygwin or MSYS is somewhere in the PATH.
-    (multiple-value-bind (io process exit-code)
-	(apply #'mkcl:run-program #+windows "sh" #-windows "/bin/sh"
-                                  (list "-c" command)
-                                  :input nil :output t #|*verbose-out*|# ;=
; will be *verbose-out* when we support it
-                                  #-windows '(:search nil))
-      (declare (ignore io process))
-      exit-code)
-
-    #+sbcl
-    (sb-ext:process-exit-code
-     (apply 'sb-ext:run-program
-            #+win32 "sh" #-win32 "/bin/sh"
-            (list  "-c" command)
-            :input nil :output *verbose-out*
-            #+win32 '(:search t) #-win32 nil))
-
-    #+xcl
-    (ext:run-shell-command command)
-
-    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl mkcl sbcl s=
cl 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 speci=
ally-
-crafted output string to recover the exit status of the shell command and a
-list of lines of output."
-  (loop :with status-prefix =3D "ASDF-EXIT-STATUS "
-    :with prefix-length =3D (length status-prefix)
-    :with exit-status =3D -1 :with lines =3D ()
-    :for line =3D (read-line stream nil nil)
-    :while line :do (push line lines) :finally
-    (let* ((last (car lines))
-           (status (and last (>=3D (length last) prefix-length)
-                        (string-equal last status-prefix :end1 prefix-leng=
th)
-                        (parse-integer last :start prefix-length :junk-all=
owed t))))
-      (when status
-        (setf exit-status status)
-        (pop lines) (when (equal "" (car lines)) (pop lines)))
-      (return (values exit-status (reverse lines))))))
-
-;;;; ---------------------------------------------------------------------=
------
-;;;; system-relative-pathname
-
-(defun* system-definition-pathname (x)
-  ;; As of 2.014.8, we mean to make this function obsolete,
-  ;; but that won't happen until all clients have been updated.
-  ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
-  "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
-It used to expose ASDF internals with subtle differences with respect to
-user expectations, that have been refactored away since.
-We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
-for a mostly compatible replacement that we're supporting,
-or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
-if that's whay you mean." ;;)
-  (system-source-file x))
-
-(defmethod system-source-file ((system system))
-  ;; might be missing when upgrading from ASDF 1 and u-i-f-r-c failed
-  (unless (slot-boundp system 'source-file)
-    (%set-system-source-file
-     (probe-asd (component-name system) (component-pathname system)) syste=
m))
-  (%system-source-file system))
-(defmethod system-source-file ((system-name string))
-  (%system-source-file (find-system system-name)))
-(defmethod system-source-file ((system-name symbol))
-  (%system-source-file (find-system system-name)))
-
-(defun* system-source-directory (system-designator)
-  "Return a pathname object corresponding to the
-directory in which the system specification (.asd file) is
-located."
-  (pathname-directory-pathname (system-source-file system-designator)))
-
-(defun* relativize-directory (directory)
-  (cond
-    ((stringp directory)
-     (list :relative directory))
-    ((eq (car directory) :absolute)
-     (cons :relative (cdr directory)))
-    (t
-     directory)))
-
-(defun* relativize-pathname-directory (pathspec)
-  (let ((p (pathname pathspec)))
-    (make-pathname
-     :directory (relativize-directory (pathname-directory p))
-     :defaults p)))
-
-(defun* system-relative-pathname (system name &key type)
-  (subpathname (system-source-directory system) name :type type))
-
-
-;;; ----------------------------------------------------------------------=
-----
-;;; implementation-identifier
-;;;
-;;; produce a string to identify current implementation.
-;;; Initially stolen from SLIME's SWANK, rewritten since.
-;;; 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) :c=
mu
-     :ecl :gcl (:lw :lispworks) :mcl :mkcl :sbcl :scl :symbolics :xcl)))
-
-(defun operating-system ()
-  (first-feature
-   '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin firs=
t!
-     (: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=3D64 :pc3=
86))
-     (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx38=
6 :x8632-target)
-     (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powe=
rpc)
-     :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 JN=
I,
-     ;; 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 (let ((s 'ccl::target-fasl-version))
-        (and (fboundp s) (funcall s)))
-      (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)))
-    (car ; as opposed to OR, this idiom prevents some unreachable code war=
ning
-     (list
-      #+allegro
-      (format nil "~A~@[~A~]~@[~A~]~@[~A~]"
-              excl::*common-lisp-version-number*
-              ;; M means "modern", as opposed to ANSI-compatible mode (whi=
ch I consider default)
-              (and (eq excl:*current-case-mode* :case-sensitive-lower) "M")
-              ;; Note if not using International ACL
-              ;; see http://www.franz.com/support/documentation/8.1/doc/op=
erators/excl/ics-target-case.htm
-              (excl:ics-target-case (:-ics "8"))
-	      (and (member :smp *features*) "S"))
-      #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
-      #+clisp
-      (subseq s 0 (position #\space s)) ; strip build information (date, e=
tc.)
-      #+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 ()
-  (substitute-if
-   #\_ #'(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)))))
-
-(defun* hostname ()
-  ;; Note: untested on RMCL
-  #+(or abcl clozure cmucl ecl genera lispworks mcl mkcl sbcl scl xcl) (ma=
chine-instance)
-  #+cormanlisp "localhost" ;; is there a better way? Does it matter?
-  #+allegro (excl.osi:gethostname)
-  #+clisp (first (split-string (machine-instance) :separator " "))
-  #+gcl (system:gethostname))
-
-
-;;; ----------------------------------------------------------------------=
-----
-;;; Generic support for configuration files
-
-(defun inter-directory-separator ()
-  (if (os-unix-p) #\: #\;))
-
-(defun* user-homedir ()
-  (truenamize
-   (pathname-directory-pathname
-    #+cormanlisp (ensure-directory-pathname (user-homedir-pathname))
-    #+mcl (current-user-homedir-pathname)
-    #-(or cormanlisp mcl) (user-homedir-pathname))))
-
-(defun* ensure-pathname* (x want-absolute want-directory fmt &rest args)
-  (when (plusp (length x))
-    (let ((p (if want-directory (ensure-directory-pathname x) (pathname x)=
)))
-      (when want-absolute
-        (unless (absolute-pathname-p p)
-          (cerror "ignore relative pathname"
-                  "Invalid relative pathname ~A~@[ ~?~]" x fmt args)
-          (return-from ensure-pathname* nil)))
-      p)))
-(defun* split-pathnames* (x want-absolute want-directory fmt &rest args)
-  (loop :for dir :in (split-string
-                      x :separator (string (inter-directory-separator)))
-        :collect (apply 'ensure-pathname* dir want-absolute want-directory=
 fmt args)))
-(defun* getenv-pathname (x &key want-absolute want-directory &aux (s (gete=
nv x)))
-  (ensure-pathname* s want-absolute want-directory "from (getenv ~S)" x))
-(defun* getenv-pathnames (x &key want-absolute want-directory &aux (s (get=
env x)))
-  (and (plusp (length s))
-       (split-pathnames* s want-absolute want-directory "from (getenv ~S) =
=3D ~S" x s)))
-(defun* getenv-absolute-directory (x)
-  (getenv-pathname x :want-absolute t :want-directory t))
-(defun* getenv-absolute-directories (x)
-  (getenv-pathnames x :want-absolute t :want-directory t))
+;;;; Generic support for configuration files
+
+(asdf/package:define-package :asdf/configuration
+  (:recycle :asdf/configuration :asdf)
+  (:use :asdf/common-lisp :asdf/utility
+   :asdf/os :asdf/pathname :asdf/filesystem :asdf/stream :asdf/image)
+  (:export
+   #:get-folder-path
+   #:user-configuration-directories #:system-configuration-directories
+   #:in-first-directory
+   #:in-user-configuration-directory #:in-system-configuration-directory
+   #:validate-configuration-form #:validate-configuration-file #:validate-=
configuration-directory
+   #:configuration-inheritance-directive-p
+   #:report-invalid-form #:invalid-configuration #:*ignored-configuration-=
form*
+   #:*clear-configuration-hook* #:clear-configuration #:register-clear-con=
figuration-hook
+   #:resolve-location #:location-designator-p #:location-function-p #:*her=
e-directory*
+   #:resolve-relative-location #:resolve-absolute-location #:upgrade-confi=
guration))
+(in-package :asdf/configuration)
+
+(define-condition invalid-configuration ()
+  ((form :reader condition-form :initarg :form)
+   (location :reader condition-location :initarg :location)
+   (format :reader condition-format :initarg :format)
+   (arguments :reader condition-arguments :initarg :arguments :initform ni=
l))
+  (:report (lambda (c s)
+               (format s (compatfmt "~@<~? (will be skipped)~@:>")
+                       (condition-format c)
+                       (list* (condition-form c) (condition-location c)
+                              (condition-arguments c))))))
 =

 (defun* get-folder-path (folder)
   (or ;; this semi-portably implements a subset of the functionality of li=
spworks' sys:get-folder-path
@@ -3357,7 +4607,7 @@
     (:local-appdata (getenv-absolute-directory "LOCALAPPDATA"))
     (:appdata (getenv-absolute-directory "APPDATA"))
     (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA")
-			 (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Applicati=
on Data/"))))))
+                         (subpathname* (getenv-absolute-directory "ALLUSER=
SPROFILE") "Application Data/"))))))
 =

 (defun* user-configuration-directories ()
   (let ((dirs
@@ -3369,7 +4619,7 @@
            ,@(when (os-windows-p)
                `(,(subpathname* (get-folder-path :local-appdata) "common-l=
isp/config/")
                  ,(subpathname* (get-folder-path :appdata) "common-lisp/co=
nfig/")))
-           ,(subpathname (user-homedir) ".config/common-lisp/"))))
+           ,(subpathname (user-homedir-pathname) ".config/common-lisp/"))))
     (remove-duplicates (remove-if-not #'absolute-pathname-p dirs)
                        :from-end t :test 'equal)))
 =

@@ -3377,10 +4627,8 @@
   (cond
     ((os-unix-p) '(#p"/etc/common-lisp/"))
     ((os-windows-p)
-     (aif
-      ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windo=
ws\CurrentVersion\Explorer\User Shell Folders\Common AppData
-      (subpathname* (get-folder-path :common-appdata) "common-lisp/config/=
")
-      (list it)))))
+     (if-let (it (subpathname* (get-folder-path :common-appdata) "common-l=
isp/config/"))
+       (list it)))))
 =

 (defun* in-first-directory (dirs x &key (direction :input))
   (loop :with fun =3D (ecase direction
@@ -3448,26 +4696,14 @@
              description forms))
     (funcall validator (car forms) :location file)))
 =

-(defun* hidden-file-p (pathname)
-  (equal (first-char (pathname-name pathname)) #\.))
-
-(defun* directory* (pathname-spec &rest keys &key &allow-other-keys)
-  (apply 'directory pathname-spec
-         (append keys '#.(or #+allegro '(:directories-are-files nil :follo=
w-symbolic-links nil)
-                             #+clozure '(:follow-links nil)
-                             #+clisp '(:circle t :if-does-not-exist :ignor=
e)
-                             #+(or cmu scl) '(:follow-links nil :truenamep=
 nil)
-                             #+sbcl (when (find-symbol* :resolve-symlinks =
'#:sb-impl)
-                                      '(:resolve-symlinks nil))))))
-
 (defun* validate-configuration-directory (directory tag validator &key inv=
alid-form-reporter)
   "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will
 be applied to the results to yield a configuration form.  Current
 values of TAG include :source-registry and :output-translations."
   (let ((files (sort (ignore-errors
                        (remove-if
-                        'hidden-file-p
-                        (directory* (make-pathname :name :wild :type "conf=
" :defaults directory))))
+                        'hidden-pathname-p
+                        (directory* (make-pathname :name *wild* :type "con=
f" :defaults directory))))
                      #'string< :key #'namestring)))
     `(,tag
       ,@(loop :for file :in files :append
@@ -3485,13 +4721,2502 @@
                   :do (report-invalid-form invalid-form-reporter :form for=
m :location file)))
       :inherit-configuration)))
 =

-
-;;; ----------------------------------------------------------------------=
-----
-;;; asdf-output-translations
-;;;
-;;; this code is heavily inspired from
-;;; asdf-binary-translations, common-lisp-controller and cl-launch.
-;;; ----------------------------------------------------------------------=
-----
+(defun* resolve-relative-location (x &key ensure-directory wilden)
+  (ensure-pathname
+   (etypecase x
+     (pathname x)
+     (string (parse-unix-namestring
+              x :ensure-directory ensure-directory))
+     (cons
+      (if (null (cdr x))
+          (resolve-relative-location
+           (car x) :ensure-directory ensure-directory :wilden wilden)
+          (let* ((car (resolve-relative-location
+                       (car x) :ensure-directory t :wilden nil)))
+            (merge-pathnames*
+             (resolve-relative-location
+              (cdr x) :ensure-directory ensure-directory :wilden wilden)
+             car))))
+     ((eql :*/) *wild-directory*)
+     ((eql :**/) *wild-inferiors*)
+     ((eql :*.*.*) *wild-file*)
+     ((eql :implementation)
+      (parse-unix-namestring
+       (implementation-identifier) :ensure-directory t))
+     ((eql :implementation-type)
+      (parse-unix-namestring
+       (string-downcase (implementation-type)) :ensure-directory t))
+     ((eql :hostname)
+      (parse-unix-namestring (hostname) :ensure-directory t)))
+  :wilden (and wilden (not (pathnamep x)) (not (member x '(:*/ :**/ :*.*.*=
))))
+  :want-relative t))
+
+(defvar *here-directory* nil
+  "This special variable is bound to the currect directory during calls to
+PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here
+directive.")
+
+(defvar *user-cache* nil
+  "A specification as per RESOLVE-LOCATION of where the user keeps his FAS=
L cache")
+
+(defun compute-user-cache ()
+  (setf *user-cache*
+        (flet ((try (x &rest sub) (and x `(,x , at sub))))
+          (or
+           (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp"=
 :implementation)
+           (when (os-windows-p)
+             (try (or (get-folder-path :local-appdata)
+                      (get-folder-path :appdata))
+                  "common-lisp" "cache" :implementation))
+           '(:home ".cache" "common-lisp" :implementation)))))
+(register-image-restore-hook 'compute-user-cache)
+
+(defun* resolve-absolute-location (x &key ensure-directory wilden)
+  (ensure-pathname
+   (etypecase x
+     (pathname x)
+     (string
+      (let ((p #-mcl (parse-namestring x)
+               #+mcl (probe-posix x)))
+        #+mcl (unless p (error "POSIX pathname ~S does not exist" x))
+        (if ensure-directory (ensure-directory-pathname p) p)))
+     (cons
+      (return-from resolve-absolute-location
+        (if (null (cdr x))
+            (resolve-absolute-location
+             (car x) :ensure-directory ensure-directory :wilden wilden)
+            (merge-pathnames*
+             (resolve-relative-location
+              (cdr x) :ensure-directory ensure-directory :wilden wilden)
+             (resolve-absolute-location
+              (car x) :ensure-directory t :wilden nil)))))
+     ((eql :root)
+      ;; special magic! we return a relative pathname,
+      ;; but what it means to the output-translations is
+      ;; "relative to the root of the source pathname's host and device".
+      (return-from resolve-absolute-location
+        (let ((p (make-pathname* :directory '(:relative))))
+          (if wilden (wilden p) p))))
+     ((eql :home) (user-homedir-pathname))
+     ((eql :here) (resolve-absolute-location
+                   *here-directory* :ensure-directory t :wilden nil))
+     ((eql :user-cache) (resolve-absolute-location
+                         *user-cache* :ensure-directory t :wilden nil)))
+   :wilden (and wilden (not (pathnamep x)))
+   :resolve-symlinks *resolve-symlinks*
+   :want-absolute t))
+
+;; Try to override declaration in previous versions of ASDF.
+(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean)
+                             (:ensure-directory boolean)) t) resolve-locat=
ion))
+
+(defun* (resolve-location) (x &key ensure-directory wilden directory)
+  ;; :directory backward compatibility, until 2014-01-16: accept directory=
 as well as ensure-directory
+  (loop* :with dirp =3D (or directory ensure-directory)
+         :with (first . rest) =3D (if (atom x) (list x) x)
+         :with path =3D (resolve-absolute-location
+                       first :ensure-directory (and (or dirp rest) t)
+                             :wilden (and wilden (null rest)))
+         :for (element . morep) :on rest
+         :for dir =3D (and (or morep dirp) t)
+         :for wild =3D (and wilden (not morep))
+         :for sub =3D (merge-pathnames*
+                     (resolve-relative-location
+                      element :ensure-directory dir :wilden wild)
+                     path)
+         :do (setf path (if (absolute-pathname-p sub) (resolve-symlinks* s=
ub) sub))
+         :finally (return path)))
+
+(defun* location-designator-p (x)
+  (flet ((absolute-component-p (c)
+           (typep c '(or string pathname
+                      (member :root :home :here :user-cache))))
+         (relative-component-p (c)
+           (typep c '(or string pathname
+                      (member :*/ :**/ :*.*.* :implementation :implementat=
ion-type)))))
+    (or (typep x 'boolean)
+        (absolute-component-p x)
+        (and (consp x) (absolute-component-p (first x)) (every #'relative-=
component-p (rest x))))))
+
+(defun* location-function-p (x)
+  (and
+   (length=3Dn-p x 2)
+   (eq (car x) :function)
+   (or (symbolp (cadr x))
+       (and (consp (cadr x))
+            (eq (caadr x) 'lambda)
+            (length=3Dn-p (cadadr x) 2)))))
+
+(defvar *clear-configuration-hook* '())
+
+(defun* register-clear-configuration-hook (hook-function &optional call-no=
w-p)
+  (register-hook-function '*clear-configuration-hook* hook-function call-n=
ow-p))
+
+(defun* clear-configuration ()
+  (call-functions *clear-configuration-hook*))
+
+(register-image-dump-hook 'clear-configuration)
+
+;; If a previous version of ASDF failed to read some configuration, try ag=
ain.
+(defun* upgrade-configuration ()
+  (when *ignored-configuration-form*
+    (clear-configuration)
+    (setf *ignored-configuration-form* nil)))
+
+
+;;;; ---------------------------------------------------------------------=
----
+;;; Hacks for backward-compatibility of the driver
+
+(asdf/package:define-package :asdf/backward-driver
+  (:recycle :asdf/backward-driver :asdf)
+  (:use :asdf/common-lisp :asdf/package :asdf/utility
+   :asdf/pathname :asdf/stream :asdf/os :asdf/image
+   :asdf/run-program :asdf/lisp-build
+   :asdf/configuration)
+  (:export
+   #:coerce-pathname #:component-name-to-pathname-components
+   #+(or ecl mkcl) #:compile-file-keeping-object
+   ))
+(in-package :asdf/backward-driver)
+
+;;;; Backward compatibility with various pathname functions.
+
+(defun* coerce-pathname (name &key type defaults)
+  ;; For backward-compatibility only, for people using internals
+  ;; Reported users in quicklisp: hu.dwim.asdf, asdf-utils, xcvb
+  ;; Will be removed after 2014-01-16.
+  ;;(warn "Please don't use ASDF::COERCE-PATHNAME. Use ASDF/PATHNAME:PARSE=
-UNIX-NAMESTRING.")
+  (parse-unix-namestring name :type type :defaults defaults))
+
+(defun* component-name-to-pathname-components (unix-style-namestring
+                                               &key force-directory force-=
relative)
+  ;; Will be removed after 2014-01-16.
+  ;; (warn "Please don't use ASDF::COMPONENT-NAME-TO-PATHNAME-COMPONENTS, =
use SPLIT-UNIX-NAMESTRING-DIRECTORY-COMPONENTS")
+  (multiple-value-bind (relabs path filename file-only)
+      (split-unix-namestring-directory-components
+       unix-style-namestring :ensure-directory force-directory)
+    (declare (ignore file-only))
+    (when (and force-relative (not (eq relabs :relative)))
+      (error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~=
_~S~@:>")
+             unix-style-namestring))
+    (values relabs path filename)))
+
+#+(or ecl mkcl)
+(defun* compile-file-keeping-object (&rest args) (apply #'compile-file* ar=
gs))
+;;;; ---------------------------------------------------------------------=
------
+;;;; Re-export all the functionality in asdf/driver
+
+(asdf/package:define-package :asdf/driver
+  (:nicknames :d :asdf-driver :asdf-utils)
+  (:use :asdf/common-lisp :asdf/package :asdf/utility
+    :asdf/os :asdf/pathname :asdf/stream :asdf/filesystem :asdf/image
+   :asdf/run-program :asdf/lisp-build
+   :asdf/configuration :asdf/backward-driver)
+  (:reexport
+   ;; NB: excluding asdf/common-lisp
+   ;; which include all of CL with compatibility modifications on select p=
latforms.
+   :asdf/package :asdf/utility
+    :asdf/os :asdf/pathname :asdf/stream :asdf/filesystem :asdf/image
+   :asdf/run-program :asdf/lisp-build
+   :asdf/configuration :asdf/backward-driver))
+;;;; ---------------------------------------------------------------------=
----
+;;;; Handle upgrade as forward- and backward-compatibly as possible
+;; See https://bugs.launchpad.net/asdf/+bug/485687
+
+(asdf/package:define-package :asdf/upgrade
+  (:recycle :asdf/upgrade :asdf)
+  (:use :asdf/common-lisp :asdf/driver)
+  (:export
+   #:asdf-version #:*previous-asdf-versions* #:*asdf-version*
+   #:asdf-message #:*verbose-out*
+   #:upgrading-p #:when-upgrading #:upgrade-asdf #:asdf-upgrade-error
+   #:*post-upgrade-cleanup-hook* #:*post-upgrade-restart-hook* #:cleanup-u=
pgraded-asdf
+   ;; There will be no symbol left behind!
+   #:intern*)
+  (:import-from :asdf/package #:intern* #:find-symbol*))
+(in-package :asdf/upgrade)
+
+;;; Special magic to detect if this is an upgrade
+
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (defun asdf-version ()
+    "Exported interface to the version of ASDF currently installed. A stri=
ng.
+You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-=
VERSION) \"3.4.5.67\")."
+    (when (find-package :asdf)
+      (or (symbol-value (find-symbol (string :*asdf-version*) :asdf))
+          (let ((ver (symbol-value (find-symbol (string :*asdf-revision*) =
:asdf))))
+            (etypecase ver
+              (string ver)
+              (cons (format nil "~{~D~^.~}" ver))
+              (null "1.0"))))))
+  (defvar *asdf-version* nil)
+  (defvar *previous-asdf-versions* nil)
+  (defvar *verbose-out* nil)
+  (defun* asdf-message (format-string &rest format-args)
+    (when *verbose-out* (apply 'format *verbose-out* format-string format-=
args)))
+  (defvar *post-upgrade-cleanup-hook* ())
+  (defvar *post-upgrade-restart-hook* ())
+  (defun* upgrading-p ()
+    (and *previous-asdf-versions* (not (equal *asdf-version* (first *previ=
ous-asdf-versions*)))))
+  (defmacro when-upgrading ((&key (upgrading-p '(upgrading-p)) when) &body=
 body)
+    `(eval-when (:compile-toplevel :load-toplevel :execute)
+       (when (and ,upgrading-p ,@(when when `(,when)))
+         (handler-bind ((style-warning #'muffle-warning))
+           (eval '(progn , at body))))))
+  (let* (;; For bug reporting sanity, please always bump this version when=
 you modify this file.
+         ;; Please also modify asdf.asd to reflect this change. make bump-=
version v=3D3.4.5.67.8
+         ;; can help you do these changes in synch (look at the source for=
 documentation).
+         ;; Relying on its automation, the version is now redundantly pres=
ent on top of this file.
+         ;; "3.4" would be the general branch for major version 3, minor v=
ersion 4.
+         ;; "3.4.5" would be an official release in the 3.4 branch.
+         ;; "3.4.5.67" would be a development version in the official upst=
ream of 3.4.5.
+         ;; "3.4.5.0.8" would be your eighth local modification of officia=
l release 3.4.5
+         ;; "3.4.5.67.8" would be your eighth local modification of develo=
pment version 3.4.5.67
+         (asdf-version "2.27")
+         (existing-version (asdf-version)))
+    (setf *asdf-version* asdf-version)
+    (when (and existing-version (not (equal asdf-version existing-version)=
))
+      (push existing-version *previous-asdf-versions*)
+      (when (or *load-verbose* *verbose-out*)
+        (format *trace-output*
+                (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]=
to version ~A~@:>~%")
+                existing-version asdf-version)))))
+
+(when-upgrading ()
+  (let ((redefined-functions ;; gf signature and/or semantics changed inco=
mpatibly. Oops.
+          '(#:component-relative-pathname #:component-parent-pathname ;; c=
omponent
+            #:source-file-type
+            #:find-system #:system-source-file #:system-relative-pathname =
;; system
+             #:find-component ;; find-component
+             #:explain #:perform #:perform-with-restarts #:input-files #:o=
utput-files ;; action
+             #:component-depends-on #:component-self-dependencies #:operat=
ion-done-p
+             #:traverse ;; plan
+             #:operate  ;; operate
+             #:apply-output-translations ;; output-translations
+             #:process-output-translations-directive
+             #:inherit-source-registry #:process-source-registry ;; source=
-registry
+             #:process-source-registry-directive
+             #:trivial-system-p ;; bundle
+             ;; NB: it's too late to do anything about asdf-driver functio=
ns!
+             ))
+         (uninterned-symbols
+           '(#:*asdf-revision* #:around #:asdf-method-combination
+             #:split #:make-collector #:do-dep #:do-one-dep
+             #:resolve-relative-location-component #:resolve-absolute-loca=
tion-component
+             #:output-files-for-system-and-operation))) ; obsolete ASDF-BI=
NARY-LOCATION function
+    (declare (ignorable redefined-functions uninterned-symbols))
+    (loop :for name :in (append #-(or ecl) redefined-functions)
+          :for sym =3D (find-symbol* name :asdf nil) :do
+            (when sym
+              (fmakunbound sym)))
+    (loop :with asdf =3D (find-package :asdf)
+          :for name :in (append #+(or ecl) redefined-functions uninterned-=
symbols) ;XXX
+          :for sym =3D (find-symbol* name :asdf nil)
+          :for base-pkg =3D (and sym (symbol-package sym)) :do
+            (when sym
+              (cond
+                ((or (eq base-pkg asdf) (not base-pkg))
+                 (unintern* sym asdf)
+                 (intern* sym asdf))
+                (t
+                 (unintern* sym base-pkg)
+                 (let ((new (intern* sym base-pkg)))
+                   (shadowing-import new asdf))))))))
+
+
+;;; Self-upgrade functions
+
+(defun* asdf-upgrade-error ()
+  ;; Important notice for whom it concerns. The crux of the matter is that
+  ;; TRAVERSE can be completely refactored, and so after the find-system r=
eturns, it's too late.
+  (error "When a system transitively depends on ASDF, it must :defsystem-d=
epends-on (:asdf)~%~
+          Otherwise, when you upgrade from ASDF 2, you must do it before y=
ou operate on any system.~%"))
+
+(defun* cleanup-upgraded-asdf (&optional (old-version (first *previous-asd=
f-versions*)))
+  (let ((new-version (asdf-version)))
+    (unless (equal old-version new-version)
+      (push new-version *previous-asdf-versions*)
+      (when old-version
+        (cond
+          ((version-compatible-p new-version old-version)
+           (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version =
~A to version ~A~@:>~%")
+                         old-version new-version))
+          ((version-compatible-p 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)))
+        (call-functions (reverse *post-upgrade-cleanup-hook*))
+        t))))
+
+(defun* upgrade-asdf ()
+  "Try to upgrade of ASDF. If a different version was used, return T.
+   We need do that before we operate on anything that may possibly depend =
on ASDF."
+  (let ((*load-print* nil)
+        (*compile-print* nil))
+    (handler-bind (((or style-warning warning) #'muffle-warning))
+      (symbol-call :asdf :load-system :asdf :verbose nil))))
+
+(register-hook-function '*post-upgrade-cleanup-hook* 'upgrade-configuratio=
n)
+;;;; ---------------------------------------------------------------------=
----
+;;;; Components
+
+(asdf/package:define-package :asdf/component
+  (:recycle :asdf/component :asdf)
+  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
+  (:export
+   #:component #:component-find-path
+   #:component-name #:component-pathname #:component-relative-pathname
+   #:component-parent #:component-system #:component-parent-pathname
+   #:child-component #:parent-component #:module
+   #:file-component
+   #:source-file #:c-source-file #:java-source-file
+   #:static-file #:doc-file #:html-file
+   #:source-file-type ;; backward-compatibility
+   #:component-in-order-to #:component-sibling-dependencies
+   #:component-if-feature #:around-compile-hook
+   #:component-description #:component-long-description
+   #:component-version #:version-satisfies
+   #:component-inline-methods ;; backward-compatibility only. DO NOT USE!
+   #:component-operation-times ;; For internal use only.
+   ;; portable ASDF encoding and implementation-specific external-format
+   #:component-external-format #:component-encoding
+   #:component-children-by-name #:component-children #:compute-children-by=
-name
+   #:component-build-operation
+   #:module-default-component-class
+   #:module-components ;; backward-compatibility. DO NOT USE.
+   #:sub-components
+
+   ;; Internals we'd like to share with the ASDF package, especially for u=
pgrade purposes
+   #:name #:version #:description #:long-description #:author #:maintainer=
 #:licence
+   #:components-by-name #:components
+   #:children #:children-by-name #:default-component-class
+   #:author #:maintainer #:licence #:source-file #:defsystem-depends-on
+   #:sibling-dependencies #:if-feature #:in-order-to #:inline-methods
+   #:relative-pathname #:absolute-pathname #:operation-times #:around-comp=
ile
+   #:%encoding #:properties #:component-properties #:parent))
+(in-package :asdf/component)
+
+(defgeneric* component-name (component)
+  (:documentation "Name of the COMPONENT, unique relative to its parent"))
+(defgeneric* component-system (component)
+  (:documentation "Find the top-level system containing COMPONENT"))
+(defgeneric* component-pathname (component)
+  (:documentation "Extracts the pathname applicable for a particular compo=
nent."))
+(defgeneric* (component-relative-pathname) (component)
+  (:documentation "Returns a pathname for the component argument intended =
to be
+interpreted relative to the pathname of that component's parent.
+Despite the function's name, the return value may be an absolute
+pathname, because an absolute pathname may be interpreted relative to
+another pathname in a degenerate way."))
+(defgeneric* component-external-format (component))
+(defgeneric* component-encoding (component))
+(defgeneric* version-satisfies (component version))
+
+;;; Backward compatible way of computing the FILE-TYPE of a component.
+;;; TODO: find users, have them stop using that.
+(defgeneric* (source-file-type) (component system))
+
+(when-upgrading (:when (find-class 'component nil))
+  (defmethod reinitialize-instance :after ((c component) &rest initargs &k=
ey)
+    (declare (ignorable c initargs)) (values)))
+
+(defclass component ()
+  ((name :accessor component-name :initarg :name :type string :documentati=
on
+         "Component name: designator for a string composed of portable pat=
hname characters")
+   ;; We might want to constrain version with
+   ;; :type (and string (satisfies parse-version))
+   ;; but we cannot until we fix all systems that don't use it correctly!
+   (version :accessor component-version :initarg :version :initform nil)
+   (description :accessor component-description :initarg :description :ini=
tform nil)
+   (long-description :accessor component-long-description :initarg :long-d=
escription :initform nil)
+   (sibling-dependencies :accessor component-sibling-dependencies :initfor=
m nil)
+   (if-feature :accessor component-if-feature :initform nil :initarg :if-f=
eature)
+   ;; In the ASDF object model, dependencies exist between *actions*,
+   ;; where an action is a pair of an operation and a component.
+   ;; Dependencies are represented as alists of operations
+   ;; to a list where each entry is a pair of an operation and a list of c=
omponent specifiers.
+   ;; Up until ASDF 2.26.9, there used to be two kinds of dependencies:
+   ;; in-order-to and do-first, each stored in its own slot. Now there is =
only in-order-to.
+   ;; in-order-to used to represent things that modify the filesystem (suc=
h as compiling a fasl)
+   ;; and do-first things that modify the current image (such as loading a=
 fasl).
+   ;; These are now unified because we now correctly propagate timestamps =
between dependencies.
+   ;; Happily, no one seems to have used do-first too much (especially sin=
ce until ASDF 2.017,
+   ;; anything you specified was overridden by ASDF itself anyway), but th=
e name in-order-to remains.
+   ;; The names are bad, but they have been the official API since Dan Bar=
low's ASDF 1.52!
+   ;; LispWorks's defsystem has caused-by and requires for in-order-to and=
 do-first respectively.
+   ;; Maybe rename the slots in ASDF? But that's not very backward-compati=
ble.
+   ;; See our ASDF 2 paper for more complete explanations.
+   (in-order-to :initform nil :initarg :in-order-to
+                :accessor component-in-order-to)
+   ;; methods defined using the "inline" style inside a defsystem form:
+   ;; need to store them somewhere so we can delete them when the system
+   ;; is re-evaluated.
+   (inline-methods :accessor component-inline-methods :initform nil) ;; OB=
SOLETE! DELETE THIS IF NO ONE USES.
+   ;; ASDF4: rename it from relative-pathname to specified-pathname. It ne=
ed not be relative.
+   ;; There is no initform and no direct accessor for this specified pathn=
ame,
+   ;; so we only access the information through appropriate methods, after=
 it has been processed.
+   ;; Unhappily, some braindead systems directly access the slot. Make the=
m stop before ASDF4.
+   (relative-pathname :initarg :pathname)
+   ;; The absolute-pathname is computed based on relative-pathname and par=
ent pathname.
+   ;; The slot is but a cache used by component-pathname.
+   (absolute-pathname)
+   (operation-times :initform (make-hash-table)
+                    :accessor component-operation-times)
+   (around-compile :initarg :around-compile)
+   ;; Properties are for backward-compatibility with ASDF2 only. DO NOT US=
E!
+   (properties :accessor component-properties :initarg :properties
+               :initform nil)
+   (%encoding :accessor %component-encoding :initform nil :initarg :encodi=
ng)
+   ;; For backward-compatibility, this slot is part of component rather th=
an of child-component. ASDF4: stop it.
+   (parent :initarg :parent :initform nil :reader component-parent)
+   (build-operation
+    :initarg :build-operation :initform nil :reader component-build-operat=
ion)))
+
+(defun* component-find-path (component)
+  (check-type component (or null component))
+  (reverse
+   (loop :for c =3D component :then (component-parent c)
+         :while c :collect (component-name c))))
+
+(defmethod print-object ((c component) stream)
+  (print-unreadable-object (c stream :type t :identity nil)
+    (format stream "~{~S~^ ~}" (component-find-path c))))
+
+(defmethod component-system ((component component))
+  (if-let (system (component-parent component))
+    (component-system system)
+    component))
+
+
+;;;; Component hierarchy within a system
+;; The tree typically but not necessarily follows the filesystem hierarchy.
+
+(defclass child-component (component) ())
+
+(defclass file-component (child-component)
+  ((type :accessor file-type :initarg :type))) ; no default
+(defclass source-file (file-component)
+  ((type :initform nil))) ;; NB: many systems have come to rely on this de=
fault.
+(defclass c-source-file (source-file)
+  ((type :initform "c")))
+(defclass java-source-file (source-file)
+  ((type :initform "java")))
+(defclass static-file (source-file)
+  ((type :initform nil)))
+(defclass doc-file (static-file) ())
+(defclass html-file (doc-file)
+  ((type :initform "html")))
+
+(defclass parent-component (component)
+  ((children
+    :initform nil
+    :initarg :components
+    :reader module-components ; backward-compatibility
+    :accessor component-children)
+   (children-by-name
+    :reader module-components-by-name ; backward-compatibility
+    :accessor component-children-by-name)
+   (default-component-class
+    :initform nil
+    :initarg :default-component-class
+    :accessor module-default-component-class)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun* compute-children-by-name (parent &key only-if-needed-p)
+    (unless (and only-if-needed-p (slot-boundp parent 'children-by-name))
+      (let ((hash (make-hash-table :test 'equal)))
+        (setf (component-children-by-name parent) hash)
+        (loop :for c :in (component-children parent)
+              :for name =3D (component-name c)
+              :for previous =3D (gethash name hash)
+              :do (when previous (error 'duplicate-names :name name))
+                  (setf (gethash name hash) c))
+        hash))))
+
+(when-upgrading (:when (find-class 'module nil))
+  (defmethod reinitialize-instance :after ((m module) &rest initargs &key)
+    (declare (ignorable m initargs)) (values))
+  (defmethod update-instance-for-redefined-class :after
+      ((m module) added deleted plist &key)
+    (declare (ignorable m added deleted plist))
+    (when (and (member 'children added) (member 'components deleted))
+      (setf (slot-value m 'children)
+            ;; old ECLs provide an alist instead of a plist(!)
+            (if (or #+ecl (consp (first plist))) (or #+ecl (cdr (assoc 'co=
mponents plist)))
+                (getf plist 'components)))
+      (compute-children-by-name m))))
+
+(defclass module (child-component parent-component)
+  (#+clisp (components))) ;; backward compatibility during upgrade only
+
+
+;;;; component pathnames
+
+(defgeneric* (component-parent-pathname) (component))
+(defmethod component-parent-pathname (component)
+  (component-pathname (component-parent component)))
+
+(defmethod component-pathname ((component component))
+  (if (slot-boundp component 'absolute-pathname)
+      (slot-value component 'absolute-pathname)
+      (let ((pathname
+             (merge-pathnames*
+              (component-relative-pathname component)
+              (pathname-directory-pathname (component-parent-pathname comp=
onent)))))
+        (unless (or (null pathname) (absolute-pathname-p pathname))
+          (error (compatfmt "~@<Invalid relative pathname ~S for component=
 ~S~@:>")
+                 pathname (component-find-path component)))
+        (setf (slot-value component 'absolute-pathname) pathname)
+        pathname)))
+
+(defmethod component-relative-pathname ((component component))
+  ;; source-file-type is backward-compatibility with ASDF1;
+  ;; we ought to be able to extract this from the component alone with COM=
PONENT-TYPE.
+  ;; TODO: track who uses it, and have them not use it anymore.
+  (parse-unix-namestring
+   (or (and (slot-boundp component 'relative-pathname)
+            (slot-value component 'relative-pathname))
+       (component-name component))
+   :want-relative t
+   :type (source-file-type component (component-system component))
+   :defaults (component-parent-pathname component)))
+
+(defmethod source-file-type ((component parent-component) system)
+  (declare (ignorable component system))
+  :directory)
+
+(defmethod source-file-type ((component file-component) system)
+  (declare (ignorable system))
+  (file-type component))
+
+
+;;;; Encodings
+
+(defmethod component-encoding ((c component))
+  (or (loop :for x =3D c :then (component-parent x)
+        :while x :thereis (%component-encoding x))
+      (detect-encoding (component-pathname c))))
+
+(defmethod component-external-format ((c component))
+  (encoding-external-format (component-encoding c)))
+
+
+;;;; around-compile-hook
+
+(defgeneric* around-compile-hook (component))
+(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)))))
+
+
+;;;; version-satisfies
+
+(defmethod version-satisfies ((c component) version)
+  (unless (and version (slot-boundp c 'version))
+    (when version
+      (warn "Requested version ~S but component ~S has no version" version=
 c))
+    (return-from version-satisfies t))
+  (version-satisfies (component-version c) version))
+
+(defmethod version-satisfies ((cver string) version)
+  (version-compatible-p cver version))
+
+
+;;; all sub-components (of a given type)
+
+(defun* sub-components (component &key (type t))
+  (while-collecting (c)
+    (labels ((recurse (x)
+               (when (if-let (it (component-if-feature x)) (featurep it) t)
+                 (when (typep x type)
+                   (c x))
+                 (when (typep x 'parent-component)
+                   (map () #'recurse (component-children x))))))
+      (recurse component))))
+
+;;;; ---------------------------------------------------------------------=
----
+;;;; Systems
+
+(asdf/package:define-package :asdf/system
+  (:recycle :asdf :asdf/system)
+  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/component)
+  (:export
+   #:system #:proto-system
+   #:system-source-file #:system-source-directory #:system-relative-pathna=
me
+   #:reset-system
+   #:system-description #:system-long-description
+   #:system-author #:system-maintainer #:system-licence #:system-license
+   #:system-defsystem-depends-on
+   #:component-build-pathname #:build-pathname
+   #:component-entry-point #:entry-point
+   #:homepage #:system-homepage
+   #:bug-tracker #:system-bug-tracker
+   #:mailto #:system-mailto
+   #:long-name #:system-long-name
+   #:source-control #:system-source-control
+   #:find-system #:builtin-system-p)) ;; forward-reference, defined in fin=
d-system
+(in-package :asdf/system)
+
+(defgeneric* (find-system) (system &optional error-p))
+(defgeneric* (system-source-file) (system)
+  (:documentation "Return the source file in which system is defined."))
+(defgeneric* component-build-pathname (component))
+
+(defgeneric* component-entry-point (component))
+(defmethod component-entry-point ((c component))
+  (declare (ignorable c))
+  nil)
+
+
+;;;; The system class
+
+(defclass proto-system () ; slots to keep when resetting a system
+  ;; To preserve identity for all objects, we'd need keep the components s=
lots
+  ;; but also to modify parse-component-form to reset the recycled objects.
+  ((name) (source-file) #|(children) (children-by-names)|#))
+
+(defclass system (module proto-system)
+  ;; Backward-compatibility: inherit from module. ASDF4: only inherit from=
 parent-component.
+  (;; {,long-}description is now inherited from component, but we add the =
legacy accessors
+   (description :accessor system-description)
+   (long-description :accessor system-long-description)
+   (author :accessor system-author :initarg :author :initform nil)
+   (maintainer :accessor system-maintainer :initarg :maintainer :initform =
nil)
+   (licence :accessor system-licence :initarg :licence
+            :accessor system-license :initarg :license :initform nil)
+   (homepage :accessor system-homepage :initarg :homepage :initform nil)
+   (bug-tracker :accessor system-bug-tracker :initarg :bug-tracker :initfo=
rm nil)
+   (mailto :accessor system-mailto :initarg :mailto :initform nil)
+   (long-name :accessor system-long-name :initarg :long-name :initform nil)
+   ;; Conventions for this slot aren't clear yet as of ASDF 2.27, but when=
ever they are, they will be enforced.
+   ;; I'm introducing the slot before the conventions are set for maximum =
compatibility.
+   (source-control :accessor system-source-control :initarg :source-contro=
l :initform nil)
+   (builtin-system-p :accessor builtin-system-p :initform nil :initarg :bu=
iltin-system-p)
+   (build-pathname
+    :initform nil :initarg :build-pathname :accessor component-build-pathn=
ame)
+   (entry-point
+    :initform nil :initarg :entry-point :accessor component-entry-point)
+   (source-file :initform nil :initarg :source-file :accessor system-sourc=
e-file)
+   (defsystem-depends-on :reader system-defsystem-depends-on :initarg :def=
system-depends-on)))
+
+(defun* reset-system (system &rest keys &key &allow-other-keys)
+  (change-class (change-class system 'proto-system) 'system)
+  (apply 'reinitialize-instance system keys))
+
+
+;;;; Pathnames
+
+(defmethod system-source-file ((system-name string))
+  (system-source-file (find-system system-name)))
+(defmethod system-source-file ((system-name symbol))
+  (system-source-file (find-system system-name)))
+
+(defun* system-source-directory (system-designator)
+  "Return a pathname object corresponding to the directory
+in which the system specification (.asd file) is located."
+  (pathname-directory-pathname (system-source-file system-designator)))
+
+(defun* (system-relative-pathname) (system name &key type)
+  (subpathname (system-source-directory system) name :type type))
+
+(defmethod component-pathname ((system system))
+  (let ((pathname (or (call-next-method) (system-source-directory system))=
))
+    (unless (and (slot-boundp system 'relative-pathname) ;; backward-compa=
tibility with ASDF1-age
+                 (slot-value system 'relative-pathname)) ;; systems that d=
irectly access this slot.
+      (setf (slot-value system 'relative-pathname) pathname))
+    pathname))
+
+(defmethod component-relative-pathname ((system system))
+  (parse-unix-namestring
+   (and (slot-boundp system 'relative-pathname)
+        (slot-value system 'relative-pathname))
+   :want-relative t
+   :type :directory
+   :ensure-absolute t
+   :defaults (system-source-directory system)))
+
+(defmethod component-parent-pathname ((system system))
+  (system-source-directory system))
+
+(defmethod component-build-pathname ((c component))
+  (declare (ignorable c))
+  nil)
+;;;; ---------------------------------------------------------------------=
----
+;;;; Stamp cache
+
+(asdf/package:define-package :asdf/cache
+  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
+  (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp
+           #:consult-asdf-cache #:do-asdf-cache
+           #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*))
+(in-package :asdf/cache)
+
+;;; This stamp cache is useful for:
+;; * consistency of stamps used within a single run
+;; * fewer accesses to the filesystem
+;; * the ability to test with fake timestamps, without touching files
+
+(defvar *asdf-cache* nil)
+
+(defun set-asdf-cache-entry (key value-list)
+  (apply 'values
+         (if *asdf-cache*
+             (setf (gethash key *asdf-cache*) value-list)
+             value-list)))
+
+(defun consult-asdf-cache (key thunk)
+  (if *asdf-cache*
+      (multiple-value-bind (results foundp) (gethash key *asdf-cache*)
+        (if foundp
+            (apply 'values results)
+            (set-asdf-cache-entry key (multiple-value-list (funcall thunk)=
))))
+      (funcall thunk)))
+
+(defmacro do-asdf-cache (key &body body)
+  `(consult-asdf-cache ,key #'(lambda () , at body)))
+
+(defun call-with-asdf-cache (thunk &key override)
+  (if (and *asdf-cache* (not override))
+      (funcall thunk)
+      (let ((*asdf-cache* (make-hash-table :test 'equal)))
+        (funcall thunk))))
+
+(defmacro with-asdf-cache ((&key override) &body body)
+  `(call-with-asdf-cache #'(lambda () , at body) :override ,override))
+
+(defun compute-file-stamp (file)
+  (safe-file-write-date file))
+
+(defun register-file-stamp (file &optional (stamp (compute-file-stamp file=
)))
+  (set-asdf-cache-entry `(get-file-stamp ,file) (list stamp)))
+
+(defun get-file-stamp (file)
+  (do-asdf-cache `(get-file-stamp ,file) (compute-file-stamp file)))
+;;;; ---------------------------------------------------------------------=
----
+;;;; Finding systems
+
+(asdf/package:define-package :asdf/find-system
+  (:recycle :asdf/find-system :asdf)
+  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
+   :asdf/component :asdf/system :asdf/cache)
+  (:export
+   #:remove-entry-from-registry #:coerce-entry-to-directory
+   #:coerce-name #:primary-system-name
+   #:find-system #:locate-system #:load-asd #:with-system-definitions
+   #:system-registered-p #:register-system #:registered-systems #:clear-sy=
stem #:map-systems
+   #:system-definition-error #:missing-component #:missing-requires #:miss=
ing-parent
+   #:formatted-system-definition-error #:format-control #:format-arguments=
 #:sysdef-error
+   #:load-system-definition-error #:error-name #:error-pathname #:error-co=
ndition
+   #:*system-definition-search-functions* #:search-for-system-definition
+   #:*central-registry* #:probe-asd #:sysdef-central-registry-search
+   #:find-system-if-being-defined #:*systems-being-defined*
+   #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility sy=
mbols, functions removed
+   #:system-find-preloaded-system #:register-preloaded-system #:*preloaded=
-systems*
+   #:clear-defined-systems #:*defined-systems*
+   ;; defined in source-registry, but specially mentioned here:
+   #:initialize-source-registry #:sysdef-source-registry-search))
+(in-package :asdf/find-system)
+
+(declaim (ftype (function (&optional t) t) initialize-source-registry)) ; =
forward reference
+
+(define-condition system-definition-error (error) ()
+  ;; [this use of :report should be redundant, but unfortunately it's not.
+  ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-fun=
ction
+  ;; over print-object; this is always conditions::%print-condition for
+  ;; condition objects, which in turn does inheritance of :report options =
at
+  ;; run-time.  fortunately, inheritance means we only need this kludge he=
re in
+  ;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]
+  #+cmu (:report print-object))
+
+(define-condition missing-component (system-definition-error)
+  ((requires :initform "(unnamed)" :reader missing-requires :initarg :requ=
ires)
+   (parent :initform nil :reader missing-parent :initarg :parent)))
+
+(define-condition formatted-system-definition-error (system-definition-err=
or)
+  ((format-control :initarg :format-control :reader format-control)
+   (format-arguments :initarg :format-arguments :reader format-arguments))
+  (:report (lambda (c s)
+               (apply 'format s (format-control c) (format-arguments c)))))
+
+(define-condition load-system-definition-error (system-definition-error)
+  ((name :initarg :name :reader error-name)
+   (pathname :initarg :pathname :reader error-pathname)
+   (condition :initarg :condition :reader error-condition))
+  (:report (lambda (c s)
+             (format s (compatfmt "~@<Error while trying to load definitio=
n for system ~A from pathname ~A: ~3i~_~A~@:>")
+                     (error-name c) (error-pathname c) (error-condition c)=
))))
+
+(defun* sysdef-error (format &rest arguments)
+  (error 'formatted-system-definition-error :format-control
+         format :format-arguments arguments))
+
+(defvar *defined-systems* (make-hash-table :test 'equal)
+  "This is a hash table whose keys are strings, being the
+names of the systems, and whose values are pairs, the first
+element of which is a universal-time indicating when the
+system definition was last updated, and the second element
+of which is a system object.")
+
+(defun* clear-defined-systems ()
+  (setf *defined-systems* (make-hash-table :test 'equal)))
+
+(register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-system=
s nil)
+
+(defun* coerce-name (name)
+  (typecase name
+    (component (component-name name))
+    (symbol (string-downcase (symbol-name name)))
+    (string name)
+    (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~=
@:>") name))))
+
+(defun* primary-system-name (name)
+  ;; When a system name has slashes, the file with defsystem is named by
+  ;; the first of the slash-separated components.
+  (first (split-string (coerce-name name) :separator "/")))
+
+(defun* system-registered-p (name)
+  (gethash (coerce-name name) *defined-systems*))
+
+(defun* registered-systems ()
+  (loop :for registered :being :the :hash-values :of *defined-systems*
+    :collect (coerce-name (cdr registered))))
+
+(defun* register-system (system)
+  (check-type system system)
+  (let ((name (component-name system)))
+    (check-type name string)
+    (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system)
+    (unless (eq system (cdr (gethash name *defined-systems*)))
+      (setf (gethash name *defined-systems*)
+            (cons (if-let (file (ignore-errors (system-source-file system)=
))
+                    (get-file-stamp file))
+                  system)))))
+
+(defun* clear-system (name)
+  "Clear the entry for a system in the database of systems previously load=
ed.
+Note that this does NOT in any way cause the code of the system to be unlo=
aded."
+  ;; There is no "unload" operation in Common Lisp, and
+  ;; a general such operation cannot be portably written,
+  ;; considering how much CL relies on side-effects to global data structu=
res.
+  (remhash (coerce-name name) *defined-systems*))
+
+(defun* map-systems (fn)
+  "Apply FN to each defined system.
+
+FN should be a function of one argument. It will be
+called with an object of type asdf:system."
+  (loop :for registered :being :the :hash-values :of *defined-systems*
+     :do (funcall fn (cdr registered))))
+
+;;; for the sake of keeping things reasonably neat, we adopt a
+;;; convention that functions in this list are prefixed SYSDEF-
+
+(defvar *system-definition-search-functions* '())
+
+(defun cleanup-system-definition-search-functions ()
+  (setf *system-definition-search-functions*
+        (append
+         ;; Remove known-incompatible sysdef functions from old versions o=
f asdf.
+         (remove-if #'(lambda (x) (member x '(contrib-sysdef-search sysdef=
-find-asdf)))
+                    *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-func=
tions*))
+                    '(sysdef-central-registry-search
+                      sysdef-source-registry-search
+                      sysdef-find-preloaded-systems)))))
+(cleanup-system-definition-search-functions)
+
+(defun* search-for-system-definition (system)
+  (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
+"A list of 'system directory designators' ASDF uses to find systems.
+
+A 'system directory designator' is a pathname or an expression
+which evaluates to a pathname. For example:
+
+    (setf asdf:*central-registry*
+          (list '*default-pathname-defaults*
+                #p\"/home/me/cl/systems/\"
+                #p\"/usr/share/common-lisp/systems/\"))
+
+This is for backward compatibility.
+Going forward, we recommend new users should be using the source-registry.
+")
+
+(defun* probe-asd (name defaults &key truename)
+  (block nil
+    (when (directory-pathname-p defaults)
+      (if-let (file (probe-file*
+                     (ensure-absolute-pathname
+                      (parse-unix-namestring name :type "asd")
+                      #'(lambda () (ensure-absolute-pathname defaults 'get=
-pathname-defaults nil))
+                      nil)
+                     :truename truename))
+        (return file))
+      #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't ha=
ve read-sequence(!)
+      (when (os-windows-p)
+        (let ((shortcut
+               (make-pathname
+                :defaults defaults :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)
+  (let ((name (primary-system-name system))
+        (to-remove nil)
+        (to-replace nil))
+    (block nil
+      (unwind-protect
+           (dolist (dir *central-registry*)
+             (let ((defaults (eval dir))
+                   directorized)
+               (when defaults
+                 (cond ((directory-pathname-p defaults)
+                        (let* ((file (probe-asd name defaults :truename *r=
esolve-symlinks*)))
+                          (when file
+                            (return file))))
+                       (t
+                        (restart-case
+                            (let* ((*print-circle* nil)
+                                   (message
+                                    (format nil
+                                            (compatfmt "~@<While searching=
 for system ~S: ~3i~_~S evaluated to ~S which is not an absolute directory.=
~@:>")
+                                            system dir defaults)))
+                              (error message))
+                          (remove-entry-from-registry ()
+                            :report "Remove entry from *central-registry* =
and continue"
+                            (push dir to-remove))
+                          (coerce-entry-to-directory ()
+                            :test (lambda (c) (declare (ignore c))
+                                    (and (not (directory-pathname-p defaul=
ts))
+                                         (directory-pathname-p
+                                          (setf directorized
+                                                (ensure-directory-pathname=
 defaults)))))
+                            :report (lambda (s)
+                                      (format s (compatfmt "~@<Coerce entr=
y to ~a, replace ~a and continue.~@:>")
+                                              directorized dir))
+                            (push (cons dir directorized) to-replace))))))=
))
+        ;; cleanup
+        (dolist (dir to-remove)
+          (setf *central-registry* (remove dir *central-registry*)))
+        (dolist (pair to-replace)
+          (let* ((current (car pair))
+                 (new (cdr pair))
+                 (position (position current *central-registry*)))
+            (setf *central-registry*
+                  (append (subseq *central-registry* 0 position)
+                          (list new)
+                          (subseq *central-registry* (1+ position))))))))))
+
+(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~@:>"))))
+
+(defmethod find-system (name &optional (error-p t))
+  (find-system (coerce-name name) error-p))
+
+(defvar *systems-being-defined* nil
+  "A hash-table of systems currently being defined keyed by name, or NIL")
+
+(defun* find-system-if-being-defined (name)
+  (when *systems-being-defined*
+    (gethash (coerce-name name) *systems-being-defined*)))
+
+(defun* call-with-system-definitions (thunk)
+  (if *systems-being-defined*
+      (call-with-asdf-cache thunk)
+      (let ((*systems-being-defined* (make-hash-table :test 'equal)))
+        (call-with-asdf-cache thunk))))
+
+(defmacro with-system-definitions ((&optional) &body body)
+  `(call-with-system-definitions #'(lambda () , at body)))
+
+(defun* load-asd (pathname &key name (external-format (encoding-external-f=
ormat (detect-encoding pathname))))
+  ;; Tries to load system definition with canonical NAME from PATHNAME.
+  (with-system-definitions ()
+    (with-standard-io-syntax
+      (let ((*package* (find-package :asdf-user))
+            (*print-readably* nil)
+            (*default-pathname-defaults*
+              ;; resolve logical-pathnames so they won't wreak havoc in pa=
rsing namestrings.
+              (pathname-directory-pathname (translate-logical-pathname pat=
hname))))
+        (handler-bind
+            ((error #'(lambda (condition)
+                        (error 'load-system-definition-error
+                               :name name :pathname pathname
+                               :condition condition))))
+          (asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[=
 for ~A~] from ~A~@:>~%")
+                        name pathname)
+          (with-muffled-loader-conditions ()
+            (load* pathname :external-format external-format)))))))
+
+(defun* locate-system (name)
+  "Given a system NAME designator, try to locate where to load the system =
from.
+Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
+FOUNDP is true when a system 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,
+either 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 l=
oaded."
+  (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))))
+         (pathname (ensure-pathname (resolve-symlinks* pathname) :want-abs=
olute t))
+         (foundp (and (or found-system pathname previous) t)))
+    (check-type found (or null pathname system))
+    (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 prev=
ious-time)
+              (locate-system name)
+            (assert (eq foundp (and (or found-system pathname previous) t)=
))
+            (let ((previous-pathname (and previous (system-source-file pre=
vious)))
+                  (system (or previous found-system)))
+              (when (and found-system (not previous))
+                (register-system found-system))
+              (when (and system pathname)
+                (setf (system-source-file system) pathname))
+              (when (and pathname
+                         (let ((stamp (get-file-stamp pathname)))
+                           (and stamp
+                                (not (and previous
+                                          (or (pathname-equal pathname pre=
vious-pathname)
+                                              (and pathname previous-pathn=
ame
+                                                   (pathname-equal
+                                                    (translate-logical-pat=
hname pathname)
+                                                    (translate-logical-pat=
hname previous-pathname))))
+                                          (stamp<=3D stamp previous-time))=
))))
+                ;; only load when it's a pathname that is different or has=
 newer content
+                (load-asd pathname :name name)))
+            (let ((in-memory (system-registered-p name))) ; try again afte=
r loading from disk if needed
+              (return
+                (cond
+                  (in-memory
+                   (when pathname
+                     (setf (car in-memory) (get-file-stamp pathname)))
+                   (cdr in-memory))
+                  (error-p
+                   (error 'missing-component :requires name))))))
+        (reinitialize-source-registry-and-retry ()
+          :report (lambda (s)
+                    (format s (compatfmt "~@<Retry finding system ~A after=
 reinitializing the source-registry.~@:>") name))
+          (initialize-source-registry))))))
+
+(defvar *preloaded-systems* (make-hash-table :test 'equal))
+
+(defun* sysdef-find-preloaded-systems (requested)
+  (let ((name (coerce-name requested)))
+    (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*)
+      (when foundp
+        (apply 'make-instance 'system :name name :source-file (getf keys :=
source-file) keys)))))
+
+(defun register-preloaded-system (system-name &rest keys)
+  (setf (gethash (coerce-name system-name) *preloaded-systems*) keys))
+
+(register-preloaded-system "asdf")
+(register-preloaded-system "asdf-driver")
+
+
+;;;; ---------------------------------------------------------------------=
----
+;;;; Finding components
+
+(asdf/package:define-package :asdf/find-component
+  (:recycle :asdf/find-component :asdf)
+  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
+   :asdf/component :asdf/system :asdf/find-system)
+  (:export
+   #:find-component
+   #:resolve-dependency-name #:resolve-dependency-spec
+   #:resolve-dependency-combination
+   ;; Conditions
+   #:missing-component #:missing-component-of-version #:retry
+   #:missing-dependency #:missing-dependency-of-version
+   #:missing-requires #:missing-parent
+   #:missing-required-by #:missing-version))
+(in-package :asdf/find-component)
+
+;;;; Missing component conditions
+
+(define-condition missing-component-of-version (missing-component)
+  ((version :initform nil :reader missing-version :initarg :version)))
+
+(define-condition missing-dependency (missing-component)
+  ((required-by :initarg :required-by :reader missing-required-by)))
+
+(defmethod print-object ((c missing-dependency) s)
+  (format s (compatfmt "~@<~A, required by ~A~@:>")
+          (call-next-method c nil) (missing-required-by c)))
+
+(define-condition missing-dependency-of-version (missing-dependency
+                                                 missing-component-of-vers=
ion)
+  ())
+
+(defmethod print-object ((c missing-component) s)
+  (format s (compatfmt "~@<Component ~S not found~@[ in ~A~]~@:>")
+          (missing-requires c)
+          (when (missing-parent c)
+            (coerce-name (missing-parent c)))))
+
+(defmethod print-object ((c missing-component-of-version) s)
+  (format s (compatfmt "~@<Component ~S does not match version ~A~@[ in ~A=
~]~@:>")
+          (missing-requires c)
+          (missing-version c)
+          (when (missing-parent c)
+            (coerce-name (missing-parent c)))))
+
+
+;;;; Finding components
+
+(defgeneric* (find-component) (base path)
+  (:documentation "Find a component by resolving the PATH starting from BA=
SE parent"))
+(defgeneric* resolve-dependency-combination (component combinator argument=
s))
+
+(defmethod find-component ((base string) path)
+  (let ((s (find-system base nil)))
+    (and s (find-component s path))))
+
+(defmethod find-component ((base symbol) path)
+  (cond
+    (base (find-component (coerce-name base) path))
+    (path (find-component path nil))
+    (t    nil)))
+
+(defmethod find-component ((base cons) path)
+  (find-component (car base) (cons (cdr base) path)))
+
+(defmethod find-component ((parent parent-component) (name string))
+  (compute-children-by-name parent :only-if-needed-p t) ;; SBCL may miss t=
he u-i-f-r-c method!!!
+  (values (gethash name (component-children-by-name parent))))
+
+(defmethod find-component (base (name symbol))
+  (if name
+      (find-component base (coerce-name name))
+      base))
+
+(defmethod find-component ((c component) (name cons))
+  (find-component (find-component c (car name)) (cdr name)))
+
+(defmethod find-component (base (actual component))
+  (declare (ignorable base))
+  actual)
+
+(defun* resolve-dependency-name (component name &optional version)
+  (loop
+    (restart-case
+        (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 (compatfmt "~@<Retry loading ~3i~_~A.~@:>") na=
me))
+        :test
+        (lambda (c)
+          (or (null c)
+              (and (typep c 'missing-dependency)
+                   (eq (missing-required-by c) component)
+                   (equal (missing-requires c) name))))))))
+
+(defun* resolve-dependency-spec (component dep-spec)
+  (let ((component (find-component () component)))
+    (if (atom dep-spec)
+        (resolve-dependency-name component dep-spec)
+        (resolve-dependency-combination component (car dep-spec) (cdr dep-=
spec)))))
+
+(defmethod resolve-dependency-combination (component combinator arguments)
+  (error (compatfmt "~@<Bad dependency ~S for ~S~@:>")
+         (cons combinator arguments) component))
+
+(defmethod resolve-dependency-combination (component (combinator (eql :fea=
ture)) arguments)
+  (declare (ignorable combinator))
+  (when (featurep (first arguments))
+    (resolve-dependency-spec component (second arguments))))
+
+(defmethod resolve-dependency-combination (component (combinator (eql :ver=
sion)) arguments)
+  (declare (ignorable combinator)) ;; See https://bugs.launchpad.net/asdf/=
+bug/527788
+  (resolve-dependency-name component (first arguments) (second arguments)))
+
+;;;; ---------------------------------------------------------------------=
----
+;;;; Operations
+
+(asdf/package:define-package :asdf/operation
+  (:recycle :asdf/operation :asdf)
+  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
+  (:export
+   #:operation
+   #:operation-original-initargs ;; backward-compatibility only. DO NOT US=
E.
+   #:build-op ;; THE generic operation
+   #:*operations*
+   #:make-operation
+   #:find-operation))
+(in-package :asdf/operation)
+
+;;; Operation Classes
+
+(when-upgrading (:when (find-class 'operation nil))
+  (defmethod shared-initialize :after ((o operation) slot-names &rest init=
args &key)
+    (declare (ignorable o slot-names initargs)) (values)))
+
+(defclass operation ()
+  ((original-initargs ;; for backward-compat -- used by GBBopen and swank =
(via operation-forced)
+    :initform nil :initarg :original-initargs :accessor operation-original=
-initargs)))
+
+(defmethod initialize-instance :after ((o operation) &rest initargs
+                                       &key force force-not system verbose=
 &allow-other-keys)
+  (declare (ignorable force force-not system verbose))
+  (unless (slot-boundp o 'original-initargs)
+    (setf (operation-original-initargs o) initargs)))
+
+(defmethod print-object ((o operation) stream)
+  (print-unreadable-object (o stream :type t :identity nil)
+    (ignore-errors
+      (format stream "~{~S~^ ~}" (operation-original-initargs o)))))
+
+;;; make-operation, find-operation
+
+(defparameter *operations* (make-hash-table :test 'equal))
+(defun* make-operation (operation-class &rest initargs)
+  (let ((key (cons operation-class initargs)))
+    (multiple-value-bind (operation foundp) (gethash key *operations*)
+    (if foundp operation
+        (setf (gethash key *operations*)
+              (apply 'make-instance operation-class initargs))))))
+
+(defgeneric* find-operation (context spec)
+  (:documentation "Find an operation by resolving the SPEC in the CONTEXT"=
))
+(defmethod find-operation (context (spec operation))
+  (declare (ignorable context))
+  spec)
+(defmethod find-operation (context (spec symbol))
+  (apply 'make-operation spec (operation-original-initargs context)))
+(defmethod operation-original-initargs ((context symbol))
+  (declare (ignorable context))
+  nil)
+
+(defclass build-op (operation) ())
+
+;;;; ---------------------------------------------------------------------=
----
+;;;; Actions
+
+(asdf/package:define-package :asdf/action
+  (:nicknames :asdf-action)
+  (:recycle :asdf/action :asdf)
+  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
+   :asdf/component :asdf/system #:asdf/cache :asdf/find-system :asdf/find-=
component :asdf/operation)
+  (:export
+   #:action #:define-convenience-action-methods
+   #:explain #:action-description
+   #:downward-operation #:upward-operation #:sibling-operation
+   #:component-depends-on #:component-self-dependencies
+   #:input-files #:output-files #:output-file #:operation-done-p
+   #:action-status #:action-stamp #:action-done-p
+   #:component-operation-time #:mark-operation-done #:compute-action-stamp
+   #:perform #:perform-with-restarts #:retry #:accept #:feature
+   #:traverse-actions #:traverse-sub-actions #:required-components ;; in p=
lan
+   #:action-path #:find-action #:stamp #:done-p))
+(in-package :asdf/action)
+
+(deftype action () '(cons operation component)) ;; a step to be performed =
while building the system
+
+(defgeneric* traverse-actions (actions &key &allow-other-keys))
+(defgeneric* traverse-sub-actions (operation component &key &allow-other-k=
eys))
+(defgeneric* required-components (component &key &allow-other-keys))
+
+;;;; Reified representation for storage or debugging. Note: dropping origi=
nal-initags
+(defun action-path (action)
+  (destructuring-bind (o . c) action (cons (type-of o) (component-find-pat=
h c))))
+(defun find-action (path)
+  (destructuring-bind (o . c) path (cons (make-operation o) (find-componen=
t () c))))
+
+
+;;;; Convenience methods
+(defmacro define-convenience-action-methods
+  (function (operation component &optional keyp)
+   &key if-no-operation if-no-component operation-initargs)
+  (let* ((rest (gensym "REST"))
+         (found (gensym "FOUND"))
+         (more-args (when keyp `(&rest ,rest &key &allow-other-keys))))
+    (flet ((next-method (o c)
+             (if keyp
+                 `(apply ',function ,o ,c ,rest)
+                 `(,function ,o ,c))))
+      `(progn
+         (defmethod ,function ((,operation symbol) ,component , at more-args)
+           (if ,operation
+               ,(next-method
+                 (if operation-initargs ;backward-compatibility with ASDF1=
's operate. Yuck.
+                     `(apply 'make-operation ,operation :original-initargs=
 ,rest ,rest)
+                     `(make-operation ,operation))
+                 `(or (find-component () ,component) ,if-no-component))
+               ,if-no-operation))
+         (defmethod ,function ((,operation operation) ,component , at more-ar=
gs)
+           (if (typep ,component 'component)
+               (error "No defined method for ~S on ~/asdf-action:format-ac=
tion/"
+                      ',function (cons ,operation ,component))
+               (let ((,found (find-component () ,component)))
+                 (if ,found
+                     ,(next-method operation found)
+                     ,if-no-component))))))))
+
+
+;;;; self-description
+
+(defgeneric* action-description (operation component)
+  (:documentation "returns a phrase that describes performing this operati=
on
+on this component, e.g. \"loading /a/b/c\".
+You can put together sentences using this phrase."))
+(defmethod action-description (operation component)
+  (format nil (compatfmt "~@<~A on ~A~@:>")
+          (type-of operation) component))
+(defgeneric* (explain) (operation component))
+(defmethod explain ((o operation) (c component))
+  (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c)))
+(define-convenience-action-methods explain (operation component))
+
+(defun* format-action (stream action &optional colon-p at-sign-p)
+  (assert (null colon-p)) (assert (null at-sign-p))
+  (destructuring-bind (operation . component) action
+    (princ (action-description operation component) stream)))
+
+
+;;;; Dependencies
+
+(defgeneric* component-depends-on (operation component) ;; ASDF4: rename t=
o component-dependencies
+  (:documentation
+   "Returns a list of dependencies needed by the component to perform
+    the operation.  A dependency has one of the following forms:
+
+      (<operation> <component>*), where <operation> is a class
+        designator and each <component> is a component
+        designator, which means that the component depends on
+        <operation> having been performed on each <component>; or
+
+      (FEATURE <feature>), which means that the component depends
+        on <feature>'s presence in *FEATURES*.
+
+    Methods specialized on subclasses of existing component types
+    should usually append the results of CALL-NEXT-METHOD to the
+    list."))
+(defgeneric* component-self-dependencies (operation component))
+(define-convenience-action-methods component-depends-on (operation compone=
nt))
+(define-convenience-action-methods component-self-dependencies (operation =
component))
+
+(defmethod component-depends-on ((o operation) (c component))
+  (cdr (assoc (type-of o) (component-in-order-to c)))) ; User-specified in=
-order dependencies
+
+(defmethod component-self-dependencies ((o operation) (c component))
+  ;; NB: result in the same format as component-depends-on
+  (loop* :for (o-spec . c-spec) :in (component-depends-on o c)
+         :unless (eq o-spec 'feature) ;; avoid the FEATURE "feature"
+           :when (find c c-spec :key #'(lambda (dep) (resolve-dependency-s=
pec c dep)))
+             :collect (list o-spec c)))
+
+;;;; upward-operation, downward-operation
+;; These together handle actions that propagate along the component hierar=
chy.
+;; Downward operations like load-op or compile-op propagate down the hiera=
rchy:
+;; operation on a parent depends-on operation on its children.
+;; By default, an operation propagates itself, but it may propagate anothe=
r one instead.
+(defclass downward-operation (operation)
+  ((downward-operation
+    :initform nil :initarg :downward-operation :reader downward-operation)=
))
+(defmethod component-depends-on ((o downward-operation) (c parent-componen=
t))
+  `((,(or (downward-operation o) o) ,@(component-children c)) ,@(call-next=
-method)))
+;; Upward operations like prepare-op propagate up the component hierarchy:
+;; operation on a child depends-on operation on its parent.
+;; By default, an operation propagates itself, but it may propagate anothe=
r one instead.
+(defclass upward-operation (operation)
+  ((upward-operation
+    :initform nil :initarg :downward-operation :reader upward-operation)))
+;; For backward-compatibility reasons, a system inherits from module and i=
s a child-component
+;; so we must guard against this case. ASDF4: remove that.
+(defmethod component-depends-on ((o upward-operation) (c child-component))
+  `(,@(if-let (p (component-parent c))
+        `((,(or (upward-operation o) o) ,p))) ,@(call-next-method)))
+;; Sibling operations propagate to siblings in the component hierarchy:
+;; operation on a child depends-on operation on its parent.
+;; By default, an operation propagates itself, but it may propagate anothe=
r one instead.
+(defclass sibling-operation (operation)
+  ((sibling-operation
+    :initform nil :initarg :sibling-operation :reader sibling-operation)))
+(defmethod component-depends-on ((o sibling-operation) (c component))
+  `((,(or (sibling-operation o) o)
+     ,@(loop :for dep :in (component-sibling-dependencies c)
+             :collect (resolve-dependency-spec c dep)))
+    ,@(call-next-method)))
+
+
+;;;; Inputs, Outputs, and invisible dependencies
+(defgeneric* (output-files) (operation component))
+(defgeneric* (input-files) (operation component))
+(defgeneric* (operation-done-p) (operation component)
+  (:documentation "Returns a boolean, which is NIL if the action is forced=
 to be performed again"))
+(define-convenience-action-methods output-files (operation component))
+(define-convenience-action-methods input-files (operation component))
+(define-convenience-action-methods operation-done-p (operation component))
+
+(defmethod operation-done-p ((o operation) (c component))
+  (declare (ignorable o c))
+  t)
+
+(defmethod output-files :around (operation component)
+  "Translate output files, unless asked not to. Memoize the result."
+  operation component ;; hush genera, not convinced by declare ignorable(!)
+  (do-asdf-cache `(output-files ,operation ,component)
+    (values
+     (multiple-value-bind (pathnames fixedp) (call-next-method)
+       ;; 1- Make sure we have absolute pathnames
+       (let* ((directory (pathname-directory-pathname
+                          (component-pathname (find-component () component=
))))
+              (absolute-pathnames
+                (loop
+                  :for pathname :in pathnames
+                  :collect (ensure-absolute-pathname pathname directory))))
+         ;; 2- Translate those pathnames as required
+         (if fixedp
+             absolute-pathnames
+             (mapcar *output-translation-function* absolute-pathnames))))
+     t)))
+(defmethod output-files ((o operation) (c component))
+  (declare (ignorable o c))
+  nil)
+(defun* output-file (operation component)
+  "The unique output file of performing OPERATION on COMPONENT"
+  (let ((files (output-files operation component)))
+    (assert (length=3Dn-p files 1))
+    (first files)))
+
+(defmethod input-files :around (operation component)
+  "memoize input files."
+  (do-asdf-cache `(input-files ,operation ,component)
+    (call-next-method)))
+
+(defmethod input-files ((o operation) (c parent-component))
+  (declare (ignorable o c))
+  nil)
+
+(defmethod input-files ((o operation) (c component))
+  (or (loop* :for (dep-o) :in (component-self-dependencies o c)
+             :append (or (output-files dep-o c) (input-files dep-o c)))
+      ;; no non-trivial previous operations needed?
+      ;; I guess we work with the original source file, then
+      (if-let ((pathname (component-pathname c)))
+        (and (file-pathname-p pathname) (list pathname)))))
+
+
+;;;; Done performing
+
+(defgeneric* component-operation-time (operation component)) ;; ASDF4: hid=
e it behind plan-action-stamp
+(define-convenience-action-methods component-operation-time (operation com=
ponent))
+
+(defgeneric* mark-operation-done (operation component)) ;; ASDF4: hide it =
behind (setf plan-action-stamp)
+(defgeneric* compute-action-stamp (plan operation component &key just-done)
+  (:documentation "Has this action been successfully done already,
+and at what known timestamp has it been done at or will it be done at?
+Takes two keywords JUST-DONE and PLAN:
+JUST-DONE is a boolean that is true if the action was just successfully pe=
rformed,
+at which point we want compute the actual stamp and warn if files are miss=
ing;
+otherwise we are making plans, anticipating the effects of the action.
+PLAN is a plan object modelling future effects of actions,
+or NIL to denote what actually happened.
+Returns two values:
+* a STAMP saying when it was done or will be done,
+  or T if the action has involves files that need to be recomputed.
+* a boolean DONE-P that indicates whether the action has actually been don=
e,
+  and both its output-files and its in-image side-effects are up to date."=
))
+
+(defclass action-status ()
+  ((stamp
+    :initarg :stamp :reader action-stamp
+    :documentation "STAMP associated with the ACTION if it has been comple=
ted already
+in some previous image, or T if it needs to be done.")
+   (done-p
+    :initarg :done-p :reader action-done-p
+    :documentation "a boolean, true iff the action was already done (befor=
e any planned action)."))
+  (:documentation "Status of an action"))
+
+(defmethod print-object ((status action-status) stream)
+  (print-unreadable-object (status stream :type t)
+    (with-slots (stamp done-p) status
+      (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p))))
+
+(defmethod component-operation-time ((o operation) (c component))
+  (gethash (type-of o) (component-operation-times c)))
+
+(defmethod mark-operation-done ((o operation) (c component))
+  (setf (gethash (type-of o) (component-operation-times c))
+        (compute-action-stamp nil o c :just-done t)))
+
+
+;;;; Perform
+
+(defgeneric* (perform-with-restarts) (operation component))
+(defgeneric* (perform) (operation component))
+(define-convenience-action-methods perform (operation component))
+
+(defmethod perform :before ((o operation) (c component))
+  (ensure-all-directories-exist (output-files o c)))
+(defmethod perform :after ((o operation) (c component))
+  (mark-operation-done o c))
+(defmethod perform ((o operation) (c parent-component))
+  (declare (ignorable o c))
+  nil)
+(defmethod perform ((o operation) (c source-file))
+  (sysdef-error
+   (compatfmt "~@<Required method PERFORM not implemented for operation ~A=
, component ~A~@:>")
+   (class-of o) (class-of 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:
+  #|(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.~@:>")
+                  (action-description operation component))))
+      (accept ()
+        :report
+        (lambda (s)
+          (format s (compatfmt "~@<Continue, treating ~A as having been su=
ccessful.~@:>")
+                  (action-description operation component)))
+        (mark-operation-done operation component)
+        (return)))))
+
+;;; Generic build operation
+(defmethod component-depends-on ((o build-op) (c component))
+  `((,(or (component-build-operation c) 'load-op) ,c)))
+
+;;;; ---------------------------------------------------------------------=
----
+;;;; Actions to build Common Lisp software
+
+(asdf/package:define-package :asdf/lisp-action
+  (:recycle :asdf/lisp-action :asdf)
+  (:intern #:proclamations #:flags)
+  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
+   :asdf/cache :asdf/component :asdf/system :asdf/find-component :asdf/ope=
ration :asdf/action)
+  (:export
+   #:try-recompiling
+   #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp
+   #:basic-load-op #:basic-compile-op #:compile-op-flags #:compile-op-proc=
lamations
+   #:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepar=
e-source-op
+   #:call-with-around-compile-hook
+   #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load=
-source #:flags))
+(in-package :asdf/lisp-action)
+
+
+;;;; Component classes
+(defclass cl-source-file (source-file)
+  ((type :initform "lisp")))
+(defclass cl-source-file.cl (cl-source-file)
+  ((type :initform "cl")))
+(defclass cl-source-file.lsp (cl-source-file)
+  ((type :initform "lsp")))
+
+
+;;;; Operation classes
+(defclass basic-load-op (operation) ())
+(defclass basic-compile-op (operation)
+  ((proclamations :initarg :proclamations :accessor compile-op-proclamatio=
ns :initform nil)
+   (flags :initarg :flags :accessor compile-op-flags
+          :initform nil)))
+
+;;; Our default operations: loading into the current lisp image
+(defclass load-op (basic-load-op downward-operation sibling-operation) ())
+(defclass prepare-op (upward-operation sibling-operation)
+  ((sibling-operation :initform 'load-op :allocation :class)))
+(defclass compile-op (basic-compile-op downward-operation)
+  ((downward-operation :initform 'load-op :allocation :class)))
+
+(defclass load-source-op (basic-load-op downward-operation) ())
+(defclass prepare-source-op (upward-operation sibling-operation)
+  ((sibling-operation :initform 'load-source-op :allocation :class)))
+
+(defclass test-op (operation) ())
+
+
+;;;; prepare-op, compile-op and load-op
+
+;;; prepare-op
+(defmethod action-description ((o prepare-op) (c component))
+  (declare (ignorable o))
+  (format nil (compatfmt "~@<loading dependencies of ~3i~_~A~@:>") c))
+(defmethod perform ((o prepare-op) (c component))
+  (declare (ignorable o c))
+  nil)
+(defmethod input-files ((o prepare-op) (c component))
+  (declare (ignorable o c))
+  nil)
+(defmethod input-files ((o prepare-op) (s system))
+  (declare (ignorable o))
+  (if-let (it (system-source-file s)) (list it)))
+
+;;; compile-op
+(defmethod action-description ((o compile-op) (c component))
+  (declare (ignorable o))
+  (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") c))
+(defmethod action-description ((o compile-op) (c parent-component))
+  (declare (ignorable o))
+  (format nil (compatfmt "~@<completing compilation for ~3i~_~A~@:>") c))
+(defgeneric* call-with-around-compile-hook (component thunk))
+(defmethod call-with-around-compile-hook ((c component) function)
+  (call-around-hook (around-compile-hook c) function))
+(defun* perform-lisp-compilation (o c)
+  (let (;; Before 2.26.53, that was unfortunately component-pathname. Now,
+        ;; we consult input-files, the first of which should be the one to=
 compile-file
+        (input-file (first (input-files o c)))
+        ;; on some implementations, there are more than one output-file,
+        ;; but the first one should always be the primary fasl that gets l=
oaded.
+        (outputs (output-files o c)))
+    (multiple-value-bind (output warnings-p failure-p)
+        (destructuring-bind
+            (output-file
+             &optional
+               #+clisp lib-file
+               #+(or ecl mkcl) object-file
+               #+(or clozure sbcl) warnings-file) outputs
+          (call-with-around-compile-hook
+           c #'(lambda (&rest flags)
+                 (with-muffled-compiler-conditions ()
+                   (apply 'compile-file* input-file
+                          :output-file output-file
+                          :external-format (component-external-format c)
+                      (append
+                       #+clisp (list :lib-file lib-file)
+                       #+(or ecl mkcl) (list :object-file object-file)
+                       #+(or clozure sbcl) (list :warnings-file warnings-f=
ile)
+                       flags (compile-op-flags o)))))))
+      (check-lisp-compile-results output warnings-p failure-p
+                                  "~/asdf-action::format-action/" (list (c=
ons o c))))))
+
+(defun* report-file-p (f)
+  (equal (pathname-type f) "build-report"))
+(defun* perform-lisp-warnings-check (o c)
+  (let* ((expected-warnings-files (remove-if-not #'warnings-file-p (input-=
files o c)))
+         (actual-warnings-files (loop :for w :in expected-warnings-files
+                                      :when (get-file-stamp w)
+                                        :collect w
+                                      :else :do (warn "Missing warnings fi=
le ~S while ~A"
+                                                      w (action-descriptio=
n o c)))))
+    (check-deferred-warnings actual-warnings-files)
+    (let* ((output (output-files o c))
+           (report (find-if #'report-file-p output)))
+      (when report
+        (with-open-file (s report :direction :output :if-exists :supersede)
+          (format s ":success~%"))))))
+(defmethod perform ((o compile-op) (c cl-source-file))
+  (perform-lisp-compilation o c))
+(defmethod output-files ((o compile-op) (c cl-source-file))
+  (declare (ignorable o))
+  (let* ((i (first (input-files o c)))
+         (f (compile-file-pathname
+             i #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl)))
+    `(,f ;; the fasl is the primary output, in first position
+      #+clisp
+      ,@`(,(make-pathname :type "lib" :defaults f))
+      #+(or clozure sbcl)
+      ,@(let ((s (component-system c)))
+          (unless (builtin-system-p s) ; includes ASDF itself
+            `(,(make-pathname :type (warnings-file-type) :defaults f))))
+      #+ecl
+      ,@(unless (use-ecl-byte-compiler-p)
+          `(,(compile-file-pathname i :type :object)))
+      #+mkcl
+      ,(compile-file-pathname i :fasl-p nil)))) ;; object file
+(defmethod component-depends-on ((o compile-op) (c component))
+  (declare (ignorable o))
+  `((prepare-op ,c) ,@(call-next-method)))
+(defmethod perform ((o compile-op) (c static-file))
+  (declare (ignorable o c))
+  nil)
+(defmethod output-files ((o compile-op) (c static-file))
+  (declare (ignorable o c))
+  nil)
+(defmethod perform ((o compile-op) (c system))
+  (declare (ignorable o c))
+  #+(or clozure sbcl) (perform-lisp-warnings-check o c))
+#+(or clozure sbcl)
+(defmethod input-files ((o compile-op) (c system))
+  (declare (ignorable o c))
+  (when *warnings-file-type*
+    (unless (builtin-system-p c)
+      ;; The most correct way to do it would be to use:
+      ;; (traverse-sub-actions o c :other-systems nil :keep-operation 'com=
pile-op :keep-component 'cl-source-file)
+      ;; but it's expensive and we don't care too much about file order or=
 ASDF extensions.
+      (loop :for sub :in (sub-components c :type 'cl-source-file)
+            :nconc (remove-if-not 'warnings-file-p (output-files o sub))))=
))
+#+(or clozure sbcl)
+(defmethod output-files ((o compile-op) (c system))
+  (when (and *warnings-file-type* (not (builtin-system-p c)))
+    (if-let ((pathname (component-pathname c)))
+      (list (subpathname pathname (component-name c) :type "build-report")=
))))
+
+;;; load-op
+(defmethod action-description ((o load-op) (c cl-source-file))
+  (declare (ignorable o))
+  (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>") c))
+(defmethod action-description ((o load-op) (c parent-component))
+  (declare (ignorable o))
+  (format nil (compatfmt "~@<completing load for ~3i~_~A~@:>") c))
+(defmethod action-description ((o load-op) component)
+  (declare (ignorable o))
+  (format nil (compatfmt "~@<loading ~3i~_~A~@:>")
+          component))
+(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 (find-operation o 'compile-op) c)))))
+(defun* perform-lisp-load-fasl (o c)
+  (if-let (fasl (first (input-files o c)))
+    (with-muffled-loader-conditions () (load* fasl))))
+(defmethod perform ((o load-op) (c cl-source-file))
+  (perform-lisp-load-fasl o c))
+(defmethod perform ((o load-op) (c static-file))
+  (declare (ignorable o c))
+  nil)
+(defmethod component-depends-on ((o load-op) (c component))
+  (declare (ignorable o))
+  ;; NB: even though compile-op depends-on on prepare-op,
+  ;; it is not needed-in-image-p, whereas prepare-op is,
+  ;; so better not omit prepare-op and think it will happen.
+  `((prepare-op ,c) (compile-op ,c) ,@(call-next-method)))
+
+
+;;;; prepare-source-op, load-source-op
+
+;;; prepare-source-op
+(defmethod action-description ((o prepare-source-op) (c component))
+  (declare (ignorable o))
+  (format nil (compatfmt "~@<loading source for dependencies of ~3i~_~A~@:=
>") c))
+(defmethod input-files ((o prepare-source-op) (c component))
+  (declare (ignorable o c))
+  nil)
+(defmethod input-files ((o prepare-source-op) (s system))
+  (declare (ignorable o))
+  (if-let (it (system-source-file s)) (list it)))
+(defmethod perform ((o prepare-source-op) (c component))
+  (declare (ignorable o c))
+  nil)
+
+;;; load-source-op
+(defmethod action-description ((o load-source-op) c)
+  (declare (ignorable o))
+  (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>") c))
+(defmethod action-description ((o load-source-op) (c parent-component))
+  (declare (ignorable o))
+  (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") c))
+(defmethod component-depends-on ((o load-source-op) (c component))
+  (declare (ignorable o))
+  `((prepare-source-op ,c) ,@(call-next-method)))
+(defun* perform-lisp-load-source (o c)
+  (call-with-around-compile-hook
+   c #'(lambda ()
+         (with-muffled-loader-conditions ()
+           (load* (first (input-files o c))
+                  :external-format (component-external-format c))))))
+
+(defmethod perform ((o load-source-op) (c cl-source-file))
+  (perform-lisp-load-source o c))
+(defmethod perform ((o load-source-op) (c static-file))
+  (declare (ignorable o c))
+  nil)
+(defmethod output-files ((o load-source-op) (c component))
+  (declare (ignorable o c))
+  nil)
+
+
+;;;; test-op
+(defmethod perform ((o test-op) (c component))
+  (declare (ignorable o c))
+  nil)
+(defmethod operation-done-p ((o test-op) (c system))
+  "Testing a system is _never_ done."
+  (declare (ignorable o c))
+  nil)
+(defmethod component-depends-on ((o test-op) (c system))
+  (declare (ignorable o))
+  `((load-op ,c) ,@(call-next-method)))
+
+;;;; ---------------------------------------------------------------------=
----
+;;;; Plan
+
+(asdf/package:define-package :asdf/plan
+  (:recycle :asdf/plan :asdf)
+  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
+   :asdf/component :asdf/operation :asdf/system
+   :asdf/cache :asdf/find-system :asdf/find-component
+   :asdf/operation :asdf/action :asdf/lisp-action)
+  (:export
+   #:component-operation-time #:mark-operation-done
+   #:plan-traversal #:sequential-plan #:*default-plan-class*
+   #:planned-action-status #:plan-action-status #:action-already-done-p
+   #:circular-dependency #:circular-dependency-actions
+   #:node-for #:needed-in-image-p
+   #:action-index #:action-planned-p #:action-valid-p
+   #:plan-record-dependency #:visiting-action-p
+   #:normalize-forced-systems #:action-forced-p #:action-forced-not-p
+   #:map-direct-dependencies #:reduce-direct-dependencies #:direct-depende=
ncies
+   #:visit-dependencies #:compute-action-stamp #:traverse-action
+   #:circular-dependency #:circular-dependency-actions
+   #:call-while-visiting-action #:while-visiting-action
+   #:traverse #:plan-actions #:perform-plan #:plan-operates-on-p
+   #:planned-p #:index #:forced #:forced-not #:total-action-count
+   #:planned-action-count #:planned-output-action-count #:visited-actions
+   #:visiting-action-set #:visiting-action-list #:plan-actions-r
+   #:required-components #:filtered-sequential-plan
+   #:plan-system
+   #:plan-action-filter #:plan-component-type #:plan-keep-operation #:plan=
-keep-component
+   #:traverse-actions #:traverse-sub-actions))
+(in-package :asdf/plan)
+
+;;;; Generic plan traversal class
+
+(defclass plan-traversal ()
+  ((system :initform nil :initarg :system :accessor plan-system)
+   (forced :initform nil :initarg :force :accessor plan-forced)
+   (forced-not :initform nil :initarg :force-not :accessor plan-forced-not)
+   (total-action-count :initform 0 :accessor plan-total-action-count)
+   (planned-action-count :initform 0 :accessor plan-planned-action-count)
+   (planned-output-action-count :initform 0 :accessor plan-planned-output-=
action-count)
+   (visited-actions :initform (make-hash-table :test 'equal) :accessor pla=
n-visited-actions)
+   (visiting-action-set :initform (make-hash-table :test 'equal) :accessor=
 plan-visiting-action-set)
+   (visiting-action-list :initform () :accessor plan-visiting-action-list)=
))
+
+
+;;;; Planned action status
+
+(defgeneric* plan-action-status (plan operation component)
+  (:documentation "Returns the ACTION-STATUS associated to
+the action of OPERATION on COMPONENT in the PLAN"))
+
+(defgeneric* (setf plan-action-status) (new-status plan operation componen=
t)
+  (:documentation "Sets the ACTION-STATUS associated to
+the action of OPERATION on COMPONENT in the PLAN"))
+
+(defclass planned-action-status (action-status)
+  ((planned-p
+    :initarg :planned-p :reader action-planned-p
+    :documentation "a boolean, true iff the action was included in the pla=
n.")
+   (index
+    :initarg :index :reader action-index
+    :documentation "an integer, counting all traversed actions in traversa=
l order."))
+  (:documentation "Status of an action in a plan"))
+
+(defmethod print-object ((status planned-action-status) stream)
+  (print-unreadable-object (status stream :type t :identity nil)
+    (with-slots (stamp done-p planned-p index) status
+      (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p :planned-p p=
lanned-p :index index))))
+
+(defmethod action-planned-p (action-status)
+  (declare (ignorable action-status)) ; default method for non planned-act=
ion-status objects
+  t)
+
+;; TODO: eliminate NODE-FOR, use CONS.
+;; Supposes cleaner protocol for operation initargs passed to MAKE-OPERATI=
ON.
+;; However, see also component-operation-time and mark-operation-done
+(defun* node-for (o c) (cons (type-of o) c))
+
+(defun* action-already-done-p (plan operation component)
+  (action-done-p (plan-action-status plan operation component)))
+
+(defmethod plan-action-status ((plan null) (o operation) (c component))
+  (declare (ignorable plan))
+  (multiple-value-bind (stamp done-p) (component-operation-time o c)
+    (make-instance 'action-status :stamp stamp :done-p done-p)))
+
+(defmethod (setf plan-action-status) (new-status (plan null) (o operation)=
 (c component))
+  (declare (ignorable plan))
+  (let ((to (type-of o))
+        (times (component-operation-times c)))
+    (if (action-done-p new-status)
+        (remhash to times)
+        (setf (gethash to times) (action-stamp new-status))))
+  new-status)
+
+
+;;;; forcing
+
+(defgeneric* action-forced-p (plan operation component))
+(defgeneric* action-forced-not-p (plan operation component))
+
+(defun* normalize-forced-systems (x system)
+  (etypecase x
+    ((member nil :all) x)
+    (cons (list-to-hash-set (mapcar #'coerce-name x)))
+    ((eql t) (when system (list-to-hash-set (list (coerce-name system)))))=
))
+
+(defun* action-override-p (plan operation component override-accessor)
+  (declare (ignorable operation))
+  (let* ((override (funcall override-accessor plan)))
+    (and override
+         (if (typep override 'hash-table)
+             (gethash (coerce-name (component-system (find-component () co=
mponent))) override)
+             t))))
+
+(defmethod action-forced-p (plan operation component)
+  (and
+   ;; Did the user ask us to re-perform the action?
+   (action-override-p plan operation component 'plan-forced)
+   ;; You really can't force a builtin system and :all doesn't apply to it,
+   ;; except it it's the specifically the system currently being built.
+   (not (let ((system (component-system component)))
+          (and (builtin-system-p system)
+               (not (eq system (plan-system plan))))))))
+
+(defmethod action-forced-not-p (plan operation component)
+  (and
+   ;; Did the user ask us to not re-perform the action?
+   (action-override-p plan operation component 'plan-forced-not)
+   ;; Force takes precedence over force-not
+   (not (action-forced-p plan operation component))))
+
+(defmethod action-forced-p ((plan null) operation component)
+  (declare (ignorable plan operation component))
+  nil)
+
+(defmethod action-forced-not-p ((plan null) operation component)
+  (declare (ignorable plan operation component))
+  nil)
+
+
+;;;; action-valid-p
+
+(defgeneric action-valid-p (plan operation component)
+  (:documentation "Is this action valid to include amongst dependencies?"))
+(defmethod action-valid-p (plan operation (c component))
+  (declare (ignorable plan operation))
+  (if-let (it (component-if-feature c)) (featurep it) t))
+(defmethod action-valid-p (plan (o null) c) (declare (ignorable plan o c))=
 nil)
+(defmethod action-valid-p (plan o (c null)) (declare (ignorable plan o c))=
 nil)
+(defmethod action-valid-p ((plan null) operation component)
+  (declare (ignorable plan operation component))
+  (and operation component t))
+
+
+;;;; Is the action needed in this image?
+
+(defgeneric* needed-in-image-p (operation component)
+  (:documentation "Is the action of OPERATION on COMPONENT needed in the c=
urrent image to be meaningful,
+    or could it just as well have been done in another Lisp image?"))
+
+(defmethod needed-in-image-p ((o operation) (c component))
+  ;; We presume that actions that modify the filesystem don't need be run
+  ;; in the current image if they have already been done in another,
+  ;; and can be run in another process (e.g. a fork),
+  ;; whereas those that don't are meant to side-effect the current image a=
nd can't.
+  (not (output-files o c)))
+
+
+;;;; Visiting dependencies of an action and computing action stamps
+
+(defun* map-direct-dependencies (operation component fun)
+  (loop* :for (dep-o-spec . dep-c-specs) :in (component-depends-on operati=
on component)
+     :unless (eq dep-o-spec 'feature) ;; avoid the "FEATURE" misfeature
+        :do (loop :with dep-o =3D (find-operation operation dep-o-spec)
+                  :for dep-c-spec :in dep-c-specs
+                  :for dep-c =3D (resolve-dependency-spec component dep-c-=
spec)
+                  :do (funcall fun dep-o dep-c))))
+
+(defun* reduce-direct-dependencies (operation component combinator seed)
+  (map-direct-dependencies
+   operation component
+   #'(lambda (dep-o dep-c)
+       (setf seed (funcall combinator dep-o dep-c seed))))
+  seed)
+
+(defun* direct-dependencies (operation component)
+  (reduce-direct-dependencies operation component #'acons nil))
+
+(defun* visit-dependencies (plan operation component dependency-stamper &a=
ux stamp)
+  (map-direct-dependencies
+   operation component
+   #'(lambda (dep-o dep-c)
+       (when (action-valid-p plan dep-o dep-c)
+         (latest-stamp-f stamp (funcall dependency-stamper dep-o dep-c)))))
+  stamp)
+
+(defmethod compute-action-stamp (plan (o operation) (c component) &key jus=
t-done)
+  ;; In a distant future, get-file-stamp and component-operation-time
+  ;; shall also be parametrized by the plan, or by a second model object.
+  (let* ((stamp-lookup #'(lambda (o c)
+                           (if-let (it (plan-action-status plan o c)) (act=
ion-stamp it) t)))
+         (out-files (output-files o c))
+         (in-files (input-files o c))
+         ;; Three kinds of actions:
+         (out-op (and out-files t)) ; those that create files on the files=
ystem
+         ;(image-op (and in-files (null out-files))) ; those that load stu=
ff into the image
+         ;(null-op (and (null out-files) (null in-files))) ; dependency pl=
aceholders that do nothing
+         ;; When was the thing last actually done? (Now, or ask.)
+         (op-time (or just-done (component-operation-time o c)))
+         ;; Accumulated timestamp from dependencies (or T if forced or out=
-of-date)
+         (dep-stamp (visit-dependencies plan o c stamp-lookup))
+         ;; Time stamps from the files at hand, and whether any is missing
+         (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-=
stamp) out-files))
+         (in-stamps (mapcar #'get-file-stamp in-files))
+         (missing-in
+           (loop :for f :in in-files :for s :in in-stamps :unless s :colle=
ct f))
+         (missing-out
+           (loop :for f :in out-files :for s :in out-stamps :unless s :col=
lect f))
+         (all-present (not (or missing-in missing-out)))
+         ;; Has any input changed since we last generated the files?
+         (earliest-out (stamps-earliest out-stamps))
+         (latest-in (stamps-latest (cons dep-stamp in-stamps)))
+         (up-to-date-p (stamp<=3D latest-in earliest-out))
+         ;; If everything is up to date, the latest of inputs and outputs =
is our stamp
+         (done-stamp (stamps-latest (cons latest-in out-stamps))))
+    ;; Warn if some files are missing:
+    ;; either our model is wrong or some other process is messing with our=
 files.
+    (when (and just-done (not all-present))
+      (warn "~A completed without ~:[~*~;~*its input file~:p~2:*~{ ~S~}~*~=
]~
+             ~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]"
+            (action-description o c)
+            missing-in (length missing-in) (and missing-in missing-out)
+            missing-out (length missing-out)))
+    ;; Note that we use stamp<=3D instead of stamp< to play nice with gene=
rated files.
+    ;; Any race condition is intrinsic to the limited timestamp resolution.
+    (if (or just-done ;; The done-stamp is valid: if we're just done, or
+            ;; if all filesystem effects are up-to-date and there's no inv=
alidating reason.
+            (and all-present up-to-date-p (operation-done-p o c) (not (act=
ion-forced-p plan o c))))
+        (values done-stamp ;; return the hard-earned timestamp
+                (or just-done
+                    (or out-op ;; a file-creating op is done when all file=
s are up to date
+                        ;; a image-effecting a placeholder op is done when=
 it was actually run,
+                        (and op-time (eql op-time done-stamp))))) ;; with =
the matching stamp
+        ;; done-stamp invalid: return a timestamp in an indefinite future,=
 action not done yet
+        (values t nil))))
+
+;;;; Generic support for plan-traversal
+
+(defgeneric* plan-record-dependency (plan operation component))
+
+(defgeneric call-while-visiting-action (plan operation component function)
+  (:documentation "Detect circular dependencies"))
+
+(defmethod initialize-instance :after ((plan plan-traversal)
+                                       &key (force () fp) (force-not () fn=
p) system
+                                       &allow-other-keys)
+  (with-slots (forced forced-not) plan
+    (when fp (setf forced (normalize-forced-systems force system)))
+    (when fnp (setf forced-not (normalize-forced-systems force-not system)=
))))
+
+(defmethod (setf plan-action-status) (new-status (plan plan-traversal) (o =
operation) (c component))
+  (setf (gethash (node-for o c) (plan-visited-actions plan)) new-status))
+
+(defmethod plan-action-status ((plan plan-traversal) (o operation) (c comp=
onent))
+  (or (and (action-forced-not-p plan o c) (plan-action-status nil o c))
+      (values (gethash (node-for o c) (plan-visited-actions plan)))))
+
+(defmethod action-valid-p ((plan plan-traversal) (o operation) (s system))
+  (and (not (action-forced-not-p plan o s)) (call-next-method)))
+
+(defmethod call-while-visiting-action ((plan plan-traversal) operation com=
ponent fun)
+  (with-accessors ((action-set plan-visiting-action-set)
+                   (action-list plan-visiting-action-list)) plan
+    (let ((action (cons operation component)))
+      (when (gethash action action-set)
+        (error 'circular-dependency :actions
+               (member action (reverse action-list) :test 'equal)))
+      (setf (gethash action action-set) t)
+      (push action action-list)
+      (unwind-protect
+           (funcall fun)
+        (pop action-list)
+        (setf (gethash action action-set) nil)))))
+
+
+;;;; Actual traversal: traverse-action
+
+(define-condition circular-dependency (system-definition-error)
+  ((actions :initarg :actions :reader circular-dependency-actions))
+  (:report (lambda (c s)
+             (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
+                     (circular-dependency-actions c)))))
+
+(defmacro while-visiting-action ((p o c) &body body)
+  `(call-while-visiting-action ,p ,o ,c #'(lambda () , at body)))
+
+(defgeneric* traverse-action (plan operation component needed-in-image-p))
+
+(defmethod traverse-action (plan operation component needed-in-image-p)
+  (block nil
+    (unless (action-valid-p plan operation component) (return nil))
+    (plan-record-dependency plan operation component)
+    (let* ((aniip (needed-in-image-p operation component))
+           (eniip (and aniip needed-in-image-p))
+           (status (plan-action-status plan operation component)))
+      (when (and status (or (action-done-p status) (action-planned-p statu=
s) (not eniip)))
+        ;; Already visited with sufficient need-in-image level: just retur=
n the stamp.
+        (return (action-stamp status)))
+      (labels ((visit-action (niip)
+                 (visit-dependencies plan operation component
+                                     #'(lambda (o c) (traverse-action plan=
 o c niip)))
+                 (multiple-value-bind (stamp done-p)
+                     (compute-action-stamp plan operation component)
+                   (let ((add-to-plan-p (or (eql stamp t) (and niip (not d=
one-p)))))
+                     (cond
+                       ((and add-to-plan-p (not niip)) ;; if we need to do=
 it,
+                        (visit-action t)) ;; then we need to do it in the =
image!
+                       (t
+                        (setf (plan-action-status plan operation component)
+                              (make-instance
+                               'planned-action-status
+                               :stamp stamp
+                               :done-p (and done-p (not add-to-plan-p))
+                               :planned-p add-to-plan-p
+                               :index (if status (action-index status) (in=
cf (plan-total-action-count plan)))))
+                        (when add-to-plan-p
+                          (incf (plan-planned-action-count plan))
+                          (unless aniip
+                            (incf (plan-planned-output-action-count plan))=
))
+                        stamp))))))
+        (while-visiting-action (plan operation component) ; maintain conte=
xt, handle circularity.
+          (visit-action eniip))))))
+
+
+;;;; Sequential plans (the default)
+
+(defclass sequential-plan (plan-traversal)
+  ((actions-r :initform nil :accessor plan-actions-r)))
+
+(defgeneric* plan-actions (plan))
+(defmethod plan-actions ((plan sequential-plan))
+  (reverse (plan-actions-r plan)))
+
+(defmethod plan-record-dependency ((plan sequential-plan)
+                                   (operation operation) (component compon=
ent))
+  (declare (ignorable plan operation component))
+  (values))
+
+(defmethod (setf plan-action-status) :after
+    (new-status (p sequential-plan) (o operation) (c component))
+  (when (action-planned-p new-status)
+    (push (cons o c) (plan-actions-r p))))
+
+
+;;;; high-level interface: traverse, perform-plan, plan-operates-on-p
+
+(defgeneric* (traverse) (operation component &key &allow-other-keys)
+  (:documentation
+"Generate and return a plan for performing OPERATION on COMPONENT.
+
+The plan returned is a list of dotted-pairs. Each pair is the CONS
+of ASDF operation object and a COMPONENT object. The pairs will be
+processed in order by OPERATE."))
+(define-convenience-action-methods traverse (operation component &key))
+
+(defgeneric* perform-plan (plan &key))
+(defgeneric* plan-operates-on-p (plan component))
+
+(defparameter *default-plan-class* 'sequential-plan)
+
+(defmethod traverse ((o operation) (c component) &rest keys &key plan-clas=
s &allow-other-keys)
+  (let ((plan (apply 'make-instance
+                     (or plan-class *default-plan-class*)
+                     :system (component-system c) (remove-plist-key :plan-=
class keys))))
+    (traverse-action plan o c t)
+    (plan-actions plan)))
+
+(defmethod perform-plan :around (plan &key)
+  (declare (ignorable plan))
+  (let ((*package* *package*)
+        (*readtable* *readtable*))
+    (with-compilation-unit () ;; backward-compatibility.
+      (call-next-method))))   ;; Going forward, see deferred-warning suppo=
rt in lisp-build.
+
+(defmethod perform-plan ((steps list) &key)
+  (loop* :for (op . component) :in steps :do
+         (perform-with-restarts op component)))
+
+(defmethod plan-operates-on-p ((plan list) (component-path list))
+  (find component-path (mapcar 'cdr plan)
+        :test 'equal :key 'component-find-path))
+
+
+;;;; Incidental traversals =

+
+(defclass filtered-sequential-plan (sequential-plan)
+  ((action-filter :initform t :initarg :action-filter :reader plan-action-=
filter)
+   (component-type :initform t :initarg :component-type :reader plan-compo=
nent-type)
+   (keep-operation :initform t :initarg :keep-operation :reader plan-keep-=
operation)
+   (keep-component :initform t :initarg :keep-component :reader plan-keep-=
component)))
+
+(defmethod initialize-instance :after ((plan filtered-sequential-plan)
+                                       &key (force () fp) (force-not () fn=
p)
+                                         other-systems)
+  (declare (ignore force force-not))
+  (with-slots (forced forced-not action-filter system) plan
+    (unless fp (setf forced (normalize-forced-systems (if other-systems :a=
ll t) system)))
+    (unless fnp (setf forced-not (normalize-forced-systems (if other-syste=
ms nil :all) system)))
+    (setf action-filter (ensure-function action-filter))))
+
+(defmethod action-valid-p ((plan filtered-sequential-plan) o c)
+  (and (funcall (plan-action-filter plan) o c)
+       (typep c (plan-component-type plan))
+       (call-next-method)))
+
+(defmethod traverse-actions (actions &rest keys &key plan-class &allow-oth=
er-keys)
+  (let ((plan (apply 'make-instance (or plan-class 'filtered-sequential-pl=
an) keys)))
+    (loop* :for (o . c) :in actions :do
+      (traverse-action plan o c t))
+    (plan-actions plan)))
+
+(define-convenience-action-methods traverse-sub-actions (o c &key))
+(defmethod traverse-sub-actions ((operation operation) (component componen=
t) &rest keys &key &allow-other-keys)
+  (apply 'traverse-actions (direct-dependencies operation component)
+         :system (component-system component) keys))
+
+(defmethod plan-actions ((plan filtered-sequential-plan))
+  (with-slots (keep-operation keep-component) plan
+  (loop* :for (o . c) :in (call-next-method)
+         :when (and (typep o keep-operation)
+                    (typep c keep-component))
+           :collect (cons o c))))
+
+(defmethod required-components (system &rest keys &key (goal-operation 'lo=
ad-op) &allow-other-keys)
+  (remove-duplicates
+   (mapcar 'cdr (apply 'traverse-sub-actions goal-operation system keys))
+   :from-end t))
+
+;;;; ---------------------------------------------------------------------=
----
+;;;; Invoking Operations
+
+(asdf/package:define-package :asdf/operate
+  (:recycle :asdf/operate :asdf)
+  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
+   :asdf/component :asdf/system :asdf/operation :asdf/action
+   :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/plan)
+  (:export
+   #:operate #:oos
+   #:*systems-being-operated* #:*asdf-upgrade-already-attempted*
+   #:build-system
+   #:load-system #:load-systems #:compile-system #:test-system #:require-s=
ystem
+   #:*load-system-operation* #:module-provide-asdf
+   #:component-loaded-p #:already-loaded-systems
+   #:upgrade-asdf #:cleanup-upgraded-asdf #:*post-upgrade-hook*))
+(in-package :asdf/operate)
+
+(defgeneric* (operate) (operation component &key &allow-other-keys))
+(define-convenience-action-methods
+    operate (operation component &key)
+    :operation-initargs t ;; backward-compatibility with ASDF1. Yuck.
+    :if-no-component (error 'missing-component :requires component))
+
+(defvar *systems-being-operated* nil
+  "A boolean indicating that some systems are being operated on")
+
+(defmethod operate :around (operation component
+                            &key verbose
+                              (on-warnings *compile-file-warnings-behaviou=
r*)
+                              (on-failure *compile-file-failure-behaviour*=
) &allow-other-keys)
+  (declare (ignorable operation component))
+  ;; Setup proper bindings around any operate call.
+  (with-system-definitions ()
+    (let* ((*verbose-out* (and verbose *standard-output*))
+           (*compile-file-warnings-behaviour* on-warnings)
+           (*compile-file-failure-behaviour* on-failure))
+      (call-next-method))))
+
+(defmethod operate ((operation operation) (component component)
+                    &rest args &key version &allow-other-keys)
+  "Operate does three things:
+
+1. It creates an instance of OPERATION-CLASS using any keyword parameters =
as initargs.
+2. It finds the  asdf-system specified by SYSTEM (possibly loading it from=
 disk).
+3. It then calls TRAVERSE with the operation and system as arguments
+
+The traverse operation is wrapped in WITH-COMPILATION-UNIT and error handl=
ing code.
+If a VERSION argument is supplied, then operate also ensures that the syst=
em found
+satisfies it using the VERSION-SATISFIES method.
+
+Note that dependencies may cause the operation to invoke other operations =
on the system
+or its components: the new operations will be created with the same initar=
gs as the original one.
+
+The :FORCE or :FORCE-NOT argument to OPERATE can be:
+  T to force the inside of the specified system to be rebuilt (resp. not),
+    without recursively forcing the other systems we depend on.
+  :ALL to force all systems including other systems we depend on to be reb=
uilt (resp. not).
+  (SYSTEM1 SYSTEM2 ... SYSTEMN) to force systems named in a given list
+:FORCE has precedence over :FORCE-NOT; builtin systems cannot be forced."
+  (let* (;; I'd like to remove-plist-keys :force :force-not :verbose,
+         ;; but swank.asd relies on :force (!).
+         (systems-being-operated *systems-being-operated*)
+         (*systems-being-operated* (or systems-being-operated (make-hash-t=
able :test 'equal)))
+         (system (component-system component)))
+    (setf (gethash (coerce-name system) *systems-being-operated*) system)
+    (unless (version-satisfies component version)
+      (error 'missing-component-of-version :requires component :version ve=
rsion))
+    ;; Before we operate on any system, make sure ASDF is up-to-date,
+    ;; for if an upgrade is ever attempted at any later time, there may be=
 BIG trouble.
+    (unless systems-being-operated
+      (let ((operation-name (reify-symbol (type-of operation)))
+            (component-path (component-find-path component)))
+        (when (upgrade-asdf)
+          ;; If we were upgraded, restart OPERATE the hardest of ways, for
+          ;; its function may have been redefined, its symbol uninterned, =
its package deleted.
+          (return-from operate
+            (apply (find-symbol* 'operate :asdf)
+                   (unreify-symbol operation-name)
+                   component-path args)))))
+    (let ((plan (apply 'traverse operation system args)))
+      (perform-plan plan)
+      (values operation plan))))
+
+(defun* oos (operation component &rest args &key &allow-other-keys)
+  (apply 'operate operation component args))
+
+(setf (documentation 'oos 'function)
+      (format nil "Short for _operate on system_ and an alias for the OPER=
ATE function.~%~%~a"
+              (documentation 'operate 'function)))
+
+
+;;;; Common operations
+
+(defvar *load-system-operation* 'load-op
+  "Operation used by ASDF:LOAD-SYSTEM. By default, ASDF:LOAD-OP.
+You may override it with e.g. ASDF:LOAD-FASL-OP from asdf-bundle,
+or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.
+
+This may change in the future as we will implement component-based strategy
+for how to load or compile stuff")
+
+(defun* build-system (system &rest keys)
+  "Shorthand for `(operate 'asdf:build-op system)`."
+  (apply 'operate 'build-op system keys)
+  t)
+
+(defun* load-system (system &rest keys &key force force-not verbose versio=
n &allow-other-keys)
+  "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for details=
."
+  (declare (ignore force force-not verbose version))
+  (apply 'operate *load-system-operation* system keys)
+  t)
+
+(defun* load-systems (&rest systems)
+  "Loading multiple systems at once."
+  (map () 'load-system systems))
+
+(defun* compile-system (system &rest args &key force force-not verbose ver=
sion &allow-other-keys)
+  "Shorthand for `(asdf:operate 'asdf:compile-op system)`. See OPERATE for=
 details."
+  (declare (ignore force force-not verbose version))
+  (apply 'operate 'compile-op system args)
+  t)
+
+(defun* test-system (system &rest args &key force force-not verbose versio=
n &allow-other-keys)
+  "Shorthand for `(asdf:operate 'asdf:test-op system)`. See OPERATE for de=
tails."
+  (declare (ignore force force-not verbose version))
+  (apply 'operate 'test-op system args)
+  t)
+
+
+;;;; Define require-system, to be hooked into CL:REQUIRE when possible,
+;; i.e. for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL
+
+(defun* component-loaded-p (c)
+  (action-already-done-p nil (make-instance 'load-op) (find-component c ()=
)))
+
+(defun* already-loaded-systems ()
+  (remove-if-not 'component-loaded-p (registered-systems)))
+
+(defun* require-system (s &rest keys &key &allow-other-keys)
+  (apply 'load-system s :force-not (already-loaded-systems) keys))
+
+(defun* module-provide-asdf (name)
+  (handler-bind
+      ((style-warning #'muffle-warning)
+       (missing-component (constantly nil))
+       (error #'(lambda (e)
+                  (format *error-output* (compatfmt "~@<ASDF could not loa=
d ~(~A~) because ~A.~@:>~%")
+                          name e))))
+    (let ((*verbose-out* (make-broadcast-stream))
+          (system (find-system (string-downcase name) nil)))
+      (when system
+        (require-system system :verbose nil)
+        t))))
+
+
+;;;; Some upgrade magic
+
+(defun* restart-upgraded-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-def=
ined* :collect name)))
+      (clrhash *systems-being-defined*)
+      (dolist (s l) (find-system s nil)))))
+
+(pushnew 'restart-upgraded-asdf *post-upgrade-restart-hook*)
+;;;; ---------------------------------------------------------------------=
------
+;;;; asdf-output-translations
+
+(asdf/package:define-package :asdf/output-translations
+  (:recycle :asdf/output-translations :asdf)
+  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
+  (:export
+   #:*output-translations* #:*output-translations-parameter*
+   #:invalid-output-translation
+   #:output-translations #:output-translations-initialized-p
+   #:initialize-output-translations #:clear-output-translations
+   #:disable-output-translations #:ensure-output-translations
+   #:apply-output-translations
+   #:validate-output-translations-directive #:validate-output-translations=
-form
+   #:validate-output-translations-file #:validate-output-translations-dire=
ctory
+   #:parse-output-translations-string #:wrapping-output-translations
+   #:user-output-translations-pathname #:system-output-translations-pathna=
me
+   #:user-output-translations-directory-pathname #:system-output-translati=
ons-directory-pathname
+   #:environment-output-translations #:process-output-translations
+   #:compute-output-translations
+   #+abcl #:translate-jar-pathname
+   ))
+(in-package :asdf/output-translations)
+
+(when-upgrading () (undefine-function '(setf output-translations)))
+
+(define-condition invalid-output-translation (invalid-configuration warnin=
g)
+  ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ =
in ~S~]~@{ ~@?~}~@:>"))))
 =

 (defvar *output-translations* ()
   "Either NIL (for uninitialized), or a list of one element,
@@ -3499,20 +7224,10 @@
 Each mapping is a pair of a source pathname and destination pathname,
 and the order is by decreasing length of namestring of the source pathname=
.")
 =

-(defvar *user-cache*
-  (flet ((try (x &rest sub) (and x `(,x , at sub))))
-    (or
-     (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp" :impl=
ementation)
-     (when (os-windows-p)
-       (try (or (get-folder-path :local-appdata)
-                (get-folder-path :appdata))
-            "common-lisp" "cache" :implementation))
-     '(:home ".cache" "common-lisp" :implementation))))
-
 (defun* output-translations ()
   (car *output-translations*))
 =

-(defun* (setf output-translations) (new-value)
+(defun* set-output-translations (new-value)
   (setf *output-translations*
         (list
          (stable-sort (copy-list new-value) #'>
@@ -3523,131 +7238,16 @@
                                   (let ((directory (pathname-directory (ca=
r x))))
                                     (if (listp directory) (length director=
y) 0))))))))
   new-value)
+(defsetf output-translations set-output-translations) ; works with gcl 2.6
 =

 (defun* output-translations-initialized-p ()
   (and *output-translations* t))
 =

 (defun* clear-output-translations ()
-  "Undoes any initialization of the output translations.
-You might want to call that before you dump an image that would be resumed
-with a different configuration, so the configuration would be re-read then=
."
+  "Undoes any initialization of the output translations."
   (setf *output-translations* '())
   (values))
-
-(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean))
-                          (values (or null pathname) &optional))
-                resolve-location))
-
-(defun* resolve-relative-location-component (x &key directory wilden)
-  (let ((r (etypecase x
-             (pathname x)
-             (string (coerce-pathname x :type (when directory :directory)))
-             (cons
-              (if (null (cdr x))
-                  (resolve-relative-location-component
-                   (car x) :directory directory :wilden wilden)
-                  (let* ((car (resolve-relative-location-component
-                               (car x) :directory t :wilden nil)))
-                    (merge-pathnames*
-                     (resolve-relative-location-component
-                      (cdr x) :directory directory :wilden wilden)
-                     car))))
-             ((eql :default-directory)
-              (relativize-pathname-directory (default-directory)))
-             ((eql :*/) *wild-directory*)
-             ((eql :**/) *wild-inferiors*)
-             ((eql :*.*.*) *wild-file*)
-             ((eql :implementation)
-              (coerce-pathname (implementation-identifier) :type :director=
y))
-             ((eql :implementation-type)
-              (coerce-pathname (string-downcase (implementation-type)) :ty=
pe :directory))
-             ((eql :hostname)
-              (coerce-pathname (hostname) :type :directory)))))
-    (when (absolute-pathname-p r)
-      (error (compatfmt "~@<pathname ~S is not relative~@:>") x))
-    (if (or (pathnamep x) (not wilden)) r (wilden r))))
-
-(defvar *here-directory* nil
-  "This special variable is bound to the currect directory during calls to
-PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here
-directive.")
-
-(defun* resolve-absolute-location-component (x &key directory wilden)
-  (let* ((r
-          (etypecase x
-            (pathname x)
-            (string (let ((p (#+mcl probe-posix #-mcl parse-namestring x)))
-                      #+mcl (unless p (error "POSIX pathname ~S does not e=
xist" x))
-                      (if directory (ensure-directory-pathname p) p)))
-            (cons
-             (return-from resolve-absolute-location-component
-               (if (null (cdr x))
-                   (resolve-absolute-location-component
-                    (car x) :directory directory :wilden wilden)
-                   (merge-pathnames*
-                    (resolve-relative-location-component
-                     (cdr x) :directory directory :wilden wilden)
-                    (resolve-absolute-location-component
-                     (car x) :directory t :wilden nil)))))
-            ((eql :root)
-             ;; special magic! we encode such paths as relative pathnames,
-             ;; but it means "relative to the root of the source pathname'=
s host and device".
-             (return-from resolve-absolute-location-component
-               (let ((p (make-pathname :directory '(:relative))))
-                 (if wilden (wilden p) p))))
-            ((eql :home) (user-homedir))
-            ((eql :here)
-             (resolve-location (or *here-directory*
-                                   ;; give semantics in the case of use in=
teractively
-                                   :default-directory)
-                          :directory t :wilden nil))
-            ((eql :user-cache) (resolve-location *user-cache* :directory t=
 :wilden nil))
-            ((eql :system-cache)
-             (error "Using the :system-cache is deprecated. ~%~
-Please remove it from your ASDF configuration"))
-            ((eql :default-directory) (default-directory))))
-         (s (if (and wilden (not (pathnamep x)))
-                (wilden r)
-                r)))
-    (unless (absolute-pathname-p s)
-      (error (compatfmt "~@<Invalid designator for an absolute pathname: ~=
3i~_~S~@:>") x))
-    s))
-
-(defun* resolve-location (x &key directory wilden)
-  (if (atom x)
-      (resolve-absolute-location-component x :directory directory :wilden =
wilden)
-      (loop :with path =3D (resolve-absolute-location-component
-                          (car x) :directory (and (or directory (cdr x)) t)
-                          :wilden (and wilden (null (cdr x))))
-        :for (component . morep) :on (cdr x)
-        :for dir =3D (and (or morep directory) t)
-        :for wild =3D (and wilden (not morep))
-        :do (setf path (merge-pathnames*
-                        (resolve-relative-location-component
-                         component :directory dir :wilden wild)
-                        path))
-        :finally (return path))))
-
-(defun* location-designator-p (x)
-  (flet ((absolute-component-p (c)
-           (typep c '(or string pathname
-                      (member :root :home :here :user-cache :system-cache =
:default-directory))))
-         (relative-component-p (c)
-           (typep c '(or string pathname
-                      (member :default-directory :*/ :**/ :*.*.*
-                        :implementation :implementation-type)))))
-    (or (typep x 'boolean)
-        (absolute-component-p x)
-        (and (consp x) (absolute-component-p (first x)) (every #'relative-=
component-p (rest x))))))
-
-(defun* location-function-p (x)
-  (and
-   (length=3Dn-p x 2)
-   (eq (car x) :function)
-   (or (symbolp (cadr x))
-       (and (consp (cadr x))
-            (eq (caadr x) 'lambda)
-            (length=3Dn-p (cadadr x) 2)))))
+(register-clear-configuration-hook 'clear-output-translations)
 =

 (defun* validate-output-translations-directive (directive)
   (or (member directive '(:enable-user-cache :disable-cache nil))
@@ -3729,12 +7329,10 @@
   `(:output-translations
     ;; Some implementations have precompiled ASDF systems,
     ;; so we must disable translations for implementation paths.
-    #+sbcl ,(let ((h (getenv-pathname "SBCL_HOME" :want-directory t)))
-              (when h `((,(truenamize h) ,*wild-inferiors*) ())))
-    ;; The below two are not needed: no precompiled ASDF system there
-    #+(or ecl mkcl) (,(translate-logical-pathname "SYS:**;*.*") ())
+    #+(or #|clozure|# ecl mkcl sbcl)
+    ,@(let ((h (resolve-symlinks* (lisp-implementation-directory))))
+        (when h `(((,h ,*wild-path*) ()))))
     #+mkcl (,(translate-logical-pathname "CONTRIB:") ())
-    ;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-de=
faults* #p"")) (truename #p"ccl:"))) ()))
     ;; All-import, here is where we want user stuff to be:
     :inherit-configuration
     ;; These are for convenience, and can be overridden by the user:
@@ -3743,8 +7341,8 @@
     ;; We enable the user cache by default, and here is the place we do:
     :enable-user-cache))
 =

-(defparameter *output-translations-file* (coerce-pathname "asdf-output-tra=
nslations.conf"))
-(defparameter *output-translations-directory* (coerce-pathname "asdf-outpu=
t-translations.conf.d/"))
+(defparameter *output-translations-file* (parse-unix-namestring "asdf-outp=
ut-translations.conf"))
+(defparameter *output-translations-directory* (parse-unix-namestring "asdf=
-output-translations.conf.d/"))
 =

 (defun* user-output-translations-pathname (&key (direction :input))
   (in-user-configuration-directory *output-translations-file* :direction d=
irection))
@@ -3758,40 +7356,12 @@
   (getenv "ASDF_OUTPUT_TRANSLATIONS"))
 =

 (defgeneric* process-output-translations (spec &key inherit collect))
-(declaim (ftype (function (t &key (:collect (or symbol function))) t)
-                inherit-output-translations))
-(declaim (ftype (function (t &key (:collect (or symbol function)) (:inheri=
t list)) t)
-                process-output-translations-directive))
-
-(defmethod process-output-translations ((x symbol) &key
-                                        (inherit *default-output-translati=
ons*)
-                                        collect)
-  (process-output-translations (funcall x) :inherit inherit :collect colle=
ct))
-(defmethod process-output-translations ((pathname pathname) &key inherit c=
ollect)
-  (cond
-    ((directory-pathname-p pathname)
-     (process-output-translations (validate-output-translations-directory =
pathname)
-                                  :inherit inherit :collect collect))
-    ((probe-file* pathname)
-     (process-output-translations (validate-output-translations-file pathn=
ame)
-                                  :inherit inherit :collect collect))
-    (t
-     (inherit-output-translations inherit :collect collect))))
-(defmethod process-output-translations ((string string) &key inherit colle=
ct)
-  (process-output-translations (parse-output-translations-string string)
-                               :inherit inherit :collect collect))
-(defmethod process-output-translations ((x null) &key inherit collect)
-  (declare (ignorable x))
-  (inherit-output-translations inherit :collect collect))
-(defmethod process-output-translations ((form cons) &key inherit collect)
-  (dolist (directive (cdr (validate-output-translations-form form)))
-    (process-output-translations-directive directive :inherit inherit :col=
lect collect)))
 =

 (defun* inherit-output-translations (inherit &key collect)
   (when inherit
     (process-output-translations (first inherit) :collect collect :inherit=
 (rest inherit))))
 =

-(defun* process-output-translations-directive (directive &key inherit coll=
ect)
+(defun* (process-output-translations-directive) (directive &key inherit co=
llect)
   (if (atom directive)
       (ecase directive
         ((:enable-user-cache)
@@ -3809,8 +7379,8 @@
               (process-output-translations (pathname dst) :inherit nil :co=
llect collect))
             (when src
               (let ((trusrc (or (eql src t)
-                                (let ((loc (resolve-location src :director=
y t :wilden t)))
-                                  (if (absolute-pathname-p loc) (truenamiz=
e loc) loc)))))
+                                (let ((loc (resolve-location src :ensure-d=
irectory t :wilden t)))
+                                  (if (absolute-pathname-p loc) (resolve-s=
ymlinks* loc) loc)))))
                 (cond
                   ((location-function-p dst)
                    (funcall collect
@@ -3822,11 +7392,34 @@
                    (funcall collect (list trusrc t)))
                   (t
                    (let* ((trudst (if dst
-                                      (resolve-location dst :directory t :=
wilden t)
-                                      trusrc))
-                          (wilddst (merge-pathnames* *wild-file* trudst)))
-                     (funcall collect (list wilddst t))
+                                      (resolve-location dst :ensure-direct=
ory t :wilden t)
+                                      trusrc)))
+                     (funcall collect (list trudst t))
                      (funcall collect (list trusrc trudst)))))))))))
+
+(defmethod process-output-translations ((x symbol) &key
+                                        (inherit *default-output-translati=
ons*)
+                                        collect)
+  (process-output-translations (funcall x) :inherit inherit :collect colle=
ct))
+(defmethod process-output-translations ((pathname #-gcl2.6 pathname #+gcl2=
.6 t) &key inherit collect)
+  (cond
+    ((directory-pathname-p pathname)
+     (process-output-translations (validate-output-translations-directory =
pathname)
+                                  :inherit inherit :collect collect))
+    ((probe-file* pathname :truename *resolve-symlinks*)
+     (process-output-translations (validate-output-translations-file pathn=
ame)
+                                  :inherit inherit :collect collect))
+    (t
+     (inherit-output-translations inherit :collect collect))))
+(defmethod process-output-translations ((string string) &key inherit colle=
ct)
+  (process-output-translations (parse-output-translations-string string)
+                               :inherit inherit :collect collect))
+(defmethod process-output-translations ((x null) &key inherit collect)
+  (declare (ignorable x))
+  (inherit-output-translations inherit :collect collect))
+(defmethod process-output-translations ((form cons) &key inherit collect)
+  (dolist (directive (cdr (validate-output-translations-form form)))
+    (process-output-translations-directive directive :inherit inherit :col=
lect collect)))
 =

 (defun* compute-output-translations (&optional parameter)
   "read the configuration, return it"
@@ -3859,30 +7452,14 @@
       (output-translations)
       (initialize-output-translations)))
 =

-(defun* translate-pathname* (path absolute-source destination &optional ro=
ot source)
-  (declare (ignore source))
-  (cond
-    ((functionp destination)
-     (funcall destination path absolute-source))
-    ((eq destination t)
-     path)
-    ((not (pathnamep destination))
-     (error "Invalid destination"))
-    ((not (absolute-pathname-p destination))
-     (translate-pathname path absolute-source (merge-pathnames* destinatio=
n root)))
-    (root
-     (translate-pathname (directorize-pathname-host-device path) absolute-=
source destination))
-    (t
-     (translate-pathname path absolute-source destination))))
-
-(defun* apply-output-translations (path)
-  #+cormanlisp (truenamize path) #-cormanlisp
+(defun* (apply-output-translations) (path)
+  #+cormanlisp (resolve-symlinks* path) #-cormanlisp
   (etypecase path
     (logical-pathname
      path)
     ((or pathname string)
      (ensure-output-translations)
-     (loop :with p =3D (truenamize path)
+     (loop* :with p =3D (resolve-symlinks* path)
        :for (source destination) :in (car *output-translations*)
        :for root =3D (when (or (eq source t)
                              (and (pathnamep source)
@@ -3896,126 +7473,63 @@
        :return (translate-pathname* p absolute-source destination root sou=
rce)
        :finally (return p)))))
 =

-(defmethod output-files :around (operation component)
-  "Translate output files, unless asked not to"
-  operation component ;; hush genera, not convinced by declare ignorable(!)
-  (values
-   (multiple-value-bind (files fixedp) (call-next-method)
-     (if fixedp
-         files
-         (mapcar #'apply-output-translations files)))
-   t))
-
-(defun* compile-file-pathname* (input-file &rest keys &key output-file &al=
low-other-keys)
-  (if (absolute-pathname-p output-file)
-      ;; what cfp should be doing, w/ mp* instead of mp
-      (let* ((type (pathname-type (apply 'compile-file-pathname "x.lisp" k=
eys)))
-	     (defaults (make-pathname
-			:type type :defaults (merge-pathnames* input-file))))
-	(merge-pathnames* output-file defaults))
-      (apply-output-translations
-       (apply 'compile-file-pathname input-file
-	      (if output-file keys (remove-keyword :output-file keys))))))
-
-(defun* tmpize-pathname (x)
-  (make-pathname
-   :name (strcat "ASDF-TMP-" (pathname-name x))
-   :defaults x))
-
-(defun* delete-file-if-exists (x)
-  (when (and x (probe-file* x))
-    (delete-file x)))
-
-(defun* compile-file* (input-file &rest keys &key compile-check output-fil=
e &allow-other-keys)
-  (let* ((keywords (remove-keyword :compile-check keys))
-         (output-file (apply 'compile-file-pathname* input-file :output-fi=
le output-file keywords))
-         (tmp-file (tmpize-pathname output-file))
-         (status :error))
-    (multiple-value-bind (output-truename warnings-p failure-p)
-        (apply 'compile-file input-file :output-file tmp-file keywords)
-      (cond
-        (failure-p
-         (setf status *compile-file-failure-behaviour*))
-        (warnings-p
-         (setf status *compile-file-warnings-behaviour*))
-        (t
-         (setf status :success)))
-      (cond
-        ((and (ecase status
-                ((:success :warn :ignore) t)
-                ((:error nil)))
-              (or (not compile-check)
-                  (apply compile-check input-file :output-file tmp-file ke=
ywords)))
-         (delete-file-if-exists output-file)
-         (when output-truename
-           (rename-file output-truename output-file)
-           (setf output-truename output-file)))
-        (t ;; error or failed check
-         (delete-file-if-exists output-truename)
-         (setf output-truename nil failure-p t)))
-      (values output-truename warnings-p failure-p))))
+;; Hook into asdf/driver's output-translation mechanism
+(setf *output-translation-function* 'apply-output-translations)
 =

 #+abcl
 (defun* translate-jar-pathname (source wildcard)
   (declare (ignore wildcard))
-  (let* ((p (pathname (first (pathname-device source))))
-         (root (format nil "/___jar___file___root___/~@[~A/~]"
-                       (and (find :windows *features*)
-                            (pathname-device p)))))
-    (apply-output-translations
-     (merge-pathnames*
-      (relativize-pathname-directory source)
-      (merge-pathnames*
-       (relativize-pathname-directory (ensure-directory-pathname p))
-       root)))))
-
-;;;; -----------------------------------------------------------------
-;;;; Compatibility mode for ASDF-Binary-Locations
-
-(defmethod operate :before (operation-class system &rest args &key &allow-=
other-keys)
-  (declare (ignorable operation-class system args))
-  (when (find-symbol* '#:output-files-for-system-and-operation :asdf)
-    (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you=
 are using.
-ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLAT=
IONS,
-which should be easier to configure. Please stop using ASDF-BINARY-LOCATIO=
NS,
-and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.
-In case you insist on preserving your previous A-B-L configuration, but
-do not know how to achieve the same effect with A-O-T, you may use function
-ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manua=
l;
-call that function where you would otherwise have loaded and configured A-=
B-L.")))
-
-(defun* enable-asdf-binary-locations-compatibility
-    (&key
-     (centralize-lisp-binaries nil)
-     (default-toplevel-directory
-         (subpathname (user-homedir) ".fasls/")) ;; Use ".cache/common-lis=
p/" instead ???
-     (include-per-user-information nil)
-     (map-all-source-files (or #+(or clisp ecl mkcl) t nil))
-     (source-to-target-mappings nil))
-  #+(or clisp ecl mkcl)
-  (when (null map-all-source-files)
-    (error "asdf:enable-asdf-binary-locations-compatibility doesn't suppor=
t :map-all-source-files nil on CLISP, ECL and MKCL"))
-  (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
-         (mapped-files (if map-all-source-files *wild-file*
-                           (make-pathname :type fasl-type :defaults *wild-=
file*)))
-         (destination-directory
-          (if centralize-lisp-binaries
-              `(,default-toplevel-directory
-                ,@(when include-per-user-information
-                        (cdr (pathname-directory (user-homedir))))
-                :implementation ,*wild-inferiors*)
-              `(:root ,*wild-inferiors* :implementation))))
-    (initialize-output-translations
-     `(:output-translations
-       , at source-to-target-mappings
-       ((:root ,*wild-inferiors* ,mapped-files)
-        (, at destination-directory ,mapped-files))
-       (t t)
-       :ignore-inherited-configuration))))
-
+  (flet ((normalize-device (pathname)
+           (if (find :windows *features*)
+               pathname
+               (make-pathname :defaults pathname :device :unspecific))))
+    (let* ((jar
+             (pathname (first (pathname-device source))))
+           (target-root-directory-namestring
+             (format nil "/___jar___file___root___/~@[~A/~]"
+                     (and (find :windows *features*)
+                          (pathname-device jar))))
+           (relative-source
+             (relativize-pathname-directory source))
+           (relative-jar
+             (relativize-pathname-directory (ensure-directory-pathname jar=
)))
+           (target-root-directory
+             (normalize-device
+              (pathname-directory-pathname
+               (parse-namestring target-root-directory-namestring))))
+           (target-root
+             (merge-pathnames* relative-jar target-root-directory))
+           (target
+             (merge-pathnames* relative-source target-root)))
+      (normalize-device (apply-output-translations target)))))
 ;;;; -----------------------------------------------------------------
 ;;;; Source Registry Configuration, by Francois-Rene Rideau
 ;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
+
+(asdf/package:define-package :asdf/source-registry
+  (:recycle :asdf/source-registry :asdf)
+  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/find-system)
+  (:export
+   #:*source-registry* #:*source-registry-parameter* #:*default-source-reg=
istries*
+   #:invalid-source-registry
+   #:source-registry #:source-registry-initialized-p
+   #:initialize-source-registry #:clear-source-registry #:*source-registry*
+   #:disable-source-registry #:ensure-source-registry #:*source-registry-p=
arameter*
+   #:*default-source-registry-exclusions* #:*source-registry-exclusions*
+   #:*wild-asd* #:directory-asd-files #:register-asd-directory
+   #:collect-asds-in-directory #:collect-sub*directories-asd-files
+   #:validate-source-registry-directive #:validate-source-registry-form
+   #:validate-source-registry-file #:validate-source-registry-directory
+   #:parse-source-registry-string #:wrapping-source-registry #:default-sou=
rce-registry
+   #:user-source-registry #:system-source-registry
+   #:user-source-registry-directory #:system-source-registry-directory
+   #:environment-source-registry #:process-source-registry
+   #:compute-source-registry #:flatten-source-registry
+   #:sysdef-source-registry-search))
+(in-package :asdf/source-registry)
+
+(define-condition invalid-source-registry (invalid-configuration warning)
+  ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~=
@{ ~@?~}~@:>"))))
 =

 ;; Using ack 1.2 exclusions
 (defvar *default-source-registry-exclusions*
@@ -4035,111 +7549,26 @@
   (typep *source-registry* 'hash-table))
 =

 (defun* clear-source-registry ()
-  "Undoes any initialization of the source registry.
-You might want to call that before you dump an image that would be resumed
-with a different configuration, so the configuration would be re-read then=
."
+  "Undoes any initialization of the source registry."
   (setf *source-registry* nil)
   (values))
+(register-clear-configuration-hook 'clear-source-registry)
 =

 (defparameter *wild-asd*
-  (make-pathname :directory nil :name *wild* :type "asd" :version :newest))
-
-(defun* filter-logical-directory-results (directory entries merger)
-  (if (typep directory 'logical-pathname)
-      ;; Try hard to not resolve logical-pathname into physical pathnames;
-      ;; otherwise logical-pathname users/lovers will be disappointed.
-      ;; If directory* could use some implementation-dependent magic,
-      ;; we will have logical pathnames already; otherwise,
-      ;; we only keep pathnames for which specifying the name and
-      ;; translating the LPN commute.
-      (loop :for f :in entries
-        :for p =3D (or (and (typep f 'logical-pathname) f)
-                     (let* ((u (ignore-errors (funcall merger f))))
-                       ;; The first u avoids a cumbersome (truename u) err=
or.
-                       ;; At this point f should already be a truename,
-                       ;; but isn't quite in CLISP, for doesn't have :vers=
ion :newest
-                       (and u (equal (ignore-errors (truename u)) (truenam=
e f)) u)))
-        :when p :collect p)
-      entries))
-
-(defun* directory-files (directory &optional (pattern *wild-file*))
-  (let ((dir (pathname directory)))
-    (when (typep dir 'logical-pathname)
-      ;; Because of the filtering we do below,
-      ;; logical pathnames have restrictions on wild patterns.
-      ;; Not that the results are very portable when you use these pattern=
s on physical pathnames.
-      (when (wild-pathname-p dir)
-        (error "Invalid wild pattern in logical directory ~S" directory))
-      (unless (member (pathname-directory pattern) '(() (:relative)) :test=
 'equal)
-        (error "Invalid file pattern ~S for logical directory ~S" pattern =
directory))
-      (setf pattern (make-pathname-logical pattern (pathname-host dir))))
-    (let ((entries (ignore-errors (directory* (merge-pathnames* pattern di=
r)))))
-      (filter-logical-directory-results
-       directory entries
-       #'(lambda (f)
-           (make-pathname :defaults dir
-                          :name (make-pathname-component-logical (pathname=
-name f))
-                          :type (make-pathname-component-logical (pathname=
-type f))
-                          :version (make-pathname-component-logical (pathn=
ame-version f))))))))
+  (make-pathname* :directory nil :name *wild* :type "asd" :version :newest=
))
 =

 (defun* directory-asd-files (directory)
   (directory-files directory *wild-asd*))
 =

-(defun* subdirectories (directory)
-  (let* ((directory (ensure-directory-pathname directory))
-         #-(or abcl cormanlisp genera xcl)
-         (wild (merge-pathnames*
-                #-(or abcl allegro cmu lispworks sbcl scl xcl)
-                *wild-directory*
-                #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
-                directory))
-         (dirs
-          #-(or abcl cormanlisp genera xcl)
-          (ignore-errors
-            (directory* wild . #.(or #+clozure '(:directories t :files nil)
-                                     #+mcl '(:directories t))))
-          #+(or abcl xcl) (system:list-directory directory)
-          #+cormanlisp (cl::directory-subdirs directory)
-          #+genera (fs:directory-list directory))
-         #+(or abcl allegro cmu genera lispworks sbcl scl xcl)
-         (dirs (loop :for x :in dirs
-                 :for d =3D #+(or abcl xcl) (extensions:probe-directory x)
-                          #+allegro (excl:probe-directory 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 (fir=
st x))
-                                  #+(or cmu lispworks sbcl scl) x)))
-    (filter-logical-directory-results
-     directory dirs
-     (let ((prefix (or (normalize-pathname-directory-component (pathname-d=
irectory directory))
-                       '(:absolute)))) ; because allegro returns NIL for #=
p"FOO:"
-       #'(lambda (d)
-           (let ((dir (normalize-pathname-directory-component (pathname-di=
rectory d))))
-             (and (consp dir) (consp (cdr dir))
-                  (make-pathname
-                   :defaults directory :name nil :type nil :version nil
-                   :directory (append prefix (make-pathname-component-logi=
cal (last dir)))))))))))
-
 (defun* collect-asds-in-directory (directory collect)
   (map () collect (directory-asd-files directory)))
 =

-(defun* collect-sub*directories (directory collectp recursep collector)
-  (when (funcall collectp directory)
-    (funcall collector directory))
-  (dolist (subdir (subdirectories directory))
-    (when (funcall recursep subdir)
-      (collect-sub*directories subdir collectp recursep collector))))
-
 (defun* collect-sub*directories-asd-files
-    (directory &key
-     (exclude *default-source-registry-exclusions*)
-     collect)
+    (directory &key (exclude *default-source-registry-exclusions*) collect)
   (collect-sub*directories
    directory
    (constantly t)
-   #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude =
:test #'equal)))
+   #'(lambda (x &aux (l (car (last (pathname-directory x))))) (not (member=
 l exclude :test #'equal)))
    #'(lambda (dir) (collect-asds-in-directory dir collect))))
 =

 (defun* validate-source-registry-directive (directive)
@@ -4223,25 +7652,23 @@
     system-source-registry-directory
     default-source-registry))
 =

-(defparameter *source-registry-file* (coerce-pathname "source-registry.con=
f"))
-(defparameter *source-registry-directory* (coerce-pathname "source-registr=
y.conf.d/"))
+(defparameter *source-registry-file* (parse-unix-namestring "source-regist=
ry.conf"))
+(defparameter *source-registry-directory* (parse-unix-namestring "source-r=
egistry.conf.d/"))
 =

 (defun* wrapping-source-registry ()
   `(:source-registry
-    #+ecl (:tree ,(translate-logical-pathname "SYS:"))
+    #+(or ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-direct=
ory)))
     #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:"))
-    #+sbcl (:tree ,(truenamize (getenv-pathname "SBCL_HOME" :want-director=
y t)))
     :inherit-configuration
     #+cmu (:tree #p"modules:")
     #+scl (:tree #p"file://modules/")))
 (defun* default-source-registry ()
   `(:source-registry
-    #+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/"))
-    (:directory ,(default-directory))
+    #+sbcl (:directory ,(subpathname (user-homedir-pathname) ".sbcl/system=
s/"))
     ,@(loop :for dir :in
         `(,@(when (os-unix-p)
               `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
-                     (subpathname (user-homedir) ".local/share/"))
+                     (subpathname (user-homedir-pathname) ".local/share/"))
                 ,@(or (getenv-absolute-directories "XDG_DATA_DIRS")
                       '("/usr/local/share" "/usr/share"))))
           ,@(when (os-windows-p)
@@ -4260,21 +7687,48 @@
 (defun* environment-source-registry ()
   (getenv "CL_SOURCE_REGISTRY"))
 =

-(defgeneric* process-source-registry (spec &key inherit register))
-(declaim (ftype (function (t &key (:register (or symbol function))) t)
-                inherit-source-registry))
-(declaim (ftype (function (t &key (:register (or symbol function)) (:inher=
it list)) t)
-                process-source-registry-directive))
+(defgeneric* (process-source-registry) (spec &key inherit register))
+
+(defun* (inherit-source-registry) (inherit &key register)
+  (when inherit
+    (process-source-registry (first inherit) :register register :inherit (=
rest inherit))))
+
+(defun* (process-source-registry-directive) (directive &key inherit regist=
er)
+  (destructuring-bind (kw &rest rest) (if (consp directive) directive (lis=
t directive))
+    (ecase kw
+      ((:include)
+       (destructuring-bind (pathname) rest
+         (process-source-registry (resolve-location pathname) :inherit nil=
 :register register)))
+      ((:directory)
+       (destructuring-bind (pathname) rest
+         (when pathname
+           (funcall register (resolve-location pathname :ensure-directory =
t)))))
+      ((:tree)
+       (destructuring-bind (pathname) rest
+         (when pathname
+           (funcall register (resolve-location pathname :ensure-directory =
t)
+                    :recurse t :exclude *source-registry-exclusions*))))
+      ((:exclude)
+       (setf *source-registry-exclusions* rest))
+      ((:also-exclude)
+       (appendf *source-registry-exclusions* rest))
+      ((:default-registry)
+       (inherit-source-registry '(default-source-registry) :register regis=
ter))
+      ((:inherit-configuration)
+       (inherit-source-registry inherit :register register))
+      ((:ignore-inherited-configuration)
+       nil)))
+  nil)
 =

 (defmethod process-source-registry ((x symbol) &key inherit register)
   (process-source-registry (funcall x) :inherit inherit :register register=
))
-(defmethod process-source-registry ((pathname pathname) &key inherit regis=
ter)
+(defmethod process-source-registry ((pathname #-gcl2.6 pathname #+gcl2.6 t=
) &key inherit register)
   (cond
     ((directory-pathname-p pathname)
-     (let ((*here-directory* (truenamize pathname)))
+     (let ((*here-directory* (resolve-symlinks* pathname)))
        (process-source-registry (validate-source-registry-directory pathna=
me)
                                 :inherit inherit :register register)))
-    ((probe-file* pathname)
+    ((probe-file* pathname :truename *resolve-symlinks*)
      (let ((*here-directory* (pathname-directory-pathname pathname)))
        (process-source-registry (validate-source-registry-file pathname)
                                 :inherit inherit :register register)))
@@ -4291,41 +7745,10 @@
     (dolist (directive (cdr (validate-source-registry-form form)))
       (process-source-registry-directive directive :inherit inherit :regis=
ter register))))
 =

-(defun* inherit-source-registry (inherit &key register)
-  (when inherit
-    (process-source-registry (first inherit) :register register :inherit (=
rest inherit))))
-
-(defun* process-source-registry-directive (directive &key inherit register)
-  (destructuring-bind (kw &rest rest) (if (consp directive) directive (lis=
t directive))
-    (ecase kw
-      ((:include)
-       (destructuring-bind (pathname) rest
-         (process-source-registry (resolve-location pathname) :inherit nil=
 :register register)))
-      ((:directory)
-       (destructuring-bind (pathname) rest
-         (when pathname
-           (funcall register (resolve-location pathname :directory t)))))
-      ((:tree)
-       (destructuring-bind (pathname) rest
-         (when pathname
-           (funcall register (resolve-location pathname :directory t)
-                    :recurse t :exclude *source-registry-exclusions*))))
-      ((:exclude)
-       (setf *source-registry-exclusions* rest))
-      ((:also-exclude)
-       (appendf *source-registry-exclusions* rest))
-      ((:default-registry)
-       (inherit-source-registry '(default-source-registry) :register regis=
ter))
-      ((:inherit-configuration)
-       (inherit-source-registry inherit :register register))
-      ((:ignore-inherited-configuration)
-       nil)))
-  nil)
-
 (defun* flatten-source-registry (&optional parameter)
   (remove-duplicates
    (while-collecting (collect)
-     (let ((*default-pathname-defaults* (default-directory)))
+     (with-pathname-defaults () ;; be location-independent
        (inherit-source-registry
         `(wrapping-source-registry
           ,parameter
@@ -4355,7 +7778,7 @@
                  ((gethash name registry) ; already shadowed by something =
else
                   nil)
                  ((gethash name h) ; conflict at current level
-                  (when *asdf-verbose*
+                  (when *verbose-out*
                     (warn (compatfmt "~@<In source-registry entry ~A~@[/~*=
~] ~
                                 found several entries for ~A - picking ~S =
over ~S~:>")
                           directory recurse name (gethash name h) asd)))
@@ -4368,8 +7791,11 @@
 (defvar *source-registry-parameter* nil)
 =

 (defun* initialize-source-registry (&optional (parameter *source-registry-=
parameter*))
+  ;; Record the parameter used to configure the registry =

   (setf *source-registry-parameter* parameter)
+  ;; Clear the previous registry database:
   (setf *source-registry* (make-hash-table :test 'equal))
+  ;; Do it!
   (compute-source-registry parameter))
 =

 ;; Checks an initial variable to see whether the state is initialized
@@ -4387,29 +7813,1207 @@
 =

 (defun* sysdef-source-registry-search (system)
   (ensure-source-registry)
-  (values (gethash (coerce-name system) *source-registry*)))
-
-(defun* clear-configuration ()
-  (clear-source-registry)
-  (clear-output-translations))
-
-
-;;; ECL and MKCL support for COMPILE-OP / LOAD-OP
+  (values (gethash (primary-system-name system) *source-registry*)))
+;;;; ---------------------------------------------------------------------=
----
+;;; Internal hacks for backward-compatibility =

+
+(asdf/package:define-package :asdf/backward-internals
+  (:recycle :asdf/backward-internals :asdf)
+  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
+   :asdf/system :asdf/component :asdf/operation
+   :asdf/find-system :asdf/action :asdf/lisp-action)
+  (:export ;; for internal use
+   #:load-sysdef #:make-temporary-package
+   #:%refresh-component-inline-methods
+   #:%resolve-if-component-dep-fails
+   #:make-sub-operation
+   #:load-sysdef #:make-temporary-package))
+(in-package :asdf/backward-internals)
+
+;;;; Backward compatibility with "inline methods"
+
+(defparameter +asdf-methods+
+  '(perform-with-restarts perform explain output-files operation-done-p))
+
+(defun* %remove-component-inline-methods (component)
+  (dolist (name +asdf-methods+)
+    (map ()
+         ;; this is inefficient as most of the stored
+         ;; methods will not be for this particular gf
+         ;; But this is hardly performance-critical
+         #'(lambda (m)
+             (remove-method (symbol-function name) m))
+         (component-inline-methods component)))
+  ;; clear methods, then add the new ones
+  (component-inline-methods component) nil)
+
+(defun* %define-component-inline-methods (ret rest)
+  (dolist (name +asdf-methods+)
+    (let ((keyword (intern (symbol-name name) :keyword)))
+      (loop :for data =3D rest :then (cddr data)
+        :for key =3D (first data)
+        :for value =3D (second data)
+        :while data
+        :when (eq key keyword) :do
+        (destructuring-bind (op qual (o c) &body body) value
+          (pushnew
+           (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
+                             , at body))
+           (component-inline-methods ret)))))))
+
+(defun* %refresh-component-inline-methods (component rest)
+  (%remove-component-inline-methods component)
+  (%define-component-inline-methods component rest))
+
+;;;; PARTIAL SUPPORT for the :if-component-dep-fails component attribute
+;; and the companion asdf:feature pseudo-dependency.
+;; This won't recurse into dependencies to accumulate feature conditions.
+;; Therefore it will accept the SB-ROTATE-BYTE of an old SBCL
+;; (older than 1.1.2.20-fe6da9f) but won't suffice to load an old nibbles.
+(defun* %resolve-if-component-dep-fails (if-component-dep-fails component)
+  (asdf-message "The system definition for ~S uses deprecated ~
+                 ASDF option :IF-COMPONENT-DEP-DAILS. ~
+                 Starting with ASDF 3, please use :IF-FEATURE instead"
+                (coerce-name (component-system component)))
+  ;; This only supports the pattern of use of the "feature" seen in the wi=
ld
+  (check-type component parent-component)
+  (check-type if-component-dep-fails (member :fail :ignore :try-next))
+  (unless (eq if-component-dep-fails :fail)
+    (loop :with o =3D (make-operation 'compile-op)
+      :for c :in (component-children component) :do
+        (loop* :for (feature? feature) :in (component-depends-on o c)
+               :when (eq feature? 'feature) :do
+                 (setf (component-if-feature c) feature)))))
+
+(when-upgrading (:when (fboundp 'make-sub-operation))
+  (defun* make-sub-operation (c o dep-c dep-o)
+    (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)))
+
+
+;;;; load-sysdef
+(defun* load-sysdef (name pathname)
+  (load-asd pathname :name name))
+
+(defun* make-temporary-package ()
+  ;; For loading a .asd file, we dont't make a temporary package anymore,
+  ;; but use ASDF-USER. I'd like to have this function do this,
+  ;; but since whoever uses it is likely to delete-package the result afte=
rwards,
+  ;; this would be a bad idea, so preserve the old behavior.
+  (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :as=
df)))
+
+
+;;;; ---------------------------------------------------------------------=
----
+;;;; Defsystem
+
+(asdf/package:define-package :asdf/defsystem
+  (:recycle :asdf/defsystem :asdf)
+  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
+   :asdf/component :asdf/system :asdf/cache
+   :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate
+   :asdf/backward-internals)
+  (:export
+   #:defsystem #:register-system-definition
+   #:class-for-type #:*default-component-class*
+   #:determine-system-directory #:parse-component-form
+   #:duplicate-names #:sysdef-error-component #:check-component-input))
+(in-package :asdf/defsystem)
+
+;;; Pathname
+
+(defun* determine-system-directory (pathname)
+  ;; The defsystem macro calls this function to determine
+  ;; the pathname of a system as follows:
+  ;; 1. if the pathname argument is an pathname object (NOT a namestring),
+  ;;    that is already an absolute pathname, return it.
+  ;; 2. otherwise, the directory containing the LOAD-PATHNAME
+  ;;    is considered (as deduced from e.g. *LOAD-PATHNAME*), and
+  ;;    if it is indeed available and an absolute pathname, then
+  ;;    the PATHNAME argument is normalized to a relative pathname
+  ;;    as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T)
+  ;;    and merged into that DIRECTORY as per SUBPATHNAME.
+  ;;    Note: avoid *COMPILE-FILE-PATHNAME* because .asd is loaded,
+  ;;    and may be from within the EVAL-WHEN of a file compilation.
+  ;; If no absolute pathname was found, we return NIL.
+  (check-type pathname (or null string pathname))
+  (resolve-symlinks*
+   (ensure-absolute-pathname
+    (parse-unix-namestring pathname :type :directory)
+    #'(lambda () (ensure-absolute-pathname
+                  (load-pathname) 'get-pathname-defaults nil))
+    nil)))
+
+
+;;; Component class
+
+(defvar *default-component-class* 'cl-source-file)
+
+(defun* class-for-type (parent type)
+  (or (loop :for symbol :in (list
+                             type
+                             (find-symbol* type *package* nil)
+                             (find-symbol* type :asdf/interface nil))
+        :for class =3D (and symbol (find-class* symbol nil))
+        :when (and class
+                   (#-cormanlisp subtypep #+cormanlisp cl::subclassp
+                                 class (find-class* 'component)))
+        :return class)
+      (and (eq type :file)
+           (find-class*
+            (or (loop :for p =3D parent :then (component-parent p) :while p
+                      :thereis (module-default-component-class p))
+                *default-component-class*) nil))
+      (sysdef-error "don't recognize component type ~A" type)))
+
+
+;;; Check inputs
+
+(define-condition duplicate-names (system-definition-error)
+  ((name :initarg :name :reader duplicate-names-name))
+  (:report (lambda (c s)
+             (format s (compatfmt "~@<Error while defining system: multipl=
e components are given same name ~A~@:>")
+                     (duplicate-names-name c)))))
+
+(defun* sysdef-error-component (msg type name value)
+  (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~=
) ~A is ~S~@:>"))
+                type name value))
+
+(defun* check-component-input (type name weakly-depends-on
+                                    depends-on components)
+  "A partial test of the values of a component."
+  (unless (listp depends-on)
+    (sysdef-error-component ":depends-on must be a list."
+                            type name depends-on))
+  (unless (listp weakly-depends-on)
+    (sysdef-error-component ":weakly-depends-on must be a list."
+                            type name weakly-depends-on))
+  (unless (listp components)
+    (sysdef-error-component ":components must be NIL or a list of componen=
ts."
+                            type name components)))
+
+(defun* normalize-version (form pathname)
+  (etypecase form
+    ((or string null) form)
+    (real
+     (asdf-message "Invalid use of real number ~D as :version in ~S. Subst=
ituting a string."
+                   form pathname)
+     (format nil "~D" form)) ;; 1.0 is "1.0"
+    (cons
+     (ecase (first form)
+       ((:read-file-form)
+        (destructuring-bind (subpath &key (at 0)) (rest form)
+          (safe-read-file-form (subpathname pathname subpath) :at at)))))))
+
+
+;;; Main parsing function
+
+(defun* parse-component-form (parent options &key previous-serial-componen=
t)
+  (destructuring-bind
+      (type name &rest rest &key
+       (builtin-system-p () bspp)
+       ;; the following list of keywords is reproduced below in the
+       ;; remove-plist-keys form.  important to keep them in sync
+       components pathname perform explain output-files operation-done-p
+       weakly-depends-on depends-on serial
+       do-first if-component-dep-fails (version nil versionp)
+       ;; list ends
+       &allow-other-keys) options
+    (declare (ignorable perform explain output-files operation-done-p buil=
tin-system-p))
+    (check-component-input type name weakly-depends-on depends-on componen=
ts)
+    (when (and parent
+               (find-component parent name)
+               (not ;; ignore the same object when rereading the defsystem
+                (typep (find-component parent name)
+                       (class-for-type parent type))))
+      (error 'duplicate-names :name name))
+    (when do-first (error "DO-FIRST is not supported anymore as of ASDF 3"=
))
+    (let* ((args `(:name ,(coerce-name name)
+                   :pathname ,pathname
+                   ,@(when parent `(:parent ,parent))
+                   ,@(remove-plist-keys
+                      '(:components :pathname :if-component-dep-fails :ver=
sion
+                        :perform :explain :output-files :operation-done-p
+                        :weakly-depends-on :depends-on :serial)
+                      rest)))
+           (component (find-component parent name)))
+      (when weakly-depends-on
+        ;; ASDF4: deprecate this feature and remove it.
+        (appendf depends-on
+                 (remove-if (complement #'(lambda (x) (find-system x nil))=
) weakly-depends-on)))
+      (when previous-serial-component
+        (push previous-serial-component depends-on))
+      (if component ; preserve identity
+          (apply 'reinitialize-instance component args)
+          (setf component (apply 'make-instance (class-for-type parent typ=
e) args)))
+      (component-pathname component) ; eagerly compute the absolute pathna=
me
+      (let ((sysdir (system-source-directory (component-system component))=
)) ;; requires the previous
+        (when (and (typep component 'system) (not bspp))
+          (setf (builtin-system-p component) (lisp-implementation-pathname=
-p sysdir)))
+        (setf version (normalize-version version sysdir)))
+      (when (and versionp version (not (parse-version version nil)))
+        (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~=
]~@:>")
+              version name parent))
+      (setf (component-version component) version)
+      (when (typep component 'parent-component)
+        (setf (component-children component)
+              (loop
+                :with previous-component =3D nil
+                :for c-form :in components
+                :for c =3D (parse-component-form component c-form
+                                               :previous-serial-component =
previous-component)
+                :for name =3D (component-name c)
+                :collect c
+                :when serial :do (setf previous-component name)))
+        (compute-children-by-name component))
+      ;; Used by POIU. ASDF4: rename to component-depends-on?
+      (setf (component-sibling-dependencies component) depends-on)
+      (%refresh-component-inline-methods component rest)
+      (when if-component-dep-fails
+        (%resolve-if-component-dep-fails if-component-dep-fails component))
+      component)))
+
+(defun* register-system-definition
+    (name &rest options &key pathname (class 'system) (source-file () sfp)
+          defsystem-depends-on &allow-other-keys)
+  ;; The system must be registered before we parse the body,
+  ;; otherwise we recur when trying to find an existing system
+  ;; of the same name to reuse options (e.g. pathname) from.
+  ;; To avoid infinite recursion in cases where you defsystem a system
+  ;; that is registered to a different location to find-system,
+  ;; we also need to remember it in a special variable *systems-being-defi=
ned*.
+  (with-system-definitions ()
+    (let* ((name (coerce-name name))
+           (source-file (if sfp source-file (resolve-symlinks* (load-pathn=
ame))))
+           (registered (system-registered-p name))
+           (registered! (if registered
+                            (rplaca registered (get-file-stamp source-file=
))
+                            (register-system
+                             (make-instance 'system :name name :source-fil=
e source-file))))
+           (system (reset-system (cdr registered!)
+                                 :name name :source-file source-file))
+           (component-options (remove-plist-key :class options)))
+      (apply 'load-systems defsystem-depends-on)
+      ;; We change-class AFTER we loaded the defsystem-depends-on
+      ;; since the class might be defined as part of those.
+      (let ((class (class-for-type nil class)))
+        (unless (eq (type-of system) class)
+          (change-class system class)))
+      (parse-component-form
+       nil (list*
+            :module name
+            :pathname (determine-system-directory pathname)
+            component-options)))))
+
+(defmacro defsystem (name &body options)
+  `(apply 'register-system-definition ',name ',options))
+;;;; ---------------------------------------------------------------------=
----
+;;;; ASDF-Bundle
+
+(asdf/package:define-package :asdf/bundle
+  (:recycle :asdf/bundle :asdf)
+  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
+   :asdf/component :asdf/system :asdf/find-system :asdf/find-component :as=
df/operation
+   :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate)
+  (:export
+   #:bundle-op #:bundle-op-build-args #:bundle-type #:bundle-system #:bund=
le-pathname-type
+   #:fasl-op #:load-fasl-op #:lib-op #:dll-op #:binary-op
+   #:monolithic-op #:monolithic-bundle-op #:direct-dependency-files
+   #:monolithic-binary-op #:monolithic-fasl-op #:monolithic-lib-op #:monol=
ithic-dll-op
+   #:program-op
+   #:compiled-file #:precompiled-system #:prebuilt-system
+   #:operation-monolithic-p
+   #:user-system-p #:user-system #:trivial-system-p
+   #+ecl #:make-build
+   #:register-pre-built-system
+   #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-lib=
rary))
+(in-package :asdf/bundle)
+
+(defclass bundle-op (operation)
+  ((build-args :initarg :args :initform nil :accessor bundle-op-build-args)
+   (name-suffix :initarg :name-suffix :initform nil)
+   (bundle-type :initform :no-output-file :reader bundle-type)
+   #+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files)
+   #+mkcl (do-fasb :initarg :do-fasb :initform t :reader bundle-op-do-fasb=
-p)
+   #+mkcl (do-static-library :initarg :do-static-library :initform t :read=
er bundle-op-do-static-library-p)))
+
+(defclass fasl-op (bundle-op)
+  ;; create a single fasl for the entire library
+  ((bundle-type :initform :fasl)))
+
+(defclass load-fasl-op (basic-load-op)
+  ;; load a single fasl for the entire library
+  ())
+
+(defclass lib-op (bundle-op)
+  ;; On ECL: compile the system and produce linkable .a library for it.
+  ;; On others: just compile the system.
+  ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-=
file)))
+
+(defclass dll-op (bundle-op)
+  ;; Link together all the dynamic library used by this system into a sing=
le one.
+  ((bundle-type :initform :dll)))
+
+(defclass binary-op (bundle-op)
+  ;; On ECL: produce lib and fasl for the system.
+  ;; On "normal" Lisps: produce just the fasl.
+  ())
+
+(defclass monolithic-op (operation) ()) ;; operation on a system and its d=
ependencies
+
+(defclass monolithic-bundle-op (monolithic-op bundle-op)
+  ((prologue-code :accessor monolithic-op-prologue-code)
+   (epilogue-code :accessor monolithic-op-epilogue-code)))
+
+(defclass monolithic-binary-op (binary-op monolithic-bundle-op)
+  ;; On ECL: produce lib and fasl for combined system and dependencies.
+  ;; On "normal" Lisps: produce an image file from system and dependencies.
+  ())
+
+(defclass monolithic-fasl-op (monolithic-bundle-op fasl-op)
+  ;; Create a single fasl for the system and its dependencies.
+  ())
+
+(defclass monolithic-lib-op (monolithic-bundle-op lib-op)
+  ;; ECL: Create a single linkable library for the system and its dependen=
cies.
+  ((bundle-type :initform :lib)))
+
+(defclass monolithic-dll-op (monolithic-bundle-op dll-op)
+  ((bundle-type :initform :dll)))
+
+(defclass program-op (monolithic-bundle-op)
+  ;; All: create an executable file from the system and its dependencies
+  ((bundle-type :initform :program)))
+
+(defun* bundle-pathname-type (bundle-type)
+  (etypecase bundle-type
+    ((eql :no-output-file) nil) ;; should we error out instead?    =

+    ((or null string) bundle-type)
+    ((eql :fasl) #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb=
")
+    #+ecl
+    ((member :binary :dll :lib :static-library :program :object :program)
+     (compile-file-type :type bundle-type))
+    ((eql :binary) "image")
+    ((eql :dll) (cond ((os-unix-p) "so") ((os-windows-p) "dll")))
+    ((member :lib :static-library) (cond ((os-unix-p) "a") ((os-windows-p)=
 "lib")))
+    ((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
+
+(defun* bundle-output-files (o c)
+  (let ((bundle-type (bundle-type o)))
+    (unless (eq bundle-type :no-output-file) ;; NIL already means somethin=
g regarding type.
+      (let ((name (or (component-build-pathname c)
+                      (format nil "~A~@[~A~]" (component-name c) (slot-val=
ue o 'name-suffix))))
+            (type (bundle-pathname-type bundle-type)))
+        (values (list (subpathname (component-pathname c) name :type type))
+                (eq (type-of o) (component-build-operation c)))))))
+
+(defmethod output-files ((o bundle-op) (c system))
+  (bundle-output-files o c))
+
+#-(or ecl mkcl)
+(progn
+  (defmethod perform ((o program-op) (c system))
+    (let ((output-file (output-file o c)))
+      (setf *image-entry-point* (ensure-function (component-entry-point c)=
))
+      (dump-image output-file :executable t)))
+
+  (defmethod perform ((o monolithic-binary-op) (c system))
+    (let ((output-file (output-file o c)))
+      (dump-image output-file))))
+
+(defclass compiled-file (file-component)
+  ((type :initform #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fa=
sb")))
+
+(defclass precompiled-system (system)
+  ((build-pathname :initarg :fasl)))
+
+(defclass prebuilt-system (system)
+  ((build-pathname :initarg :static-library :initarg :lib
+                    :accessor prebuilt-system-static-library)))
+
 ;;;
-;;; In ECL and MKCL, these operations produce both
-;;; FASL files and the object files that they are built from.
-;;; Having both of them allows us to later on reuse the object files
-;;; for bundles, libraries, standalone executables, etc.
+;;; BUNDLE-OP
 ;;;
-;;; This has to be in asdf.lisp and not asdf-ecl.lisp, or else it becomes
-;;; a problem for asdf on ECL to compile asdf-ecl.lisp after loading asdf.=
lisp.
+;;; This operation takes all components from one or more systems and
+;;; creates a single output file, which may be
+;;; a FASL, a statically linked library, a shared library, etc.
+;;; The different targets are defined by specialization.
 ;;;
-;;; Also, register-pre-built-system.
+
+(defun* operation-monolithic-p (op)
+  (typep op 'monolithic-op))
+
+(defmethod initialize-instance :after ((instance bundle-op) &rest initargs
+                                       &key (name-suffix nil name-suffix-p)
+                                       &allow-other-keys)
+  (declare (ignorable initargs name-suffix))
+  (unless name-suffix-p
+    (setf (slot-value instance 'name-suffix)
+          (unless (typep instance 'program-op)
+            (if (operation-monolithic-p instance) ".all-systems" #-ecl ".s=
ystem"))))
+  (when (typep instance 'monolithic-bundle-op)
+    (destructuring-bind (&rest original-initargs
+                         &key lisp-files prologue-code epilogue-code
+                         &allow-other-keys)
+        (operation-original-initargs instance)
+      (setf (operation-original-initargs instance)
+            (remove-plist-keys '(:lisp-files :epilogue-code :prologue-code=
) original-initargs)
+            (monolithic-op-prologue-code instance) prologue-code
+            (monolithic-op-epilogue-code instance) epilogue-code)
+      #-ecl (assert (null (or lisp-files epilogue-code prologue-code)))
+      #+ecl (setf (bundle-op-lisp-files instance) lisp-files)))
+  (setf (bundle-op-build-args instance)
+        (remove-plist-keys '(:type :monolithic :name-suffix)
+                     (operation-original-initargs instance))))
+
+(defmethod bundle-op-build-args :around ((o lib-op))
+  (declare (ignorable o))
+  (let ((args (call-next-method)))
+    (remf args :ld-flags)
+    args))
+
+(defun* bundlable-file-p (pathname)
+  (let ((type (pathname-type pathname)))
+    (declare (ignorable type))
+    (or #+ecl (or (equal type (compile-file-type :type :object))
+                  (equal type (compile-file-type :type :static-library)))
+        #+mkcl (equal type (compile-file-type :fasl-p nil))
+        #+(or allegro clisp clozure cmu lispworks sbcl scl xcl) (equal typ=
e (compile-file-type)))))
+
+(defgeneric* (trivial-system-p) (component))
+
+(defun* user-system-p (s)
+  (and (typep s 'system)
+       (not (builtin-system-p s))
+       (not (trivial-system-p s))))
+
+(deftype user-system () '(and system (satisfies user-system-p)))
+
+;;;
+;;; First we handle monolithic bundles.
+;;; These are standalone systems which contain everything,
+;;; including other ASDF systems required by the current one.
+;;; A PROGRAM is always monolithic.
+;;;
+;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL
+;;;
+
+(defmethod component-depends-on ((o monolithic-lib-op) (c system))
+  (declare (ignorable o))
+  `((lib-op ,@(required-components c :other-systems t :component-type 'sys=
tem
+                                     :goal-operation 'load-op
+                                     :keep-operation 'compile-op))))
+
+(defmethod component-depends-on ((o monolithic-fasl-op) (c system))
+  (declare (ignorable o))
+  `((fasl-op ,@(required-components c :other-systems t :component-type 'sy=
stem
+                                      :goal-operation 'load-fasl-op
+                                      :keep-operation 'fasl-op))))
+
+(defmethod component-depends-on ((o program-op) (c system))
+  (declare (ignorable o))
+  #+(or ecl mkcl) (component-depends-on (make-operation 'monolithic-lib-op=
) c)
+  #-(or ecl mkcl) `((load-op ,c)))
+
+(defmethod component-depends-on ((o binary-op) (c system))
+  (declare (ignorable o))
+  `((fasl-op ,c)
+    (lib-op ,c)))
+
+(defmethod component-depends-on ((o monolithic-binary-op) (c system))
+  `((,(find-operation o 'monolithic-fasl-op) ,c)
+    (,(find-operation o 'monolithic-lib-op) ,c)))
+
+(defmethod component-depends-on ((o lib-op) (c system))
+  (declare (ignorable o))
+  `((compile-op ,@(required-components c :other-systems nil :component-typ=
e '(not system)
+                                         :goal-operation 'load-op
+                                         :keep-operation 'compile-op))))
+
+(defmethod component-depends-on ((o fasl-op) (c system))
+  (declare (ignorable o))
+  #+ecl `((lib-op ,c))
+  #-ecl
+  (component-depends-on (find-operation o 'lib-op) c))
+
+(defmethod component-depends-on ((o dll-op) c)
+  (component-depends-on (find-operation o 'lib-op) c))
+
+(defmethod component-depends-on ((o bundle-op) c)
+  (declare (ignorable o c))
+  nil)
+
+(defmethod component-depends-on :around ((o bundle-op) (c component))
+  (declare (ignorable o c))
+  (if-let (op (and (eq (type-of o) 'bundle-op) (component-build-operation =
c)))
+      `((,op ,c))
+      (call-next-method)))
+
+(defun* direct-dependency-files (o c &key (test 'identity) (key 'output-fi=
les) &allow-other-keys)
+  (while-collecting (collect)
+    (map-direct-dependencies
+     o c #'(lambda (sub-o sub-c)
+             (loop :for f :in (funcall key sub-o sub-c)
+                   :when (funcall test f) :do (collect f))))))
+
+(defmethod input-files ((o bundle-op) (c system))
+  (direct-dependency-files o c :test 'bundlable-file-p :key 'output-files))
+
+(defun* select-bundle-operation (type &optional monolithic)
+  (ecase type
+    ((:binary)
+     (if monolithic 'monolithic-binary-op 'binary-op))
+    ((:dll :shared-library)
+     (if monolithic 'monolithic-dll-op 'dll-op))
+    ((:lib :static-library)
+     (if monolithic 'monolithic-lib-op 'lib-op))
+    ((:fasl)
+     (if monolithic 'monolithic-fasl-op 'fasl-op))
+    ((:program)
+     'program-op)))
+
+(defun* make-build (system &rest args &key (monolithic nil) (type :fasl)
+                   (move-here nil move-here-p)
+                   &allow-other-keys)
+  (let* ((operation-name (select-bundle-operation type monolithic))
+         (move-here-path (if (and move-here
+                                  (typep move-here '(or pathname string)))
+                             (pathname move-here)
+                             (system-relative-pathname system "asdf-output=
/")))
+         (operation (apply #'operate operation-name
+                           system
+                           (remove-plist-keys '(:monolithic :type :move-he=
re) args)))
+         (system (find-system system))
+         (files (and system (output-files operation system))))
+    (if (or move-here (and (null move-here-p)
+                           (member operation-name '(:program :binary))))
+        (loop :with dest-path =3D (resolve-symlinks* (ensure-directories-e=
xist move-here-path))
+              :for f :in files
+              :for new-f =3D (make-pathname :name (pathname-name f)
+                                :type (pathname-type f)
+                                :defaults dest-path)
+              :do (rename-file-overwriting-target f new-f)
+              :collect new-f)
+        files)))
+
+;;;
+;;; LOAD-FASL-OP
+;;;
+;;; This is like ASDF's LOAD-OP, but using monolithic fasl files.
+;;;
+
+(defmethod component-depends-on ((o load-fasl-op) (c system))
+  (declare (ignorable o))
+  `((,o ,@(loop :for dep :in (component-sibling-dependencies c)
+                :collect (resolve-dependency-spec c dep)))
+    (,(if (user-system-p c) 'fasl-op 'load-op) ,c)
+    ,@(call-next-method)))
+
+(defmethod input-files ((o load-fasl-op) (c system))
+  (when (user-system-p c)
+    (output-files (find-operation o 'fasl-op) c)))
+
+(defmethod perform ((o load-fasl-op) c)
+  (declare (ignorable o c))
+  nil)
+
+(defmethod perform ((o load-fasl-op) (c system))
+  (perform-lisp-load-fasl o c))
+
+(defmethod mark-operation-done :after ((o load-fasl-op) (c system))
+  (mark-operation-done (find-operation o 'load-op) c))
+
+;;;
+;;; PRECOMPILED FILES
+;;;
+;;; This component can be used to distribute ASDF systems in precompiled f=
orm.
+;;; Only useful when the dependencies have also been precompiled.
+;;;
+
+(defmethod trivial-system-p ((s system))
+  (every #'(lambda (c) (typep c 'compiled-file)) (component-children s)))
+
+(defmethod output-files (o (c compiled-file))
+  (declare (ignorable o c))
+  nil)
+(defmethod input-files (o (c compiled-file))
+  (declare (ignorable o))
+  (component-pathname c))
+(defmethod perform ((o load-op) (c compiled-file))
+  (perform-lisp-load-fasl o c))
+(defmethod perform ((o load-source-op) (c compiled-file))
+  (perform (find-operation o 'load-op) c))
+(defmethod perform ((o load-fasl-op) (c compiled-file))
+  (perform (find-operation o 'load-op) c))
+(defmethod perform (o (c compiled-file))
+  (declare (ignorable o c))
+  nil)
+
+;;;
+;;; Pre-built systems
+;;;
+(defmethod trivial-system-p ((s prebuilt-system))
+  (declare (ignorable s))
+  t)
+
+(defmethod perform ((o lib-op) (c prebuilt-system))
+  (declare (ignorable o c))
+  nil)
+
+(defmethod component-depends-on ((o lib-op) (c prebuilt-system))
+  (declare (ignorable o c))
+  nil)
+
+(defmethod component-depends-on ((o monolithic-lib-op) (c prebuilt-system))
+  (declare (ignorable o))
+  nil)
+
+
+;;;
+;;; PREBUILT SYSTEM CREATOR
+;;;
+
+
+(defmethod output-files ((o binary-op) (s system))
+  (list (make-pathname :name (component-name s) :type "asd"
+                       :defaults (component-pathname s))))
+
+(defmethod perform ((o binary-op) (s system))
+  (let* ((dependencies (component-depends-on o s))
+         (fasl (first (apply #'output-files (first dependencies))))
+         (library (first (apply #'output-files (second dependencies))))
+         (asd (first (output-files o s)))
+         (name (pathname-name asd))
+         (name-keyword (intern (string name) (find-package :keyword))))
+    (with-open-file (s asd :direction :output :if-exists :supersede
+                       :if-does-not-exist :create)
+      (format s ";;; Prebuilt ASDF definition for system ~A" name)
+      (format s ";;; Built for ~A ~A on a ~A/~A ~A"
+              (lisp-implementation-type)
+              (lisp-implementation-version)
+              (software-type)
+              (machine-type)
+              (software-version))
+      (let ((*package* (find-package :keyword)))
+        (pprint `(defsystem ,name-keyword
+                     :class prebuilt-system
+                     :components ((:compiled-file ,(pathname-name fasl)))
+                     :lib ,(and library (file-namestring library)))
+                s)))))
+
+#-(or ecl mkcl)
+(defmethod perform ((o fasl-op) (c system))
+  (let* ((input-files (input-files o c))
+         (fasl-files (remove (compile-file-type) input-files :key #'pathna=
me-type :test-not #'string=3D))
+         (non-fasl-files (remove (compile-file-type) input-files :key #'pa=
thname-type :test #'string=3D))
+         (output-files (output-files o c))
+         (output-file (first output-files)))
+    (unless input-files (format t "WTF no input-files for ~S on ~S !???" o=
 c))
+    (when input-files
+      (assert output-files)
+      (when non-fasl-files
+        (error "On ~A, asdf-bundle can only bundle FASL files, but these w=
ere also produced: ~S"
+               (implementation-type) non-fasl-files))
+      (when (and (typep o 'monolithic-bundle-op)
+                 (or (monolithic-op-prologue-code o) (monolithic-op-epilog=
ue-code o)))
+        (error "prologue-code and epilogue-code are not supported on ~A"
+               (implementation-type)))
+      (with-staging-pathname (output-file)
+        (combine-fasls fasl-files output-file)))))
+
+(defmethod input-files ((o load-op) (s precompiled-system))
+  (declare (ignorable o))
+  (bundle-output-files (find-operation o 'fasl-op) s))
+
+(defmethod component-depends-on ((o load-fasl-op) (s precompiled-system))
+  (declare (ignorable o))
+  `((load-op ,s) ,@(call-next-method)))
+
+#| ;; Example use:
+(asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :f=
asl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-ut=
ils "asdf-utils.system.fasl")))
+(asdf:load-system :precompiled-asdf-utils)
+|#
+
+#+ecl
+(defmethod perform ((o bundle-op) (c system))
+  (let* ((object-files (input-files o c))
+         (output (output-files o c))
+         (bundle (first output))
+         (kind (bundle-type o)))
+    (create-image
+     bundle (append object-files (bundle-op-lisp-files o))
+     :kind kind
+     :entry-point (component-entry-point c)
+     :prologue-code
+     (when (typep o 'monolithic-bundle-op)
+       (monolithic-op-prologue-code o))
+     :epilogue-code
+     (when (typep o 'monolithic-bundle-op)
+       (monolithic-op-epilogue-code o))
+     :build-args (bundle-op-build-args o))))
+
+#+mkcl
+(progn
+  (defmethod perform ((o lib-op) (s system))
+    (apply #'compiler::build-static-library (first output)
+           :lisp-object-files (input-files o s) (bundle-op-build-args o)))
+
+  (defmethod perform ((o fasl-op) (s system))
+    (apply #'compiler::build-bundle (second output)
+           :lisp-object-files (input-files o s) (bundle-op-build-args o)))
+
+  (defun* bundle-system (system &rest args &key force (verbose t) version =
&allow-other-keys)
+    (declare (ignore force verbose version))
+    (apply #'operate 'binary-op system args)))
+
+#+(or ecl mkcl)
+(defun* register-pre-built-system (name)
+  (register-system (make-instance 'system :name (coerce-name name) :source=
-file nil)))
+;;;; ---------------------------------------------------------------------=
----
+;;;; Concatenate-source
+
+(asdf/package:define-package :asdf/concatenate-source
+  (:recycle :asdf/concatenate-source :asdf)
+  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
+   :asdf/component :asdf/operation
+   :asdf/system :asdf/find-system :asdf/defsystem
+   :asdf/action :asdf/lisp-action :asdf/bundle)
+  (:export
+   #:concatenate-source-op
+   #:load-concatenated-source-op
+   #:compile-concatenated-source-op
+   #:load-compiled-concatenated-source-op
+   #:monolithic-concatenate-source-op
+   #:monolithic-load-concatenated-source-op
+   #:monolithic-compile-concatenated-source-op
+   #:monolithic-load-compiled-concatenated-source-op
+   #:component-concatenated-source-file
+   #:concatenated-source-file))
+(in-package :asdf/concatenate-source)
+
+;;;
+;;; Concatenate sources
+;;;
+(defclass concatenate-source-op (bundle-op)
+  ((bundle-type :initform "lisp")))
+(defclass load-concatenated-source-op (basic-load-op operation)
+  ((bundle-type :initform :no-output-file)))
+(defclass compile-concatenated-source-op (basic-compile-op bundle-op)
+  ((bundle-type :initform :fasl)))
+(defclass load-compiled-concatenated-source-op (basic-load-op operation)
+  ((bundle-type :initform :no-output-file)))
+
+(defclass monolithic-concatenate-source-op (concatenate-source-op monolith=
ic-op) ())
+(defclass monolithic-load-concatenated-source-op (load-concatenated-source=
-op monolithic-op) ())
+(defclass monolithic-compile-concatenated-source-op (compile-concatenated-=
source-op monolithic-op) ())
+(defclass monolithic-load-compiled-concatenated-source-op (load-compiled-c=
oncatenated-source-op monolithic-op) ())
+
+(defmethod input-files ((operation concatenate-source-op) (s system))
+  (loop :with encoding =3D (or (component-encoding s) *default-encoding*)
+        :with other-encodings =3D '()
+        :with around-compile =3D (around-compile-hook s)
+        :with other-around-compile =3D '()
+        :for c :in (required-components
+                    s :goal-operation 'compile-op
+                      :keep-operation 'compile-op
+                      :other-systems (operation-monolithic-p operation))
+        :append
+        (when (typep c 'cl-source-file)
+          (let ((e (component-encoding c)))
+            (unless (equal e encoding)
+              (pushnew e other-encodings :test 'equal)))
+          (let ((a (around-compile-hook c)))
+            (unless (equal a around-compile)
+              (pushnew a other-around-compile :test 'equal)))
+          (input-files (make-operation 'compile-op) c)) :into inputs
+        :finally
+           (when other-encodings
+             (warn "~S uses encoding ~A but has sources that use these enc=
odings: ~A"
+                   operation encoding other-encodings))
+           (when other-around-compile
+             (warn "~S uses around-compile hook ~A but has sources that us=
e these hooks: ~A"
+                   operation around-compile other-around-compile))
+           (return inputs)))
+
+(defmethod input-files ((o load-concatenated-source-op) (s system))
+  (direct-dependency-files o s))
+(defmethod input-files ((o compile-concatenated-source-op) (s system))
+  (direct-dependency-files o s))
+(defmethod output-files ((o compile-concatenated-source-op) (s system))
+  (let ((input (first (input-files o s))))
+    (list (compile-file-pathname input))))
+(defmethod input-files ((o load-compiled-concatenated-source-op) (s system=
))
+  (direct-dependency-files o s))
+
+(defmethod perform ((o concatenate-source-op) (s system))
+  (let ((inputs (input-files o s))
+        (output (output-file o s)))
+    (concatenate-files inputs output)))
+(defmethod perform ((o load-concatenated-source-op) (s system))
+  (perform-lisp-load-source o s))
+(defmethod perform ((o compile-concatenated-source-op) (s system))
+  (perform-lisp-compilation o s))
+(defmethod perform ((o load-compiled-concatenated-source-op) (s system))
+  (perform-lisp-load-fasl o s))
+
+(defmethod component-depends-on ((o concatenate-source-op) (s system))
+  (declare (ignorable o s)) nil)
+(defmethod component-depends-on ((o load-concatenated-source-op) (s system=
))
+  (declare (ignorable o s)) `((prepare-op ,s) (concatenate-source-op ,s)))
+(defmethod component-depends-on ((o compile-concatenated-source-op) (s sys=
tem))
+  (declare (ignorable o s)) `((concatenate-source-op ,s)))
+(defmethod component-depends-on ((o load-compiled-concatenated-source-op) =
(s system))
+  (declare (ignorable o s)) `((compile-concatenated-source-op ,s)))
+
+(defmethod component-depends-on ((o monolithic-concatenate-source-op) (s s=
ystem))
+  (declare (ignorable o s)) nil)
+(defmethod component-depends-on ((o monolithic-load-concatenated-source-op=
) (s system))
+  (declare (ignorable o s)) `((monolithic-concatenate-source-op ,s)))
+(defmethod component-depends-on ((o monolithic-compile-concatenated-source=
-op) (s system))
+  (declare (ignorable o s)) `((monolithic-concatenate-source-op ,s)))
+(defmethod component-depends-on ((o monolithic-load-compiled-concatenated-=
source-op) (s system))
+  (declare (ignorable o s)) `((monolithic-compile-concatenated-source-op ,=
s)))
+
+;;;; ---------------------------------------------------------------------=
----
+;;; Backward-compatible interfaces
+
+(asdf/package:define-package :asdf/backward-interface
+  (:recycle :asdf/backward-interface :asdf)
+  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
+   :asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/ac=
tion
+   :asdf/lisp-build :asdf/operate :asdf/output-translations)
+  (:export
+   #:*asdf-verbose*
+   #:operation-error #:compile-error #:compile-failed #:compile-warned
+   #:error-component #:error-operation
+   #:component-load-dependencies
+   #:enable-asdf-binary-locations-compatibility
+   #:operation-forced
+   #:operation-on-failure
+   #:operation-on-warnings
+   #:component-property
+   #:run-shell-command
+   #:system-definition-pathname))
+(in-package :asdf/backward-interface)
+
+(define-condition operation-error (error) ;; Bad, backward-compatible name
+  ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi=
-tests, sb-grovel
+  ((component :reader error-component :initarg :component)
+   (operation :reader error-operation :initarg :operation))
+  (:report (lambda (c s)
+               (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>")
+                       (type-of c) (error-operation c) (error-component c)=
))))
+(define-condition compile-error (operation-error) ())
+(define-condition compile-failed (compile-error) ())
+(define-condition compile-warned (compile-error) ())
+
+(defun* component-load-dependencies (component)
+  ;; Old deprecated name for the same thing. Please update your software.
+  (component-sibling-dependencies component))
+
+(defgeneric* operation-forced (operation)) ;; Used by swank.asd for swank-=
loader.
+(defmethod operation-forced ((o operation)) (getf (operation-original-init=
args o) :force))
+
+(defgeneric* operation-on-warnings (operation))
+(defgeneric* operation-on-failure (operation))
+#-gcl2.6 (defgeneric* (setf operation-on-warnings) (x operation))
+#-gcl2.6 (defgeneric* (setf operation-on-failure) (x operation))
+(defmethod operation-on-warnings ((o operation))
+  (declare (ignorable o)) *compile-file-warnings-behaviour*)
+(defmethod operation-on-failure ((o operation))
+  (declare (ignorable o)) *compile-file-failure-behaviour*)
+(defmethod (setf operation-on-warnings) (x (o operation))
+  (declare (ignorable o)) (setf *compile-file-warnings-behaviour* x))
+(defmethod (setf operation-on-failure) (x (o operation))
+  (declare (ignorable o)) (setf *compile-file-failure-behaviour* x))
+
+(defun* system-definition-pathname (x)
+  ;; As of 2.014.8, we mean to make this function obsolete,
+  ;; but that won't happen until all clients have been updated.
+  ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
+  "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
+It used to expose ASDF internals with subtle differences with respect to
+user expectations, that have been refactored away since.
+We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
+for a mostly compatible replacement that we're supporting,
+or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
+if that's whay you mean." ;;)
+  (system-source-file x))
+
+
+;;;; ASDF-Binary-Locations compatibility
+
+(defun* enable-asdf-binary-locations-compatibility
+    (&key
+     (centralize-lisp-binaries nil)
+     (default-toplevel-directory
+         (subpathname (user-homedir-pathname) ".fasls/")) ;; Use ".cache/c=
ommon-lisp/" instead ???
+     (include-per-user-information nil)
+     (map-all-source-files (or #+(or clisp ecl mkcl) t nil))
+     (source-to-target-mappings nil)
+     (file-types `(,(compile-file-type)
+                   "build-report"
+                   #+ecl (compile-file-type :type :object)
+                   #+mkcl (compile-file-type :fasl-p nil)
+                   #+clisp "lib" #+sbcl "cfasl"
+                   #+sbcl "sbcl-warnings" #+clozure "ccl-warnings")))
+  #+(or clisp ecl mkcl)
+  (when (null map-all-source-files)
+    (error "asdf:enable-asdf-binary-locations-compatibility doesn't suppor=
t :map-all-source-files nil on CLISP, ECL and MKCL"))
+  (let* ((patterns (if map-all-source-files (list *wild-file*)
+                       (loop :for type :in file-types
+                             :collect (make-pathname :type type :defaults =
*wild-file*))))
+         (destination-directory
+          (if centralize-lisp-binaries
+              `(,default-toplevel-directory
+                ,@(when include-per-user-information
+                        (cdr (pathname-directory (user-homedir-pathname))))
+                :implementation ,*wild-inferiors*)
+              `(:root ,*wild-inferiors* :implementation))))
+    (initialize-output-translations
+     `(:output-translations
+       , at source-to-target-mappings
+       #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pat=
hname))
+       #+abcl (#p"/___jar___file___root___/**/*.*" (, at destination-director=
y))
+       ,@(loop :for pattern :in patterns
+               :collect `((:root ,*wild-inferiors* ,pattern)
+                          (, at destination-directory ,pattern)))
+       (t t)
+       :ignore-inherited-configuration))))
+
+(defmethod operate :before (operation-class system &rest args &key &allow-=
other-keys)
+  (declare (ignorable operation-class system args))
+  (when (find-symbol* '#:output-files-for-system-and-operation :asdf nil)
+    (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you=
 are using.
+ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLAT=
IONS,
+which should be easier to configure. Please stop using ASDF-BINARY-LOCATIO=
NS,
+and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.
+In case you insist on preserving your previous A-B-L configuration, but
+do not know how to achieve the same effect with A-O-T, you may use function
+ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manua=
l;
+call that function where you would otherwise have loaded and configured A-=
B-L.")))
+
+
+;;;; run-shell-command
+;;
+;; WARNING! The function below is dysfunctional and deprecated.
+;; Please use asdf/run-program:run-program instead.
+;;
+(defun* run-shell-command (control-string &rest args)
+  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
+synchronously execute the result using a Bourne-compatible shell, with
+output to *VERBOSE-OUT*.  Returns the shell's exit code.
+
+PLEASE DO NOT USE.
+Deprecated function, for backward-compatibility only.
+Please use ASDF-DRIVER:RUN-PROGRAM instead."
+  (let ((command (apply 'format nil control-string args)))
+    (asdf-message "; $ ~A~%" command)
+    (run-program command :force-shell t :ignore-error-status t :output *ve=
rbose-out*)))
+
+(defvar *asdf-verbose* nil) ;; backward-compatibility with ASDF2 only. Unu=
sed.
+
+;; backward-compatibility methods. Do NOT use in new code. NOT SUPPORTED.
+(defgeneric* component-property (component property))
+#-gcl2.6 (defgeneric* (setf component-property) (new-value component prope=
rty))
+
+(defmethod component-property ((c component) property)
+  (cdr (assoc property (slot-value c 'properties) :test #'equal)))
+
+(defmethod (setf component-property) (new-value (c component) property)
+  (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
+    (if a
+        (setf (cdr a) new-value)
+        (setf (slot-value c 'properties)
+              (acons property new-value (slot-value c 'properties)))))
+  new-value)
+;;;; ---------------------------------------------------------------------=
------
+;;;; Handle ASDF package upgrade, including implementation-dependent magic.
+
+(asdf/package:define-package :asdf/interface
+  (:nicknames :asdf :asdf-utilities)
+  (:recycle :asdf/interface :asdf)
+  (:unintern
+   #:*asdf-revision* #:around #:asdf-method-combination
+   #:do-traverse #:do-dep #:do-one-dep #:visit-action #:component-visited-p
+   #:split #:make-collector
+   #:loaded-systems ; makes for annoying SLIME completion
+   #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATIO=
N function
+  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/cache
+   :asdf/component :asdf/system :asdf/find-system :asdf/find-component
+   :asdf/operation :asdf/action :asdf/lisp-action
+   :asdf/output-translations :asdf/source-registry
+   :asdf/plan :asdf/operate :asdf/defsystem :asdf/bundle :asdf/concatenate=
-source
+   :asdf/backward-internals :asdf/backward-interface)
+  ;; TODO: automatically generate interface with reexport?
+  (:export
+   #:defsystem #:find-system #:locate-system #:coerce-name
+   #:oos #:operate #:traverse #:perform-plan
+   #:system-definition-pathname #:with-system-definitions
+   #:search-for-system-definition #:find-component #:component-find-path
+   #:compile-system #:load-system #:load-systems
+   #:require-system #:test-system #:clear-system
+   #:operation #:upward-operation #:downward-operation #:make-operation
+   #:build-system #:build-op
+   #:load-op #:prepare-op #:compile-op
+   #:prepare-source-op #:load-source-op #:test-op
+   #:feature #:version #:version-satisfies #:upgrade-asdf
+   #:implementation-identifier #:implementation-type #:hostname
+   #:input-files #:output-files #:output-file #:perform
+   #:operation-done-p #:explain #:action-description #:component-sibling-d=
ependencies
+   #:needed-in-image-p
+   ;; #:run-program ; we can't export it, because SB-GROVEL :use's both AS=
DF and SB-EXT.
+   #:component-load-dependencies #:run-shell-command ; deprecated, do not =
use
+   #:bundle-op  #:precompiled-system #:compiled-file #:bundle-system
+   #+ecl #:make-build
+   #:program-op #:load-fasl-op #:fasl-op #:lib-op #:binary-op
+   #:concatenate-source-op
+   #:load-concatenated-source-op
+   #:compile-concatenated-source-op
+   #:load-compiled-concatenated-source-op
+   #:monolithic-concatenate-source-op
+   #:monolithic-load-concatenated-source-op
+   #:monolithic-compile-concatenated-source-op
+   #:monolithic-load-compiled-concatenated-source-op
+   #:operation-monolithic-p
+   #:required-components
+
+   #:component #:parent-component #:child-component #:system #:module
+   #:file-component #:source-file #:c-source-file #:java-source-file
+   #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp
+   #:static-file #:doc-file #:html-file :text-file
+   #:source-file-type
+
+   #:component-children          ; component accessors
+   #:component-children-by-name
+   #:component-pathname
+   #:component-relative-pathname
+   #:component-name
+   #:component-version
+   #:component-parent
+   #:component-system
+   #:component-encoding
+   #:component-external-format
+
+   #:component-depends-on ; backward-compatible name rather than action-de=
pends-on
+   #:module-components ; backward-compatibility
+   #:operation-on-warnings #:operation-on-failure ; backward-compatibility
+   #:component-property ; backward-compatibility
+
+   #:system-description
+   #:system-long-description
+   #:system-author
+   #:system-maintainer
+   #:system-license
+   #:system-licence
+   #:system-source-file
+   #:system-source-directory
+   #:system-relative-pathname
+   #:system-homepage
+   #:system-bug-tracker
+   #:system-developers-email
+   #:system-long-name
+   #:system-source-control
+   #:map-systems
+
+   #:*system-definition-search-functions*   ; variables
+   #:*central-registry*
+   #:*compile-file-warnings-behaviour*
+   #:*compile-file-failure-behaviour*
+   #:*resolve-symlinks*
+   #:*load-system-operation*
+   #:*asdf-verbose* ;; unused. For backward-compatibility only.
+   #:*verbose-out*
+
+   #:asdf-version
+
+   #:compile-condition #:compile-file-error #:compile-warned-error #:compi=
le-failed-error
+   #:compile-warned-warning #:compile-failed-warning
+   #:operation-error #:compile-failed #:compile-warned #:compile-error ;; =
backward compatibility
+   #:error-name
+   #:error-pathname
+   #:load-system-definition-error
+   #:error-component #:error-operation
+   #:system-definition-error
+   #:missing-component
+   #:missing-component-of-version
+   #:missing-dependency
+   #:missing-dependency-of-version
+   #:circular-dependency        ; errors
+   #:duplicate-names
+
+   #:try-recompiling
+   #:retry
+   #:accept                     ; restarts
+   #:coerce-entry-to-directory
+   #:remove-entry-from-registry
+
+   #:*encoding-detection-hook*
+   #:*encoding-external-format-hook*
+   #:*default-encoding*
+   #:*utf-8-external-format*
+
+   #:clear-configuration
+   #:*output-translations-parameter*
+   #:initialize-output-translations
+   #:disable-output-translations
+   #:clear-output-translations
+   #:ensure-output-translations
+   #:apply-output-translations
+   #:compile-file*
+   #:compile-file-pathname*
+   #:*warnings-file-type*
+   #:enable-asdf-binary-locations-compatibility
+   #:*default-source-registries*
+   #:*source-registry-parameter*
+   #:initialize-source-registry
+   #:compute-source-registry
+   #:clear-source-registry
+   #:ensure-source-registry
+   #:process-source-registry
+   #:system-registered-p #:registered-systems #:already-loaded-systems
+   #:resolve-location
+   #: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))
+
+;;;; ---------------------------------------------------------------------=
------
+;;;; ASDF-USER, where the action happens.
+
+(asdf/package:define-package :asdf/user
+  (:nicknames :asdf-user)
+  (:use :asdf/common-lisp :asdf/package :asdf/interface))
+;;;; ---------------------------------------------------------------------=
--
+;;;; ASDF Footer: last words and cleanup
+
+(asdf/package:define-package :asdf/footer
+  (:recycle :asdf/footer :asdf)
+  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
+   :asdf/find-system :asdf/find-component :asdf/operation :asdf/action :as=
df/lisp-action
+   :asdf/operate :asdf/bundle :asdf/concatenate-source
+   :asdf/output-translations :asdf/source-registry
+   :asdf/backward-internals :asdf/defsystem :asdf/backward-interface))
+(in-package :asdf/footer)
+
+;;;; Hook ASDF into the implementation's REQUIRE and other entry points.
+
+#+(or abcl clisp clozure cmu ecl mkcl sbcl)
+(if-let (x (and #+clisp (find-symbol* '#:*module-provider-functions* :cust=
om nil)))
+  (eval `(pushnew 'module-provide-asdf
+                  #+abcl sys::*module-provider-functions*
+                  #+clisp ,x
+                  #+clozure ccl:*module-provider-functions*
+                  #+(or cmu ecl) ext:*module-provider-functions*
+                  #+mkcl mk-ext:*module-provider-functions*
+                  #+sbcl sb-ext:*module-provider-functions*)))
 =

 #+(or ecl mkcl)
 (progn
-  (defun register-pre-built-system (name)
-    (register-system (make-instance 'system :name (coerce-name name) :sour=
ce-file nil)))
+  (pushnew '("fasb" . si::load-binary) si:*load-hooks* :test 'equal :key '=
car)
 =

   #+(or (and ecl win32) (and mkcl windows))
   (unless (assoc "asd" #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* :tes=
t 'equal)
@@ -4422,94 +9026,26 @@
           :collect #'(lambda (name)
                        (let ((l (multiple-value-list (funcall f name))))
                          (and (first l) (register-pre-built-system (coerce=
-name name)))
-                         (values-list l)))))
-
-  (setf *compile-op-compile-file-function* 'compile-file-keeping-object)
-
-  (defun compile-file-keeping-object (input-file &rest keys &key &allow-ot=
her-keys)
-    (#+ecl if #+ecl (use-ecl-byte-compiler-p) #+ecl (apply 'compile-file* =
input-file keys)
-     #+mkcl progn
-     (multiple-value-bind (object-file flags1 flags2)
-         (apply 'compile-file* input-file
-                #+ecl :system-p #+ecl t #+mkcl :fasl-p #+mkcl nil keys)
-       (values (and object-file
-                    (compiler::build-fasl
-                     (compile-file-pathname object-file
-                                            #+ecl :type #+ecl :fasl #+mkcl=
 :fasl-p #+mkcl t)
-                     #+ecl :lisp-files #+mkcl :lisp-object-files (list obj=
ect-file))
-                    object-file)
-               flags1
-               flags2)))))
-
-;;;; ---------------------------------------------------------------------=
--
-;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SB=
CL
-;;;;
-(defun* module-provide-asdf (name)
-  (handler-bind
-      ((style-warning #'muffle-warning)
-       #-genera
-       (missing-component (constantly nil))
-       (error #'(lambda (e)
-                  (format *error-output* (compatfmt "~@<ASDF could not loa=
d ~(~A~) because ~A.~@:>~%")
-                          name e))))
-    (let ((*verbose-out* (make-broadcast-stream))
-          (system (find-system (string-downcase name) nil)))
-      (when system
-        (require-system system :verbose nil)
-        t))))
-
-#+(or abcl clisp clozure cmu ecl mkcl sbcl)
-(let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom=
))))
-  (when x
-    (eval `(pushnew 'module-provide-asdf
-            #+abcl sys::*module-provider-functions*
-            #+clisp ,x
-            #+clozure ccl:*module-provider-functions*
-            #+(or cmu ecl) ext:*module-provider-functions*
-            #+mkcl mk-ext:*module-provider-functions*
-            #+sbcl sb-ext:*module-provider-functions*))))
-
-
-;;;; ---------------------------------------------------------------------=
----
-;;;; Cleanups after hot-upgrade.
-;;;; Things to do in case we're upgrading from a previous version of ASDF.
-;;;; See https://bugs.launchpad.net/asdf/+bug/485687
-;;;;
-
-;;; If a previous version of ASDF failed to read some configuration, try a=
gain.
-(when *ignored-configuration-form*
-  (clear-configuration)
-  (setf *ignored-configuration-form* nil))
-
-;;;; -----------------------------------------------------------------
+                         (values-list l))))))
+
+
 ;;;; Done!
-(when *load-verbose*
-  (asdf-message ";; ASDF, version ~a~%" (asdf-version)))
-
-#+mkcl
-(progn
-  (defvar *loading-asdf-bundle* nil)
-  (unless *loading-asdf-bundle*
-    (let ((*central-registry*
-           (cons (translate-logical-pathname #P"CONTRIB:asdf-bundle;") *ce=
ntral-registry*))
-	  (*loading-asdf-bundle* t))
-      (clear-system :asdf-bundle) ;; we hope to force a reload.
-      (multiple-value-bind (result bundling-error)
-          (ignore-errors (asdf:oos 'asdf:load-op :asdf-bundle))
-        (unless result
-	  (format *error-output*
-		  "~&;;; ASDF: Failed to load package 'asdf-bundle'!~%;;; ASDF: Reason i=
s: ~A.~%"
-		  bundling-error))))))
 =

 #+allegro
 (eval-when (:compile-toplevel :execute)
   (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
-    (setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*)))
-
-(pushnew :asdf *features*)
-(pushnew :asdf2 *features*)
+    (setf excl:*warn-on-nested-reader-conditionals* asdf/common-lisp::*acl=
-warn-save*)))
+
+(dolist (f '(:asdf :asdf2 :asdf3)) (pushnew f *features*))
 =

 (provide :asdf)
+
+;;;; Cleanups after hot-upgrade.
+(cleanup-upgraded-asdf)
+
+(when *load-verbose*
+  (asdf-message ";; ASDF, version ~a~%" (asdf-version)))
+
 =

 ;;; Local Variables:
 ;;; mode: lisp


From gb at clozure.com  Fri Feb  1 16:06:25 2013
From: gb at clozure.com (gb at clozure.com)
Date: Fri, 01 Feb 2013 22:06:25 -0000
Subject: [Openmcl-cvs-notifications] r15632 - in /release/1.9/source:
	level-0/l0-init.lisp level-1/version.lisp
Message-ID: <20130201220625.BECEE703880@setf.clozure.com>

Author: gb
Date: Fri Feb  1 16:06:25 2013
New Revision: 15632

Log:
:ccl-1.9 on *FEATURES*.

rc1 in version string.

Modified:
    release/1.9/source/level-0/l0-init.lisp
    release/1.9/source/level-1/version.lisp

Modified: release/1.9/source/level-0/l0-init.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- release/1.9/source/level-0/l0-init.lisp (original)
+++ release/1.9/source/level-0/l0-init.lisp Fri Feb  1 16:06:25 2013
@@ -34,6 +34,7 @@
     :ccl-1.6
     :ccl-1.7
     :ccl-1.8
+    :ccl-1.9
     :clozure
     :clozure-common-lisp
     :ansi-cl

Modified: release/1.9/source/level-1/version.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- release/1.9/source/level-1/version.lisp (original)
+++ release/1.9/source/level-1/version.lisp Fri Feb  1 16:06:25 2013
@@ -19,7 +19,7 @@
 =

 (defparameter *openmcl-major-version* 1)
 (defparameter *openmcl-minor-version* 9)
-(defparameter *openmcl-revision* "dev")
+(defparameter *openmcl-revision* "rc1")
 ;;; May be set by xload-level-0
 (defvar *openmcl-svn-revision* nil)
 (defparameter *openmcl-dev-level* nil)


From rme at clozure.com  Fri Feb  1 16:37:34 2013
From: rme at clozure.com (rme at clozure.com)
Date: Fri, 01 Feb 2013 22:37:34 -0000
Subject: [Openmcl-cvs-notifications] r15633 - /trunk/source/tools/asdf.lisp
Message-ID: <20130201223734.3198B703880@setf.clozure.com>

Author: rme
Date: Fri Feb  1 16:37:33 2013
New Revision: 15633

Log:
Make that ASDF 2.28.

Modified:
    trunk/source/tools/asdf.lisp

Modified: trunk/source/tools/asdf.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/tools/asdf.lisp (original)
+++ trunk/source/tools/asdf.lisp Fri Feb  1 16:37:33 2013
@@ -1,5 +1,5 @@
 ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
-;;; This is ASDF 2.27: Another System Definition Facility.
+;;; This is ASDF 2.28: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
 ;;; please mail to <asdf-devel at common-lisp.net>.
@@ -4972,7 +4972,7 @@
          ;; "3.4.5.67" would be a development version in the official upst=
ream of 3.4.5.
          ;; "3.4.5.0.8" would be your eighth local modification of officia=
l release 3.4.5
          ;; "3.4.5.67.8" would be your eighth local modification of develo=
pment version 3.4.5.67
-         (asdf-version "2.27")
+         (asdf-version "2.28")
          (existing-version (asdf-version)))
     (setf *asdf-version* asdf-version)
     (when (and existing-version (not (equal asdf-version existing-version)=
))
@@ -7935,12 +7935,13 @@
   ;;    and may be from within the EVAL-WHEN of a file compilation.
   ;; If no absolute pathname was found, we return NIL.
   (check-type pathname (or null string pathname))
-  (resolve-symlinks*
-   (ensure-absolute-pathname
-    (parse-unix-namestring pathname :type :directory)
-    #'(lambda () (ensure-absolute-pathname
-                  (load-pathname) 'get-pathname-defaults nil))
-    nil)))
+  (pathname-directory-pathname
+   (resolve-symlinks*
+    (ensure-absolute-pathname
+     (parse-unix-namestring pathname :type :directory)
+     #'(lambda () (ensure-absolute-pathname
+                   (load-pathname) 'get-pathname-defaults nil))
+     nil))))
 =

 =

 ;;; Component class


From rme at clozure.com  Fri Feb  1 19:34:47 2013
From: rme at clozure.com (rme at clozure.com)
Date: Sat, 02 Feb 2013 01:34:47 -0000
Subject: [Openmcl-cvs-notifications] r15634 - in /release/1.9/source: ./
	tools/asdf.lisp
Message-ID: <20130202013448.3A4DF703880@setf.clozure.com>

Author: rme
Date: Fri Feb  1 19:34:47 2013
New Revision: 15634

Log:
Merge ASDF 2.28 from trunk.

Modified:
    release/1.9/source/   (props changed)
    release/1.9/source/tools/asdf.lisp

Propchange: release/1.9/source/
---------------------------------------------------------------------------=
---
--- svn:mergeinfo (original)
+++ svn:mergeinfo Fri Feb  1 19:34:47 2013
@@ -4,3 +4,4 @@
 /branches/rme-logops:13875-13886
 /branches/working-0711/ccl:7970-13192,13197-13198,13202,13208,13214,13235-=
13236,13239,13263,13277-13278,13290,13293-13294,13302-13306,13331-13332,133=
39,13361-13364,13379,13383,13386,13388,13409,13435-13436,13438,13440-13442,=
13460-13461,13465,13467,13476,13487,13490,13492-13493,13502-13528,13545-135=
47,13549,13557-13558
 /release/1.5/source:13667
+/trunk/source:15630-15633

Modified: release/1.9/source/tools/asdf.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- release/1.9/source/tools/asdf.lisp (original)
+++ release/1.9/source/tools/asdf.lisp Fri Feb  1 19:34:47 2013
@@ -1,5 +1,5 @@
-;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: u=
tf-8 -*-
-;;; This is ASDF 2.26: Another System Definition Facility.
+;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
+;;; This is ASDF 2.28: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
 ;;; please mail to <asdf-devel at common-lisp.net>.
@@ -47,425 +47,855 @@
 =

 #+xcvb (module ())
 =

-(cl:in-package :common-lisp-user)
-#+genera (in-package :future-common-lisp-user)
+(in-package :cl-user)
+
+#+cmu
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (declaim (optimize (speed 1) (safety 3) (debug 3)))
+  (setf ext:*gc-verbose* nil))
+
+#+(or abcl clisp cmu ecl xcl)
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (unless (member :asdf3 *features*)
+    (let* ((existing-version
+             (when (find-package :asdf)
+               (or (symbol-value (find-symbol (string :*asdf-version*) :as=
df))
+                   (let ((ver (symbol-value (find-symbol (string :*asdf-re=
vision*) :asdf))))
+                     (etypecase ver
+                       (string ver)
+                       (cons (format nil "~{~D~^.~}" ver))
+                       (null "1.0"))))))
+           (first-dot (when existing-version (position #\. existing-versio=
n)))
+           (second-dot (when first-dot (position #\. existing-version :sta=
rt (1+ first-dot))))
+           (existing-major-minor (subseq existing-version 0 second-dot))
+           (existing-version-number (and existing-version (read-from-strin=
g existing-major-minor)))
+           (away (format nil "~A-~A" :asdf existing-version)))
+      (when (and existing-version (< existing-version-number
+                                     #+abcl 2.25 #+clisp 2.27 #+cmu 2.018 =
#+ecl 2.21 #+xcl 2.27))
+        (rename-package :asdf away)
+        (when *load-verbose*
+          (format t "; First thing, renamed package ~A away to ~A~%" :asdf=
 away))))))
+
+;;;; ---------------------------------------------------------------------=
------
+;;;; Handle ASDF package upgrade, including implementation-dependent magic.
+;;
+;; See https://bugs.launchpad.net/asdf/+bug/485687
+;;
+;; CAUTION: we must handle the first few packages specially for hot-upgrad=
e.
+;; asdf/package will be frozen as of ASDF 3
+;; to forever export the same exact symbols.
+;; Any other symbol must be import-from'ed
+;; and reexported in a different package
+;; (alternatively the package may be dropped & replaced by one with a new =
name).
+
+(defpackage :asdf/package
+  (:use :common-lisp)
+  (:export
+   #:find-package* #:find-symbol* #:symbol-call
+   #:intern* #:unintern* #:export* #:make-symbol*
+   #:symbol-shadowing-p #:home-package-p #:rehome-symbol
+   #:symbol-package-name #:standard-common-lisp-symbol-p
+   #:reify-package #:unreify-package #:reify-symbol #:unreify-symbol
+   #:nuke-symbol-in-package #:nuke-symbol
+   #:ensure-package-unused #:delete-package*
+   #:fresh-package-name #:rename-package-away #:package-names #:packages-f=
rom-names
+   #:package-definition-form #:parse-define-package-form
+   #:ensure-package #:define-package))
+
+(in-package :asdf/package)
+
+;;;; General purpose package utilities
+
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (defun find-package* (package-designator &optional (error t))
+    (let ((package (find-package package-designator)))
+      (cond
+        (package package)
+        (error (error "No package named ~S" (string package-designator)))
+        (t nil))))
+  (defun find-symbol* (name package-designator &optional (error t))
+    "Find a symbol in a package of given string'ified NAME;
+unless CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax
+by letting you supply a symbol or keyword for the name;
+also works well when the package is not present.
+If optional ERROR argument is NIL, return NIL instead of an error
+when the symbol is not found."
+    (block nil
+      (let ((package (find-package* package-designator error)))
+        (when package ;; package error handled by find-package* already
+          (multiple-value-bind (symbol status) (find-symbol (string name) =
package)
+            (cond
+              (status (return (values symbol status)))
+              (error (error "There is no symbol ~S in package ~S" name (pa=
ckage-name package))))))
+        (values nil nil))))
+  (defun symbol-call (package name &rest args)
+    "Call a function associated with symbol of given name in given package,
+with given ARGS. Useful when the call is read before the package is loaded,
+or when loading the package is optional."
+    (apply (find-symbol* name package) args))
+  (defun intern* (name package-designator &optional (error t))
+    (intern (string name) (find-package* package-designator error)))
+  (defun export* (name package-designator)
+    (let* ((package (find-package* package-designator))
+           (symbol (intern* name package)))
+      (export (or symbol (list symbol)) package)))
+  (defun make-symbol* (name)
+    (etypecase name
+      (string (make-symbol name))
+      (symbol (copy-symbol name))))
+  (defun unintern* (name package-designator &optional (error t))
+    (block nil
+      (let ((package (find-package* package-designator error)))
+        (when package
+          (multiple-value-bind (symbol status) (find-symbol* name package =
error)
+            (cond
+              (status (unintern symbol package)
+                      (return (values symbol status)))
+              (error (error "symbol ~A not present in package ~A"
+                            (string symbol) (package-name package))))))
+        (values nil nil))))
+  (defun symbol-shadowing-p (symbol package)
+    (and (member symbol (package-shadowing-symbols package)) t))
+  (defun home-package-p (symbol package)
+    (and package (let ((sp (symbol-package symbol)))
+                   (and sp (let ((pp (find-package* package)))
+                             (and pp (eq sp pp))))))))
+
+
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (defun symbol-package-name (symbol)
+    (let ((package (symbol-package symbol)))
+      (and package (package-name package))))
+  (defun standard-common-lisp-symbol-p (symbol)
+    (multiple-value-bind (sym status) (find-symbol* symbol :common-lisp ni=
l)
+      (and (eq sym symbol) (eq status :external))))
+  (defun reify-package (package &optional package-context)
+    (if (eq package package-context) t
+        (etypecase package
+          (null nil)
+          ((eql (find-package :cl)) :cl)
+          (package (package-name package)))))
+  (defun unreify-package (package &optional package-context)
+    (etypecase package
+      (null nil)
+      ((eql t) package-context)
+      ((or symbol string) (find-package package))))
+  (defun reify-symbol (symbol &optional package-context)
+    (etypecase symbol
+      ((or keyword (satisfies standard-common-lisp-symbol-p)) symbol)
+      (symbol (vector (symbol-name symbol)
+                      (reify-package (symbol-package symbol) package-conte=
xt)))))
+  (defun unreify-symbol (symbol &optional package-context)
+    (etypecase symbol
+      (symbol symbol)
+      ((simple-vector 2)
+       (let* ((symbol-name (svref symbol 0))
+              (package-foo (svref symbol 1))
+              (package (unreify-package package-foo package-context)))
+         (if package (intern* symbol-name package)
+             (make-symbol* symbol-name)))))))
+
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (defvar *all-package-happiness* '())
+  (defvar *all-package-fishiness* (list t))
+  (defun record-fishy (info)
+    ;;(format t "~&FISHY: ~S~%" info)
+    (push info *all-package-fishiness*))
+  (defmacro when-package-fishiness (&body body)
+    `(when *all-package-fishiness* , at body))
+  (defmacro note-package-fishiness (&rest info)
+    `(when-package-fishiness (record-fishy (list , at info)))))
+
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  #+(or clisp clozure)
+  (defun get-setf-function-symbol (symbol)
+    #+clisp (let ((sym (get symbol 'system::setf-function)))
+              (if sym (values sym :setf-function)
+                  (let ((sym (get symbol 'system::setf-expander)))
+                    (if sym (values sym :setf-expander)
+                        (values nil nil)))))
+    #+clozure (gethash symbol ccl::%setf-function-names%))
+  #+(or clisp clozure)
+  (defun set-setf-function-symbol (new-setf-symbol symbol &optional kind)
+    #+clisp (assert (member kind '(:setf-function :setf-expander)))
+    #+clozure (assert (eq kind t))
+    #+clisp
+    (cond
+      ((null new-setf-symbol)
+       (remprop symbol 'system::setf-function)
+       (remprop symbol 'system::setf-expander))
+      ((eq kind :setf-function)
+       (setf (get symbol 'system::setf-function) new-setf-symbol))
+      ((eq kind :setf-expander)
+       (setf (get symbol 'system::setf-expander) new-setf-symbol))
+      (t (error "invalid kind of setf-function ~S for ~S to be set to ~S"
+                kind symbol new-setf-symbol)))
+    #+clozure
+    (progn
+      (gethash symbol ccl::%setf-function-names%) new-setf-symbol
+      (gethash new-setf-symbol ccl::%setf-function-name-inverses%) symbol))
+  #+(or clisp clozure)
+  (defun create-setf-function-symbol (symbol)
+    #+clisp (system::setf-symbol symbol)
+    #+clozure (ccl::construct-setf-function-name symbol))
+  (defun set-dummy-symbol (symbol reason other-symbol)
+    (setf (get symbol 'dummy-symbol) (cons reason other-symbol)))
+  (defun make-dummy-symbol (symbol)
+    (let ((dummy (copy-symbol symbol)))
+      (set-dummy-symbol dummy 'replacing symbol)
+      (set-dummy-symbol symbol 'replaced-by dummy)
+      dummy))
+  (defun dummy-symbol (symbol)
+    (get symbol 'dummy-symbol))
+  (defun get-dummy-symbol (symbol)
+    (let ((existing (dummy-symbol symbol)))
+      (if existing (values (cdr existing) (car existing))
+          (make-dummy-symbol symbol))))
+  (defun nuke-symbol-in-package (symbol package-designator)
+    (let ((package (find-package* package-designator))
+          (name (symbol-name symbol)))
+      (multiple-value-bind (sym stat) (find-symbol name package)
+        (when (and (member stat '(:internal :external)) (eq symbol sym))
+          (if (symbol-shadowing-p symbol package)
+              (shadowing-import (get-dummy-symbol symbol) package)
+              (unintern symbol package))))))
+  (defun nuke-symbol (symbol &optional (packages (list-all-packages)))
+    #+(or clisp clozure)
+    (multiple-value-bind (setf-symbol kind)
+        (get-setf-function-symbol symbol)
+      (when kind (nuke-symbol setf-symbol)))
+    (loop :for p :in packages :do (nuke-symbol-in-package symbol p)))
+  (defun rehome-symbol (symbol package-designator)
+    "Changes the home package of a symbol, also leaving it present in its =
old home if any"
+    (let* ((name (symbol-name symbol))
+           (package (find-package* package-designator))
+           (old-package (symbol-package symbol))
+           (old-status (and old-package (nth-value 1 (find-symbol name old=
-package))))
+           (shadowing (and old-package (symbol-shadowing-p symbol old-pack=
age) (make-symbol name))))
+      (multiple-value-bind (overwritten-symbol overwritten-symbol-status) =
(find-symbol name package)
+        (unless (eq package old-package)
+          (let ((overwritten-symbol-shadowing-p
+                  (and overwritten-symbol-status
+                       (symbol-shadowing-p overwritten-symbol package))))
+            (note-package-fishiness
+             :rehome-symbol name
+             (when old-package (package-name old-package)) old-status (and=
 shadowing t)
+             (package-name package) overwritten-symbol-status overwritten-=
symbol-shadowing-p)
+            (when old-package
+              (if shadowing
+                  (shadowing-import shadowing old-package))
+              (unintern symbol old-package))
+            (cond
+              (overwritten-symbol-shadowing-p
+               (shadowing-import symbol package))
+              (t
+               (when overwritten-symbol-status
+                 (unintern overwritten-symbol package))
+               (import symbol package)))
+            (if shadowing
+                (shadowing-import symbol old-package)
+                (import symbol old-package))
+            #+(or clisp clozure)
+            (multiple-value-bind (setf-symbol kind)
+                (get-setf-function-symbol symbol)
+              (when kind
+                (let* ((setf-function (fdefinition setf-symbol))
+                       (new-setf-symbol (create-setf-function-symbol symbo=
l)))
+                  (note-package-fishiness
+                   :setf-function
+                   name (package-name package)
+                   (symbol-name setf-symbol) (symbol-package-name setf-sym=
bol)
+                   (symbol-name new-setf-symbol) (symbol-package-name new-=
setf-symbol))
+                  (when (symbol-package setf-symbol)
+                    (unintern setf-symbol (symbol-package setf-symbol)))
+                  (setf (fdefinition new-setf-symbol) setf-function)
+                  (set-setf-function-symbol new-setf-symbol symbol kind))))
+            #+(or clisp clozure)
+            (multiple-value-bind (overwritten-setf foundp)
+                (get-setf-function-symbol overwritten-symbol)
+              (when foundp
+                (unintern overwritten-setf)))
+            (when (eq old-status :external)
+              (export* symbol old-package))
+            (when (eq overwritten-symbol-status :external)
+              (export* symbol package))))
+        (values overwritten-symbol overwritten-symbol-status))))
+  (defun ensure-package-unused (package)
+    (loop :for p :in (package-used-by-list package) :do
+      (unuse-package package p)))
+  (defun delete-package* (package &key nuke)
+    (let ((p (find-package package)))
+      (when p
+        (when nuke (do-symbols (s p) (when (home-package-p s p) (nuke-symb=
ol s))))
+        (ensure-package-unused p)
+        (delete-package package))))
+  (defun package-names (package)
+    (cons (package-name package) (package-nicknames package)))
+  (defun packages-from-names (names)
+    (remove-duplicates (remove nil (mapcar #'find-package names)) :from-en=
d t))
+  (defun fresh-package-name (&key (prefix :%TO-BE-DELETED)
+                               separator
+                               (index (random most-positive-fixnum)))
+    (loop :for i :from index
+          :for n =3D (format nil "~A~@[~A~D~]" prefix (and (plusp i) (or s=
eparator "")) i)
+          :thereis (and (not (find-package n)) n)))
+  (defun rename-package-away (p &rest keys &key prefix &allow-other-keys)
+    (let ((new-name
+            (apply 'fresh-package-name
+                   :prefix (or prefix (format nil "__~A__" (package-name p=
))) keys)))
+      (record-fishy (list :rename-away (package-names p) new-name))
+      (rename-package p new-name))))
+
+
+;;; Communicable representation of symbol and package information
+
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (defun package-definition-form (package-designator
+                                  &key (nicknamesp t) (usep t)
+                                    (shadowp t) (shadowing-import-p t)
+                                    (exportp t) (importp t) internp (error=
 t))
+    (let* ((package (or (find-package* package-designator error)
+                        (return-from package-definition-form nil)))
+           (name (package-name package))
+           (nicknames (package-nicknames package))
+           (use (mapcar #'package-name (package-use-list package)))
+           (shadow ())
+           (shadowing-import (make-hash-table :test 'equal))
+           (import (make-hash-table :test 'equal))
+           (export ())
+           (intern ()))
+      (when package
+        (loop :for sym :being :the :symbols :in package
+              :for status =3D (nth-value 1 (find-symbol* sym package)) :do
+                (ecase status
+                  ((nil :inherited))
+                  ((:internal :external)
+                   (let* ((name (symbol-name sym))
+                          (external (eq status :external))
+                          (home (symbol-package sym))
+                          (home-name (package-name home))
+                          (imported (not (eq home package)))
+                          (shadowing (symbol-shadowing-p sym package)))
+                     (cond
+                       ((and shadowing imported)
+                        (push name (gethash home-name shadowing-import)))
+                       (shadowing
+                        (push name shadow))
+                       (imported
+                        (push name (gethash home-name import))))
+                     (cond
+                       (external
+                        (push name export))
+                       (imported)
+                       (t (push name intern)))))))
+        (labels ((sort-names (names)
+                   (sort names #'string<))
+                 (table-keys (table)
+                   (loop :for k :being :the :hash-keys :of table :collect =
k))
+                 (when-relevant (key value)
+                   (when value (list (cons key value))))
+                 (import-options (key table)
+                   (loop :for i :in (sort-names (table-keys table))
+                         :collect `(,key ,i ,@(sort-names (gethash i table=
))))))
+          `(defpackage ,name
+             ,@(when-relevant :nicknames (and nicknamesp (sort-names nickn=
ames)))
+             (:use ,@(and usep (sort-names use)))
+             ,@(when-relevant :shadow (and shadowp (sort-names shadow)))
+             ,@(import-options :shadowing-import-from (and shadowing-impor=
t-p shadowing-import))
+             ,@(import-options :import-from (and importp import))
+             ,@(when-relevant :export (and exportp (sort-names export)))
+             ,@(when-relevant :intern (and internp (sort-names intern)))))=
))))
+
+
+;;; ensure-package, define-package
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (defun ensure-shadowing-import (name to-package from-package shadowed im=
ported)
+    (check-type name string)
+    (check-type to-package package)
+    (check-type from-package package)
+    (check-type shadowed hash-table)
+    (check-type imported hash-table)
+    (let ((import-me (find-symbol* name from-package)))
+      (multiple-value-bind (existing status) (find-symbol name to-package)
+        (cond
+          ((gethash name shadowed)
+           (unless (eq import-me existing)
+             (error "Conflicting shadowings for ~A" name)))
+          (t
+           (setf (gethash name shadowed) t)
+           (setf (gethash name imported) t)
+           (unless (or (null status)
+                       (and (member status '(:internal :external))
+                            (eq existing import-me)
+                            (symbol-shadowing-p existing to-package)))
+             (note-package-fishiness
+              :shadowing-import name
+              (package-name from-package)
+              (or (home-package-p import-me from-package) (symbol-package-=
name import-me))
+              (package-name to-package) status
+              (and status (or (home-package-p existing to-package) (symbol=
-package-name existing)))))
+           (shadowing-import import-me to-package))))))
+  (defun ensure-import (name to-package from-package shadowed imported)
+    (check-type name string)
+    (check-type to-package package)
+    (check-type from-package package)
+    (check-type shadowed hash-table)
+    (check-type imported hash-table)
+    (multiple-value-bind (import-me import-status) (find-symbol name from-=
package)
+      (when (null import-status)
+        (note-package-fishiness
+         :import-uninterned name (package-name from-package) (package-name=
 to-package))
+        (setf import-me (intern name from-package)))
+      (multiple-value-bind (existing status) (find-symbol name to-package)
+        (cond
+          ((gethash name imported)
+           (unless (eq import-me existing)
+             (error "Can't import ~S from both ~S and ~S"
+                    name (package-name (symbol-package existing)) (package=
-name from-package))))
+          ((gethash name shadowed)
+           (error "Can't both shadow ~S and import it from ~S" name (packa=
ge-name from-package)))
+          (t
+           (setf (gethash name imported) t)
+           (unless (and status (eq import-me existing))
+             (when status
+               (note-package-fishiness
+                :import name
+                (package-name from-package)
+                (or (home-package-p import-me from-package) (symbol-packag=
e-name import-me))
+                (package-name to-package) status
+                (and status (or (home-package-p existing to-package) (symb=
ol-package-name existing))))
+               (unintern* existing to-package))
+             (import import-me to-package)))))))
+  (defun ensure-inherited (name symbol to-package from-package mixp shadow=
ed imported inherited)
+    (check-type name string)
+    (check-type symbol symbol)
+    (check-type to-package package)
+    (check-type from-package package)
+    (check-type mixp (member nil t)) ; no cl:boolean on Genera
+    (check-type shadowed hash-table)
+    (check-type imported hash-table)
+    (check-type inherited hash-table)
+    (multiple-value-bind (existing status) (find-symbol name to-package)
+      (let* ((sp (symbol-package symbol))
+             (in (gethash name inherited))
+             (xp (and status (symbol-package existing))))
+        (when (null sp)
+          (note-package-fishiness
+           :import-uninterned name
+           (package-name from-package) (package-name to-package) mixp)
+          (import symbol from-package)
+          (setf sp (package-name from-package)))
+        (cond
+          ((gethash name shadowed))
+          (in
+           (unless (equal sp (first in))
+             (if mixp
+                 (ensure-shadowing-import name to-package (second in) shad=
owed imported)
+                 (error "Can't inherit ~S from ~S, it is inherited from ~S"
+                        name (package-name sp) (package-name (first in))))=
))
+          ((gethash name imported)
+           (unless (eq symbol existing)
+             (error "Can't inherit ~S from ~S, it is imported from ~S"
+                    name (package-name sp) (package-name xp))))
+          (t
+           (setf (gethash name inherited) (list sp from-package))
+           (when (and status (not (eq sp xp)))
+             (let ((shadowing (symbol-shadowing-p existing to-package)))
+               (note-package-fishiness
+                :inherited name
+                (package-name from-package)
+                (or (home-package-p symbol from-package) (symbol-package-n=
ame symbol))
+                (package-name to-package)
+                (or (home-package-p existing to-package) (symbol-package-n=
ame existing)))
+               (if shadowing (ensure-shadowing-import name to-package from=
-package shadowed imported)
+                   (unintern* existing to-package)))))))))
+  (defun ensure-mix (name symbol to-package from-package shadowed imported=
 inherited)
+    (check-type name string)
+    (check-type symbol symbol)
+    (check-type to-package package)
+    (check-type from-package package)
+    (check-type shadowed hash-table)
+    (check-type imported hash-table)
+    (check-type inherited hash-table)
+    (unless (gethash name shadowed)
+      (multiple-value-bind (existing status) (find-symbol name to-package)
+        (let* ((sp (symbol-package symbol))
+               (im (gethash name imported))
+               (in (gethash name inherited)))
+          (cond
+            ((or (null status)
+                 (and status (eq symbol existing))
+                 (and in (eq sp (first in))))
+             (ensure-inherited name symbol to-package from-package t shado=
wed imported inherited))
+            (in
+             (remhash name inherited)
+             (ensure-shadowing-import name to-package (second in) shadowed=
 imported))
+            (im
+             (error "Symbol ~S import from ~S~:[~; actually ~:[uninterned~=
;~:*from ~S~]~] conflicts with existing symbol in ~S~:[~; actually ~:[unint=
erned~;from ~:*~S~]~]"
+                    name (package-name from-package)
+                    (home-package-p symbol from-package) (symbol-package-n=
ame symbol)
+                    (package-name to-package)
+                    (home-package-p existing to-package) (symbol-package-n=
ame existing)))
+            (t
+             (ensure-inherited name symbol to-package from-package t shado=
wed imported inherited)))))))
+  (defun recycle-symbol (name recycle exported)
+    (check-type name string)
+    (check-type recycle list)
+    (check-type exported hash-table)
+    (when (gethash name exported) ;; don't bother recycling private symbols
+      (let (recycled foundp)
+        (dolist (r recycle (values recycled foundp))
+          (multiple-value-bind (symbol status) (find-symbol name r)
+            (when (and status (home-package-p symbol r))
+              (cond
+                (foundp
+                 ;; (nuke-symbol symbol)) -- even simple variable names li=
ke O or C will do that.
+                 (note-package-fishiness :recycled-duplicate name (package=
-name foundp) (package-name r)))
+                (t
+                 (setf recycled symbol foundp r)))))))))
+  (defun symbol-recycled-p (sym recycle)
+    (check-type sym symbol)
+    (check-type recycle list)
+    (member (symbol-package sym) recycle))
+  (defun ensure-symbol (name package intern recycle shadowed imported inhe=
rited exported)
+    (check-type name string)
+    (check-type package package)
+    (check-type intern (member nil t)) ; no cl:boolean on Genera
+    (check-type shadowed hash-table)
+    (check-type imported hash-table)
+    (check-type inherited hash-table)
+    (unless (or (gethash name shadowed)
+                (gethash name imported)
+                (gethash name inherited))
+      (multiple-value-bind (existing status)
+          (find-symbol name package)
+        (multiple-value-bind (recycled previous) (recycle-symbol name recy=
cle exported)
+          (cond
+            ((and status (eq existing recycled) (eq previous package)))
+            (previous
+             (rehome-symbol recycled package))
+            ((and status (eq package (symbol-package existing))))
+            (t
+             (when status
+               (note-package-fishiness
+                :ensure-symbol name
+                (reify-package (symbol-package existing) package)
+                status intern)
+               (unintern existing))
+             (when intern
+               (intern* name package))))))))
+  (declaim (ftype function ensure-exported))
+  (defun ensure-exported-to-user (name symbol to-package &optional recycle)
+    (check-type name string)
+    (check-type symbol symbol)
+    (check-type to-package package)
+    (check-type recycle list)
+    (multiple-value-bind (existing status) (find-symbol name to-package)
+      (unless (and status (eq symbol existing))
+        (let ((accessible
+                (or (null status)
+                    (let ((shadowing (symbol-shadowing-p existing to-packa=
ge))
+                          (recycled (symbol-recycled-p existing recycle)))
+                      (unless (and shadowing (not recycled))
+                        (note-package-fishiness
+                         :ensure-export name (symbol-package-name symbol)
+                         (package-name to-package)
+                         (or (home-package-p existing to-package) (symbol-=
package-name existing))
+                         status shadowing)
+                        (if (or (eq status :inherited) shadowing)
+                            (shadowing-import symbol to-package)
+                            (unintern existing to-package))
+                        t)))))
+          (when (and accessible (eq status :external))
+            (ensure-exported name symbol to-package recycle))))))
+  (defun ensure-exported (name symbol from-package &optional recycle)
+    (dolist (to-package (package-used-by-list from-package))
+      (ensure-exported-to-user name symbol to-package recycle))
+    (import symbol from-package)
+    (export* name from-package))
+  (defun ensure-export (name from-package &optional recycle)
+    (multiple-value-bind (symbol status) (find-symbol* name from-package)
+      (unless (eq status :external)
+        (ensure-exported name symbol from-package recycle))))
+  (defun ensure-package (name &key
+                                nicknames documentation use
+                                shadow shadowing-import-from
+                                import-from export intern
+                                recycle mix reexport
+                                unintern)
+    #+(or gcl2.6 genera) (declare (ignore documentation))
+    (let* ((package-name (string name))
+           (nicknames (mapcar #'string nicknames))
+           (names (cons package-name nicknames))
+           (previous (packages-from-names names))
+           (discarded (cdr previous))
+           (to-delete ())
+           (package (or (first previous) (make-package package-name :nickn=
ames nicknames)))
+           (recycle (packages-from-names recycle))
+           (use (mapcar 'find-package* use))
+           (mix (mapcar 'find-package* mix))
+           (reexport (mapcar 'find-package* reexport))
+           (shadow (mapcar 'string shadow))
+           (export (mapcar 'string export))
+           (intern (mapcar 'string intern))
+           (unintern (mapcar 'string unintern))
+           (shadowed (make-hash-table :test 'equal)) ; string to bool
+           (imported (make-hash-table :test 'equal)) ; string to bool
+           (exported (make-hash-table :test 'equal)) ; string to bool
+           ;; string to list home package and use package:
+           (inherited (make-hash-table :test 'equal)))
+      (when-package-fishiness (record-fishy package-name))
+      #-(or gcl2.6 genera)
+      (when documentation (setf (documentation package t) documentation))
+      (loop :for p :in (set-difference (package-use-list package) (append =
mix use))
+            :do (note-package-fishiness :over-use name (package-names p))
+                (unuse-package p package))
+      (loop :for p :in discarded
+            :for n =3D (remove-if #'(lambda (x) (member x names :test 'equ=
al))
+                                (package-names p))
+            :do (note-package-fishiness :nickname name (package-names p))
+                (cond (n (rename-package p (first n) (rest n)))
+                      (t (rename-package-away p)
+                         (push p to-delete))))
+      (rename-package package package-name nicknames)
+      (dolist (name unintern)
+        (multiple-value-bind (existing status) (find-symbol name package)
+          (when status
+            (unless (eq status :inherited)
+              (note-package-fishiness
+               :unintern (package-name package) name (symbol-package-name =
existing) status)
+              (unintern* name package nil)))))
+      (dolist (name export)
+        (setf (gethash name exported) t))
+      (dolist (p reexport)
+        (do-external-symbols (sym p)
+          (setf (gethash (string sym) exported) t)))
+      (do-external-symbols (sym package)
+        (let ((name (symbol-name sym)))
+          (unless (gethash name exported)
+            (note-package-fishiness
+             :over-export (package-name package) name
+             (or (home-package-p sym package) (symbol-package-name sym)))
+            (unexport sym package))))
+      (dolist (name shadow)
+        (setf (gethash name shadowed) t)
+        (multiple-value-bind (existing status) (find-symbol name package)
+          (multiple-value-bind (recycled previous) (recycle-symbol name re=
cycle exported)
+            (let ((shadowing (and status (symbol-shadowing-p existing pack=
age))))
+              (cond
+                ((eq previous package))
+                (previous
+                 (rehome-symbol recycled package))
+                ((or (member status '(nil :inherited))
+                     (home-package-p existing package)))
+                (t
+                 (let ((dummy (make-symbol name)))
+                   (note-package-fishiness
+                    :shadow-imported (package-name package) name
+                    (symbol-package-name existing) status shadowing)
+                   (shadowing-import dummy package)
+                   (import dummy package)))))))
+        (shadow name package))
+      (loop :for (p . syms) :in shadowing-import-from
+            :for pp =3D (find-package* p) :do
+              (dolist (sym syms) (ensure-shadowing-import (string sym) pac=
kage pp shadowed imported)))
+      (loop :for p :in mix
+            :for pp =3D (find-package* p) :do
+              (do-external-symbols (sym pp) (ensure-mix (symbol-name sym) =
sym package pp shadowed imported inherited)))
+      (loop :for (p . syms) :in import-from
+            :for pp =3D (find-package p) :do
+              (dolist (sym syms) (ensure-import (symbol-name sym) package =
pp shadowed imported)))
+      (dolist (p (append use mix))
+        (do-external-symbols (sym p) (ensure-inherited (string sym) sym pa=
ckage p nil shadowed imported inherited))
+        (use-package p package))
+      (loop :for name :being :the :hash-keys :of exported :do
+        (ensure-symbol name package t recycle shadowed imported inherited =
exported)
+        (ensure-export name package recycle))
+      (dolist (name intern)
+        (ensure-symbol name package t recycle shadowed imported inherited =
exported))
+      (do-symbols (sym package)
+        (ensure-symbol (symbol-name sym) package nil recycle shadowed impo=
rted inherited exported))
+      (map () 'delete-package* to-delete)
+      package)))
+
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (defun parse-define-package-form (package clauses)
+    (loop
+      :with use-p =3D nil :with recycle-p =3D nil
+      :with documentation =3D nil
+      :for (kw . args) :in clauses
+      :when (eq kw :nicknames) :append args :into nicknames :else
+        :when (eq kw :documentation)
+          :do (cond
+                (documentation (error "define-package: can't define docume=
ntation twice"))
+                ((or (atom args) (cdr args)) (error "define-package: bad d=
ocumentation"))
+                (t (setf documentation (car args)))) :else
+      :when (eq kw :use) :append args :into use :and :do (setf use-p t) :e=
lse
+        :when (eq kw :shadow) :append args :into shadow :else
+          :when (eq kw :shadowing-import-from) :collect args :into shadowi=
ng-import-from :else
+            :when (eq kw :import-from) :collect args :into import-from :el=
se
+              :when (eq kw :export) :append args :into export :else
+                :when (eq kw :intern) :append args :into intern :else
+                  :when (eq kw :recycle) :append args :into recycle :and :=
do (setf recycle-p t) :else
+                    :when (eq kw :mix) :append args :into mix :else
+                      :when (eq kw :reexport) :append args :into reexport =
:else
+                        :when (eq kw :unintern) :append args :into uninter=
n :else
+                          :do (error "unrecognized define-package keyword =
~S" kw)
+      :finally (return `(,package
+                         :nicknames ,nicknames :documentation ,documentati=
on
+                         :use ,(if use-p use '(:common-lisp))
+                         :shadow ,shadow :shadowing-import-from ,shadowing=
-import-from
+                         :import-from ,import-from :export ,export :intern=
 ,intern
+                         :recycle ,(if recycle-p recycle (cons package nic=
knames))
+                         :mix ,mix :reexport ,reexport :unintern ,unintern=
)))))
+
+(defmacro define-package (package &rest clauses)
+  (let ((ensure-form
+          `(apply 'ensure-package ',(parse-define-package-form package cla=
uses))))
+    `(progn
+       #+clisp
+       (eval-when (:compile-toplevel :load-toplevel :execute)
+         ,ensure-form)
+       #+(or clisp ecl gcl) (defpackage ,package (:use))
+       (eval-when (:compile-toplevel :load-toplevel :execute)
+         ,ensure-form))))
+
+;;;; Final tricks to keep various implementations happy.
+;; We want most such tricks in common-lisp.lisp,
+;; but these need to be done before the define-package form there,
+;; that we nevertheless want to be the very first form.
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  #+allegro ;; We need to disable autoloading BEFORE any mention of packag=
e ASDF.
+  (setf excl::*autoload-package-name-alist*
+        (remove "asdf" excl::*autoload-package-name-alist*
+                :test 'equalp :key 'car))
+  #+gcl
+  ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff,
+  ;; but can run ASDF 2.011. GCL 2.6 has even more issues.
+  (cond
+    ((or (< system::*gcl-major-version* 2)
+         (and (=3D system::*gcl-major-version* 2)
+              (< system::*gcl-minor-version* 6)))
+     (error "GCL 2.6 or later required to use ASDF"))
+    ((and (=3D system::*gcl-major-version* 2)
+          (=3D system::*gcl-minor-version* 6))
+     (pushnew 'ignorable pcl::*variable-declarations-without-argument*)
+     (pushnew :gcl2.6 *features*))
+    (t
+     (pushnew :gcl2.7 *features*))))
+;;;; ---------------------------------------------------------------------=
----
+;;;; Handle compatibility with multiple implementations.
+;;; This file is for papering over the deficiencies and peculiarities
+;;; of various Common Lisp implementations.
+;;; For implementation-specific access to the system, see os.lisp instead.
+;;; A few functions are defined here, but actually exported from utility;
+;;; from this package only common-lisp symbols are exported.
+
+(asdf/package:define-package :asdf/common-lisp
+  (:nicknames :asdf/cl)
+  (:use #-genera :common-lisp #+genera :future-common-lisp :asdf/package)
+  (:reexport :common-lisp)
+  (:recycle :asdf/common-lisp :asdf)
+  #+allegro (:intern #:*acl-warn-save*)
+  #+cormanlisp (:shadow #:user-homedir-pathname)
+  #+cormanlisp
+  (:export
+   #:logical-pathname #:translate-logical-pathname
+   #:make-broadcast-stream #:file-namestring)
+  #+gcl2.6 (:shadow #:type-of #:with-standard-io-syntax) ; causes errors w=
hen loading fasl(!)
+  #+gcl2.6 (:shadowing-import-from :system #:*load-pathname*)
+  #+genera (:shadowing-import-from :scl #:boolean)
+  #+genera (:export #:boolean #:ensure-directories-exist)
+  #+mcl (:shadow #:user-homedir-pathname))
+(in-package :asdf/common-lisp)
 =

 #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks m=
cl mkcl sbcl scl xcl)
 (error "ASDF is not supported on your implementation. Please help us port =
it.")
 =

-;;;; Create and setup packages in a way that is compatible with hot-upgrad=
e.
-;;;; See https://bugs.launchpad.net/asdf/+bug/485687
-;;;; See these two eval-when forms, and more near the end of the file.
-
-#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and=
 needs this
-
+;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; DON'T: trust impl=
ementation defaults.
+
+
+;;;; Early meta-level tweaks
+
+#+(or abcl (and allegro ics) (and (or clisp cmu ecl mkcl) unicode)
+      clozure lispworks (and sbcl sb-unicode) scl)
 (eval-when (:load-toplevel :compile-toplevel :execute)
-  ;;; Before we do anything, some implementation-dependent tweaks
-  ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; NO: trust imple=
mentation defaults.
-  #+allegro
-  (setf excl::*autoload-package-name-alist*
-        (remove "asdf" excl::*autoload-package-name-alist*
-                :test 'equalp :key 'car)) ; need that BEFORE any mention o=
f package ASDF as below
-  #+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 co=
mpile ASDF at all
-            (and (=3D system::*gcl-major-version* 2)
-                 (< system::*gcl-minor-version* 7)))
-    (pushnew :gcl-pre2.7 *features*))
-  #+(or abcl (and allegro ics) (and (or clisp cmu ecl mkcl) unicode)
-        clozure lispworks (and sbcl sb-unicode) scl)
-  (pushnew :asdf-unicode *features*)
-  ;;; make package if it doesn't exist yet.
-  ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
-  (unless (find-package :asdf)
-    (make-package :asdf :use '(:common-lisp))))
-
-(in-package :asdf)
-
+  (pushnew :asdf-unicode *features*))
+
+#+allegro
 (eval-when (:load-toplevel :compile-toplevel :execute)
-  ;;; This would belong amongst implementation-dependent tweaks above,
-  ;;; except that the defun has to be in package asdf.
-  #+ecl (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *featu=
res*) t))
-  #+ecl (unless (use-ecl-byte-compiler-p) (require :cmp))
-  #+mkcl (require :cmp)
-  #+mkcl (setq clos::*redefine-class-in-place* t) ;; Make sure we have str=
ict ANSI class redefinition semantics
-
-  ;;; Package setup, step 2.
-  (defvar *asdf-version* nil)
-  (defvar *upgraded-p* nil)
-  (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12.
-  (defun find-symbol* (s p)
-    (find-symbol (string s) p))
-  ;; Strip out formatting that is not supported on Genera.
-  ;; Has to be inside the eval-when to make Lispworks happy (!)
-  (defun strcat (&rest strings)
-    (apply 'concatenate 'string strings))
-  (defmacro compatfmt (format)
-    #-(or gcl genera) format
-    #+(or gcl genera)
-    (loop :for (unsupported . replacement) :in
-      (append
-       '(("~3i~_" . ""))
-       #+genera '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . "")=
)) :do
-      (loop :for found =3D (search unsupported format) :while found :do
-        (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.
-         ;; Please also modify asdf.asd to reflect this change. The script=
 bin/bump-version
-         ;; can help you do these changes in synch (look at the source for=
 documentation).
-         ;; Relying on its automation, the version is now redundantly pres=
ent on top of this file.
-         ;; "2.345" would be an official release
-         ;; "2.345.6" would be a development version in the official upstr=
eam
-         ;; "2.345.0.7" would be your seventh local modification of offici=
al release 2.345
-         ;; "2.345.6.7" would be your seventh local modification of develo=
pment version 2.345.6
-         (asdf-version "2.26")
-         (existing-asdf (find-class 'component nil))
-         (existing-version *asdf-version*)
-         (already-there (equal asdf-version existing-version)))
-    (unless (and existing-asdf already-there)
-      (when (and existing-asdf *asdf-verbose*)
-        (format *trace-output*
-                (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]=
to version ~A~@:>~%")
-                existing-version asdf-version))
-      (labels
-          ((present-symbol-p (symbol package)
-             (member (nth-value 1 (find-symbol* symbol package)) '(:intern=
al :external)))
-           (present-symbols (package)
-             ;; #-genera (loop :for s :being :the :present-symbols :in pac=
kage :collect s) #+genera
-             (let (l)
-               (do-symbols (s package)
-                 (when (present-symbol-p s package) (push s l)))
-               (reverse l)))
-           (unlink-package (package)
-             (let ((u (find-package package)))
-               (when u
-                 (ensure-unintern u (present-symbols u))
-                 (loop :for p :in (package-used-by-list u) :do
-                   (unuse-package u p))
-                 (delete-package u))))
-           (ensure-exists (name nicknames use)
-             (let ((previous
-                    (remove-duplicates
-                     (mapcar #'find-package (cons name nicknames))
-                     :from-end t)))
-               ;; do away with packages with conflicting (nick)names
-               (map () #'unlink-package (cdr previous))
-               ;; reuse previous package with same name
-               (let ((p (car previous)))
-                 (cond
-                   (p
-                    (rename-package p name nicknames)
-                    (ensure-use p use)
-                    p)
-                   (t
-                    (make-package name :nicknames nicknames :use use))))))
-           (intern* (symbol package)
-             (intern (string symbol) package))
-           (remove-symbol (symbol package)
-             (let ((sym (find-symbol* symbol package)))
-               (when sym
-                 #-cormanlisp (unexport sym package)
-                 (unintern sym package)
-                 sym)))
-           (ensure-unintern (package symbols)
-             (loop :with packages =3D (list-all-packages)
-               :for sym :in symbols
-               :for removed =3D (remove-symbol sym package)
-               :when removed :do
-               (loop :for p :in packages :do
-                 (when (eq removed (find-symbol* sym p))
-                   (unintern removed p)))))
-           (ensure-shadow (package symbols)
-             (shadow symbols package))
-           (ensure-use (package use)
-             (dolist (used (package-use-list package))
-               (unless (member (package-name used) use :test 'string=3D)
-                 (unuse-package used)
-                 (do-external-symbols (sym used)
-                   (when (eq sym (find-symbol* sym package))
-                     (remove-symbol sym package)))))
-             (dolist (used (reverse use))
-               (do-external-symbols (sym used)
-                 (unless (eq sym (find-symbol* sym package))
-                   (remove-symbol sym package)))
-               (use-package used package)))
-           (ensure-fmakunbound (package symbols)
-             (loop :for name :in symbols
-               :for sym =3D (find-symbol* name package)
-               :when sym :do (fmakunbound sym)))
-           (ensure-export (package export)
-             (let ((formerly-exported-symbols nil)
-                   (bothly-exported-symbols nil)
-                   (newly-exported-symbols nil))
-               (do-external-symbols (sym package)
-                 (if (member sym export :test 'string-equal)
-                     (push sym bothly-exported-symbols)
-                     (push sym formerly-exported-symbols)))
-               (loop :for sym :in export :do
-                 (unless (member sym bothly-exported-symbols :test 'equal)
-                   (push sym newly-exported-symbols)))
-               (loop :for user :in (package-used-by-list package)
-                 :for shadowing =3D (package-shadowing-symbols user) :do
-                 (loop :for new :in newly-exported-symbols
-                   :for old =3D (find-symbol* new user)
-                   :when (and old (not (member old shadowing)))
-                   :do (unintern old user)))
-               (loop :for x :in newly-exported-symbols :do
-                 (export (intern* x package)))))
-           (ensure-package (name &key nicknames use unintern
-                                 shadow export redefined-functions)
-             (let* ((p (ensure-exists name nicknames use)))
-               (ensure-unintern p (append unintern #+cmu redefined-functio=
ns))
-               (ensure-shadow p shadow)
-               (ensure-export p export)
-               #-cmu (ensure-fmakunbound p redefined-functions)
-               p)))
-        (macrolet
-            ((pkgdcl (name &key nicknames use export
-                           redefined-functions unintern shadow)
-                 `(ensure-package
-                   ',name :nicknames ',nicknames :use ',use :export ',expo=
rt
-                   :shadow ',shadow
-                   :unintern ',unintern
-                   :redefined-functions ',redefined-functions)))
-          (pkgdcl
-           :asdf
-           :use (:common-lisp)
-           :redefined-functions
-           (#:perform #:explain #:output-files #:operation-done-p
-            #:perform-with-restarts #:component-relative-pathname
-            #:system-source-file #:operate #:find-component #:find-system
-            #:apply-output-translations #:translate-pathname* #:resolve-lo=
cation
-            #: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 #:do-dep #:do-one-dep
-            #:resolve-relative-location-component #:resolve-absolute-locat=
ion-component
-            #:output-files-for-system-and-operation) ; obsolete ASDF-BINAR=
Y-LOCATION function
-           :export
-           (#:defsystem #:oos #:operate #:find-system #:locate-system #:ru=
n-shell-command
-            #:system-definition-pathname #:with-system-definitions
-            #:search-for-system-definition #:find-component #:component-fi=
nd-path
-            #:compile-system #:load-system #:load-systems
-            #:require-system #:test-system #:clear-system
-            #:operation #:compile-op #:load-op #:load-source-op #:test-op
-            #:feature #:version #:version-satisfies
-            #:upgrade-asdf
-            #:implementation-identifier #:implementation-type #:hostname
-            #:input-files #:output-files #:output-file #:perform
-            #:operation-done-p #:explain
-
-            #:component #:source-file
-            #:c-source-file #:cl-source-file #:java-source-file
-            #:cl-source-file.cl #:cl-source-file.lsp
-            #:static-file
-            #:doc-file
-            #:html-file
-            #:text-file
-            #:source-file-type
-            #:module                     ; components
-            #:system
-            #:unix-dso
-
-            #:module-components          ; component accessors
-            #:module-components-by-name
-            #:component-pathname
-            #:component-relative-pathname
-            #:component-name
-            #:component-version
-            #:component-parent
-            #:component-property
-            #:component-system
-            #:component-depends-on
-            #:component-encoding
-            #:component-external-format
-
-            #:system-description
-            #:system-long-description
-            #:system-author
-            #:system-maintainer
-            #:system-license
-            #:system-licence
-            #:system-source-file
-            #:system-source-directory
-            #:system-relative-pathname
-            #:map-systems
-
-            #:operation-description
-            #:operation-on-warnings
-            #:operation-on-failure
-            #:component-visited-p
-
-            #:*system-definition-search-functions*   ; variables
-            #:*central-registry*
-            #:*compile-file-warnings-behaviour*
-            #:*compile-file-failure-behaviour*
-            #:*resolve-symlinks*
-            #:*load-system-operation*
-            #:*asdf-verbose*
-            #:*verbose-out*
-
-            #:asdf-version
-
-            #:operation-error #:compile-failed #:compile-warned #:compile-=
error
-            #:error-name
-            #:error-pathname
-            #:load-system-definition-error
-            #:error-component #:error-operation
-            #:system-definition-error
-            #:missing-component
-            #:missing-component-of-version
-            #:missing-dependency
-            #:missing-dependency-of-version
-            #:circular-dependency        ; errors
-            #:duplicate-names
-
-            #:try-recompiling
-            #:retry
-            #:accept                     ; restarts
-            #:coerce-entry-to-directory
-            #:remove-entry-from-registry
-
-            #:*encoding-detection-hook*
-            #:*encoding-external-format-hook*
-            #:*default-encoding*
-            #:*utf-8-external-format*
-
-            #:clear-configuration
-            #:*output-translations-parameter*
-            #:initialize-output-translations
-            #:disable-output-translations
-            #:clear-output-translations
-            #:ensure-output-translations
-            #:apply-output-translations
-            #:compile-file*
-            #:compile-file-pathname*
-            #:enable-asdf-binary-locations-compatibility
-            #:*default-source-registries*
-            #:*source-registry-parameter*
-            #:initialize-source-registry
-            #:compute-source-registry
-            #:clear-source-registry
-            #:ensure-source-registry
-            #:process-source-registry
-            #:system-registered-p #:registered-systems #:loaded-systems
-            #:resolve-location
-            #: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: please use asdf-utils instead
-            #|
-            ;; #:aif #:it
-            ;; #:appendf #:orf
-            #:length=3Dn-p
-            #:remove-keys #:remove-keyword
-            #:first-char #:last-char #:string-suffix-p
-            #:coerce-name
-            #:directory-pathname-p #:ensure-directory-pathname
-            #:absolute-pathname-p #:ensure-pathname-absolute #:pathname-ro=
ot
-            #:getenv #:getenv-pathname #:getenv-pathnames
-            #:getenv-absolute-directory #:getenv-absolute-directories
-            #:probe-file*
-            #:find-symbol* #:strcat
-            #:make-pathname-component-logical #:make-pathname-logical
-            #:merge-pathnames* #:coerce-pathname #:subpathname #:subpathna=
me*
-            #:pathname-directory-pathname #:pathname-parent-directory-path=
name
-            #:read-file-forms
-            #:resolve-symlinks #:truenamize
-            #:split-string
-            #:component-name-to-pathname-components
-            #:split-name-type
-            #:subdirectories #:directory-files
-            #:while-collecting
-            #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors*
-            #:*wild-path* #:wilden
-            #:directorize-pathname-host-device|#
-            )))
-        #+genera (import 'scl:boolean :asdf)
-        (setf *asdf-version* asdf-version
-              *upgraded-p* (if existing-version
-                               (cons existing-version *upgraded-p*)
-                               *upgraded-p*))))))
-
-;;;; ---------------------------------------------------------------------=
----
-;;;; User-visible parameters
-;;;;
-(defvar *resolve-symlinks* t
-  "Determine whether or not ASDF resolves symlinks when defining systems.
-
-Defaults to T.")
-
-(defvar *compile-file-warnings-behaviour*
-  (or #+clisp :ignore :warn)
-  "How should ASDF react if it encounters a warning when compiling a file?
-Valid values are :error, :warn, and :ignore.")
-
-(defvar *compile-file-failure-behaviour*
-  (or #+sbcl :error #+clisp :ignore :warn)
-  "How should ASDF react if it encounters a failure (per the ANSI spec of =
COMPILE-FILE)
-when compiling a file?  Valid values are :error, :warn, and :ignore.
-Note that ASDF ALWAYS raises an error if it fails to create an output file=
 when compiling.")
-
-(defvar *verbose-out* nil)
-
-(defparameter +asdf-methods+
-  '(perform-with-restarts perform explain output-files operation-done-p))
-
-(defvar *load-system-operation* 'load-op
-  "Operation used by ASDF:LOAD-SYSTEM. By default, ASDF:LOAD-OP.
-You may override it with e.g. ASDF:LOAD-FASL-OP from asdf-bundle,
-or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.")
-
-(defvar *compile-op-compile-file-function* 'compile-file*
-  "Function used to compile lisp files.")
-
-
-
-#+allegro
-(eval-when (:compile-toplevel :execute)
   (defparameter *acl-warn-save*
-                (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
-                  excl:*warn-on-nested-reader-conditionals*))
+    (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
+      excl:*warn-on-nested-reader-conditionals*))
   (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
-    (setf excl:*warn-on-nested-reader-conditionals* nil)))
-
-;;;; ---------------------------------------------------------------------=
----
-;;;; Resolve forward references
-
-(declaim (ftype (function (t) t)
-                format-arguments format-control
-                error-name error-pathname error-condition
-                duplicate-names-name
-                error-component error-operation
-                module-components module-components-by-name
-                circular-dependency-components
-                condition-arguments condition-form
-                condition-format condition-location
-                coerce-name)
-         (ftype (function (&optional t) (values)) initialize-source-regist=
ry)
-         #-(or cormanlisp gcl-pre2.7)
-         (ftype (function (t t) t) (setf module-components-by-name)))
-
-;;;; ---------------------------------------------------------------------=
----
-;;;; Compatibility various implementations
+    (setf excl:*warn-on-nested-reader-conditionals* nil))
+  (setf *print-readably* nil))
+
 #+cormanlisp
 (progn
   (deftype logical-pathname () nil)
   (defun make-broadcast-stream () *error-output*)
   (defun translate-logical-pathname (x) x)
+  (defun user-homedir-pathname (&optional host)
+    (declare (ignore host))
+    (parse-namestring (format nil "~A\\" (cl:user-homedir-pathname))))
   (defun file-namestring (p)
     (setf p (pathname p))
     (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
+
+#+ecl
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (setf *load-verbose* nil)
+  (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) =
t))
+  (unless (use-ecl-byte-compiler-p) (require :cmp)))
+
+#+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, bu=
t can run ASDF 2.011
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (unless (member :ansi-cl *features*)
+    (error "ASDF only supports GCL in ANSI mode. Aborting.~%"))
+  (setf compiler::*compiler-default-type* (pathname "")
+        compiler::*lsp-ext* ""))
+
+#+gcl2.6
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (shadow 'type-of :asdf/common-lisp)
+  (shadowing-import 'system:*load-pathname* :asdf/common-lisp))
+
+#+gcl2.6
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (export 'type-of :asdf/common-lisp)
+  (export 'system:*load-pathname* :asdf/common-lisp))
+
+#+gcl2.6
+(progn ;; Doesn't support either logical-pathnames or output-translations.
+  (defvar *gcl2.6* t)
+  (deftype logical-pathname () nil)
+  (defun type-of (x) (class-name (class-of x)))
+  (defun wild-pathname-p (path) (declare (ignore path)) nil)
+  (defun translate-logical-pathname (x) x)
+  (defvar *compile-file-pathname* nil)
+  (defun pathname-match-p (in-pathname wild-pathname)
+    (declare (ignore in-wildname wild-wildname)) nil)
+  (defun translate-pathname (source from-wildname to-wildname &key)
+    (declare (ignore from-wildname to-wildname)) source)
+  (defun %print-unreadable-object (object stream type identity thunk)
+    (format stream "#<~@[~S ~]" (when type (type-of object)))
+    (funcall thunk)
+    (format stream "~@[ ~X~]>" (when identity (system:address object))))
+  (defmacro with-standard-io-syntax (&body body)
+    `(progn , at body))
+  (defmacro with-compilation-unit (options &body body)
+    (declare (ignore options)) `(progn , at body))
+  (defmacro print-unreadable-object ((object stream &key type identity) &b=
ody body)
+    `(%print-unreadable-object ,object ,stream ,type ,identity (lambda () =
, at body)))
+  (defun ensure-directories-exist (path)
+    (lisp:system (format nil "mkdir -p ~S"
+                         (namestring (make-pathname :name nil :type nil :v=
ersion nil :defaults path))))))
+
+#+genera
+(unless (fboundp 'ensure-directories-exist)
+  (defun ensure-directories-exist (path)
+    (fs:create-directories-recursively (pathname path))))
 =

 #.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl
       (read-from-string
@@ -476,7 +906,7 @@
           ;; the pathname of the current user's home directory, whereas
           ;; MCL by default provides the directory from which MCL was star=
ted.
           ;; See http://code.google.com/p/mcl/wiki/Portability
-          (defun current-user-homedir-pathname ()
+          (defun user-homedir-pathname ()
             (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))
           (defun probe-posix (posix-namestring)
             \"If a file exists for the posix namestring, return the pathna=
me\"
@@ -486,21 +916,164 @@
                 (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir))
                   (ccl::%path-from-fsref fsref is-dir))))))"))
 =

+#+mkcl
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (require :cmp)
+  (setq clos::*redefine-class-in-place* t)) ;; Make sure we have strict AN=
SI class redefinition semantics
+
+
+;;;; Looping
+(defmacro loop* (&rest rest)
+  #-genera `(loop , at rest)
+  #+genera `(lisp:loop , at rest)) ;; In genera, CL:LOOP can't destructure, s=
o we use LOOP*. Sigh.
+
+
+;;;; compatfmt: avoid fancy format directives when unsupported
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (defun remove-substrings (substrings string)
+    (let ((length (length string)) (stream nil))
+      (labels ((emit (start end)
+                 (when (and (zerop start) (=3D end length))
+                   (return-from remove-substrings string))
+                 (when (< start end)
+                   (unless stream (setf stream (make-string-output-stream)=
))
+                   (write-string string stream :start start :end end)))
+               (recurse (substrings start end)
+                 (cond
+                   ((>=3D start end))
+                   ((null substrings) (emit start end))
+                   (t (let* ((sub (first substrings))
+                             (found (search sub string :start2 start :end2=
 end))
+                             (more (rest substrings)))
+                        (cond
+                          (found
+                           (recurse more start found)
+                           (recurse substrings (+ found (length sub)) end))
+                          (t
+                           (recurse more start end))))))))
+        (recurse substrings 0 length))
+      (if stream (get-output-stream-string stream) ""))))
+
+(defmacro compatfmt (format)
+  #+(or gcl genera)
+  (remove-substrings `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>"=
 "~:>")) format)
+  #-(or gcl genera) format)
+
+
 ;;;; ---------------------------------------------------------------------=
----
-;;;; General Purpose Utilities
-
-(macrolet
-    ((defdef (def* def)
-       `(defmacro ,def* (name formals &rest rest)
-          `(progn
-             #+(or ecl (and gcl (not gcl-pre2.7))) (fmakunbound ',name)
-             #-gcl ; gcl 2.7.0 notinline functions lose secondary return v=
alues :-(
-             ,(when (and #+ecl (symbolp name)) ; fails for setf functions =
on ecl
-                `(declaim (notinline ,name)))
-             (,',def ,name ,formals , at rest)))))
-  (defdef defgeneric* defgeneric)
-  (defdef defun* defun))
-
+;;;; General Purpose Utilities for ASDF
+
+(asdf/package:define-package :asdf/utility
+  (:recycle :asdf/utility :asdf)
+  (:use :asdf/common-lisp :asdf/package)
+  ;; import and reexport a few things defined in :asdf/common-lisp
+  (:import-from :asdf/common-lisp #:compatfmt #:loop* #:remove-substrings
+   #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
+  (:export #:compatfmt #:loop* #:remove-substrings #:compatfmt
+   #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
+  (:export
+   ;; magic helper to define debugging functions:
+   #:asdf-debug #:load-asdf-debug-utility #:*asdf-debug-utility*
+   #:undefine-function #:undefine-functions #:defun* #:defgeneric* ;; (un)=
defining functions
+   #:if-let ;; basic flow control
+   #:while-collecting #:appendf #:length=3Dn-p #:remove-plist-keys #:remov=
e-plist-key ;; lists and plists
+   #:emptyp ;; sequences
+   #:strcat #:first-char #:last-char #:split-string ;; strings
+   #:string-prefix-p #:string-enclosed-p #:string-suffix-p
+   #:find-class* ;; CLOS
+   #:stamp< #:stamps< #:stamp*< #:stamp<=3D ;; stamps
+   #:earlier-stamp #:stamps-earliest #:earliest-stamp
+   #:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f
+   #:list-to-hash-set ;; hash-table
+   #:ensure-function #:access-at #:access-at-count ;; functions
+   #:call-function #:call-functions #:register-hook-function
+   #:match-condition-p #:match-any-condition-p ;; conditions
+   #:call-with-muffled-conditions #:with-muffled-conditions
+   #:load-string #:load-stream
+   #:lexicographic< #:lexicographic<=3D
+   #:parse-version #:unparse-version #:version< #:version<=3D #:version-co=
mpatible-p)) ;; version
+(in-package :asdf/utility)
+
+;;;; Defining functions in a way compatible with hot-upgrade:
+;; DEFUN* and DEFGENERIC* use FMAKUNBOUND to delete any previous fdefiniti=
on,
+;; thus replacing the function without warning or error
+;; even if the signature and/or generic-ness of the function has changed.
+;; For a generic function, this invalidates any previous DEFMETHOD.
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (defun undefine-function (function-spec)
+    (cond
+      ((symbolp function-spec)
+       #+clisp
+       (let ((f (and (fboundp function-spec) (fdefinition function-spec))))
+         (when (typep f 'clos:standard-generic-function)
+           (loop :for m :in (clos:generic-function-methods f)
+                 :do (remove-method f m))))
+       (fmakunbound function-spec))
+      ((and (consp function-spec) (eq (car function-spec) 'setf)
+            (consp (cdr function-spec)) (null (cddr function-spec)))
+       #-gcl2.6 (fmakunbound function-spec))
+      (t (error "bad function spec ~S" function-spec))))
+  (defun undefine-functions (function-spec-list)
+    (map () 'undefine-function function-spec-list))
+  (macrolet
+      ((defdef (def* def)
+         `(defmacro ,def* (name formals &rest rest)
+            (destructuring-bind (name &key (supersede t))
+                (if (or (atom name) (eq (car name) 'setf))
+                    (list name :supersede nil)
+                    name)
+              (declare (ignorable supersede))
+              `(progn
+                 ;; undefining the previous function is the portable way
+                 ;; of overriding any incompatible previous gf, except on =
CLISP.
+                 ;; We usually try to do it only for the functions that ne=
ed it,
+                 ;; which happens in asdf/upgrade - however, for ECL, we n=
eed this hammer,
+                 ;; (which causes issues in clisp)
+                 ,@(when (or #-clisp supersede #+(or ecl gcl2.7) t) ; XXX
+                     `((undefine-function ',name)))
+                 #-gcl ; gcl 2.7.0 notinline functions lose secondary retu=
rn values :-(
+                 ,@(when (and #+ecl (symbolp name)) ; fails for setf funct=
ions on ecl
+                     `((declaim (notinline ,name))))
+                 (,',def ,name ,formals , at rest))))))
+    (defdef defgeneric* defgeneric)
+    (defdef defun* defun)))
+
+
+;;; Magic debugging help. See contrib/debug.lisp
+(defvar *asdf-debug-utility*
+  '(or (ignore-errors
+        (symbol-call :asdf :system-relative-pathname :asdf-driver "contrib=
/debug.lisp"))
+    (merge-pathnames "cl/asdf/contrib/debug.lisp" (user-homedir-pathname)))
+  "form that evaluates to the pathname to your favorite debugging utilitie=
s")
+
+(defmacro asdf-debug (&rest keys)
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (load-asdf-debug-utility , at keys)))
+
+(defun* load-asdf-debug-utility (&key package utility-file)
+  (let* ((*package* (if package (find-package package) *package*))
+         (keyword (read-from-string
+                   (format nil ":DBG-~:@(~A~)" (package-name *package*)))))
+    (unless (member keyword *features*)
+      (let* ((utility-file (or utility-file *asdf-debug-utility*))
+             (file (ignore-errors (probe-file (eval utility-file)))))
+        (if file (load file)
+            (error "Failed to locate debug utility file: ~S" utility-file)=
)))))
+
+
+;;; Flow control
+(defmacro if-let (bindings &body (then-form &optional else-form)) ;; from =
alexandria
+  ;; bindings can be (var form) or ((var1 form1) ...)
+  (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
+                           (list bindings)
+                           bindings))
+         (variables (mapcar #'car binding-list)))
+    `(let ,binding-list
+       (if (and , at variables)
+           ,then-form
+           ,else-form))))
+
+;;; List manipulation
 (defmacro while-collecting ((&rest collectors) &body body)
   "COLLECTORS should be a list of names for collections.  A collector
 defines a function that, when applied to an argument inside BODY, will
@@ -519,133 +1092,47 @@
          , at body
          (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))
 =

-(defmacro aif (test then &optional else)
-  "Anaphoric version of IF, On Lisp style"
-  `(let ((it ,test)) (if it ,then ,else)))
-
-(defun* pathname-directory-pathname (pathname)
-  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
-and NIL NAME, TYPE and VERSION components"
-  (when pathname
-    (make-pathname :name nil :type nil :version nil :defaults pathname)))
-
-(defun* normalize-pathname-directory-component (directory)
-  "Given a pathname directory component, return an equivalent form that is=
 a list"
-  (cond
-    #-(or cmu sbcl scl) ;; these implementations already normalize directo=
ry components.
-    ((stringp directory) `(:absolute ,directory) directory)
-    #+gcl
-    ((and (consp directory) (stringp (first directory)))
-     `(:absolute , at directory))
-    ((or (null directory)
-         (and (consp directory) (member (first directory) '(:absolute :rel=
ative))))
-     directory)
-    (t
-     (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:=
>") directory))))
-
-(defun* merge-pathname-directory-components (specified defaults)
-  ;; Helper for merge-pathnames* that handles directory components.
-  (let ((directory (normalize-pathname-directory-component specified)))
-    (ecase (first directory)
-      ((nil) defaults)
-      (:absolute specified)
-      (:relative
-       (let ((defdir (normalize-pathname-directory-component defaults))
-             (reldir (cdr directory)))
-         (cond
-           ((null defdir)
-            directory)
-           ((not (eq :back (first reldir)))
-            (append defdir reldir))
-           (t
-            (loop :with defabs =3D (first defdir)
-              :with defrev =3D (reverse (rest defdir))
-              :while (and (eq :back (car reldir))
-                          (or (and (eq :absolute defabs) (null defrev))
-                              (stringp (car defrev))))
-              :do (pop reldir) (pop defrev)
-              :finally (return (cons defabs (append (reverse defrev) reldi=
r)))))))))))
-
-(defun* make-pathname-component-logical (x)
-  "Make a pathname component suitable for use in a logical-pathname"
-  (typecase x
-    ((eql :unspecific) nil)
-    #+clisp (string (string-upcase x))
-    #+clisp (cons (mapcar 'make-pathname-component-logical x))
-    (t x)))
-
-(defun* make-pathname-logical (pathname host)
-  "Take a PATHNAME's directory, name, type and version components,
-and make a new pathname with corresponding components and specified logica=
l HOST"
-  (make-pathname
-   :host host
-   :directory (make-pathname-component-logical (pathname-directory pathnam=
e))
-   :name (make-pathname-component-logical (pathname-name pathname))
-   :type (make-pathname-component-logical (pathname-type pathname))
-   :version (make-pathname-component-logical (pathname-version pathname))))
-
-(defun* merge-pathnames* (specified &optional (defaults *default-pathname-=
defaults*))
-  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
-if the SPECIFIED pathname does not have an absolute directory,
-then the HOST and DEVICE both come from the DEFAULTS, whereas
-if the SPECIFIED pathname does have an absolute directory,
-then the HOST and DEVICE both come from the SPECIFIED.
-Also, if either argument is NIL, then the other argument is returned unmod=
ified."
-  (when (null specified) (return-from merge-pathnames* defaults))
-  (when (null defaults) (return-from merge-pathnames* specified))
-  #+scl
-  (ext:resolve-pathname specified defaults)
-  #-scl
-  (let* ((specified (pathname specified))
-         (defaults (pathname defaults))
-         (directory (normalize-pathname-directory-component (pathname-dire=
ctory specified)))
-         (name (or (pathname-name specified) (pathname-name defaults)))
-         (type (or (pathname-type specified) (pathname-type defaults)))
-         (version (or (pathname-version specified) (pathname-version defau=
lts))))
-    (labels ((unspecific-handler (p)
-               (if (typep p 'logical-pathname) #'make-pathname-component-l=
ogical #'identity)))
-      (multiple-value-bind (host device directory unspecific-handler)
-          (ecase (first directory)
-            ((:absolute)
-             (values (pathname-host specified)
-                     (pathname-device specified)
-                     directory
-                     (unspecific-handler specified)))
-            ((nil :relative)
-             (values (pathname-host defaults)
-                     (pathname-device defaults)
-                     (merge-pathname-directory-components directory (pathn=
ame-directory defaults))
-                     (unspecific-handler defaults))))
-        (make-pathname :host host :device device :directory directory
-                       :name (funcall unspecific-handler name)
-                       :type (funcall unspecific-handler type)
-                       :version (funcall unspecific-handler version))))))
-
-(defun* pathname-parent-directory-pathname (pathname)
-  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
-and NIL NAME, TYPE and VERSION components"
-  (when pathname
-    (make-pathname :name nil :type nil :version nil
-                   :directory (merge-pathname-directory-components
-                               '(:relative :back) (pathname-directory path=
name))
-                   :defaults pathname)))
-
 (define-modify-macro appendf (&rest args)
   append "Append onto list") ;; only to be used on short lists.
 =

-(define-modify-macro orf (&rest args)
-  or "or a flag")
+(defun* length=3Dn-p (x n) ;is it that (=3D (length x) n) ?
+  (check-type n (integer 0 *))
+  (loop
+    :for l =3D x :then (cdr l)
+    :for i :downfrom n :do
+    (cond
+      ((zerop i) (return (null l)))
+      ((not (consp l)) (return nil)))))
+
+;;; remove a key from a plist, i.e. for keyword argument cleanup
+(defun* remove-plist-key (key plist)
+  "Remove a single key from a plist"
+  (loop* :for (k v) :on plist :by #'cddr
+    :unless (eq k key)
+    :append (list k v)))
+
+(defun* remove-plist-keys (keys plist)
+  "Remove a list of keys from a plist"
+  (loop* :for (k v) :on plist :by #'cddr
+    :unless (member k keys)
+    :append (list k v)))
+
+
+;;; Sequences
+(defun* emptyp (x)
+  "Predicate that is true for an empty sequence"
+  (or (null x) (and (vectorp x) (zerop (length x)))))
+
+
+;;; Strings
+(defun* strcat (&rest strings)
+  (apply 'concatenate 'string strings))
 =

 (defun* first-char (s)
   (and (stringp s) (plusp (length s)) (char s 0)))
 =

 (defun* last-char (s)
   (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
-
-
-(defun* asdf-message (format-string &rest format-args)
-  (declare (dynamic-extent format-args))
-  (apply 'format *verbose-out* format-string format-args))
 =

 (defun* split-string (string &key max (separator '(#\Space #\Tab)))
   "Split STRING into a list of components separated by
@@ -653,10 +1140,10 @@
 If MAX is specified, then no more than max(1,MAX) components will be retur=
ned,
 starting the separation from the end, e.g. when called with arguments
  \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e=
\")."
-  (catch nil
+  (block ()
     (let ((list nil) (words 0) (end (length string)))
       (flet ((separatorp (char) (find char separator))
-             (done () (throw nil (cons (subseq string 0 end) list))))
+             (done () (return (cons (subseq string 0 end) list))))
         (loop
           :for start =3D (if (and max (>=3D words (1- max)))
                            (done)
@@ -667,69 +1154,285 @@
           (incf words)
           (setf end start))))))
 =

-(defun* split-name-type (filename)
-  (let ((unspecific
-         ;; Giving :unspecific as argument to make-pathname is not portabl=
e.
-         ;; See CLHS make-pathname and 19.2.2.2.3.
-         ;; We only use it on implementations that support it,
-         #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl=
 xcl) :unspecific
-         #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) ni=
l))
-    (destructuring-bind (name &optional (type unspecific))
-        (split-string filename :max 2 :separator ".")
-      (if (equal name "")
-          (values filename unspecific)
-          (values name type)))))
-
-(defun* component-name-to-pathname-components (s &key force-directory forc=
e-relative)
-  "Splits the path string S, returning three values:
-A flag that is either :absolute or :relative, indicating
-   how the rest of the values are to be interpreted.
-A directory path --- a list of strings, suitable for
-   use with MAKE-PATHNAME when prepended with the flag
-   value.
-A filename with type extension, possibly NIL in the
-   case of a directory pathname.
-FORCE-DIRECTORY forces S to be interpreted as a directory
-pathname \(third return value will be NIL, final component
-of S will be treated as part of the directory path.
-
-The intention of this function is to support structured component names,
-e.g., \(:file \"foo/bar\"\), which will be unpacked to relative
-pathnames."
-  (check-type s string)
-  (when (find #\: s)
-    (error (compatfmt "~@<A portable ASDF pathname designator cannot inclu=
de a #\: character: ~3i~_~S~@:>") s))
-  (let* ((components (split-string s :separator "/"))
-         (last-comp (car (last components))))
-    (multiple-value-bind (relative components)
-        (if (equal (first components) "")
-            (if (equal (first-char s) #\/)
-                (progn
-                  (when force-relative
-                    (error (compatfmt "~@<Absolute pathname designator not=
 allowed: ~3i~_~S~@:>") s))
-                  (values :absolute (cdr components)))
-                (values :relative nil))
-          (values :relative components))
-      (setf components (remove-if #'(lambda (x) (member x '("" ".") :test =
#'equal)) components))
-      (setf components (substitute :back ".." components :test #'equal))
+(defun* string-prefix-p (prefix string)
+  "Does STRING begin with PREFIX?"
+  (let* ((x (string prefix))
+         (y (string string))
+         (lx (length x))
+         (ly (length y)))
+    (and (<=3D lx ly) (string=3D x y :end2 lx))))
+
+(defun* string-suffix-p (string suffix)
+  "Does STRING end with SUFFIX?"
+  (let* ((x (string string))
+         (y (string suffix))
+         (lx (length x))
+         (ly (length y)))
+    (and (<=3D ly lx) (string=3D x y :start1 (- lx ly)))))
+
+(defun* string-enclosed-p (prefix string suffix)
+  "Does STRING begin with PREFIX and end with SUFFIX?"
+  (and (string-prefix-p prefix string)
+       (string-suffix-p string suffix)))
+
+
+;;; CLOS
+(defun* find-class* (x &optional (errorp t) environment)
+  (etypecase x
+    ((or standard-class built-in-class) x)
+    #+gcl2.6 (keyword nil)
+    (symbol (find-class x errorp environment))))
+
+
+;;; stamps: a REAL or boolean where NIL=3D-infinity, T=3D+infinity
+(deftype stamp () '(or real boolean))
+(defun* stamp< (x y)
+  (etypecase x
+    (null (and y t))
+    ((eql t) nil)
+    (real (etypecase y
+            (null nil)
+            ((eql t) t)
+            (real (< x y))))))
+(defun* stamps< (list) (loop :for y :in list :for x =3D nil :then y :alway=
s (stamp< x y)))
+(defun* stamp*< (&rest list) (stamps< list))
+(defun* stamp<=3D (x y) (not (stamp< y x)))
+(defun* earlier-stamp (x y) (if (stamp< x y) x y))
+(defun* stamps-earliest (list) (reduce 'earlier-stamp list :initial-value =
t))
+(defun* earliest-stamp (&rest list) (stamps-earliest list))
+(defun* later-stamp (x y) (if (stamp< x y) y x))
+(defun* stamps-latest (list) (reduce 'later-stamp list :initial-value nil))
+(defun* latest-stamp (&rest list) (stamps-latest list))
+(define-modify-macro latest-stamp-f (&rest stamps) latest-stamp)
+
+
+;;; Hash-tables
+(defun* list-to-hash-set (list &aux (h (make-hash-table :test 'equal)))
+  (dolist (x list h) (setf (gethash x h) t)))
+
+
+;;; Function designators
+(defun* ensure-function (fun &key (package :cl))
+  "Coerce the object FUN into a function.
+
+If FUN is a FUNCTION, return it.
+If the FUN is a non-sequence literal constant, return constantly that,
+i.e. for a boolean keyword character number or pathname.
+Otherwise if FUN is a non-literally constant symbol, return its FDEFINITIO=
N.
+If FUN is a CONS, return the function that applies its CAR
+to the appended list of the rest of its CDR and the arguments.
+If FUN is a string, READ a form from it in the specified PACKAGE (default:=
 CL)
+and EVAL that in a (FUNCTION ...) context."
+  (etypecase fun
+    (function fun)
+    ((or boolean keyword character number pathname) (constantly fun))
+    ((or function symbol) fun)
+    (cons #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args))=
))
+    (string (eval `(function ,(with-standard-io-syntax
+                                (let ((*package* (find-package package)))
+                                  (read-from-string fun))))))))
+
+(defun* access-at (object at)
+  "Given an OBJECT and an AT specifier, list of successive accessors,
+call each accessor on the result of the previous calls.
+An accessor may be an integer, meaning a call to ELT,
+a keyword, meaning a call to GETF,
+NIL, meaning identity,
+a function or other symbol, meaning itself,
+or a list of a function designator and arguments, interpreted as per ENSUR=
E-FUNCTION.
+As a degenerate case, the AT specifier may be an atom of a single such acc=
essor
+instead of a list."
+  (flet ((access (object accessor)
+           (etypecase accessor
+             (function (funcall accessor object))
+             (integer (elt object accessor))
+             (keyword (getf object accessor))
+             (null object)
+             (symbol (funcall accessor object))
+             (cons (funcall (ensure-function accessor) object)))))
+    (if (listp at)
+        (dolist (accessor at object)
+          (setf object (access object accessor)))
+        (access object at))))
+
+(defun* access-at-count (at)
+  "From an AT specification, extract a COUNT of maximum number
+   of sub-objects to read as per ACCESS-AT"
+  (cond
+    ((integerp at)
+     (1+ at))
+    ((and (consp at) (integerp (first at)))
+     (1+ (first at)))))
+
+(defun* call-function (function-spec &rest arguments)
+  (apply (ensure-function function-spec) arguments))
+
+(defun* call-functions (function-specs)
+  (map () 'call-function function-specs))
+
+(defun* register-hook-function (variable hook &optional call-now-p)
+  (pushnew hook (symbol-value variable))
+  (when call-now-p (call-function hook)))
+
+
+;;; Version handling
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defun* unparse-version (version-list)
+  (format nil "~{~D~^.~}" version-list))
+
+(defun* parse-version (version-string &optional on-error)
+  "Parse a VERSION-STRING as a series of natural integers separated by dot=
s.
+Return a (non-null) list of integers if the string is valid;
+otherwise return NIL.
+
+When invalid, ON-ERROR is called as per CALL-FUNCTION before to return NIL,
+with format arguments explaining why the version is invalid.
+ON-ERROR is also called if the version is not canonical
+in that it doesn't print back to itself, but the list is returned anyway."
+  (block nil
+   (unless (stringp version-string)
+     (call-function on-error "~S: ~S is not a string" 'parse-version versi=
on-string)
+     (return))
+   (unless (loop :for prev =3D nil :then c :for c :across version-string
+                 :always (or (digit-char-p c)
+                             (and (eql c #\.) prev (not (eql prev #\.))))
+                 :finally (return (and c (digit-char-p c))))
+     (call-function on-error "~S: ~S doesn't follow asdf version numbering=
 convention"
+                    'parse-version version-string)
+     (return))
+   (let* ((version-list
+            (mapcar #'parse-integer (split-string version-string :separato=
r ".")))
+          (normalized-version (unparse-version version-list)))
+     (unless (equal version-string normalized-version)
+       (call-function on-error "~S: ~S contains leading zeros" 'parse-vers=
ion version-string))
+     version-list)))
+
+(defun* lexicographic< (< x y)
+  (cond ((null y) nil)
+        ((null x) t)
+        ((funcall < (car x) (car y)) t)
+        ((funcall < (car y) (car x)) nil)
+        (t (lexicographic< < (cdr x) (cdr y)))))
+
+(defun* lexicographic<=3D (< x y)
+  (not (lexicographic< < y x)))
+
+(defun* version< (version1 version2)
+  (let ((v1 (parse-version version1 nil))
+        (v2 (parse-version version2 nil)))
+    (lexicographic< '< v1 v2)))
+
+(defun* version<=3D (version1 version2)
+  (not (version< version2 version1)))
+
+(defun* version-compatible-p (provided-version required-version)
+  "Is the provided version a compatible substitution for the required-vers=
ion?
+If major versions differ, it's not compatible.
+If they are equal, then any later version is compatible,
+with later being determined by a lexicographical comparison of minor numbe=
rs."
+  (let ((x (parse-version provided-version nil))
+        (y (parse-version required-version nil)))
+    (and x y (=3D (car x) (car y)) (lexicographic<=3D '< (cdr y) (cdr x)))=
))
+); eval-when for version support
+
+
+;;; Condition control
+
+(defvar *uninteresting-conditions* nil
+  "Uninteresting conditions, as per MATCH-CONDITION-P")
+
+(defparameter +simple-condition-format-control-slot+
+  #+abcl 'system::format-control
+  #+allegro 'excl::format-control
+  #+clisp 'system::$format-control
+  #+clozure 'ccl::format-control
+  #+(or cmu scl) 'conditions::format-control
+  #+ecl 'si::format-control
+  #+(or gcl lispworks) 'conditions::format-string
+  #+sbcl 'sb-kernel:format-control
+  #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl) nil
+  "Name of the slot for FORMAT-CONTROL in simple-condition")
+
+(defun* match-condition-p (x condition)
+  "Compare received CONDITION to some pattern X:
+a symbol naming a condition class,
+a simple vector of length 2, arguments to find-symbol* with result as abov=
e,
+or a string describing the format-control of a simple-condition."
+  (etypecase x
+    (symbol (typep condition x))
+    ((simple-vector 2) (typep condition (find-symbol* (svref x 0) (svref x=
 1) nil)))
+    (function (funcall x condition))
+    (string (and (typep condition 'simple-condition)
+                 ;; On SBCL, it's always set and the check triggers a warn=
ing
+                 #+(or allegro clozure cmu lispworks scl)
+		 (slot-boundp condition +simple-condition-format-control-slot+)
+                 (ignore-errors (equal (simple-condition-format-control co=
ndition) x))))))
+
+(defun* match-any-condition-p (condition conditions)
+  "match CONDITION against any of the patterns of CONDITIONS supplied"
+  (loop :for x :in conditions :thereis (match-condition-p x condition)))
+
+(defun* call-with-muffled-conditions (thunk conditions)
+  (handler-bind ((t #'(lambda (c) (when (match-any-condition-p c condition=
s)
+                                    (muffle-warning c)))))
+    (funcall thunk)))
+
+(defmacro with-muffled-uninteresting-conditions ((conditions) &body body)
+  `(call-with-muffled-uninteresting-conditions #'(lambda () , at body) ,condi=
tions))
+
+
+;;;; ---------------------------------------------------------------------=
------
+;;;; Access to the Operating System
+
+(asdf/package:define-package :asdf/os
+  (:recycle :asdf/os :asdf)
+  (:use :asdf/common-lisp :asdf/package :asdf/utility)
+  (:export
+   #:featurep #:os-unix-p #:os-windows-p #:os-genera-p #:detect-os ;; feat=
ures
+   #:getenv #:getenvp ;; environment variables
+   #:implementation-identifier ;; implementation identifier
+   #:implementation-type #:*implementation-type*
+   #:operating-system #:architecture #:lisp-version-string
+   #:hostname #:getcwd #:chdir
+   ;; Windows shortcut support
+   #:read-null-terminated-string #:read-little-endian
+   #:parse-file-location-info #:parse-windows-shortcut))
+(in-package :asdf/os)
+
+;;; Features
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (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))=
))
+      ((eq :or (car x)) (some #'featurep (cdr x)))
+      ((eq :and (car x)) (every #'featurep (cdr x)))
+      (t (error "Malformed feature specification ~S" x))))
+
+  (defun* os-unix-p ()
+    (or #+abcl (featurep :unix)
+        #+(and (not abcl) (or unix cygwin darwin)) t))
+
+  (defun* os-windows-p ()
+    (or #+abcl (featurep :windows)
+        #+(and (not (or unix cygwin darwin)) (or win32 windows mswindows m=
ingw32)) t))
+
+  (defun* os-genera-p ()
+    (or #+genera t))
+
+  (defun* detect-os ()
+    (flet ((yes (yes) (pushnew yes *features*))
+           (no (no) (setf *features* (remove no *features*))))
       (cond
-        ((equal last-comp "")
-         (values relative components nil)) ; "" already removed
-        (force-directory
-         (values relative components nil))
-        (t
-         (values relative (butlast components) last-comp))))))
-
-(defun* remove-keys (key-names args)
-  (loop :for (name val) :on args :by #'cddr
-    :unless (member (symbol-name name) key-names
-                    :key #'symbol-name :test 'equal)
-    :append (list name val)))
-
-(defun* remove-keyword (key args)
-  (loop :for (k v) :on args :by #'cddr
-    :unless (eq k key)
-    :append (list k v)))
+        ((os-unix-p) (yes :os-unix) (no :os-windows) (no :genera))
+        ((os-windows-p) (yes :os-windows) (no :os-unix) (no :genera))
+        ((os-genera-p) (no :os-unix) (no :os-windows) (yes :genera))
+        (t (error "Congratulations for trying XCVB on an operating system~=
%~
+that is neither Unix, nor Windows, nor even Genera.~%Now you port it.")))))
+
+  (detect-os))
+
+;;;; Environment variables: getting them, and parsing them.
 =

 (defun* getenv (x)
   (declare (ignorable x))
@@ -754,764 +1457,170 @@
           (let ((value (_getenv name)))
             (unless (ccl:%null-ptr-p value)
               (ccl:%get-cstring value))))
-  #+mkcl (#.(or (find-symbol* 'getenv :si) (find-symbol* 'getenv :mk-ext))=
 x)
+  #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-e=
xt nil)) x)
   #+sbcl (sb-ext:posix-getenv x)
   #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks=
 mcl mkcl sbcl scl xcl)
   (error "~S is not supported on your implementation" 'getenv))
 =

-(defun* directory-pathname-p (pathname)
-  "Does PATHNAME represent a directory?
-
-A directory-pathname is a pathname _without_ a filename. The three
-ways that the filename components can be missing are for it to be NIL,
-:UNSPECIFIC or the empty string.
-
-Note that this does _not_ check to see that PATHNAME points to an
-actually-existing directory."
-  (when pathname
-    (let ((pathname (pathname pathname)))
-      (flet ((check-one (x)
-               (member x '(nil :unspecific "") :test 'equal)))
-        (and (not (wild-pathname-p pathname))
-             (check-one (pathname-name pathname))
-             (check-one (pathname-type pathname))
-             t)))))
-
-(defun* ensure-directory-pathname (pathspec)
-  "Converts the non-wild pathname designator PATHSPEC to directory form."
-  (cond
-   ((stringp pathspec)
-    (ensure-directory-pathname (pathname pathspec)))
-   ((not (pathnamep pathspec))
-    (error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec))
-   ((wild-pathname-p pathspec)
-    (error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>=
") pathspec))
-   ((directory-pathname-p pathspec)
-    pathspec)
-   (t
-    (make-pathname :directory (append (or (pathname-directory pathspec)
-                                          (list :relative))
-                                      (list (file-namestring pathspec)))
-                   :name nil :type nil :version nil
-                   :defaults pathspec))))
-
-#+genera
-(unless (fboundp 'ensure-directories-exist)
-  (defun* ensure-directories-exist (path)
-    (fs:create-directories-recursively (pathname path))))
-
-(defun* absolute-pathname-p (pathspec)
-  (and (typep pathspec '(or pathname string))
-       (eq :absolute (car (pathname-directory (pathname pathspec))))))
-
-(defun* coerce-pathname (name &key type defaults)
-  "coerce NAME into a PATHNAME.
-When given a string, portably decompose it into a relative pathname:
-#\\/ separates subdirectories. The last #\\/-separated string is as follow=
s:
-if TYPE is NIL, its last #\\. if any separates name and type from from typ=
e;
-if TYPE is a string, it is the type, and the whole string is the name;
-if TYPE is :DIRECTORY, the string is a directory component;
-if the string is empty, it's a directory.
-Any directory named .. is read as :BACK.
-Host, device and version components are taken from DEFAULTS."
-  ;; The defaults are required notably because they provide the default ho=
st
-  ;; to the below make-pathname, which may crucially matter to people using
-  ;; merge-pathnames with non-default hosts,  e.g. for logical-pathnames.
-  ;; NOTE that the host and device slots will be taken from the defaults,
-  ;; but that should only matter if you later merge relative pathnames with
-  ;; CL:MERGE-PATHNAMES instead of ASDF:MERGE-PATHNAMES*
-  (etypecase name
-    ((or null pathname)
-     name)
-    (symbol
-     (coerce-pathname (string-downcase name) :type type :defaults defaults=
))
-    (string
-     (multiple-value-bind (relative path filename)
-         (component-name-to-pathname-components name :force-directory (eq =
type :directory)
-                                                :force-relative t)
-       (multiple-value-bind (name type)
-           (cond
-             ((or (eq type :directory) (null filename))
-              (values nil nil))
-             (type
-              (values filename type))
-             (t
-              (split-name-type filename)))
-         (apply 'make-pathname :directory (cons relative path) :name name =
:type type
-                (when defaults `(:defaults ,defaults))))))))
-
-(defun* merge-component-name-type (name &key type defaults)
-  ;; For backwards compatibility only, for people using internals.
-  ;; Will be removed in a future release, e.g. 2.016.
-  (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE=
-PATHNAME.")
-  (coerce-pathname name :type type :defaults defaults))
-
-(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 typ=
e)))
-
-(defun* length=3Dn-p (x n) ;is it that (=3D (length x) n) ?
-  (check-type n (integer 0 *))
-  (loop
-    :for l =3D x :then (cdr l)
-    :for i :downfrom n :do
-    (cond
-      ((zerop i) (return (null l)))
-      ((not (consp l)) (return nil)))))
-
-(defun* string-suffix-p (s suffix)
-  (check-type s string)
-  (check-type suffix string)
-  (let ((start (- (length s) (length suffix))))
-    (and (<=3D 0 start)
-         (string-equal s suffix :start1 start))))
-
-(defun* read-file-forms (file)
-  (with-open-file (in file)
-    (loop :with eof =3D (list nil)
-     :for form =3D (read in nil eof)
-     :until (eq form eof)
-     :collect form)))
-
-(defun* pathname-root (pathname)
-  (make-pathname :directory '(:absolute)
-                 :name nil :type nil :version nil
-                 :defaults pathname ;; host device, and on scl, *some*
-                 ;; scheme-specific parts: port username password, not oth=
ers:
-                 . #.(or #+scl '(:parameters nil :query nil :fragment nil)=
)))
-
-(defun* probe-file* (p)
-  "when given a pathname P, probes the filesystem for a file or directory
-with given pathname and if it exists return its truename."
-  (etypecase p
-    (null nil)
-    (string (probe-file* (parse-namestring p)))
-    (pathname (unless (wild-pathname-p p)
-                #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks m=
kcl sbcl scl)
-                      '(probe-file p)
-                      #+clisp (aif (find-symbol* '#:probe-pathname :ext)
-                                   `(ignore-errors (,it p)))
-                      '(ignore-errors (truename p)))))))
-
-(defun* truenamize (pathname &optional (defaults *default-pathname-default=
s*))
-  "Resolve as much of a pathname as possible"
-  (block nil
-    (when (typep pathname '(or null logical-pathname)) (return pathname))
-    (let ((p (merge-pathnames* pathname defaults)))
-      (when (typep p 'logical-pathname) (return p))
-      (let ((found (probe-file* p)))
-        (when found (return found)))
-      (unless (absolute-pathname-p p)
-        (let ((true-defaults (ignore-errors (truename defaults))))
-          (when true-defaults
-            (setf p (merge-pathnames pathname true-defaults)))))
-      (unless (absolute-pathname-p p) (return p))
-      (let ((sofar (probe-file* (pathname-root p))))
-        (unless sofar (return p))
-        (flet ((solution (directories)
-                 (merge-pathnames*
-                  (make-pathname :host nil :device nil
-                                 :directory `(:relative , at directories)
-                                 :name (pathname-name p)
-                                 :type (pathname-type p)
-                                 :version (pathname-version p))
-                  sofar)))
-          (loop :with directory =3D (normalize-pathname-directory-component
-                                   (pathname-directory p))
-            :for component :in (cdr directory)
-            :for rest :on (cdr directory)
-            :for more =3D (probe-file*
-                         (merge-pathnames*
-                          (make-pathname :directory `(:relative ,component=
))
-                          sofar)) :do
-            (if more
-                (setf sofar more)
-                (return (solution rest)))
-            :finally
-            (return (solution nil))))))))
-
-(defun* resolve-symlinks (path)
-  #-allegro (truenamize path)
-  #+allegro (if (typep path 'logical-pathname)
-                path
-                (excl:pathname-resolve-symbolic-links path)))
-
-(defun* resolve-symlinks* (path)
-  (if *resolve-symlinks*
-      (and path (resolve-symlinks path))
-      path))
-
-(defun* ensure-pathname-absolute (path)
-  (cond
-    ((absolute-pathname-p path) path)
-    ((stringp path) (ensure-pathname-absolute (pathname path)))
-    ((not (pathnamep path)) (error "not a valid pathname designator ~S" pa=
th))
-    (t (let ((resolved (resolve-symlinks path)))
-         (assert (absolute-pathname-p resolved))
-         resolved))))
-
-(defun* default-directory ()
-  (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
-
-(defun* lispize-pathname (input-file)
-  (make-pathname :type "lisp" :defaults input-file))
-
-(defparameter *wild* #-cormanlisp :wild #+cormanlisp "*")
-(defparameter *wild-file*
-  (make-pathname :name *wild* :type *wild*
-                 :version (or #-(or abcl xcl) *wild*) :directory nil))
-(defparameter *wild-directory*
-  (make-pathname :directory `(:relative ,*wild*) :name nil :type nil :vers=
ion nil))
-(defparameter *wild-inferiors*
-  (make-pathname :directory '(:relative :wild-inferiors) :name nil :type n=
il :version nil))
-(defparameter *wild-path*
-  (merge-pathnames *wild-file* *wild-inferiors*))
-
-(defun* wilden (path)
-  (merge-pathnames* *wild-path* path))
-
-#-scl
-(defun* directory-separator-for-host (&optional (pathname *default-pathnam=
e-defaults*))
-  (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathna=
me)))
-    (last-char (namestring foo))))
-
-#-scl
-(defun* directorize-pathname-host-device (pathname)
-  (let* ((root (pathname-root pathname))
-         (wild-root (wilden root))
-         (absolute-pathname (merge-pathnames* pathname root))
-         (separator (directory-separator-for-host root))
-         (root-namestring (namestring root))
-         (root-string
-          (substitute-if #\/
-                         #'(lambda (x) (or (eql x #\:)
-                                           (eql x separator)))
-                         root-namestring)))
-    (multiple-value-bind (relative path filename)
-        (component-name-to-pathname-components root-string :force-director=
y t)
-      (declare (ignore relative filename))
-      (let ((new-base
-             (make-pathname :defaults root
-                            :directory `(:absolute , at path))))
-        (translate-pathname absolute-pathname wild-root (wilden new-base))=
))))
-
-#+scl
-(defun* directorize-pathname-host-device (pathname)
-  (let ((scheme (ext:pathname-scheme pathname))
-        (host (pathname-host pathname))
-        (port (ext:pathname-port pathname))
-        (directory (pathname-directory pathname)))
-    (flet ((specificp (x) (and x (not (eq x :unspecific)))))
-      (if (or (specificp port)
-              (and (specificp host) (plusp (length host)))
-              (specificp scheme))
-        (let ((prefix ""))
-          (when (specificp port)
-            (setf prefix (format nil ":~D" port)))
-          (when (and (specificp host) (plusp (length host)))
-            (setf prefix (strcat host prefix)))
-          (setf prefix (strcat ":" prefix))
-          (when (specificp scheme)
-            (setf prefix (strcat scheme prefix)))
-          (assert (and directory (eq (first directory) :absolute)))
-          (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
-                         :defaults pathname)))
-    pathname)))
-
-;;;; ---------------------------------------------------------------------=
----
-;;;; ASDF Interface, in terms of generic functions.
-(defgeneric* find-system (system &optional error-p))
-(defgeneric* perform-with-restarts (operation component))
-(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))
-(defgeneric* input-files (operation component))
-(defgeneric* component-operation-time (operation component))
-(defgeneric* operation-description (operation component)
-  (:documentation "returns a phrase that describes performing this operati=
on
-on this component, e.g. \"loading /a/b/c\".
-You can put together sentences using this phrase."))
-
-(defgeneric* system-source-file (system)
-  (:documentation "Return the source file in which system is defined."))
-
-(defgeneric* component-system (component)
-  (:documentation "Find the top-level system containing COMPONENT"))
-
-(defgeneric* component-pathname (component)
-  (:documentation "Extracts the pathname applicable for a particular compo=
nent."))
-
-(defgeneric* component-relative-pathname (component)
-  (:documentation "Returns a pathname for the component argument intended =
to be
-interpreted relative to the pathname of that component's parent.
-Despite the function's name, the return value may be an absolute
-pathname, because an absolute pathname may be interpreted relative to
-another pathname in a degenerate way."))
-
-(defgeneric* component-property (component property))
-
-(defgeneric* (setf component-property) (new-value component property))
-
-(defgeneric* component-external-format (component))
-
-(defgeneric* component-encoding (component))
-
-(eval-when (#-gcl :compile-toplevel :load-toplevel :execute)
-  (defgeneric* (setf module-components-by-name) (new-value module)))
-
-(defgeneric* version-satisfies (component version))
-
-(defgeneric* find-component (base path)
-  (:documentation "Finds the component with PATH starting from BASE module;
-if BASE is nil, then the component is assumed to be a system."))
-
-(defgeneric* source-file-type (component system))
-
-(defgeneric* operation-ancestor (operation)
-  (:documentation
-   "Recursively chase the operation's parent pointer until we get to
-the head of the tree"))
-
-(defgeneric* component-visited-p (operation component)
-  (:documentation "Returns the value stored by a call to
-VISIT-COMPONENT, if that has been called, otherwise NIL.
-This value stored will be a cons cell, the first element
-of which is a computed key, so not interesting.  The
-CDR wil be the DATA value stored by VISIT-COMPONENT; recover
-it as (cdr (component-visited-p op c)).
-  In the current form of ASDF, the DATA value retrieved is
-effectively a boolean, indicating whether some operations are
-to be performed in order to do OPERATION X COMPONENT.  If the
-data value is NIL, the combination had been explored, but no
-operations needed to be performed."))
-
-(defgeneric* visit-component (operation component data)
-  (:documentation "Record DATA as being associated with OPERATION
-and COMPONENT.  This is a side-effecting function:  the association
-will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the
-OPERATION\).
-  No evidence that DATA is ever interesting, beyond just being
-non-NIL.  Using the data field is probably very risky; if there is
-already a record for OPERATION X COMPONENT, DATA will be quietly
-discarded instead of recorded.
-  Starting with 2.006, TRAVERSE will store an integer in data,
-so that nodes can be sorted in decreasing order of traversal."))
-
-
-(defgeneric* (setf visiting-component) (new-value operation component))
-
-(defgeneric* component-visiting-p (operation component))
-
-(defgeneric* component-depends-on (operation component)
-  (:documentation
-   "Returns a list of dependencies needed by the component to perform
-    the operation.  A dependency has one of the following forms:
-
-      (<operation> <component>*), where <operation> is a class
-        designator and each <component> is a component
-        designator, which means that the component depends on
-        <operation> having been performed on each <component>; or
-
-      (FEATURE <feature>), which means that the component depends
-        on <feature>'s presence in *FEATURES*.
-
-    Methods specialized on subclasses of existing component types
-    should usually append the results of CALL-NEXT-METHOD to the
-    list."))
-
-(defgeneric* component-self-dependencies (operation component))
-
-(defgeneric* traverse (operation component)
-  (:documentation
-"Generate and return a plan for performing OPERATION on COMPONENT.
-
-The plan returned is a list of dotted-pairs. Each pair is the CONS
-of ASDF operation object and a COMPONENT object. The pairs will be
-processed in order by OPERATE."))
-
-
-;;;; ---------------------------------------------------------------------=
----
-;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+b=
ug/485687
-(when *upgraded-p*
-  (when (find-class 'module nil)
-    (eval
-     '(defmethod update-instance-for-redefined-class :after
-          ((m module) added deleted plist &key)
-        (declare (ignorable deleted plist))
-        (when *asdf-verbose*
-          (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~=
%")
-                        m (asdf-version)))
-        (when (member 'components-by-name added)
-          (compute-module-components-by-name m))
-        (when (typep m 'system)
-          (when (member 'source-file added)
-            (%set-system-source-file
-             (probe-asd (component-name m) (component-pathname m)) m)
-           (when (equal (component-name m) "asdf")
-             (setf (component-version m) *asdf-version*))))))))
-
-;;;; ---------------------------------------------------------------------=
----
-;;;; Classes, Conditions
-
-(define-condition system-definition-error (error) ()
-  ;; [this use of :report should be redundant, but unfortunately it's not.
-  ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-fun=
ction
-  ;; over print-object; this is always conditions::%print-condition for
-  ;; condition objects, which in turn does inheritance of :report options =
at
-  ;; run-time.  fortunately, inheritance means we only need this kludge he=
re in
-  ;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]
-  #+cmu (:report print-object))
-
-(define-condition formatted-system-definition-error (system-definition-err=
or)
-  ((format-control :initarg :format-control :reader format-control)
-   (format-arguments :initarg :format-arguments :reader format-arguments))
-  (:report (lambda (c s)
-               (apply 'format s (format-control c) (format-arguments c)))))
-
-(define-condition load-system-definition-error (system-definition-error)
-  ((name :initarg :name :reader error-name)
-   (pathname :initarg :pathname :reader error-pathname)
-   (condition :initarg :condition :reader error-condition))
-  (:report (lambda (c s)
-             (format s (compatfmt "~@<Error while trying to load definitio=
n for system ~A from pathname ~A: ~3i~_~A~@:>")
-                     (error-name c) (error-pathname c) (error-condition c)=
))))
-
-(define-condition circular-dependency (system-definition-error)
-  ((components :initarg :components :reader circular-dependency-components=
))
-  (:report (lambda (c s)
-             (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
-                     (circular-dependency-components c)))))
-
-(define-condition duplicate-names (system-definition-error)
-  ((name :initarg :name :reader duplicate-names-name))
-  (:report (lambda (c s)
-             (format s (compatfmt "~@<Error while defining system: multipl=
e components are given same name ~A~@:>")
-                     (duplicate-names-name c)))))
-
-(define-condition missing-component (system-definition-error)
-  ((requires :initform "(unnamed)" :reader missing-requires :initarg :requ=
ires)
-   (parent :initform nil :reader missing-parent :initarg :parent)))
-
-(define-condition missing-component-of-version (missing-component)
-  ((version :initform nil :reader missing-version :initarg :version)))
-
-(define-condition missing-dependency (missing-component)
-  ((required-by :initarg :required-by :reader missing-required-by)))
-
-(define-condition missing-dependency-of-version (missing-dependency
-                                                 missing-component-of-vers=
ion)
-  ())
-
-(define-condition operation-error (error)
-  ((component :reader error-component :initarg :component)
-   (operation :reader error-operation :initarg :operation))
-  (:report (lambda (c s)
-               (format s (compatfmt "~@<Error while invoking ~A on ~A~@:>")
-                       (error-operation c) (error-component c)))))
-(define-condition compile-error (operation-error) ())
-(define-condition compile-failed (compile-error) ())
-(define-condition compile-warned (compile-error) ())
-
-(define-condition invalid-configuration ()
-  ((form :reader condition-form :initarg :form)
-   (location :reader condition-location :initarg :location)
-   (format :reader condition-format :initarg :format)
-   (arguments :reader condition-arguments :initarg :arguments :initform ni=
l))
-  (:report (lambda (c s)
-               (format s (compatfmt "~@<~? (will be skipped)~@:>")
-                       (condition-format c)
-                       (list* (condition-form c) (condition-location c)
-                              (condition-arguments c))))))
-(define-condition invalid-source-registry (invalid-configuration warning)
-  ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~=
@{ ~@?~}~@:>"))))
-(define-condition invalid-output-translation (invalid-configuration warnin=
g)
-  ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ =
in ~S~]~@{ ~@?~}~@:>"))))
-
-(defclass component ()
-  ((name :accessor component-name :initarg :name :type string :documentati=
on
-         "Component name: designator for a string composed of portable pat=
hname characters")
-   ;; We might want to constrain version with
-   ;; :type (and string (satisfies parse-version))
-   ;; but we cannot until we fix all systems that don't use it correctly!
-   (version :accessor component-version :initarg :version)
-   (description :accessor component-description :initarg :description)
-   (long-description :accessor component-long-description :initarg :long-d=
escription)
-   ;; This one below is used by POIU - http://www.cliki.net/poiu
-   ;; a parallelizing extension of ASDF that compiles in multiple parallel
-   ;; slave processes (forked on demand) and loads in the master process.
-   ;; Maybe in the future ASDF may use it internally instead of in-order-t=
o.
-   (load-dependencies :accessor component-load-dependencies :initform nil)
-   ;; In the ASDF object model, dependencies exist between *actions*
-   ;; (an action is a pair of operation and component). They are represent=
ed
-   ;; alists of operations to dependencies (other actions) in each compone=
nt.
-   ;; There are two kinds of dependencies, each stored in its own slot:
-   ;; in-order-to and do-first dependencies. These two kinds are related to
-   ;; the fact that some actions modify the filesystem,
-   ;; whereas other actions modify the current image, and
-   ;; this implies a difference in how to interpret timestamps.
-   ;; in-order-to dependencies will trigger re-performing the action
-   ;; when the timestamp of some dependency
-   ;; makes the timestamp of current action out-of-date;
-   ;; do-first dependencies do not trigger such re-performing.
-   ;; Therefore, a FASL must be recompiled if it is obsoleted
-   ;; by any of its FASL dependencies (in-order-to); but
-   ;; it needn't be recompiled just because one of these dependencies
-   ;; hasn't yet been loaded in the current image (do-first).
-   ;; The names are crap, but they have been the official API since Dan Ba=
rlow's ASDF 1.52!
-   ;; LispWorks's defsystem has caused-by and requires for in-order-to and=
 do-first respectively.
-   ;; Maybe rename the slots in ASDF? But that's not very backwards compat=
ible.
-   ;; See our ASDF 2 paper for more complete explanations.
-   (in-order-to :initform nil :initarg :in-order-to
-                :accessor component-in-order-to)
-   (do-first :initform nil :initarg :do-first
-             :accessor component-do-first)
-   ;; methods defined using the "inline" style inside a defsystem form:
-   ;; need to store them somewhere so we can delete them when the system
-   ;; is re-evaluated
-   (inline-methods :accessor component-inline-methods :initform nil)
-   (parent :initarg :parent :initform nil :reader component-parent)
-   ;; no direct accessor for pathname, we do this as a method to allow
-   ;; 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)
-   (%encoding :accessor %component-encoding :initform nil :initarg :encodi=
ng)
-   ;; XXX we should provide some atomic interface for updating the
-   ;; component properties
-   (properties :accessor component-properties :initarg :properties
-               :initform nil)))
-
-(defun* component-find-path (component)
-  (reverse
-   (loop :for c =3D component :then (component-parent c)
-     :while c :collect (component-name c))))
-
-(defmethod print-object ((c component) stream)
-  (print-unreadable-object (c stream :type t :identity nil)
-    (format stream "~{~S~^ ~}" (component-find-path c))))
-
-
-;;;; methods: conditions
-
-(defmethod print-object ((c missing-dependency) s)
-  (format s (compatfmt "~@<~A, required by ~A~@:>")
-          (call-next-method c nil) (missing-required-by c)))
-
-(defun* sysdef-error (format &rest arguments)
-  (error 'formatted-system-definition-error :format-control
-         format :format-arguments arguments))
-
-;;;; methods: components
-
-(defmethod print-object ((c missing-component) s)
-  (format s (compatfmt "~@<Component ~S not found~@[ in ~A~]~@:>")
-          (missing-requires c)
-          (when (missing-parent c)
-            (coerce-name (missing-parent c)))))
-
-(defmethod print-object ((c missing-component-of-version) s)
-  (format s (compatfmt "~@<Component ~S does not match version ~A~@[ in ~A=
~]~@:>")
-          (missing-requires c)
-          (missing-version c)
-          (when (missing-parent c)
-            (coerce-name (missing-parent c)))))
-
-(defmethod component-system ((component component))
-  (aif (component-parent component)
-       (component-system it)
-       component))
-
-(defvar *default-component-class* 'cl-source-file)
-
-(defun* compute-module-components-by-name (module)
-  (let ((hash (make-hash-table :test 'equal)))
-    (setf (module-components-by-name module) hash)
-    (loop :for c :in (module-components module)
-      :for name =3D (component-name c)
-      :for previous =3D (gethash name (module-components-by-name module))
-      :do
-      (when previous
-        (error 'duplicate-names :name name))
-      :do (setf (gethash name (module-components-by-name module)) c))
-    hash))
-
-(defclass module (component)
-  ((components
-    :initform nil
-    :initarg :components
-    :accessor module-components)
-   (components-by-name
-    :accessor module-components-by-name)
-   ;; What to do if we can't satisfy a dependency of one of this module's
-   ;; components.  This allows a limited form of conditional processing.
-   (if-component-dep-fails
-    :initform :fail
-    :initarg :if-component-dep-fails
-    :accessor module-if-component-dep-fails)
-   (default-component-class
-    :initform nil
-    :initarg :default-component-class
-    :accessor module-default-component-class)))
-
-(defun* component-parent-pathname (component)
-  ;; No default anymore (in particular, no *default-pathname-defaults*).
-  ;; If you force component to have a NULL pathname, you better arrange
-  ;; for any of its children to explicitly provide a proper absolute pathn=
ame
-  ;; wherever a pathname is actually wanted.
-  (let ((parent (component-parent component)))
-    (when parent
-      (component-pathname parent))))
-
-(defmethod component-pathname ((component component))
-  (if (slot-boundp component 'absolute-pathname)
-      (slot-value component 'absolute-pathname)
-      (let ((pathname
-             (merge-pathnames*
-              (component-relative-pathname component)
-              (pathname-directory-pathname (component-parent-pathname comp=
onent)))))
-        (unless (or (null pathname) (absolute-pathname-p pathname))
-          (error (compatfmt "~@<Invalid relative pathname ~S for component=
 ~S~@:>")
-                 pathname (component-find-path component)))
-        (setf (slot-value component 'absolute-pathname) pathname)
-        pathname)))
-
-(defmethod component-property ((c component) property)
-  (cdr (assoc property (slot-value c 'properties) :test #'equal)))
-
-(defmethod (setf component-property) (new-value (c component) property)
-  (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
-    (if a
-        (setf (cdr a) new-value)
-        (setf (slot-value c 'properties)
-              (acons property new-value (slot-value c 'properties)))))
-  new-value)
-
-(defvar *default-encoding* :default
-  "Default encoding for source files.
-The default value :default preserves the legacy behavior.
-A future default might be :utf-8 or :autodetect
-reading emacs-style -*- coding: utf-8 -*- specifications,
-and falling back to utf-8 or latin1 if nothing is specified.")
-
-(defparameter *utf-8-external-format*
-  #+(and asdf-unicode (not clisp)) :utf-8
-  #+(and asdf-unicode clisp) charset:utf-8
-  #-asdf-unicode :default
-  "Default :external-format argument to pass to CL:OPEN and also
-CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file.
-On modern implementations, this will decode UTF-8 code points as CL charac=
ters.
-On legacy implementations, it may fall back on some 8-bit encoding,
-with non-ASCII code points being read as several CL characters;
-hopefully, if done consistently, that won't affect program behavior too mu=
ch.")
-
-(defun* always-default-encoding (pathname)
-  (declare (ignore pathname))
-  *default-encoding*)
-
-(defvar *encoding-detection-hook* #'always-default-encoding
-  "Hook for an extension to define a function to automatically detect a fi=
le's encoding")
-
-(defun* detect-encoding (pathname)
-  (funcall *encoding-detection-hook* pathname))
-
-(defmethod component-encoding ((c component))
-  (or (loop :for x =3D c :then (component-parent x)
-        :while x :thereis (%component-encoding x))
-      (detect-encoding (component-pathname c))))
-
-(defun* default-encoding-external-format (encoding)
-  (case encoding
-    (:default :default) ;; for backwards compatibility only. Explicit usag=
e discouraged.
-    (:utf-8 *utf-8-external-format*)
-    (otherwise
-     (cerror "Continue using :external-format :default" (compatfmt "~@<You=
r ASDF component is using encoding ~S but it isn't recognized. Your system =
should :defsystem-depends-on (:asdf-encodings).~:>") encoding)
-     :default)))
-
-(defvar *encoding-external-format-hook*
-  #'default-encoding-external-format
-  "Hook for an extension to define a mapping between non-default encodings
-and implementation-defined external-format's")
-
-(defun encoding-external-format (encoding)
-  (funcall *encoding-external-format-hook* encoding))
-
-(defmethod component-external-format ((c component))
-  (encoding-external-format (component-encoding c)))
-
-(defclass proto-system () ; slots to keep when resetting a system
-  ;; To preserve identity for all objects, we'd need keep the components s=
lots
-  ;; 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
-   (description :accessor system-description :initarg :description)
-   (long-description :accessor system-long-description :initarg :long-desc=
ription)
-   (author :accessor system-author :initarg :author)
-   (maintainer :accessor system-maintainer :initarg :maintainer)
-   (licence :accessor system-licence :initarg :licence
-            :accessor system-license :initarg :license)
-   (source-file :reader %system-source-file :initarg :source-file ; for CL=
ISP upgrade
-                :writer %set-system-source-file)
-   (defsystem-depends-on :reader system-defsystem-depends-on :initarg :def=
system-depends-on)))
-
-;;;; ---------------------------------------------------------------------=
----
-;;;; version-satisfies
-
-(defmethod version-satisfies ((c component) version)
-  (unless (and version (slot-boundp c 'version))
-    (when version
-      (warn "Requested version ~S but component ~S has no version" version=
 c))
-    (return-from version-satisfies t))
-  (version-satisfies (component-version c) version))
-
-(defun* asdf-version ()
-  "Exported interface to the version of ASDF currently installed. A string.
-You can compare this string with e.g.:
-(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")."
-  *asdf-version*)
-
-(defun* parse-version (string &optional on-error)
-  "Parse a version string as a series of natural integers separated by dot=
s.
-Return a (non-null) list of integers if the string is valid, NIL otherwise.
-If on-error is error, warn, or designates a function of compatible signatu=
re,
-the function is called with an explanation of what is wrong with the argum=
ent.
-NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2=
.3"
-  (and
-   (or (stringp string)
-       (when on-error
-         (funcall on-error "~S: ~S is not a string"
-                  'parse-version string)) nil)
-   (or (loop :for prev =3D nil :then c :for c :across string
-         :always (or (digit-char-p c)
-                     (and (eql c #\.) prev (not (eql prev #\.))))
-         :finally (return (and c (digit-char-p c))))
-       (when on-error
-         (funcall on-error "~S: ~S doesn't follow asdf version numbering c=
onvention"
-                  'parse-version string)) nil)
-   (mapcar #'parse-integer (split-string string :separator "."))))
-
-(defmethod version-satisfies ((cver string) version)
-  (let ((x (parse-version cver 'warn))
-        (y (parse-version version 'warn)))
-    (labels ((bigger (x y)
-               (cond ((not y) t)
-                     ((not x) nil)
-                     ((> (car x) (car y)) t)
-                     ((=3D (car x) (car y))
-                      (bigger (cdr x) (cdr y))))))
-      (and x y (=3D (car x) (car y))
-           (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
+(defun* getenvp (x)
+  "Predicate that is true if the named variable is present in the libc env=
ironment,
+then returning the non-empty string value of the variable"
+  (let ((g (getenv x))) (and (not (emptyp g)) g)))
+
+
+;;;; implementation-identifier
+;;
+;; produce a string to identify current implementation.
+;; Initially stolen from SLIME's SWANK, completely rewritten since.
+;; We're back to runtime checking, for the sake of e.g. ABCL.
+
+(defun* first-feature (feature-sets)
+  (dolist (x feature-sets)
+    (multiple-value-bind (short long feature-expr)
+        (if (consp x)
+            (values (first x) (second x) (cons :or (rest x)))
+            (values x x x))
+      (when (featurep feature-expr)
+        (return (values short long))))))
+
+(defun* implementation-type ()
+  (first-feature
+   '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp)
+     (:cmu :cmucl :cmu) :ecl :gcl
+     (:lwpe :lispworks-personal-edition) (:lw :lispworks)
+     :mcl :mkcl :sbcl :scl (:smbx :symbolics) :xcl)))
+
+(defvar *implementation-type* (implementation-type))
+
+(defun* operating-system ()
+  (first-feature
+   '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin firs=
t!
+     (: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 :x86-64 :x86_64 :x8664-target :amd64 (:and :word-size=3D64 :pc3=
86))
+     (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx38=
6 :x8632-target)
+     (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powe=
rpc)
+     :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 JN=
I,
+     ;; 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 (let ((s 'ccl::target-fasl-version))
+        (and (fboundp s) (funcall s)))
+      (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)))
+    (car ; as opposed to OR, this idiom prevents some unreachable code war=
ning
+     (list
+      #+allegro
+      (format nil "~A~@[~A~]~@[~A~]~@[~A~]"
+              excl::*common-lisp-version-number*
+              ;; M means "modern", as opposed to ANSI-compatible mode (whi=
ch I consider default)
+              (and (eq excl:*current-case-mode* :case-sensitive-lower) "M")
+              ;; Note if not using International ACL
+              ;; see http://www.franz.com/support/documentation/8.1/doc/op=
erators/excl/ics-target-case.htm
+              (excl:ics-target-case (:-ics "8"))
+              (and (member :smp *features*) "S"))
+      #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
+      #+clisp
+      (subseq s 0 (position #\space s)) ; strip build information (date, e=
tc.)
+      #+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 ()
+  (substitute-if
+   #\_ #'(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)))))
+
+
+;;;; Other system information
+
+(defun* hostname ()
+  ;; Note: untested on RMCL
+  #+(or abcl clozure cmucl ecl genera lispworks mcl mkcl sbcl scl xcl) (ma=
chine-instance)
+  #+cormanlisp "localhost" ;; is there a better way? Does it matter?
+  #+allegro (symbol-call :excl.osi :gethostname)
+  #+clisp (first (split-string (machine-instance) :separator " "))
+  #+gcl (system:gethostname))
+
+
+;;; Current directory
+#+cmu
+(defun* parse-unix-namestring* (unix-namestring)
+  (multiple-value-bind (host device directory name type version)
+      (lisp::parse-unix-namestring unix-namestring 0 (length unix-namestri=
ng))
+    (make-pathname :host (or host lisp::*unix-host*) :device device
+                   :directory directory :name name :type type :version ver=
sion)))
+
+(defun* getcwd ()
+  "Get the current working directory as per POSIX getcwd(3), as a pathname=
 object"
+  (or #+abcl (parse-namestring
+              (java:jstatic "getProperty" "java.lang.System" "user.dir") :=
ensure-directory t)
+      #+allegro (excl::current-directory)
+      #+clisp (ext:default-directory)
+      #+clozure (ccl:current-directory)
+      #+(or cmu scl) (#+cmu parse-unix-namestring* #+scl lisp::parse-unix-=
namestring
+                      (strcat (nth-value 1 (unix:unix-current-directory)) =
"/"))
+      #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type =
does it return?
+      #+ecl (ext:getcwd)
+      #+gcl (parse-namestring ;; this is a joke. Isn't there a better way?
+             (first (symbol-call :asdf/driver :run-program '("/bin/pwd") :=
output :lines)))
+      #+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canoni=
cal!
+      #+lispworks (system:current-directory)
+      #+mkcl (mk-ext:getcwd)
+      #+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/))
+      #+xcl (extensions:current-directory)
+      (error "getcwd not supported on your implementation")))
+
+(defun* chdir (x)
+  "Change current directory, as per POSIX chdir(2), to a given pathname ob=
ject"
+  (if-let (x (pathname x))
+    (or #+abcl (java:jstatic "setProperty" "java.lang.System" "user.dir" (=
namestring x))
+        #+allegro (excl:chdir x)
+        #+clisp (ext:cd x)
+        #+clozure (setf (ccl:current-directory) x)
+        #+(or cmu scl) (unix:unix-chdir (ext:unix-namestring x))
+        #+cormanlisp (unless (zerop (win32::_chdir (namestring x)))
+                       (error "Could not set current directory to ~A" x))
+        #+ecl (ext:chdir x)
+        #+genera (setf *default-pathname-defaults* x)
+        #+lispworks (hcl:change-directory x)
+        #+mkcl (mk-ext:chdir x)
+        #+sbcl (symbol-call :sb-posix :chdir (sb-ext:native-namestring x))
+        (error "chdir not supported on your implementation"))))
+
 =

 ;;;; -----------------------------------------------------------------
 ;;;; Windows shortcut support.  Based on:
@@ -1584,1770 +1693,2911 @@
                          (buffer (make-array length)))
                     (read-sequence buffer s)
                     (map 'string #'code-char buffer)))))))
-      (end-of-file ()
+      (end-of-file (c)
+        (declare (ignore c))
         nil)))))
 =

+
 ;;;; ---------------------------------------------------------------------=
----
-;;;; Finding systems
-
-(defun* make-defined-systems-table ()
-  (make-hash-table :test 'equal))
-
-(defvar *defined-systems* (make-defined-systems-table)
-  "This is a hash table whose keys are strings, being the
-names of the systems, and whose values are pairs, the first
-element of which is a universal-time indicating when the
-system definition was last updated, and the second element
-of which is a system object.")
-
-(defun* coerce-name (name)
-  (typecase name
-    (component (component-name name))
-    (symbol (string-downcase (symbol-name name)))
-    (string name)
-    (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~=
@:>") name))))
-
-(defun* system-registered-p (name)
-  (gethash (coerce-name name) *defined-systems*))
-
-(defun* registered-systems ()
-  (loop :for (() . system) :being :the :hash-values :of *defined-systems*
-    :collect (coerce-name system)))
-
-(defun* register-system (system)
-  (check-type system system)
-  (let ((name (component-name system)))
-    (check-type name string)
-    (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system)
-    (unless (eq system (cdr (gethash name *defined-systems*)))
-      (setf (gethash name *defined-systems*)
-            (cons (get-universal-time) system)))))
-
-(defun* clear-system (name)
-  "Clear the entry for a system in the database of systems previously load=
ed.
-Note that this does NOT in any way cause the code of the system to be unlo=
aded."
-  ;; There is no "unload" operation in Common Lisp, and
-  ;; a general such operation cannot be portably written,
-  ;; considering how much CL relies on side-effects to global data structu=
res.
-  (remhash (coerce-name name) *defined-systems*))
-
-(defun* map-systems (fn)
-  "Apply FN to each defined system.
-
-FN should be a function of one argument. It will be
-called with an object of type asdf:system."
-  (maphash #'(lambda (_ datum)
-               (declare (ignore _))
-               (destructuring-bind (_ . def) datum
-                 (declare (ignore _))
-                 (funcall fn def)))
-           *defined-systems*))
-
-;;; for the sake of keeping things reasonably neat, we adopt a
-;;; convention that functions in this list are prefixed SYSDEF-
-
-(defvar *system-definition-search-functions* '())
-
-(setf *system-definition-search-functions*
-      (append
-       ;; Remove known-incompatible sysdef functions from ancient sbcl asd=
f.
-       (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-functi=
ons*))
-                  '(sysdef-central-registry-search
-                    sysdef-source-registry-search
-                    sysdef-find-asdf))))
-
-(defun* search-for-system-definition (system)
-  (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
-"A list of 'system directory designators' ASDF uses to find systems.
-
-A 'system directory designator' is a pathname or an expression
-which evaluates to a pathname. For example:
-
-    (setf asdf:*central-registry*
-          (list '*default-pathname-defaults*
-                #p\"/home/me/cl/systems/\"
-                #p\"/usr/share/common-lisp/systems/\"))
-
-This is for backward compatibilily.
-Going forward, we recommend new users should be using the source-registry.
-")
-
-(defun* featurep (x &optional (features *features*))
+;;;; Portability layer around Common Lisp pathnames
+;; This layer allows for portable manipulation of pathname objects themsel=
ves,
+;; which all is necessary prior to any access the filesystem or environmen=
t.
+
+(asdf/package:define-package :asdf/pathname
+  (:recycle :asdf/pathname :asdf)
+  (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os)
+  (:export
+   ;; Making and merging pathnames, portably
+   #:normalize-pathname-directory-component #:denormalize-pathname-directo=
ry-component
+   #:merge-pathname-directory-components #:*unspecific-pathname-type* #:ma=
ke-pathname*
+   #:make-pathname-component-logical #:make-pathname-logical
+   #:merge-pathnames*
+   #:nil-pathname #:*nil-pathname* #:with-pathname-defaults
+   ;; Predicates
+   #:pathname-equal #:logical-pathname-p #:physical-pathname-p
+   #:absolute-pathname-p #:relative-pathname-p #:hidden-pathname-p #:file-=
pathname-p
+   ;; Directories
+   #:pathname-directory-pathname #:pathname-parent-directory-pathname
+   #:directory-pathname-p #:ensure-directory-pathname
+   ;; Parsing filenames
+   #:component-name-to-pathname-components
+   #:split-name-type #:parse-unix-namestring #:unix-namestring
+   #:split-unix-namestring-directory-components
+   ;; Absolute and relative pathnames
+   #:subpathname #:subpathname*
+   #:ensure-absolute-pathname
+   #:pathname-root #:pathname-host-pathname
+   #:subpathp
+   ;; Checking constraints
+   #:ensure-pathname ;; implemented in filesystem.lisp to accommodate for =
existence constraints
+   ;; Wildcard pathnames
+   #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* #:*wild-pa=
th* #:wilden
+   ;; Translate a pathname
+   #:relativize-directory-component #:relativize-pathname-directory
+   #:directory-separator-for-host #:directorize-pathname-host-device
+   #:translate-pathname*
+   #:*output-translation-function*))
+(in-package :asdf/pathname)
+
+;;; Normalizing pathnames across implementations
+
+(defun* normalize-pathname-directory-component (directory)
+  "Given a pathname directory component, return an equivalent form that is=
 a list"
+  #+gcl2.6 (setf directory (substitute :back :parent directory))
   (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)))
+    #-(or cmu sbcl scl) ;; these implementations already normalize directo=
ry components.
+    ((stringp directory) `(:absolute ,directory))
+    #+gcl2.6
+    ((and (consp directory) (eq :root (first directory)))
+     `(:absolute ,@(rest directory)))
+    ((or (null directory)
+         (and (consp directory) (member (first directory) '(:absolute :rel=
ative))))
+     directory)
+    #+gcl2.6
+    ((consp directory)
+     `(:relative , at directory))
     (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 :mingw=
32))))
-
-(defun* probe-asd (name defaults)
+     (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:=
>") directory))))
+
+(defun* denormalize-pathname-directory-component (directory-component)
+  #-gcl2.6 directory-component
+  #+gcl2.6
+  (let ((d (substitute-if :parent (lambda (x) (member x '(:up :back)))
+                          directory-component)))
+    (cond
+      ((and (consp d) (eq :relative (first d))) (rest d))
+      ((and (consp d) (eq :absolute (first d))) `(:root ,@(rest d)))
+      (t d))))
+
+(defun* merge-pathname-directory-components (specified defaults)
+  ;; Helper for merge-pathnames* that handles directory components.
+  (let ((directory (normalize-pathname-directory-component specified)))
+    (ecase (first directory)
+      ((nil) defaults)
+      (:absolute specified)
+      (:relative
+       (let ((defdir (normalize-pathname-directory-component defaults))
+             (reldir (cdr directory)))
+         (cond
+           ((null defdir)
+            directory)
+           ((not (eq :back (first reldir)))
+            (append defdir reldir))
+           (t
+            (loop :with defabs =3D (first defdir)
+              :with defrev =3D (reverse (rest defdir))
+              :while (and (eq :back (car reldir))
+                          (or (and (eq :absolute defabs) (null defrev))
+                              (stringp (car defrev))))
+              :do (pop reldir) (pop defrev)
+              :finally (return (cons defabs (append (reverse defrev) reldi=
r)))))))))))
+
+;; Giving :unspecific as :type argument to make-pathname is not portable.
+;; See CLHS make-pathname and 19.2.2.2.3.
+;; This will be :unspecific if supported, or NIL if not.
+(defparameter *unspecific-pathname-type*
+  #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :=
unspecific
+  #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil)
+
+(defun* make-pathname* (&rest keys &key (directory nil #+gcl2.6 directoryp)
+                              host (device () #+allegro devicep) name type=
 version defaults
+                              #+scl &allow-other-keys)
+  "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and
+   tries hard to make a pathname that will actually behave as documented,
+   despite the peculiarities of each implementation"
+  (declare (ignorable host device directory name type version defaults))
+  (apply 'make-pathname
+         (append
+          #+allegro (when (and devicep (null device)) `(:device :unspecifi=
c))
+          #+gcl2.6
+          (when directoryp
+            `(:directory ,(denormalize-pathname-directory-component direct=
ory)))
+          keys)))
+
+(defun* make-pathname-component-logical (x)
+  "Make a pathname component suitable for use in a logical-pathname"
+  (typecase x
+    ((eql :unspecific) nil)
+    #+clisp (string (string-upcase x))
+    #+clisp (cons (mapcar 'make-pathname-component-logical x))
+    (t x)))
+
+(defun* make-pathname-logical (pathname host)
+  "Take a PATHNAME's directory, name, type and version components,
+and make a new pathname with corresponding components and specified logica=
l HOST"
+  (make-pathname*
+   :host host
+   :directory (make-pathname-component-logical (pathname-directory pathnam=
e))
+   :name (make-pathname-component-logical (pathname-name pathname))
+   :type (make-pathname-component-logical (pathname-type pathname))
+   :version (make-pathname-component-logical (pathname-version pathname))))
+
+(defun* merge-pathnames* (specified &optional (defaults *default-pathname-=
defaults*))
+  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
+if the SPECIFIED pathname does not have an absolute directory,
+then the HOST and DEVICE both come from the DEFAULTS, whereas
+if the SPECIFIED pathname does have an absolute directory,
+then the HOST and DEVICE both come from the SPECIFIED.
+This is what users want on a modern Unix or Windows operating system,
+unlike the MERGE-PATHNAME behavior.
+Also, if either argument is NIL, then the other argument is returned unmod=
ified;
+this is unlike MERGE-PATHNAME which always merges with a pathname,
+by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL."
+  (when (null specified) (return-from merge-pathnames* defaults))
+  (when (null defaults) (return-from merge-pathnames* specified))
+  #+scl
+  (ext:resolve-pathname specified defaults)
+  #-scl
+  (let* ((specified (pathname specified))
+         (defaults (pathname defaults))
+         (directory (normalize-pathname-directory-component (pathname-dire=
ctory specified)))
+         (name (or (pathname-name specified) (pathname-name defaults)))
+         (type (or (pathname-type specified) (pathname-type defaults)))
+         (version (or (pathname-version specified) (pathname-version defau=
lts))))
+    (labels ((unspecific-handler (p)
+               (if (typep p 'logical-pathname) #'make-pathname-component-l=
ogical #'identity)))
+      (multiple-value-bind (host device directory unspecific-handler)
+          (ecase (first directory)
+            ((:absolute)
+             (values (pathname-host specified)
+                     (pathname-device specified)
+                     directory
+                     (unspecific-handler specified)))
+            ((nil :relative)
+             (values (pathname-host defaults)
+                     (pathname-device defaults)
+                     (merge-pathname-directory-components directory (pathn=
ame-directory defaults))
+                     (unspecific-handler defaults))))
+        (make-pathname* :host host :device device :directory directory
+                        :name (funcall unspecific-handler name)
+                        :type (funcall unspecific-handler type)
+                        :version (funcall unspecific-handler version))))))
+
+(defun* nil-pathname (&optional (defaults *default-pathname-defaults*))
+  "A pathname that is as neutral as possible for use as defaults
+   when merging, making or parsing pathnames"
+  ;; 19.2.2.2.1 says a NIL host can mean a default host;
+  ;; see also "valid physical pathname host" in the CLHS glossary, that su=
ggests
+  ;; strings and lists of strings or :unspecific
+  ;; But CMUCL decides to die on NIL.
+  #.`(make-pathname* :directory nil :name nil :type nil :version nil :devi=
ce nil
+                     :host (or #+cmu lisp::*unix-host*)
+                     #+scl ,@'(:scheme nil :scheme-specific-part nil
+                               :username nil :password nil :parameters nil=
 :query nil :fragment nil)
+                     ;; the default shouldn't matter, but we really want s=
omething physical
+                     :defaults defaults))
+
+(defvar *nil-pathname* (nil-pathname (translate-logical-pathname (user-hom=
edir-pathname))))
+
+(defmacro with-pathname-defaults ((&optional defaults) &body body)
+  `(let ((*default-pathname-defaults* ,(or defaults '*nil-pathname*))) , at b=
ody))
+
+
+;;; Some pathname predicates
+
+(defun* pathname-equal (p1 p2)
+  (when (stringp p1) (setf p1 (pathname p1)))
+  (when (stringp p2) (setf p2 (pathname p2)))
+  (flet ((normalize-component (x)
+           (unless (member x '(nil :unspecific :newest (:relative)) :test =
'equal)
+             x)))
+    (macrolet ((=3D? (&rest accessors)
+                 (flet ((frob (x)
+                          (reduce 'list (cons 'normalize-component accesso=
rs)
+                                  :initial-value x :from-end t)))
+                   `(equal ,(frob 'p1) ,(frob 'p2)))))
+      (or (and (null p1) (null p2))
+          (and (pathnamep p1) (pathnamep p2)
+               (and (=3D? pathname-host)
+                    (=3D? pathname-device)
+                    (=3D? normalize-pathname-directory-component pathname-=
directory)
+                    (=3D? pathname-name)
+                    (=3D? pathname-type)
+                    (=3D? pathname-version)))))))
+
+(defun* logical-pathname-p (x)
+  (typep x 'logical-pathname))
+
+(defun* physical-pathname-p (x)
+  (and (pathnamep x) (not (logical-pathname-p x))))
+
+(defun* absolute-pathname-p (pathspec)
+  "If PATHSPEC is a pathname or namestring object that parses as a pathname
+possessing an :ABSOLUTE directory component, return the (parsed) pathname.
+Otherwise return NIL"
+  (and pathspec
+       (typep pathspec '(or null pathname string))
+       (let ((pathname (pathname pathspec)))
+         (and (eq :absolute (car (normalize-pathname-directory-component
+                                  (pathname-directory pathname))))
+              pathname))))
+
+(defun* relative-pathname-p (pathspec)
+  "If PATHSPEC is a pathname or namestring object that parses as a pathname
+possessing a :RELATIVE or NIL directory component, return the (parsed) pat=
hname.
+Otherwise return NIL"
+  (and pathspec
+       (typep pathspec '(or null pathname string))
+       (let* ((pathname (pathname pathspec))
+              (directory (normalize-pathname-directory-component
+                          (pathname-directory pathname))))
+         (when (or (null directory) (eq :relative (car directory)))
+           pathname))))
+
+(defun* hidden-pathname-p (pathname)
+  "Return a boolean that is true if the pathname is hidden as per Unix sty=
le,
+i.e. its name starts with a dot."
+  (and pathname (equal (first-char (pathname-name pathname)) #\.)))
+
+(defun* file-pathname-p (pathname)
+  "Does PATHNAME represent a file, i.e. has a non-null NAME component?
+
+Accepts NIL, a string (converted through PARSE-NAMESTRING) or a PATHNAME.
+
+Note that this does _not_ check to see that PATHNAME points to an
+actually-existing file.
+
+Returns the (parsed) PATHNAME when true"
+  (when pathname
+    (let* ((pathname (pathname pathname))
+           (name (pathname-name pathname)))
+      (when (not (member name '(nil :unspecific "") :test 'equal))
+        pathname))))
+
+
+;;; Directory pathnames
+(defun* pathname-directory-pathname (pathname)
+  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
+and NIL NAME, TYPE and VERSION components"
+  (when pathname
+    (make-pathname :name nil :type nil :version nil :defaults pathname)))
+
+(defun* pathname-parent-directory-pathname (pathname)
+  "Returns a new pathname that corresponds to the parent of the current pa=
thname's directory,
+i.e. removing one level of depth in the DIRECTORY component. e.g. if pathn=
ame is
+Unix pathname /foo/bar/baz/file.type then return /foo/bar/"
+  (when pathname
+    (make-pathname* :name nil :type nil :version nil
+                    :directory (merge-pathname-directory-components
+                                '(:relative :back) (pathname-directory pat=
hname))
+                    :defaults pathname)))
+
+(defun* directory-pathname-p (pathname)
+  "Does PATHNAME represent a directory?
+
+A directory-pathname is a pathname _without_ a filename. The three
+ways that the filename components can be missing are for it to be NIL,
+:UNSPECIFIC or the empty string.
+
+Note that this does _not_ check to see that PATHNAME points to an
+actually-existing directory."
+  (when pathname
+    (let ((pathname (pathname pathname)))
+      (flet ((check-one (x)
+               (member x '(nil :unspecific "") :test 'equal)))
+        (and (not (wild-pathname-p pathname))
+             (check-one (pathname-name pathname))
+             (check-one (pathname-type pathname))
+             t)))))
+
+(defun* ensure-directory-pathname (pathspec &optional (on-error 'error))
+  "Converts the non-wild pathname designator PATHSPEC to directory form."
+  (cond
+   ((stringp pathspec)
+    (ensure-directory-pathname (pathname pathspec)))
+   ((not (pathnamep pathspec))
+    (call-function on-error (compatfmt "~@<Invalid pathname designator ~S~=
@:>") pathspec))
+   ((wild-pathname-p pathspec)
+    (call-function on-error (compatfmt "~@<Can't reliably convert wild pat=
hname ~3i~_~S~@:>") pathspec))
+   ((directory-pathname-p pathspec)
+    pathspec)
+   (t
+    (make-pathname* :directory (append (or (normalize-pathname-directory-c=
omponent
+                                            (pathname-directory pathspec))
+                                           (list :relative))
+                                       (list (file-namestring pathspec)))
+                    :name nil :type nil :version nil :defaults pathspec))))
+
+
+;;; Parsing filenames
+(defun* split-unix-namestring-directory-components
+    (unix-namestring &key ensure-directory dot-dot)
+  "Splits the path string UNIX-NAMESTRING, returning four values:
+A flag that is either :absolute or :relative, indicating
+   how the rest of the values are to be interpreted.
+A directory path --- a list of strings and keywords, suitable for
+   use with MAKE-PATHNAME when prepended with the flag value.
+   Directory components with an empty name or the name . are removed.
+   Any directory named .. is read as DOT-DOT, or :BACK if it's NIL (not :U=
P).
+A last-component, either a file-namestring including type extension,
+   or NIL in the case of a directory pathname.
+A flag that is true iff the unix-style-pathname was just
+   a file-namestring without / path specification.
+ENSURE-DIRECTORY forces the namestring to be interpreted as a directory pa=
thname:
+the third return value will be NIL, and final component of the namestring
+will be treated as part of the directory path.
+
+An empty string is thus read as meaning a pathname object with all fields =
nil.
+
+Note that : characters will NOT be interpreted as host specification.
+Absolute pathnames are only appropriate on Unix-style systems.
+
+The intention of this function is to support structured component names,
+e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathnames."
+  (check-type unix-namestring string)
+  (check-type dot-dot (member nil :back :up))
+  (if (and (not (find #\/ unix-namestring)) (not ensure-directory)
+           (plusp (length unix-namestring)))
+      (values :relative () unix-namestring t)
+      (let* ((components (split-string unix-namestring :separator "/"))
+             (last-comp (car (last components))))
+        (multiple-value-bind (relative components)
+            (if (equal (first components) "")
+                (if (equal (first-char unix-namestring) #\/)
+                    (values :absolute (cdr components))
+                    (values :relative nil))
+                (values :relative components))
+          (setf components (remove-if #'(lambda (x) (member x '("" ".") :t=
est #'equal))
+                                      components))
+          (setf components (substitute (or dot-dot :back) ".." components =
:test #'equal))
+          (cond
+            ((equal last-comp "")
+             (values relative components nil nil)) ; "" already removed fr=
om components
+            (ensure-directory
+             (values relative components nil nil))
+            (t
+             (values relative (butlast components) last-comp nil)))))))
+
+(defun* split-name-type (filename)
+  "Split a filename into two values NAME and TYPE that are returned.
+We assume filename has no directory component.
+The last . if any separates name and type from from type,
+except that if there is only one . and it is in first position,
+the whole filename is the NAME with an empty type.
+NAME is always a string.
+For an empty type, *UNSPECIFIC-PATHNAME-TYPE* is returned."
+  (check-type filename string)
+  (assert (plusp (length filename)))
+  (destructuring-bind (name &optional (type *unspecific-pathname-type*))
+      (split-string filename :max 2 :separator ".")
+    (if (equal name "")
+        (values filename *unspecific-pathname-type*)
+        (values name type))))
+
+(defun* parse-unix-namestring (name &rest keys &key type defaults dot-dot =
ensure-directory
+                                    &allow-other-keys)
+  "Coerce NAME into a PATHNAME using standard Unix syntax.
+
+Unix syntax is used whether or not the underlying system is Unix;
+on such non-Unix systems it is only usable but for relative pathnames;
+but especially to manipulate relative pathnames portably, it is of crucial
+to possess a portable pathname syntax independent of the underlying OS.
+This is what PARSE-UNIX-NAMESTRING provides, and why we use it in ASDF.
+
+When given a PATHNAME object, just return it untouched.
+When given NIL, just return NIL.
+When given a non-null SYMBOL, first downcase its name and treat it as a st=
ring.
+When given a STRING, portably decompose it into a pathname as below.
+
+#\\/ separates directory components.
+
+The last #\\/-separated substring is interpreted as follows:
+1- If TYPE is :DIRECTORY or ENSURE-DIRECTORY is true,
+ the string is made the last directory component, and NAME and TYPE are NI=
L.
+ if the string is empty, it's the empty pathname with all slots NIL.
+2- If TYPE is NIL, the substring is file-namestring, and its NAME and TYPE
+ are separated by SPLIT-NAME-TYPE.
+3- If TYPE is a string, it is the given TYPE, and the whole string is the =
NAME.
+
+Directory components with an empty name the name . are removed.
+Any directory named .. is read as DOT-DOT,
+which must be one of :BACK or :UP and defaults to :BACK.
+
+HOST, DEVICE and VERSION components are taken from DEFAULTS,
+which itself defaults to *NIL-PATHNAME*, also used if DEFAULTS in NIL.
+No host or device can be specified in the string itself,
+which makes it unsuitable for absolute pathnames outside Unix.
+
+For relative pathnames, these components (and hence the defaults) won't ma=
tter
+if you use MERGE-PATHNAMES* but will matter if you use MERGE-PATHNAMES,
+which is an important reason to always use MERGE-PATHNAMES*.
+
+Arbitrary keys are accepted, and the parse result is passed to ENSURE-PATH=
NAME
+with those keys, removing TYPE DEFAULTS and DOT-DOT.
+When you're manipulating pathnames that are supposed to make sense portably
+even though the OS may not be Unixish, we recommend you use :WANT-RELATIVE=
 T
+to throw an error if the pathname is absolute"
   (block nil
-    (when (directory-pathname-p defaults)
-      (let* ((file (probe-file* (subpathname defaults (strcat name ".asd")=
))))
-        (when file
-          (return file)))
-      #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't ha=
ve 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)
-  (let ((name (coerce-name system))
-        (to-remove nil)
-        (to-replace nil))
-    (block nil
-      (unwind-protect
-           (dolist (dir *central-registry*)
-             (let ((defaults (eval dir)))
-               (when defaults
-                 (cond ((directory-pathname-p defaults)
-                        (let ((file (probe-asd name defaults)))
-                          (when file
-                            (return file))))
-                       (t
-                        (restart-case
-                            (let* ((*print-circle* nil)
-                                   (message
-                                    (format nil
-                                            (compatfmt "~@<While searching=
 for system ~S: ~3i~_~S evaluated to ~S which is not a directory.~@:>")
-                                            system dir defaults)))
-                              (error message))
-                          (remove-entry-from-registry ()
-                            :report "Remove entry from *central-registry* =
and continue"
-                            (push dir to-remove))
-                          (coerce-entry-to-directory ()
-                            :report (lambda (s)
-                                      (format s (compatfmt "~@<Coerce entr=
y to ~a, replace ~a and continue.~@:>")
-                                              (ensure-directory-pathname d=
efaults) dir))
-                            (push (cons dir (ensure-directory-pathname def=
aults)) to-replace))))))))
-        ;; cleanup
-        (dolist (dir to-remove)
-          (setf *central-registry* (remove dir *central-registry*)))
-        (dolist (pair to-replace)
-          (let* ((current (car pair))
-                 (new (cdr pair))
-                 (position (position current *central-registry*)))
-            (setf *central-registry*
-                  (append (subseq *central-registry* 0 position)
-                          (list new)
-                          (subseq *central-registry* (1+ position))))))))))
-
-(defun* make-temporary-package ()
-  (flet ((try (counter)
-           (ignore-errors
-             (make-package (format nil "~A~D" :asdf counter)
-                           :use '(:cl :asdf)))))
-    (do* ((counter 0 (+ counter 1))
-          (package (try counter) (try counter)))
-         (package package))))
+    (check-type type (or null string (eql :directory)))
+    (when ensure-directory
+      (setf type :directory))
+    (etypecase name
+      ((or null pathname) (return name))
+      (symbol
+       (setf name (string-downcase name)))
+      (string))
+    (multiple-value-bind (relative path filename file-only)
+        (split-unix-namestring-directory-components
+         name :dot-dot dot-dot :ensure-directory (eq type :directory))
+      (multiple-value-bind (name type)
+          (cond
+            ((or (eq type :directory) (null filename))
+             (values nil nil))
+            (type
+             (values filename type))
+            (t
+             (split-name-type filename)))
+        (apply 'ensure-pathname
+               (make-pathname*
+                :directory (unless file-only (cons relative path))
+                :name name :type type
+                :defaults (or defaults *nil-pathname*))
+               (remove-plist-keys '(:type :dot-dot :defaults) keys))))))
+
+(defun* unix-namestring (pathname)
+  "Given a non-wild PATHNAME, return a Unix-style namestring for it.
+If the PATHNAME is NIL or a STRING, return it unchanged.
+
+This only considers the DIRECTORY, NAME and TYPE components of the pathnam=
e.
+This is a portable solution for representing relative pathnames,
+But unless you are running on a Unix system, it is not a general solution
+to representing native pathnames.
+
+An error is signaled if the argument is not NULL, a STRING or a PATHNAME,
+or if it is a PATHNAME but some of its components are not recognized."
+  (etypecase pathname
+    ((or null string) pathname)
+    (pathname
+     (with-output-to-string (s)
+       (flet ((err () (error "Not a valid unix-namestring ~S" pathname)))
+         (let* ((dir (normalize-pathname-directory-component (pathname-dir=
ectory pathname)))
+                (name (pathname-name pathname))
+                (type (pathname-type pathname))
+                (type (and (not (eq type :unspecific)) type)))
+           (cond
+             ((eq dir ()))
+             ((eq dir '(:relative)) (princ "./" s))
+             ((consp dir)
+              (destructuring-bind (relabs &rest dirs) dir
+                (or (member relabs '(:relative :absolute)) (err))
+                (when (eq relabs :absolute) (princ #\/ s))
+                (loop :for x :in dirs :do
+                  (cond
+                    ((member x '(:back :up)) (princ "../" s))
+                    ((equal x "") (err))
+                    ;;((member x '("." "..") :test 'equal) (err))
+                    ((stringp x) (format s "~A/" x))
+                    (t (err))))))
+             (t (err)))
+           (cond
+             (name
+              (or (and (stringp name) (or (null type) (stringp type))) (er=
r))
+              (format s "~A~@[.~A~]" name type))
+             (t
+              (or (null type) (err))))))))))
+
+;;; Absolute and relative pathnames
+(defun* subpathname (pathname subpath &key type)
+  "This function takes a PATHNAME and a SUBPATH and a TYPE.
+If SUBPATH is already a PATHNAME object (not namestring),
+and is an absolute pathname at that, it is returned unchanged;
+otherwise, SUBPATH is turned into a relative pathname with given TYPE
+as per PARSE-UNIX-NAMESTRING with :WANT-RELATIVE T :TYPE TYPE,
+then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
+  (or (and (pathnamep subpath) (absolute-pathname-p subpath))
+      (merge-pathnames* (parse-unix-namestring subpath :type type :want-re=
lative t)
+                        (pathname-directory-pathname pathname))))
+
+(defun* subpathname* (pathname subpath &key type)
+  "returns NIL if the base pathname is NIL, otherwise like SUBPATHNAME."
+  (and pathname
+       (subpathname (ensure-directory-pathname pathname) subpath :type typ=
e)))
+
+
+;;; Pathname host and its root
+(defun* pathname-root (pathname)
+  (make-pathname* :directory '(:absolute)
+                  :name nil :type nil :version nil
+                  :defaults pathname ;; host device, and on scl, *some*
+                  ;; scheme-specific parts: port username password, not ot=
hers:
+                  . #.(or #+scl '(:parameters nil :query nil :fragment nil=
))))
+
+(defun* pathname-host-pathname (pathname)
+  (make-pathname* :directory nil
+                  :name nil :type nil :version nil :device nil
+                  :defaults pathname ;; host device, and on scl, *some*
+                  ;; scheme-specific parts: port username password, not ot=
hers:
+                  . #.(or #+scl '(:parameters nil :query nil :fragment nil=
))))
+
+(defun* subpathp (maybe-subpath base-pathname)
+  (and (pathnamep maybe-subpath) (pathnamep base-pathname)
+       (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathn=
ame)
+       (directory-pathname-p base-pathname) (not (wild-pathname-p base-pat=
hname))
+       (pathname-equal (pathname-root maybe-subpath) (pathname-root base-p=
athname))
+       (with-pathname-defaults ()
+         (let ((enough (enough-namestring maybe-subpath base-pathname)))
+           (and (relative-pathname-p enough) (pathname enough))))))
+
+(defun* ensure-absolute-pathname (path &optional defaults (on-error 'error=
))
+  (cond
+    ((absolute-pathname-p path))
+    ((stringp path) (ensure-absolute-pathname (pathname path) defaults on-=
error))
+    ((not (pathnamep path)) (call-function on-error "not a valid pathname =
designator ~S" path))
+    ((let ((default-pathname (if (pathnamep defaults) defaults (call-funct=
ion defaults))))
+       (or (if (absolute-pathname-p default-pathname)
+               (absolute-pathname-p (merge-pathnames* path default-pathnam=
e))
+               (call-function on-error "Default pathname ~S is not an abso=
lute pathname"
+                              default-pathname))
+           (call-function on-error "Failed to merge ~S with ~S into an abs=
olute pathname"
+                          path default-pathname))))
+    (t (call-function on-error
+                      "Cannot ensure ~S is evaluated as an absolute pathna=
me with defaults ~S"
+                      path defaults))))
+
+
+;;; Wildcard pathnames
+(defparameter *wild* (or #+cormanlisp "*" :wild))
+(defparameter *wild-directory-component* (or #+gcl2.6 "*" :wild))
+(defparameter *wild-inferiors-component* (or #+gcl2.6 "**" :wild-inferiors=
))
+(defparameter *wild-file*
+  (make-pathname :directory nil :name *wild* :type *wild*
+                 :version (or #-(or allegro abcl xcl) *wild*)))
+(defparameter *wild-directory*
+  (make-pathname* :directory `(:relative ,*wild-directory-component*)
+                  :name nil :type nil :version nil))
+(defparameter *wild-inferiors*
+  (make-pathname* :directory `(:relative ,*wild-inferiors-component*)
+                  :name nil :type nil :version nil))
+(defparameter *wild-path*
+  (merge-pathnames* *wild-file* *wild-inferiors*))
+
+(defun* wilden (path)
+  (merge-pathnames* *wild-path* path))
+
+
+;;; Translate a pathname
+(defun relativize-directory-component (directory-component)
+  (let ((directory (normalize-pathname-directory-component directory-compo=
nent)))
+    (cond
+      ((stringp directory)
+       (list :relative directory))
+      ((eq (car directory) :absolute)
+       (cons :relative (cdr directory)))
+      (t
+       directory))))
+
+(defun* relativize-pathname-directory (pathspec)
+  (let ((p (pathname pathspec)))
+    (make-pathname*
+     :directory (relativize-directory-component (pathname-directory p))
+     :defaults p)))
+
+(defun* directory-separator-for-host (&optional (pathname *default-pathnam=
e-defaults*))
+  (let ((foo (make-pathname* :directory '(:absolute "FOO") :defaults pathn=
ame)))
+    (last-char (namestring foo))))
+
+#-scl
+(defun* directorize-pathname-host-device (pathname)
+  #+(or unix abcl)
+  (when (and #+abcl (os-unix-p) (physical-pathname-p pathname))
+    (return-from directorize-pathname-host-device pathname))
+  (let* ((root (pathname-root pathname))
+         (wild-root (wilden root))
+         (absolute-pathname (merge-pathnames* pathname root))
+         (separator (directory-separator-for-host root))
+         (root-namestring (namestring root))
+         (root-string
+          (substitute-if #\/
+                         #'(lambda (x) (or (eql x #\:)
+                                           (eql x separator)))
+                         root-namestring)))
+    (multiple-value-bind (relative path filename)
+        (split-unix-namestring-directory-components root-string :ensure-di=
rectory t)
+      (declare (ignore relative filename))
+      (let ((new-base
+             (make-pathname* :defaults root :directory `(:absolute , at path)=
)))
+        (translate-pathname absolute-pathname wild-root (wilden new-base))=
))))
+
+#+scl
+(defun* directorize-pathname-host-device (pathname)
+  (let ((scheme (ext:pathname-scheme pathname))
+        (host (pathname-host pathname))
+        (port (ext:pathname-port pathname))
+        (directory (pathname-directory pathname)))
+    (flet ((specificp (x) (and x (not (eq x :unspecific)))))
+      (if (or (specificp port)
+              (and (specificp host) (plusp (length host)))
+              (specificp scheme))
+        (let ((prefix ""))
+          (when (specificp port)
+            (setf prefix (format nil ":~D" port)))
+          (when (and (specificp host) (plusp (length host)))
+            (setf prefix (strcat host prefix)))
+          (setf prefix (strcat ":" prefix))
+          (when (specificp scheme)
+            (setf prefix (strcat scheme prefix)))
+          (assert (and directory (eq (first directory) :absolute)))
+          (make-pathname* :directory `(:absolute ,prefix ,@(rest directory=
))
+                          :defaults pathname)))
+    pathname)))
+
+(defun* (translate-pathname*) (path absolute-source destination &optional =
root source)
+  (declare (ignore source))
+  (cond
+    ((functionp destination)
+     (funcall destination path absolute-source))
+    ((eq destination t)
+     path)
+    ((not (pathnamep destination))
+     (error "Invalid destination"))
+    ((not (absolute-pathname-p destination))
+     (translate-pathname path absolute-source (merge-pathnames* destinatio=
n root)))
+    (root
+     (translate-pathname (directorize-pathname-host-device path) absolute-=
source destination))
+    (t
+     (translate-pathname path absolute-source destination))))
+
+(defvar *output-translation-function* 'identity) ; Hook for output transla=
tions
+
+
+;;;; ---------------------------------------------------------------------=
----
+;;;; Portability layer around Common Lisp filesystem access
+
+(asdf/package:define-package :asdf/filesystem
+  (:recycle :asdf/pathname :asdf)
+  (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os :asdf/pathn=
ame)
+  (:export
+   ;; Native namestrings
+   #:native-namestring #:parse-native-namestring
+   ;; Probing the filesystem
+   #:truename* #:safe-file-write-date #:probe-file*
+   #:directory* #:filter-logical-directory-results #:directory-files #:sub=
directories
+   #:collect-sub*directories
+   ;; Resolving symlinks somewhat
+   #:truenamize #:resolve-symlinks #:*resolve-symlinks* #:resolve-symlinks*
+   ;; merging with cwd
+   #:get-pathname-defaults #:call-with-current-directory #:with-current-di=
rectory
+   ;; Environment pathnames
+   #:inter-directory-separator #:split-native-pathnames-string
+   #:getenv-pathname #:getenv-pathnames
+   #:getenv-absolute-directory #:getenv-absolute-directories
+   #:lisp-implementation-directory #:lisp-implementation-pathname-p
+   ;; Simple filesystem operations
+   #:ensure-all-directories-exist
+   #:rename-file-overwriting-target
+   #:delete-file-if-exists))
+(in-package :asdf/filesystem)
+
+;;; Native namestrings, as seen by the operating system calls rather than =
Lisp
+(defun* native-namestring (x)
+  "From a non-wildcard CL pathname, a return namestring suitable for passi=
ng to the operating system"
+  (when x
+    (let ((p (pathname x)))
+      #+clozure (with-pathname-defaults () (ccl:native-translated-namestri=
ng p)) ; see ccl bug 978
+      #+(or cmu scl) (ext:unix-namestring p nil)
+      #+sbcl (sb-ext:native-namestring p)
+      #-(or clozure cmu sbcl scl)
+      (if (os-unix-p) (unix-namestring p)
+          (namestring p)))))
+
+(defun* parse-native-namestring (string &rest constraints &key ensure-dire=
ctory &allow-other-keys)
+  "From a native namestring suitable for use by the operating system, retu=
rn
+a CL pathname satisfying all the specified constraints as per ENSURE-PATHN=
AME"
+  (check-type string (or string null))
+  (let* ((pathname
+           (when string
+             (with-pathname-defaults ()
+               #+clozure (ccl:native-to-pathname string)
+               #+sbcl (sb-ext:parse-native-namestring string)
+               #-(or clozure sbcl)
+               (if (os-unix-p)
+                   (parse-unix-namestring string :ensure-directory ensure-=
directory)
+                   (parse-namestring string)))))
+         (pathname
+           (if ensure-directory
+               (and pathname (ensure-directory-pathname pathname))
+               pathname)))
+    (apply 'ensure-pathname pathname constraints)))
+
+
+;;; Probing the filesystem
+(defun* truename* (p)
+  ;; avoids both logical-pathname merging and physical resolution issues
+  (and p (handler-case (with-pathname-defaults () (truename p)) (file-erro=
r () nil))))
 =

 (defun* safe-file-write-date (pathname)
   ;; If FILE-WRITE-DATE returns NIL, it's possible that
   ;; the user or some other agent has deleted an input file.
   ;; Also, generated files will not exist at the time planning is done
-  ;; and calls operation-done-p which calls safe-file-write-date.
+  ;; and calls compute-action-stamp which calls safe-file-write-date.
   ;; So it is very possible that we can't get a valid file-write-date,
   ;; and we can survive and we will continue the planning
   ;; as if the file were very old.
   ;; (or should we treat the case in a different, special way?)
-  (or (and pathname (probe-file* pathname) (ignore-errors (file-write-date=
 pathname)))
-      (progn
-        (when (and pathname *asdf-verbose*)
-          (warn (compatfmt "~@<Missing FILE-WRITE-DATE for ~S, treating it=
 as zero.~@:>")
-                pathname))
-        0)))
-
-(defmethod find-system ((name null) &optional (error-p t))
-  (declare (ignorable name))
-  (when error-p
-    (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
-
-(defmethod find-system (name &optional (error-p t))
-  (find-system (coerce-name name) error-p))
-
-(defvar *systems-being-defined* nil
-  "A hash-table of systems currently being defined keyed by name, or NIL")
-
-(defun* find-system-if-being-defined (name)
-  (when *systems-being-defined*
-    (gethash (coerce-name name) *systems-being-defined*)))
-
-(defun* call-with-system-definitions (thunk)
-  (if *systems-being-defined*
-      (funcall thunk)
-      (let ((*systems-being-defined* (make-hash-table :test 'equal)))
-        (funcall thunk))))
-
-(defmacro with-system-definitions ((&optional) &body body)
-  `(call-with-system-definitions #'(lambda () , at body)))
-
-(defun* load-sysdef (name pathname)
-  ;; Tries to load system definition with canonical NAME from PATHNAME.
-  (with-system-definitions ()
-    (let ((package (make-temporary-package)))
-      (unwind-protect
-           (handler-bind
-               ((error #'(lambda (condition)
-                           (error 'load-system-definition-error
-                                  :name name :pathname pathname
-                                  :condition condition))))
-             (let ((*package* package)
-                   (*default-pathname-defaults*
-                    ;; resolve logical-pathnames so they won't wreak havoc=
 in parsing namestrings.
-                    (pathname-directory-pathname (translate-logical-pathna=
me pathname)))
-                   (external-format (encoding-external-format (detect-enco=
ding pathname))))
-               (asdf-message (compatfmt "~&~@<; ~@;Loading system definiti=
on from ~A into ~A~@:>~%")
-                             pathname package)
-               (load pathname :external-format external-format)))
-        (delete-package package)))))
-
-(defun* locate-system (name)
-  "Given a system NAME designator, try to locate where to load the system =
from.
-Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
-FOUNDP is true when a system 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,
-either 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 l=
oaded."
-  (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))))
-         (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)))
-        (setf pathname (ensure-pathname-absolute pathname))
-        (when found-system
-          (%set-system-source-file pathname found-system)))
-      (when (and previous (not (#-cormanlisp equal #+cormanlisp equalp
-                                             (system-source-file previous)=
 pathname)))
-        (%set-system-source-file pathname previous)
-        (setf previous-time nil))
-      (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 prev=
ious-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 mean=
s some clock is skewed
-                           ;; and trying to load might cause an infinite l=
oop.
-                           (< previous-time (safe-file-write-date pathname=
) (get-universal-time))))
-              (load-sysdef name pathname))
-            (let ((in-memory (system-registered-p name))) ; try again afte=
r 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 (compatfmt "~@<Retry finding system ~A after=
 reinitializing the source-registry.~@:>") name))
-          (initialize-source-registry))))))
-
-(defun* find-system-fallback (requested fallback &rest keys &key source-fi=
le &allow-other-keys)
-  (setf fallback (coerce-name fallback)
-        requested (coerce-name requested))
-  (when (equal requested fallback)
-    (let ((registered (cdr (gethash fallback *defined-systems*))))
-      (or registered
-          (apply 'make-instance 'system
-                 :name fallback :source-file source-file keys)))))
-
-(defun* sysdef-find-asdf (name)
-  ;; Bug: :version *asdf-version* won't be updated when ASDF is updated.
-  (find-system-fallback name "asdf" :version *asdf-version*))
-
-
-;;;; ---------------------------------------------------------------------=
----
-;;;; Finding components
-
-(defmethod find-component ((base string) path)
-  (let ((s (find-system base nil)))
-    (and s (find-component s path))))
-
-(defmethod find-component ((base symbol) path)
-  (cond
-    (base (find-component (coerce-name base) path))
-    (path (find-component path nil))
-    (t    nil)))
-
-(defmethod find-component ((base cons) path)
-  (find-component (car base) (cons (cdr base) path)))
-
-(defmethod find-component ((module module) (name string))
-  (unless (slot-boundp module 'components-by-name) ;; SBCL may miss the u-=
i-f-r-c method!!!
-    (compute-module-components-by-name module))
-  (values (gethash name (module-components-by-name module))))
-
-(defmethod find-component ((component component) (name symbol))
-  (if name
-      (find-component component (coerce-name name))
-      component))
-
-(defmethod find-component ((module module) (name cons))
-  (find-component (find-component module (car name)) (cdr name)))
-
-
-;;; component subclasses
-
-(defclass source-file (component)
-  ((type :accessor source-file-explicit-type :initarg :type :initform nil)=
))
-
-(defclass cl-source-file (source-file)
-  ((type :initform "lisp")))
-(defclass cl-source-file.cl (cl-source-file)
-  ((type :initform "cl")))
-(defclass cl-source-file.lsp (cl-source-file)
-  ((type :initform "lsp")))
-(defclass c-source-file (source-file)
-  ((type :initform "c")))
-(defclass java-source-file (source-file)
-  ((type :initform "java")))
-(defclass static-file (source-file) ())
-(defclass doc-file (static-file) ())
-(defclass html-file (doc-file)
-  ((type :initform "html")))
-
-(defmethod source-file-type ((component module) (s module))
-  (declare (ignorable component s))
-  :directory)
-(defmethod source-file-type ((component source-file) (s module))
-  (declare (ignorable s))
-  (source-file-explicit-type component))
-
-(defmethod component-relative-pathname ((component component))
-  (coerce-pathname
-   (or (slot-value component 'relative-pathname)
-       (component-name component))
-   :type (source-file-type component (component-system component))
-   :defaults (component-parent-pathname component)))
-
-;;;; ---------------------------------------------------------------------=
----
-;;;; Operations
-
-;;; one of these is instantiated whenever #'operate is called
-
-(defclass operation ()
-  (;; as of danb's 2003-03-16 commit e0d02781, :force can be:
-   ;; T to force the inside of the specified system,
-   ;;   but not recurse to other systems we depend on.
-   ;; :ALL (or any other atom) to force all systems
-   ;;   including other systems we depend on.
-   ;; (SYSTEM1 SYSTEM2 ... SYSTEMN)
-   ;;   to force systems named in a given list
-   ;; However, but this feature has only ever worked but starting with ASD=
F 2.014.5
-   (forced :initform nil :initarg :force :accessor operation-forced)
-   (forced-not :initform nil :initarg :force-not :accessor operation-force=
d-not)
-   (original-initargs :initform nil :initarg :original-initargs
-                      :accessor operation-original-initargs)
-   (visited-nodes :initform (make-hash-table :test 'equal) :accessor opera=
tion-visited-nodes)
-   (visiting-nodes :initform (make-hash-table :test 'equal) :accessor oper=
ation-visiting-nodes)
-   (parent :initform nil :initarg :parent :accessor operation-parent)))
-
-(defmethod print-object ((o operation) stream)
-  (print-unreadable-object (o stream :type t :identity t)
-    (ignore-errors
-      (prin1 (operation-original-initargs o) stream))))
-
-(defmethod shared-initialize :after ((operation operation) slot-names
-                                     &key force force-not
-                                     &allow-other-keys)
-  ;; the &allow-other-keys disables initarg validity checking
-  (declare (ignorable operation slot-names force force-not))
-  (macrolet ((frob (x) ;; normalize forced and forced-not slots
-               `(when (consp (,x operation))
-                  (setf (,x operation)
-                        (mapcar #'coerce-name (,x operation))))))
-    (frob operation-forced) (frob operation-forced-not))
-  (values))
-
-(defun* node-for (o c)
-  (cons (class-name (class-of o)) c))
-
-(defmethod operation-ancestor ((operation operation))
-  (aif (operation-parent operation)
-       (operation-ancestor it)
-       operation))
-
-
-(defun* make-sub-operation (c o dep-c dep-o)
-  "C is a component, O is an operation, DEP-C is another
-component, and DEP-O, confusingly enough, is an operation
-class specifier, not an operation."
-  (let* ((args (copy-list (operation-original-initargs o)))
-         (force-p (getf args :force)))
-    ;; note explicit comparison with T: any other non-NIL force value
-    ;; (e.g. :recursive) will pass through
-    (cond ((and (null (component-parent c))
-                (null (component-parent dep-c))
-                (not (eql c dep-c)))
-           (when (eql force-p t)
-             (setf (getf args :force) nil))
-           (apply 'make-instance dep-o
-                  :parent o
-                  :original-initargs args args))
-          ((subtypep (type-of o) dep-o)
-           o)
-          (t
-           (apply 'make-instance dep-o
-                  :parent o :original-initargs args args)))))
-
-
-(defmethod visit-component ((o operation) (c component) data)
-  (unless (component-visited-p o c)
-    (setf (gethash (node-for o c)
-                   (operation-visited-nodes (operation-ancestor o)))
-          (cons t data))))
-
-(defmethod component-visited-p ((o operation) (c component))
-  (gethash (node-for o c)
-           (operation-visited-nodes (operation-ancestor o))))
-
-(defmethod (setf visiting-component) (new-value operation component)
-  ;; MCL complains about unused lexical variables
-  (declare (ignorable operation component))
-  new-value)
-
-(defmethod (setf visiting-component) (new-value (o operation) (c component=
))
-  (let ((node (node-for o c))
-        (a (operation-ancestor o)))
-    (if new-value
-        (setf (gethash node (operation-visiting-nodes a)) t)
-        (remhash node (operation-visiting-nodes a)))
-    new-value))
-
-(defmethod component-visiting-p ((o operation) (c component))
-  (let ((node (node-for o c)))
-    (gethash node (operation-visiting-nodes (operation-ancestor o)))))
-
-(defmethod component-depends-on ((op-spec symbol) (c component))
-  ;; Note: we go from op-spec to operation via make-instance
-  ;; to allow for specialization through defmethod's, even though
-  ;; it's a detour in the default case below.
-  (component-depends-on (make-instance op-spec) c))
-
-(defmethod component-depends-on ((o operation) (c component))
-  (cdr (assoc (type-of o) (component-in-order-to c))))
-
-(defmethod component-self-dependencies ((o operation) (c component))
-  (remove-if-not
-   #'(lambda (x) (member (component-name c) (cdr x) :test #'string=3D))
-   (component-depends-on o c)))
-
-(defmethod input-files ((operation operation) (c component))
-  (let ((parent (component-parent c))
-        (self-deps (component-self-dependencies operation c)))
-    (if self-deps
-        (mapcan #'(lambda (dep)
-                    (destructuring-bind (op name) dep
-                      (output-files (make-instance op)
-                                    (find-component parent name))))
-                self-deps)
-        ;; no previous operations needed?  I guess we work with the
-        ;; original source file, then
-        (list (component-pathname c)))))
-
-(defmethod input-files ((operation operation) (c module))
-  (declare (ignorable operation c))
-  nil)
-
-(defmethod component-operation-time (o c)
-  (gethash (type-of o) (component-operation-times c)))
-
-(defmethod operation-done-p ((o operation) (c component))
-  (let ((out-files (output-files o c))
-        (in-files (input-files o c))
-        (op-time (component-operation-time o c)))
-    (flet ((earliest-out ()
-             (reduce #'min (mapcar #'safe-file-write-date out-files)))
-           (latest-in ()
-             (reduce #'max (mapcar #'safe-file-write-date in-files))))
-      (cond
-        ((and (not in-files) (not out-files))
-         ;; arbitrary decision: an operation that uses nothing to
-         ;; produce nothing probably isn't doing much.
-         ;; e.g. operations on systems, modules that have no immediate act=
ion,
-         ;; but are only meaningful through traversed dependencies
-         t)
-        ((not out-files)
-         ;; an operation without output-files is probably meant
-         ;; for its side-effects in the current image,
-         ;; assumed to be idem-potent,
-         ;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE.
-         (and op-time (>=3D op-time (latest-in))))
-        ((not in-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.
-         ;; (I don't think there is any such case in ASDF unless extended)
-         nil)
-        (t
-         ;; an operation with both input and output files is assumed
-         ;; as computing the latter from the former,
-         ;; assumed to have been done if the latter are all older
-         ;; than the former.
-         ;; e.g. COMPILE-OP of some CL-SOURCE-FILE.
-         ;; We use >=3D instead of > to play nice with generated files.
-         ;; This opens a race condition if an input file is changed
-         ;; after the output is created but within the same second
-         ;; of filesystem time; but the same race condition exists
-         ;; whenever the computation from input to output takes more
-         ;; than one second of filesystem time (or just crosses the
-         ;; second). So that's cool.
-         (and
-          (every #'probe-file* in-files)
-          (every #'probe-file* out-files)
-          (>=3D (earliest-out) (latest-in))))))))
-
-
-
-;;; For 1.700 I've done my best to refactor TRAVERSE
-;;; by splitting it up in a bunch of functions,
-;;; so as to improve the collection and use-detection algorithm. --fare
-;;; The protocol is as follows: we pass around operation, dependency,
-;;; bunch of other stuff, and a force argument. Return a force flag.
-;;; The returned flag is T if anything has changed that requires a rebuild.
-;;; The force argument is a list of components that will require a rebuild
-;;; if the flag is T, at which point whoever returns the flag has to
-;;; mark them all as forced, and whoever recurses again can use a NIL list
-;;; as a further argument.
-
-(defvar *forcing* nil
-  "This dynamically-bound variable is used to force operations in
-recursive calls to traverse.")
-
-(defgeneric* do-traverse (operation component collect))
-
-(defun* resolve-dependency-name (component name &optional version)
-  (loop
-    (restart-case
-        (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 (compatfmt "~@<Retry loading ~3i~_~A.~@:>") na=
me))
-        :test
-        (lambda (c)
-          (or (null c)
-              (and (typep c 'missing-dependency)
-                   (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 (extensibl=
y)
-    ;; 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 depen=
dencies! 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 (:vers=
ion <name> <version>), (:feature <feature> <name>), or <name>.~@:>") dep-sp=
ec))))
-
-(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 u=
s.
-  ;; 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-s=
pecs
-  ;; as dependencies of a larger plan involving op and c.
-  ;; Returns t if this should force recompilation of those who depend on u=
s.
-  ;; dep-op-spec is either an operation class name (not an operation objec=
t),
-  ;; or the magic symbol asdf:feature.
-  ;; If dep-op-spec is asdf:feature, then the first dep-c-specs is a keywo=
rd,
-  ;; 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 (list :feature (car dep-c-specs)))))
-        (t
-         (let ((flag nil))
-           (dolist (d dep-c-specs)
-             (when (do-one-dep op c collect dep-op-spec
-                               (resolve-dependency-spec c d))
-               (setf flag t)))
-           flag))))
-
-(defvar *visit-count* 0) ; counter that allows to sort nodes from operatio=
n-visited-nodes
-
-(defun* do-collect (collect x)
-  (funcall collect x))
-
-(defmethod do-traverse ((operation operation) (c component) collect)
-  (let ((*forcing* *forcing*)
-        (flag nil)) ;; return value: must we rebuild this and its dependen=
cies?
-    (labels
-        ((update-flag (x)
-           (orf flag x))
-         (dep (op comp)
-           (update-flag (do-dep operation c collect op comp))))
-      ;; Have we been visited yet? If so, just process the result.
-      (aif (component-visited-p operation c)
-           (progn
-             (update-flag (cdr it))
-             (return-from do-traverse flag)))
-      ;; dependencies
-      (when (component-visiting-p operation c)
-        (error 'circular-dependency :components (list c)))
-      (setf (visiting-component operation c) t)
-      (unwind-protect
-           (block nil
-             (when (typep c 'system) ;; systems can be forced or forced-not
-               (let ((ancestor (operation-ancestor operation)))
-                 (flet ((match? (f)
-                          (and f (or (not (consp f)) ;; T or :ALL
-                                     (member (component-name c) f :test #'=
equal)))))
-                   (cond
-                     ((match? (operation-forced ancestor))
-                      (setf *forcing* t))
-                     ((match? (operation-forced-not ancestor))
-                      (return))))))
-             ;; first we check and do all the dependencies for the module.
-             ;; Operations planned in this loop will show up
-             ;; in the results, and are consumed below.
-             (let ((*forcing* nil))
-               ;; upstream dependencies are never forced to happen just be=
cause
-               ;; the things that depend on them are....
-               (loop
-                 :for (required-op . deps) :in (component-depends-on opera=
tion c)
-                 :do (dep required-op deps)))
-             ;; constituent bits
-             (let ((module-ops
-                    (when (typep c 'module)
-                      (let ((at-least-one nil)
-                            ;; This is set based on the results of the
-                            ;; dependencies and whether we are in the
-                            ;; context of a *forcing* call...
-                            ;; inter-system dependencies do NOT trigger
-                            ;; building components
-                            (*forcing*
-                             (or *forcing*
-                                 (and flag (not (typep c 'system)))))
-                            (error nil))
-                        (while-collecting (internal-collect)
-                          (dolist (kid (module-components c))
-                            (handler-case
-                                (update-flag
-                                 (do-traverse operation kid #'internal-col=
lect))
-                              #-genera
-                              (missing-dependency (condition)
-                                (when (eq (module-if-component-dep-fails c)
-                                          :fail)
-                                  (error condition))
-                                (setf error condition))
-                              (:no-error (c)
-                                (declare (ignore c))
-                                (setf at-least-one t))))
-                          (when (and (eq (module-if-component-dep-fails c)
-                                         :try-next)
-                                     (not at-least-one))
-                            (error error)))))))
-               (update-flag (or *forcing* (not (operation-done-p operation=
 c))))
-                 ;; For sub-operations, check whether
-                 ;; the original ancestor operation was forced,
-                 ;; or names us amongst an explicit list of things to forc=
e...
-                 ;; except that this check doesn't distinguish
-                 ;; between all the things with a given name. Sigh.
-                 ;; BROKEN!
-               (when flag
-                 (let ((do-first (cdr (assoc (class-name (class-of operati=
on))
-                                             (component-do-first c)))))
-                   (loop :for (required-op . deps) :in do-first
-                     :do (do-dep operation c collect required-op deps)))
-                 (do-collect collect (vector module-ops))
-                 (do-collect collect (cons operation c)))))
-        (setf (visiting-component operation c) nil)))
-    (visit-component operation c (when flag (incf *visit-count*)))
-    flag))
-
-(defun* flatten-tree (l)
-  ;; You collected things into a list.
-  ;; Most elements are just things to collect again.
-  ;; A (simple-vector 1) indicate that you should recurse into its content=
s.
-  ;; This way, in two passes (rather than N being the depth of the tree),
-  ;; you can collect things with marginally constant-time append,
-  ;; achieving linear time collection instead of quadratic time.
-  (while-collecting (c)
-    (labels ((r (x)
-               (if (typep x '(simple-vector 1))
-                   (r* (svref x 0))
-                   (c x)))
-             (r* (l)
-               (dolist (x l) (r x))))
-      (r* l))))
-
-(defmethod traverse ((operation operation) (c component))
-  (flatten-tree
-   (while-collecting (collect)
-     (let ((*visit-count* 0))
-       (do-traverse operation c #'collect)))))
-
-(defmethod perform ((operation operation) (c source-file))
-  (sysdef-error
-   (compatfmt "~@<Required method PERFORM not implemented for operation ~A=
, component ~A~@:>")
-   (class-of operation) (class-of c)))
-
-(defmethod perform ((operation operation) (c module))
-  (declare (ignorable operation c))
-  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 su=
ccessful.~@:>")
-                  (operation-description operation component)))
-        (mark-operation-done operation component)
-        (return)))))
-
-(defmethod explain ((operation operation) (component component))
-  (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%")
-                (operation-description operation component)))
-
-(defmethod operation-description (operation component)
-  (format nil (compatfmt "~@<~A on ~A~@:>")
-          (class-of operation) component))
-
-;;;; ---------------------------------------------------------------------=
----
-;;;; compile-op
-
-(defclass compile-op (operation)
-  ((proclamations :initarg :proclamations :accessor compile-op-proclamatio=
ns :initform nil)
-   (on-warnings :initarg :on-warnings :accessor operation-on-warnings
-                :initform *compile-file-warnings-behaviour*)
-   (on-failure :initarg :on-failure :accessor operation-on-failure
-               :initform *compile-file-failure-behaviour*)
-   (flags :initarg :flags :accessor compile-op-flags
-          :initform nil)))
-
-(defun* output-file (operation component)
-  "The unique output file of performing OPERATION on COMPONENT"
-  (let ((files (output-files operation component)))
-    (assert (length=3Dn-p files 1))
-    (first files)))
-
+  (handler-case (file-write-date (translate-logical-pathname pathname)) (f=
ile-error () nil)))
+
+(defun* probe-file* (p &key truename)
+  "when given a pathname P (designated by a string as per PARSE-NAMESTRING=
),
+probes the filesystem for a file or directory with given pathname.
+If it exists, return its truename is ENSURE-PATHNAME is true,
+or the original (parsed) pathname if it is false (the default)."
+  (with-pathname-defaults () ;; avoids logical-pathname issues on some imp=
lementations
+    (etypecase p
+      (null nil)
+      (string (probe-file* (parse-namestring p) :truename truename))
+      (pathname
+       (handler-case
+           (or
+            #+allegro
+            (probe-file p :follow-symlinks truename)
+            #-(or allegro clisp gcl2.6)
+            (if truename
+                (probe-file p)
+                (and (not (wild-pathname-p p))
+                     (ignore-errors
+                      (let ((pp (translate-logical-pathname p)))
+                        #+(or cmu scl) (unix:unix-stat (ext:unix-namestrin=
g pp))
+                        #+(and lispworks unix) (system:get-file-stat pp)
+                        #+sbcl (sb-unix:unix-stat (sb-ext:native-namestrin=
g pp))
+                        #-(or cmu (and lispworks unix) sbcl scl) (file-wri=
te-date pp)))
+                     p))
+            #+(or clisp gcl2.6)
+            #.(flet ((probe (probe)
+                       `(let ((foundtrue ,probe))
+                          (cond
+                            (truename foundtrue)
+                            (foundtrue p)))))
+                #+gcl2.6
+                (probe '(or (probe-file p)
+                         (and (directory-pathname-p p)
+                          (ignore-errors
+                           (ensure-directory-pathname
+                            (truename* (subpathname
+                                        (ensure-directory-pathname p) ".")=
))))))
+                #+clisp
+                (let* ((fs (find-symbol* '#:file-stat :posix nil))
+                       (pp (find-symbol* '#:probe-pathname :ext nil))
+                       (resolve (if pp
+                                    `(ignore-errors (,pp p))
+                                    '(or (truename* p)
+                                      (truename* (ignore-errors (ensure-di=
rectory-pathname p)))))))
+                  (if fs
+                      `(if truename
+                           ,resolve
+                           (and (ignore-errors (,fs p)) p))
+                      (probe resolve)))))
+         (file-error () nil))))))
+
+(defun* directory* (pathname-spec &rest keys &key &allow-other-keys)
+  (apply 'directory pathname-spec
+         (append keys '#.(or #+allegro '(:directories-are-files nil :follo=
w-symbolic-links nil)
+                             #+clozure '(:follow-links nil)
+                             #+clisp '(:circle t :if-does-not-exist :ignor=
e)
+                             #+(or cmu scl) '(:follow-links nil :truenamep=
 nil)
+                             #+sbcl (when (find-symbol* :resolve-symlinks =
'#:sb-impl nil)
+                                      '(:resolve-symlinks nil))))))
+
+(defun* filter-logical-directory-results (directory entries merger)
+  (if (logical-pathname-p directory)
+      ;; Try hard to not resolve logical-pathname into physical pathnames;
+      ;; otherwise logical-pathname users/lovers will be disappointed.
+      ;; If directory* could use some implementation-dependent magic,
+      ;; we will have logical pathnames already; otherwise,
+      ;; we only keep pathnames for which specifying the name and
+      ;; translating the LPN commute.
+      (loop :for f :in entries
+        :for p =3D (or (and (logical-pathname-p f) f)
+                     (let* ((u (ignore-errors (funcall merger f))))
+                       ;; The first u avoids a cumbersome (truename u) err=
or.
+                       ;; At this point f should already be a truename,
+                       ;; but isn't quite in CLISP, for it doesn't have :v=
ersion :newest
+                       (and u (equal (truename* u) (truename* f)) u)))
+        :when p :collect p)
+      entries))
+
+(defun* directory-files (directory &optional (pattern *wild-file*))
+  (let ((dir (pathname directory)))
+    (when (logical-pathname-p dir)
+      ;; Because of the filtering we do below,
+      ;; logical pathnames have restrictions on wild patterns.
+      ;; Not that the results are very portable when you use these pattern=
s on physical pathnames.
+      (when (wild-pathname-p dir)
+        (error "Invalid wild pattern in logical directory ~S" directory))
+      (unless (member (pathname-directory pattern) '(() (:relative)) :test=
 'equal)
+        (error "Invalid file pattern ~S for logical directory ~S" pattern =
directory))
+      (setf pattern (make-pathname-logical pattern (pathname-host dir))))
+    (let ((entries (ignore-errors (directory* (merge-pathnames* pattern di=
r)))))
+      (filter-logical-directory-results
+       directory entries
+       #'(lambda (f)
+           (make-pathname :defaults dir
+                          :name (make-pathname-component-logical (pathname=
-name f))
+                          :type (make-pathname-component-logical (pathname=
-type f))
+                          :version (make-pathname-component-logical (pathn=
ame-version f))))))))
+
+(defun* subdirectories (directory)
+  (let* ((directory (ensure-directory-pathname directory))
+         #-(or abcl cormanlisp genera xcl)
+         (wild (merge-pathnames*
+                #-(or abcl allegro cmu lispworks sbcl scl xcl)
+                *wild-directory*
+                #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
+                directory))
+         (dirs
+          #-(or abcl cormanlisp genera xcl)
+          (ignore-errors
+            (directory* wild . #.(or #+clozure '(:directories t :files nil)
+                                     #+mcl '(:directories t))))
+          #+(or abcl xcl) (system:list-directory directory)
+          #+cormanlisp (cl::directory-subdirs directory)
+          #+genera (fs:directory-list directory))
+         #+(or abcl allegro cmu genera lispworks sbcl scl xcl)
+         (dirs (loop :for x :in dirs
+                 :for d =3D #+(or abcl xcl) (extensions:probe-directory x)
+                          #+allegro (excl:probe-directory 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 (fir=
st x))
+                                  #+(or cmu lispworks sbcl scl) x)))
+    (filter-logical-directory-results
+     directory dirs
+     (let ((prefix (or (normalize-pathname-directory-component (pathname-d=
irectory directory))
+                       '(:absolute)))) ; because allegro returns NIL for #=
p"FOO:"
+       #'(lambda (d)
+           (let ((dir (normalize-pathname-directory-component (pathname-di=
rectory d))))
+             (and (consp dir) (consp (cdr dir))
+                  (make-pathname
+                   :defaults directory :name nil :type nil :version nil
+                   :directory (append prefix (make-pathname-component-logi=
cal (last dir)))))))))))
+
+(defun* collect-sub*directories (directory collectp recursep collector)
+  (when (funcall collectp directory)
+    (funcall collector directory))
+  (dolist (subdir (subdirectories directory))
+    (when (funcall recursep subdir)
+      (collect-sub*directories subdir collectp recursep collector))))
+
+;;; Resolving symlinks somewhat
+(defun* truenamize (pathname)
+  "Resolve as much of a pathname as possible"
+  (block nil
+    (when (typep pathname '(or null logical-pathname)) (return pathname))
+    (let ((p pathname))
+      (unless (absolute-pathname-p p)
+        (setf p (or (absolute-pathname-p (ensure-absolute-pathname p 'get-=
pathname-defaults nil))
+                    (return p))))
+      (when (logical-pathname-p p) (return p))
+      (let ((found (probe-file* p :truename t)))
+        (when found (return found)))
+      (let* ((directory (normalize-pathname-directory-component (pathname-=
directory p)))
+             (up-components (reverse (rest directory)))
+             (down-components ()))
+        (assert (eq :absolute (first directory)))
+        (loop :while up-components :do
+          (if-let (parent (probe-file* (make-pathname* :directory `(:absol=
ute ,@(reverse up-components))
+                                                       :name nil :type nil=
 :version nil :defaults p)))
+            (return (merge-pathnames* (make-pathname* :directory `(:relati=
ve , at down-components)
+                                                      :defaults p)
+                                      (ensure-directory-pathname parent)))
+            (push (pop up-components) down-components))
+          :finally (return p))))))
+
+(defun* resolve-symlinks (path)
+  #-allegro (truenamize path)
+  #+allegro
+  (if (physical-pathname-p path)
+      (or (ignore-errors (excl:pathname-resolve-symbolic-links path)) path)
+      path))
+
+(defvar *resolve-symlinks* t
+  "Determine whether or not ASDF resolves symlinks when defining systems.
+Defaults to T.")
+
+(defun* resolve-symlinks* (path)
+  (if *resolve-symlinks*
+      (and path (resolve-symlinks path))
+      path))
+
+
+;;; Check pathname constraints
+
+(defun* ensure-pathname
+    (pathname &key
+              on-error
+              defaults type dot-dot
+              want-pathname
+              want-logical want-physical ensure-physical
+              want-relative want-absolute ensure-absolute ensure-subpath
+              want-non-wild want-wild wilden
+              want-file want-directory ensure-directory
+              want-existing ensure-directories-exist
+              truename resolve-symlinks truenamize
+              &aux (p pathname)) ;; mutable working copy, preserve original
+  "Coerces its argument into a PATHNAME,
+optionally doing some transformations and checking specified constraints.
+
+If the argument is NIL, then NIL is returned unless the WANT-PATHNAME cons=
traint is specified.
+
+If the argument is a STRING, it is first converted to a pathname via PARSE=
-UNIX-NAMESTRING
+reusing the keywords DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE;
+then the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE =
is true,
+and the all the checks and transformations are run.
+
+Each non-nil constraint argument can be one of the symbols T, ERROR, CERRO=
R or IGNORE.
+The boolean T is an alias for ERROR.
+ERROR means that an error will be raised if the constraint is not satisfie=
d.
+CERROR means that an continuable error will be raised if the constraint is=
 not satisfied.
+IGNORE means just return NIL instead of the pathname.
+
+The ON-ERROR argument, if not NIL, is a function designator (as per CALL-F=
UNCTION)
+that will be called with the the following arguments:
+a generic format string for ensure pathname, the pathname,
+the keyword argument corresponding to the failed check or transformation,
+a format string for the reason ENSURE-PATHNAME failed,
+and a list with arguments to that format string.
+If ON-ERROR is NIL, ERROR is used instead, which does the right thing.
+You could also pass (CERROR \"CONTINUE DESPITE FAILED CHECK\").
+
+The transformations and constraint checks are done in this order,
+which is also the order in the lambda-list:
+
+WANT-PATHNAME checks that pathname (after parsing if needed) is not null.
+Otherwise, if the pathname is NIL, ensure-pathname returns NIL.
+WANT-LOGICAL checks that pathname is a LOGICAL-PATHNAME
+WANT-PHYSICAL checks that pathname is not a LOGICAL-PATHNAME
+ENSURE-PHYSICAL ensures that pathname is physical via TRANSLATE-LOGICAL-PA=
THNAME
+WANT-RELATIVE checks that pathname has a relative directory component
+WANT-ABSOLUTE checks that pathname does have an absolute directory compone=
nt
+ENSURE-ABSOLUTE merges with the DEFAULTS, then checks again
+that the result absolute is an absolute pathname indeed.
+ENSURE-SUBPATH checks that the pathname is a subpath of the DEFAULTS.
+WANT-FILE checks that pathname has a non-nil FILE component
+WANT-DIRECTORY checks that pathname has nil FILE and TYPE components
+ENSURE-DIRECTORY uses ENSURE-DIRECTORY-PATHNAME to interpret
+any file and type components as being actually a last directory component.
+WANT-NON-WILD checks that pathname is not a wild pathname
+WANT-WILD checks that pathname is a wild pathname
+WILDEN merges the pathname with **/*.*.* if it is not wild
+WANT-EXISTING checks that a file (or directory) exists with that pathname.
+ENSURE-DIRECTORIES-EXIST creates any parent directory with ENSURE-DIRECTOR=
IES-EXIST.
+TRUENAME replaces the pathname by its truename, or errors if not possible.
+RESOLVE-SYMLINKS replaces the pathname by a variant with symlinks resolved=
 by RESOLVE-SYMLINKS.
+TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
+  (block nil
+    (flet ((report-error (keyword description &rest arguments)
+             (call-function (or on-error 'error)
+                            "Invalid pathname ~S: ~*~?"
+                            pathname keyword description arguments)))
+      (macrolet ((err (constraint &rest arguments)
+                   `(report-error ',(intern* constraint :keyword) , at argume=
nts))
+                 (check (constraint condition &rest arguments)
+                   `(when ,constraint
+                      (unless ,condition (err ,constraint , at arguments))))
+                 (transform (transform condition expr)
+                   `(when ,transform
+                      (,@(if condition `(when ,condition) '(progn))
+                       (setf p ,expr)))))
+        (etypecase p
+          ((or null pathname))
+          (string
+           (setf p (parse-unix-namestring
+                    p :defaults defaults :type type :dot-dot dot-dot
+                    :ensure-directory ensure-directory :want-relative want=
-relative))))
+        (check want-pathname (pathnamep p) "Expected a pathname, not NIL")
+        (unless (pathnamep p) (return nil))
+        (check want-logical (logical-pathname-p p) "Expected a logical pat=
hname")
+        (check want-physical (physical-pathname-p p) "Expected a physical =
pathname")
+        (transform ensure-physical () (translate-logical-pathname p))
+        (check ensure-physical (physical-pathname-p p) "Could not translat=
e to a physical pathname")
+        (check want-relative (relative-pathname-p p) "Expected a relative =
pathname")
+        (check want-absolute (absolute-pathname-p p) "Expected an absolute=
 pathname")
+        (transform ensure-absolute (not (absolute-pathname-p p)) (merge-pa=
thnames* p defaults))
+        (check ensure-absolute (absolute-pathname-p p)
+               "Could not make into an absolute pathname even after mergin=
g with ~S" defaults)
+        (check ensure-subpath (absolute-pathname-p defaults)
+               "cannot be checked to be a subpath of non-absolute pathname=
 ~S" defaults)
+        (check ensure-subpath (subpathp p defaults) "is not a sub pathname=
 of ~S" defaults)
+        (check want-file (file-pathname-p p) "Expected a file pathname")
+        (check want-directory (directory-pathname-p p) "Expected a directo=
ry pathname")
+        (transform ensure-directory (not (directory-pathname-p p)) (ensure=
-directory-pathname p))
+        (check want-non-wild (not (wild-pathname-p p)) "Expected a non-wil=
dcard pathname")
+        (check want-wild (wild-pathname-p p) "Expected a wildcard pathname=
")
+        (transform wilden (not (wild-pathname-p p)) (wilden p))
+        (when want-existing
+          (let ((existing (probe-file* p :truename truename)))
+            (if existing
+                (when truename
+                  (return existing))
+                (err want-existing "Expected an existing pathname"))))
+        (when ensure-directories-exist (ensure-directories-exist p))
+        (when truename
+          (let ((truename (truename* p)))
+            (if truename
+                (return truename)
+                (err truename "Can't get a truename for pathname"))))
+        (transform resolve-symlinks () (resolve-symlinks p))
+        (transform truenamize () (truenamize p))
+        p))))
+
+
+;;; Pathname defaults
+(defun* get-pathname-defaults (&optional (defaults *default-pathname-defau=
lts*))
+  (or (absolute-pathname-p defaults)
+      (merge-pathnames* defaults (getcwd))))
+
+(defun* call-with-current-directory (dir thunk)
+  (if dir
+      (let* ((dir (resolve-symlinks* (get-pathname-defaults (pathname-dire=
ctory-pathname dir))))
+             (*default-pathname-defaults* dir)
+             (cwd (getcwd)))
+        (chdir dir)
+        (unwind-protect
+             (funcall thunk)
+          (chdir cwd)))
+      (funcall thunk)))
+
+(defmacro with-current-directory ((&optional dir) &body body)
+  "Call BODY while the POSIX current working directory is set to DIR"
+  `(call-with-current-directory ,dir #'(lambda () , at body)))
+
+
+;;; Environment pathnames
+(defun* inter-directory-separator ()
+  (if (os-unix-p) #\: #\;))
+
+(defun* split-native-pathnames-string (string &rest constraints &key &allo=
w-other-keys)
+  (loop :for namestring :in (split-string string :separator (string (inter=
-directory-separator)))
+        :collect (apply 'parse-native-namestring namestring constraints)))
+
+(defun* getenv-pathname (x &rest constraints &key on-error &allow-other-ke=
ys)
+  (apply 'parse-native-namestring (getenvp x)
+         :on-error (or on-error
+                       `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" g=
etenv-pathname ,x))
+         constraints))
+(defun* getenv-pathnames (x &rest constraints &key on-error &allow-other-k=
eys)
+  (apply 'split-native-pathnames-string (getenvp x)
+         :on-error (or on-error
+                       `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" g=
etenv-pathnames ,x))
+         constraints))
+(defun* getenv-absolute-directory (x)
+  (getenv-pathname x :want-absolute t :ensure-directory t))
+(defun* getenv-absolute-directories (x)
+  (getenv-pathnames x :want-absolute t :ensure-directory t))
+
+(defun* lisp-implementation-directory (&key truename)
+  (declare (ignorable truename))
+  #+(or clozure ecl gcl mkcl sbcl)
+  (let ((dir
+          (ignore-errors
+           #+clozure #p"ccl:"
+           #+(or ecl mkcl) #p"SYS:"
+           #+gcl system::*system-directory*
+           #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int=
 nil))
+                     (funcall it)
+                     (getenv-pathname "SBCL_HOME" :ensure-directory t)))))
+    (if (and dir truename)
+        (truename* dir)
+        dir)))
+
+(defun* lisp-implementation-pathname-p (pathname)
+  ;; Other builtin systems are those under the implementation directory
+  (and (when pathname
+         (if-let (impdir (lisp-implementation-directory))
+           (or (subpathp pathname impdir)
+               (when *resolve-symlinks*
+                 (if-let (truename (truename* pathname))
+                   (if-let (trueimpdir (truename* impdir))
+                     (subpathp truename trueimpdir)))))))
+       t))
+
+
+;;; Simple filesystem operations
 (defun* ensure-all-directories-exist (pathnames)
    (dolist (pathname pathnames)
      (ensure-directories-exist (translate-logical-pathname pathname))))
 =

-(defmethod perform :before ((operation compile-op) (c source-file))
-  (ensure-all-directories-exist (output-files operation c)))
-
-(defmethod perform :after ((operation operation) (c component))
-  (mark-operation-done operation c))
-
-(defgeneric* around-compile-hook (component))
-(defgeneric* call-with-around-compile-hook (component thunk))
-
-(defmethod around-compile-hook ((c component))
+(defun* rename-file-overwriting-target (source target)
+  #+clisp ;; But for a bug in CLISP 2.48, we should use :if-exists :overwr=
ite and be atomic
+  (posix:copy-file source target :method :rename)
+  #-clisp
+  (rename-file source target
+               #+clozure :if-exists #+clozure :rename-and-delete))
+
+(defun* delete-file-if-exists (x)
+  (when x (handler-case (delete-file x) (file-error () nil))))
+
+
+;;;; ---------------------------------------------------------------------=
------
+;;;; Utilities related to streams
+
+(asdf/package:define-package :asdf/stream
+  (:recycle :asdf/stream)
+  (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os :asdf/pathn=
ame :asdf/filesystem)
+  (:export
+   #:*default-stream-element-type* #:*stderr* #:setup-stderr
+   #:with-safe-io-syntax #:call-with-safe-io-syntax
+   #:with-output #:output-string #:with-input
+   #:with-input-file #:call-with-input-file
+   #:finish-outputs #:format! #:safe-format!
+   #:copy-stream-to-stream #:concatenate-files
+   #:copy-stream-to-stream-line-by-line
+   #:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line
+   #:slurp-stream-forms #:slurp-stream-form
+   #:read-file-string #:read-file-lines #:read-file-forms #:read-file-form=
 #:safe-read-file-form
+   #:eval-input #:eval-thunk #:standard-eval-thunk
+   #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding
+   #:encoding-external-format #:*encoding-external-format-hook* #:default-=
encoding-external-format
+   #:*default-encoding* #:*utf-8-external-format*
+   ;; Temporary files
+   #:*temporary-directory* #:temporary-directory #:default-temporary-direc=
tory
+   #:setup-temporary-directory
+   #:call-with-temporary-file #:with-temporary-file
+   #:add-pathname-suffix #:tmpize-pathname
+   #:call-with-staging-pathname #:with-staging-pathname))
+(in-package :asdf/stream)
+
+(defvar *default-stream-element-type* (or #+(or abcl cmu cormanlisp scl xc=
l) 'character :default)
+  "default element-type for open (depends on the current CL implementation=
)")
+
+(defvar *stderr* *error-output*
+  "the original error output stream at startup")
+
+(defun setup-stderr ()
+  (setf *stderr*
+        #+allegro excl::*stderr*
+        #+clozure ccl::*stderr*
+        #-(or allegro clozure) *error-output*))
+(setup-stderr)
+
+
+;;; Safe syntax
+
+(defvar *standard-readtable* (copy-readtable nil))
+
+(defmacro with-safe-io-syntax ((&key (package :cl)) &body body)
+  "Establish safe CL reader options around the evaluation of BODY"
+  `(call-with-safe-io-syntax #'(lambda () (let ((*package* (find-package ,=
package))) , at body))))
+
+(defun* call-with-safe-io-syntax (thunk &key (package :cl))
+  (with-standard-io-syntax ()
+    (let ((*package* (find-package package))
+          (*readtable* *standard-readtable*)
+          (*read-default-float-format* 'double-float)
+          (*print-readably* nil)
+	  (*read-eval* nil))
+      (funcall thunk))))
+
+
+;;; Output to a stream or string, FORMAT-style
+
+(defun* call-with-output (output function)
+  "Calls FUNCTION with an actual stream argument,
+behaving like FORMAT with respect to how stream designators are interprete=
d:
+If OUTPUT is a stream, use it as the stream.
+If OUTPUT is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the=
 resulting string.
+If OUTPUT is T, use *STANDARD-OUTPUT* as the stream.
+If OUTPUT is a string with a fill-pointer, use it as a string-output-strea=
m.
+Otherwise, signal an error."
+  (etypecase output
+    (null
+     (with-output-to-string (stream) (funcall function stream)))
+    ((eql t)
+     (funcall function *standard-output*))
+    (stream
+     (funcall function output))
+    (string
+     (assert (fill-pointer output))
+     (with-output-to-string (stream output) (funcall function stream)))))
+
+(defmacro with-output ((output-var &optional (value output-var)) &body bod=
y)
+  "Bind OUTPUT-VAR to an output stream, coercing VALUE (default: previous =
binding of OUTPUT-VAR)
+as per FORMAT, and evaluate BODY within the scope of this binding."
+  `(call-with-output ,value #'(lambda (,output-var) , at body)))
+
+(defun* output-string (string &optional output)
+  "If the desired OUTPUT is not NIL, print the string to the output; other=
wise return the string"
+  (if output
+      (with-output (output) (princ string output))
+      string))
+
+
+;;; Input helpers
+
+(defun* call-with-input (input function)
+  "Calls FUNCTION with an actual stream argument, interpreting
+stream designators like READ, but also coercing strings to STRING-INPUT-ST=
REAM.
+If INPUT is a STREAM, use it as the stream.
+If INPUT is NIL, use a *STANDARD-INPUT* as the stream.
+If INPUT is T, use *TERMINAL-IO* as the stream.
+As an extension, if INPUT is a string, use it as a string-input-stream.
+Otherwise, signal an error."
+  (etypecase input
+    (null (funcall function *standard-input*))
+    ((eql t) (funcall function *terminal-io*))
+    (stream (funcall function input))
+    (string (with-input-from-string (stream input) (funcall function strea=
m)))))
+
+(defmacro with-input ((input-var &optional (value input-var)) &body body)
+  "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous bi=
nding of INPUT-VAR)
+as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding=
."
+  `(call-with-input ,value #'(lambda (,input-var) , at body)))
+
+(defun* call-with-input-file (pathname thunk
+                                       &key
+                                       (element-type *default-stream-eleme=
nt-type*)
+                                       (external-format :default)
+                                       (if-does-not-exist :error))
+  "Open FILE for input with given recognizes options, call THUNK with the =
resulting stream.
+Other keys are accepted but discarded."
+  #+gcl2.6 (declare (ignore external-format))
+  (with-open-file (s pathname :direction :input
+                     :element-type element-type
+                     #-gcl2.6 :external-format #-gcl2.6 external-format
+                     :if-does-not-exist if-does-not-exist)
+    (funcall thunk s)))
+
+(defmacro with-input-file ((var pathname &rest keys &key element-type exte=
rnal-format) &body body)
+  (declare (ignore element-type external-format))
+  `(call-with-input-file ,pathname #'(lambda (,var) , at body) , at keys))
+
+
+;;; Ensure output buffers are flushed
+
+(defun* finish-outputs (&rest streams)
+  "Finish output on the main output streams as well as any specified one.
+Useful for portably flushing I/O before user input or program exit."
+  ;; CCL notably buffers its stream output by default.
+  (dolist (s (append streams
+                     (list *stderr* *error-output* *standard-output* *trac=
e-output*
+                           *debug-io* *terminal-io* *debug-io* *query-io*)=
))
+    (ignore-errors (finish-output s)))
+  (values))
+
+(defun* format! (stream format &rest args)
+  "Just like format, but call finish-outputs before and after the output."
+  (finish-outputs stream)
+  (apply 'format stream format args)
+  (finish-output stream))
+
+(defun* safe-format! (stream format &rest args)
+  (with-safe-io-syntax ()
+    (ignore-errors (apply 'format! stream format args))
+    (finish-outputs stream))) ; just in case format failed
+
+
+;;; Simple Whole-Stream processing
+
+
+(defun* copy-stream-to-stream (input output &key element-type buffer-size =
linewise prefix)
+  "Copy the contents of the INPUT stream into the OUTPUT stream.
+If LINEWISE is true, then read and copy the stream line by line, with an o=
ptional PREFIX.
+Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE."
+  (with-open-stream (input input)
+    (if linewise
+        (loop* :for (line eof) =3D (multiple-value-list (read-line input n=
il nil))
+               :while line :do
+               (when prefix (princ prefix output))
+               (princ line output)
+               (unless eof (terpri output))
+               (finish-output output)
+               (when eof (return)))
+        (loop
+          :with buffer-size =3D (or buffer-size 8192)
+          :for buffer =3D (make-array (list buffer-size) :element-type (or=
 element-type 'character))
+          :for end =3D (read-sequence buffer input)
+          :until (zerop end)
+          :do (write-sequence buffer output :end end)
+              (when (< end buffer-size) (return))))))
+
+(defun* concatenate-files (inputs output)
+  (with-open-file (o output :element-type '(unsigned-byte 8)
+                            :direction :output :if-exists :rename-and-dele=
te)
+    (dolist (input inputs)
+      (with-open-file (i input :element-type '(unsigned-byte 8)
+                               :direction :input :if-does-not-exist :error)
+        (copy-stream-to-stream i o :element-type '(unsigned-byte 8))))))
+
+(defun* slurp-stream-string (input &key (element-type 'character))
+  "Read the contents of the INPUT stream as a string"
+  (with-open-stream (input input)
+    (with-output-to-string (output)
+      (copy-stream-to-stream input output :element-type element-type))))
+
+(defun* slurp-stream-lines (input &key count)
+  "Read the contents of the INPUT stream as a list of lines, return those =
lines.
+
+Read no more than COUNT lines."
+  (check-type count (or null integer))
+  (with-open-stream (input input)
+    (loop :for n :from 0
+          :for l =3D (and (or (not count) (< n count))
+                        (read-line input nil nil))
+          :while l :collect l)))
+
+(defun* slurp-stream-line (input &key (at 0))
+  "Read the contents of the INPUT stream as a list of lines,
+then return the ACCESS-AT of that list of lines using the AT specifier.
+PATH defaults to 0, i.e. return the first line.
+PATH is typically an integer, or a list of an integer and a function.
+If PATH is NIL, it will return all the lines in the file.
+
+The stream will not be read beyond the Nth lines,
+where N is the index specified by path
+if path is either an integer or a list that starts with an integer."
+  (access-at (slurp-stream-lines input :count (access-at-count at)) at))
+
+(defun* slurp-stream-forms (input &key count)
+"Read the contents of the INPUT stream as a list of forms,
+and return those forms.
+
+If COUNT is null, read to the end of the stream;
+if COUNT is an integer, stop after COUNT forms were read.
+
+BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
+  (check-type count (or null integer))
+  (loop :with eof =3D '#:eof
+        :for n :from 0
+        :for form =3D (if (and count (>=3D n count))
+                        eof
+                        (read-preserving-whitespace input nil eof))
+        :until (eq form eof) :collect form))
+
+(defun* slurp-stream-form (input &key (at 0))
+"Read the contents of the INPUT stream as a list of forms,
+then return the ACCESS-AT of these forms following the AT.
+AT defaults to 0, i.e. return the first form.
+AT is typically a list of integers.
+If AT is NIL, it will return all the forms in the file.
+
+The stream will not be read beyond the Nth form,
+where N is the index specified by path,
+if path is either an integer or a list that starts with an integer.
+
+BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
+  (access-at (slurp-stream-forms input :count (access-at-count at)) at))
+
+(defun* read-file-string (file &rest keys)
+  "Open FILE with option KEYS, read its contents as a string"
+  (apply 'call-with-input-file file 'slurp-stream-string keys))
+
+(defun* read-file-lines (file &rest keys)
+  "Open FILE with option KEYS, read its contents as a list of lines
+BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
+  (apply 'call-with-input-file file 'slurp-stream-lines keys))
+
+(defun* read-file-forms (file &rest keys &key count &allow-other-keys)
+  "Open input FILE with option KEYS (except COUNT),
+and read its contents as per SLURP-STREAM-FORMS with given COUNT.
+BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
+  (apply 'call-with-input-file file
+         #'(lambda (input) (slurp-stream-forms input :count count))
+         (remove-plist-key :count keys)))
+
+(defun* read-file-form (file &rest keys &key (at 0) &allow-other-keys)
+  "Open input FILE with option KEYS (except AT),
+and read its contents as per SLURP-STREAM-FORM with given AT specifier.
+BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
+  (apply 'call-with-input-file file
+         #'(lambda (input) (slurp-stream-form input :at at))
+         (remove-plist-key :at keys)))
+
+(defun* safe-read-file-form (pathname &rest keys &key (package :cl) &allow=
-other-keys)
+  "Reads the specified form from the top of a file using a safe standardiz=
ed syntax.
+Extracts the form using READ-FILE-FORM,
+within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
+  (with-safe-io-syntax (:package package)
+    (apply 'read-file-form pathname (remove-plist-key :package keys))))
+
+(defun* eval-input (input)
+  "Portably read and evaluate forms from INPUT, return the last values."
+  (with-input (input)
+    (loop :with results :with eof =3D'#:eof
+          :for form =3D (read input nil eof)
+          :until (eq form eof)
+          :do (setf results (multiple-value-list (eval form)))
+          :finally (return (apply 'values results)))))
+
+(defun* eval-thunk (thunk)
+  "Evaluate a THUNK of code:
+If a function, FUNCALL it without arguments.
+If a constant literal and not a sequence, return it.
+If a cons or a symbol, EVAL it.
+If a string, repeatedly read and evaluate from it, returning the last valu=
es."
+  (etypecase thunk
+    ((or boolean keyword number character pathname) thunk)
+    ((or cons symbol) (eval thunk))
+    (function (funcall thunk))
+    (string (eval-input thunk))))
+
+(defun* standard-eval-thunk (thunk &key (package :cl))
+  "Like EVAL-THUNK, but in a more standardized evaluation context."
+  ;; Note: it's "standard-" not "safe-", because evaluation is never safe.
+  (when thunk
+    (with-safe-io-syntax (:package package)
+      (let ((*read-eval* t))
+        (eval-thunk thunk)))))
+
+
+;;; Encodings
+
+(defvar *default-encoding* :default
+  "Default encoding for source files.
+The default value :default preserves the legacy behavior.
+A future default might be :utf-8 or :autodetect
+reading emacs-style -*- coding: utf-8 -*- specifications,
+and falling back to utf-8 or latin1 if nothing is specified.")
+
+(defparameter *utf-8-external-format*
+  #+(and asdf-unicode (not clisp)) :utf-8
+  #+(and asdf-unicode clisp) charset:utf-8
+  #-asdf-unicode :default
+  "Default :external-format argument to pass to CL:OPEN and also
+CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file.
+On modern implementations, this will decode UTF-8 code points as CL charac=
ters.
+On legacy implementations, it may fall back on some 8-bit encoding,
+with non-ASCII code points being read as several CL characters;
+hopefully, if done consistently, that won't affect program behavior too mu=
ch.")
+
+(defun* always-default-encoding (pathname)
+  (declare (ignore pathname))
+  *default-encoding*)
+
+(defvar *encoding-detection-hook* #'always-default-encoding
+  "Hook for an extension to define a function to automatically detect a fi=
le's encoding")
+
+(defun* detect-encoding (pathname)
+  (if (and pathname (not (directory-pathname-p pathname)) (probe-file* pat=
hname))
+      (funcall *encoding-detection-hook* pathname)
+      *default-encoding*))
+
+(defun* default-encoding-external-format (encoding)
+  (case encoding
+    (:default :default) ;; for backward-compatibility only. Explicit usage=
 discouraged.
+    (:utf-8 *utf-8-external-format*)
+    (otherwise
+     (cerror "Continue using :external-format :default" (compatfmt "~@<You=
r ASDF component is using encoding ~S but it isn't recognized. Your system =
should :defsystem-depends-on (:asdf-encodings).~:>") encoding)
+     :default)))
+
+(defvar *encoding-external-format-hook*
+  #'default-encoding-external-format
+  "Hook for an extension to define a mapping between non-default encodings
+and implementation-defined external-format's")
+
+(defun* encoding-external-format (encoding)
+  (funcall *encoding-external-format-hook* encoding))
+
+
+;;; Using temporary files
+(defun* default-temporary-directory ()
+  (or
+   (when (os-unix-p)
+     (or (getenv-pathname "TMPDIR" :ensure-directory t)
+         (parse-native-namestring "/tmp/")))
+   (when (os-windows-p)
+     (getenv-pathname "TEMP" :ensure-directory t))
+   (subpathname (user-homedir-pathname) "tmp/")))
+
+(defvar *temporary-directory* nil)
+
+(defun* temporary-directory ()
+  (or *temporary-directory* (default-temporary-directory)))
+
+(defun setup-temporary-directory ()
+  (setf *temporary-directory* (default-temporary-directory))
+  ;; basic lack fixed after gcl 2.7.0-61, but ending / required still on 2=
.7.0-64.1
+  #+(and gcl (not gcl2.6)) (setf system::*tmp-dir* *temporary-directory*))
+
+(defun* call-with-temporary-file
+    (thunk &key
+     prefix keep (direction :io)
+     (element-type *default-stream-element-type*)
+     (external-format :default))
+  #+gcl2.6 (declare (ignorable external-format))
+  (check-type direction (member :output :io))
+  (loop
+    :with prefix =3D (or prefix (format nil "~Atmp" (native-namestring (te=
mporary-directory))))
+    :for counter :from (random (ash 1 32))
+    :for pathname =3D (pathname (format nil "~A~36R" prefix counter)) :do
+     ;; TODO: on Unix, do something about umask
+     ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EX=
CL
+     ;; TODO: on Unix, use CFFI and mkstemp -- but asdf/driver is precisel=
y meant to not depend on CFFI or on anything! Grrrr.
+    (with-open-file (stream pathname
+                            :direction direction
+                            :element-type element-type
+                            #-gcl2.6 :external-format #-gcl2.6 external-fo=
rmat
+                            :if-exists nil :if-does-not-exist :create)
+      (when stream
+        (return
+          (if keep
+              (funcall thunk stream pathname)
+              (unwind-protect
+                   (funcall thunk stream pathname)
+                (ignore-errors (delete-file pathname)))))))))
+
+(defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp)
+                                (pathname (gensym "PATHNAME") pathnamep)
+                                prefix keep direction element-type externa=
l-format)
+                               &body body)
+  "Evaluate BODY where the symbols specified by keyword arguments
+STREAM and PATHNAME are bound corresponding to a newly created temporary f=
ile
+ready for I/O. Unless KEEP is specified, delete the file afterwards."
+  (check-type stream symbol)
+  (check-type pathname symbol)
+  `(flet ((think (,stream ,pathname)
+            ,@(unless pathnamep `((declare (ignore ,pathname))))
+            ,@(unless streamp `((when ,stream (close ,stream))))
+            , at body))
+     #-gcl (declare (dynamic-extent #'think))
+     (call-with-temporary-file
+      #'think
+      ,@(when direction `(:direction ,direction))
+      ,@(when prefix `(:prefix ,prefix))
+      ,@(when keep `(:keep ,keep))
+      ,@(when element-type `(:element-type ,element-type))
+      ,@(when external-format `(:external-format external-format)))))
+
+;;; Temporary pathnames
+(defun* add-pathname-suffix (pathname suffix)
+  (make-pathname :name (strcat (pathname-name pathname) suffix)
+                 :defaults pathname))
+
+(defun* tmpize-pathname (x)
+  (add-pathname-suffix x "-ASDF-TMP"))
+
+(defun* call-with-staging-pathname (pathname fun)
+  "Calls fun with a staging pathname, and atomically
+renames the staging pathname to the pathname in the end.
+Note: this protects only against failure of the program,
+not against concurrent attempts.
+For the latter case, we ought pick random suffix and atomically open it."
+  (let* ((pathname (pathname pathname))
+         (staging (tmpize-pathname pathname)))
+    (unwind-protect
+         (multiple-value-prog1
+             (funcall fun staging)
+           (rename-file-overwriting-target staging pathname))
+      (delete-file-if-exists staging))))
+
+(defmacro with-staging-pathname ((pathname-var &optional (pathname-value p=
athname-var)) &body body)
+  `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,=
@body)))
+
+
+;;;; ---------------------------------------------------------------------=
----
+;;;; Starting, Stopping, Dumping a Lisp image
+
+(asdf/package:define-package :asdf/image
+  (:recycle :asdf/image :xcvb-driver)
+  (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/pathname :asdf=
/stream :asdf/os)
+  (:export
+   #:*image-dumped-p* #:raw-command-line-arguments #:*command-line-argumen=
ts*
+   #:command-line-arguments #:raw-command-line-arguments #:setup-command-l=
ine-arguments
+   #:*lisp-interaction*
+   #:fatal-conditions #:fatal-condition-p #:handle-fatal-condition
+   #:call-with-fatal-condition-handler #:with-fatal-condition-handler
+   #:*image-restore-hook* #:*image-prelude* #:*image-entry-point*
+   #:*image-postlude* #:*image-dump-hook*
+   #:quit #:die #:raw-print-backtrace #:print-backtrace #:print-condition-=
backtrace
+   #:shell-boolean-exit
+   #:register-image-restore-hook #:register-image-dump-hook
+   #:call-image-restore-hook #:call-image-dump-hook
+   #:initialize-asdf-utilities #:restore-image #:dump-image #:create-image
+))
+(in-package :asdf/image)
+
+(defvar *lisp-interaction* t
+  "Is this an interactive Lisp environment, or is it batch processing?")
+
+(defvar *command-line-arguments* nil
+  "Command-line arguments")
+
+(defvar *image-dumped-p* nil ; may matter as to how to get to command-line=
-arguments
+  "Is this a dumped image? As a standalone executable?")
+
+(defvar *image-restore-hook* nil
+  "Functions to call (in reverse order) when the image is restored")
+
+(defvar *image-prelude* nil
+  "a form to evaluate, or string containing forms to read and evaluate
+when the image is restarted, but before the entry point is called.")
+
+(defvar *image-entry-point* nil
+  "a function with which to restart the dumped image when execution is res=
tored from it.")
+
+(defvar *image-postlude* nil
+  "a form to evaluate, or string containing forms to read and evaluate
+before the image dump hooks are called and before the image is dumped.")
+
+(defvar *image-dump-hook* nil
+  "Functions to call (in order) when before an image is dumped")
+
+(defvar *fatal-conditions* '(error)
+  "conditions that cause the Lisp image to enter the debugger if interacti=
ve,
+or to die if not interactive")
+
+
+;;; Exiting properly or im-
+(defun* quit (&optional (code 0) (finish-output t))
+  "Quits from the Lisp world, with the given exit status if provided.
+This is designed to abstract away the implementation specific quit forms."
+  (when finish-output ;; essential, for ClozureCL, and for standard compli=
ance.
+    (finish-outputs))
+  #+(or abcl xcl) (ext:quit :status code)
+  #+allegro (excl:exit code :quiet t)
+  #+clisp (ext:quit code)
+  #+clozure (ccl:quit code)
+  #+cormanlisp (win32:exitprocess code)
+  #+(or cmu scl) (unix:unix-exit code)
+  #+ecl (si:quit code)
+  #+gcl (lisp:quit code)
+  #+genera (error "You probably don't want to Halt the Machine. (code: ~S)=
" code)
+  #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignor=
e-errors-p t)
+  #+mcl (ccl:quit) ;; or should we use FFI to call libc's exit(3) ?
+  #+mkcl (mk-ext:quit :exit-code code)
+  #+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil))
+		 (quit (find-symbol* :quit :sb-ext nil)))
+	     (cond
+	       (exit `(,exit :code code :abort (not finish-output)))
+	       (quit `(,quit :unix-status code :recklessly-p (not finish-output))=
)))
+  #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl s=
bcl scl xcl)
+  (error "~S called with exit code ~S but there's no quitting on this impl=
ementation" 'quit code))
+
+(defun* die (code format &rest arguments)
+  "Die in error with some error message"
+  (with-safe-io-syntax ()
+    (ignore-errors
+     (fresh-line *stderr*)
+     (apply #'format *stderr* format arguments)
+     (format! *stderr* "~&")))
+  (quit code))
+
+(defun* raw-print-backtrace (&key (stream *debug-io*) count)
+  "Print a backtrace, directly accessing the implementation"
+  (declare (ignorable stream count))
+  #+abcl
+  (let ((*debug-io* stream)) (top-level::backtrace-command count))
+  #+allegro
+  (let ((*terminal-io* stream)
+        (*standard-output* stream)
+        (tpl:*zoom-print-circle* *print-circle*)
+        (tpl:*zoom-print-level* *print-level*)
+        (tpl:*zoom-print-length* *print-length*))
+    (tpl:do-command "zoom"
+      :from-read-eval-print-loop nil
+      :count t
+      :all t))
+  #+clisp
+  (system::print-backtrace :out stream :limit count)
+  #+(or clozure mcl)
+  (let ((*debug-io* stream))
+    (ccl:print-call-history :count count :start-frame-number 1)
+    (finish-output stream))
+  #+(or cmucl scl)
+  (let ((debug:*debug-print-level* *print-level*)
+        (debug:*debug-print-length* *print-length*))
+    (debug:backtrace most-positive-fixnum stream))
+  #+ecl
+  (si::tpl-backtrace)
+  #+lispworks
+  (let ((dbg::*debugger-stack*
+          (dbg::grab-stack nil :how-many (or count most-positive-fixnum)))
+        (*debug-io* stream)
+        (dbg:*debug-print-level* *print-level*)
+        (dbg:*debug-print-length* *print-length*))
+    (dbg:bug-backtrace nil))
+  #+sbcl
+  (sb-debug:backtrace
+   #.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream '(or count mo=
st-positive-fixnum))
+   stream))
+
+(defun* print-backtrace (&rest keys &key stream count)
+  (declare (ignore stream count))
+  (with-safe-io-syntax (:package :cl)
+    (let ((*print-readably* nil)
+          (*print-circle* t)
+          (*print-miser-width* 75)
+          (*print-length* nil)
+          (*print-level* nil)
+          (*print-pretty* t))
+      (ignore-errors (apply 'raw-print-backtrace keys)))))
+
+(defun* print-condition-backtrace (condition &key (stream *stderr*) count)
+  ;; We print the condition *after* the backtrace,
+  ;; for the sake of who sees the backtrace at a terminal.
+  ;; It is up to the caller to print the condition *before*, with some con=
text.
+  (print-backtrace :stream stream :count count)
+  (when condition
+    (safe-format! stream "~&Above backtrace due to this condition:~%~A~&"
+                  condition)))
+
+(defun fatal-condition-p (condition)
+  (match-any-condition-p condition *fatal-conditions*))
+
+(defun* handle-fatal-condition (condition)
+  "Depending on whether *LISP-INTERACTION* is set, enter debugger or die"
   (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))))
-
-;;; perform is required to check output-files to find out where to put
-;;; its answers, in case it has been overridden for site policy
-(defmethod perform ((operation compile-op) (c cl-source-file))
-  (let ((source-file (component-pathname c))
-        ;; on some implementations, there are more than one output-file,
-        ;; but the first one should always be the primary fasl that gets l=
oaded.
-        (output-file (first (output-files operation c)))
-        (*compile-file-warnings-behaviour* (operation-on-warnings operatio=
n))
-        (*compile-file-failure-behaviour* (operation-on-failure operation)=
))
-    (multiple-value-bind (output warnings-p failure-p)
-        (call-with-around-compile-hook
-         c #'(lambda (&rest flags)
-               (apply *compile-op-compile-file-function* source-file
-                      :output-file output-file
-                      :external-format (component-external-format c)
-                      (append flags (compile-op-flags operation)))))
-      (unless output
-        (error 'compile-error :component c :operation operation))
-      (when failure-p
-        (case (operation-on-failure operation)
-          (:warn (warn
-                  (compatfmt "~@<COMPILE-FILE failed while performing ~A o=
n ~A.~@:>")
-                  operation c))
-          (:error (error 'compile-failed :component c :operation operation=
))
-          (:ignore nil)))
-      (when warnings-p
-        (case (operation-on-warnings operation)
-          (:warn (warn
-                  (compatfmt "~@<COMPILE-FILE warned while performing ~A o=
n ~A.~@:>")
-                  operation c))
-          (:error (error 'compile-warned :component c :operation operation=
))
-          (:ignore nil))))))
-
-(defmethod output-files ((operation compile-op) (c cl-source-file))
-  (declare (ignorable operation))
-  (let* ((p (lispize-pathname (component-pathname c)))
-         (f (compile-file-pathname ;; fasl
-             p #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl))
-         #+mkcl (o (compile-file-pathname p :fasl-p nil))) ;; object file
-    #+ecl (if (use-ecl-byte-compiler-p)
-              (list f)
-              (list (compile-file-pathname p :type :object) f))
-    #+mkcl (list o f)
-    #-(or ecl mkcl) (list f)))
-
-(defmethod perform ((operation compile-op) (c static-file))
-  (declare (ignorable operation c))
-  nil)
-
-(defmethod output-files ((operation compile-op) (c static-file))
-  (declare (ignorable operation c))
-  nil)
-
-(defmethod input-files ((operation compile-op) (c static-file))
-  (declare (ignorable operation c))
-  nil)
-
-(defmethod operation-description ((operation compile-op) component)
-  (declare (ignorable operation))
-  (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") component))
-
-(defmethod operation-description ((operation compile-op) (component module=
))
-  (declare (ignorable operation))
-  (format nil (compatfmt "~@<compiled ~3i~_~A~@:>") component))
-
-
+    (*lisp-interaction*
+     (invoke-debugger condition))
+    (t
+     (safe-format! *stderr* "~&Fatal condition:~%~A~%" condition)
+     (print-condition-backtrace condition :stream *stderr*)
+     (die 99 "~A" condition))))
+
+(defun* call-with-fatal-condition-handler (thunk)
+  (handler-bind (((satisfies fatal-condition-p) #'handle-fatal-condition))
+    (funcall thunk)))
+
+(defmacro with-fatal-condition-handler ((&optional) &body body)
+  `(call-with-fatal-condition-handler #'(lambda () , at body)))
+
+(defun* shell-boolean-exit (x)
+  "Quit with a return code that is 0 iff argument X is true"
+  (quit (if x 0 1)))
+
+
+;;; Using image hooks
+
+(defun* register-image-restore-hook (hook &optional (call-now-p t))
+  (register-hook-function '*image-restore-hook* hook call-now-p))
+
+(defun* register-image-dump-hook (hook &optional (call-now-p nil))
+  (register-hook-function '*image-dump-hook* hook call-now-p))
+
+(defun* call-image-restore-hook ()
+  (call-functions (reverse *image-restore-hook*)))
+
+(defun* call-image-dump-hook ()
+  (call-functions *image-dump-hook*))
+
+
+;;; Proper command-line arguments
+
+(defun* raw-command-line-arguments ()
+  "Find what the actual command line for this process was."
+  #+abcl ext:*command-line-argument-list* ; Use 1.0.0 or later!
+  #+allegro (sys:command-line-arguments) ; default: :application t
+  #+clisp (coerce (ext:argv) 'list)
+  #+clozure (ccl::command-line-arguments)
+  #+(or cmu scl) extensions:*command-line-strings*
+  #+ecl (loop :for i :from 0 :below (si:argc) :collect (si:argv i))
+  #+gcl si:*command-args*
+  #+genera nil
+  #+lispworks sys:*line-arguments-list*
+  #+sbcl sb-ext:*posix-argv*
+  #+xcl system:*argv*
+  #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks sbcl scl x=
cl)
+  (error "raw-command-line-arguments not implemented yet"))
+
+(defun* command-line-arguments (&optional (arguments (raw-command-line-arg=
uments)))
+  "Extract user arguments from command-line invocation of current process.
+Assume the calling conventions of a generated script that uses --
+if we are not called from a directly executable image."
+  #+abcl arguments
+  #-abcl
+  (let* (#-(or sbcl allegro)
+	 (arguments
+	  (if (eq *image-dumped-p* :executable)
+	      arguments
+	      (member "--" arguments :test 'string-equal))))
+    (rest arguments)))
+
+(defun setup-command-line-arguments ()
+  (setf *command-line-arguments* (command-line-arguments)))
+
+(defun* restore-image (&key
+                       ((:lisp-interaction *lisp-interaction*) *lisp-inter=
action*)
+                       ((:restore-hook *image-restore-hook*) *image-restor=
e-hook*)
+                       ((:prelude *image-prelude*) *image-prelude*)
+                       ((:entry-point *image-entry-point*) *image-entry-po=
int*))
+  (with-fatal-condition-handler ()
+    (call-image-restore-hook)
+    (standard-eval-thunk *image-prelude*)
+    (let ((results (multiple-value-list
+                    (if *image-entry-point*
+                        (call-function *image-entry-point*)
+                        t))))
+      (if *lisp-interaction*
+          (apply 'values results)
+          (shell-boolean-exit (first results))))))
+
+
+;;; Dumping an image
+
+#-(or ecl mkcl)
+(defun* dump-image (filename &key output-name executable
+                             ((:postlude *image-postlude*) *image-postlude=
*)
+                             ((:dump-hook *image-dump-hook*) *image-dump-h=
ook*))
+  (declare (ignorable filename output-name executable))
+  (setf *image-dumped-p* (if executable :executable t))
+  (standard-eval-thunk *image-postlude*)
+  (call-image-dump-hook)
+  #-(or clisp clozure cmu lispworks sbcl scl)
+  (when executable
+    (error "Dumping an executable is not supported on this implementation!=
 Aborting."))
+  #+allegro
+  (progn
+    (sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure =
t) ; :new 5000000
+    (excl:dumplisp :name filename :suppress-allegro-cl-banner t))
+  #+clisp
+  (apply #'ext:saveinitmem filename
+   :quiet t
+   :start-package *package*
+   :keep-global-handlers nil
+   :executable (if executable 0 t) ;--- requires clisp 2.48 or later, stil=
l catches --clisp-x
+   (when executable
+     (list
+      ;; :parse-options nil ;--- requires a non-standard patch to clisp.
+      :norc t :script nil :init-function #'restore-image)))
+  #+clozure
+  (ccl:save-application filename :prepend-kernel t
+                        :toplevel-function (when executable #'restore-imag=
e))
+  #+(or cmu scl)
+  (progn
+   (ext:gc :full t)
+   (setf ext:*batch-mode* nil)
+   (setf ext::*gc-run-time* 0)
+   (apply 'ext:save-lisp filename #+cmu :executable #+cmu t
+          (when executable '(:init-function restore-image :process-command=
-line nil))))
+  #+gcl
+  (progn
+   (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t)
+   (si::save-system filename))
+  #+lispworks
+  (if executable
+      (lispworks:deliver 'restore-image filename 0 :interface nil)
+      (hcl:save-image filename :environment nil))
+  #+sbcl
+  (progn
+    ;;(sb-pcl::precompile-random-code-segments) ;--- it is ugly slow at co=
mpile-time (!) when the initial core is a big CLOS program. If you want it,=
 do it yourself
+   (setf sb-ext::*gc-run-time* 0)
+   (apply 'sb-ext:save-lisp-and-die filename
+    :executable t ;--- always include the runtime that goes with the core
+    (when executable (list :toplevel #'restore-image :save-runtime-options=
 t)))) ;--- only save runtime-options for standalone executables
+  #-(or allegro clisp clozure cmu gcl lispworks sbcl scl)
+  (die 98 "Can't dump ~S: asdf doesn't support image dumping with ~A.~%"
+       filename (nth-value 1 (implementation-type))))
+
+
+#+ecl
+(defun create-image (destination object-files
+                     &key kind output-name prologue-code epilogue-code =

+                       (prelude () preludep) (entry-point () entry-point-p=
) build-args)
+  ;; Is it meaningful to run these in the current environment?
+  ;; only if we also track the object files that constitute the "current" =
image,
+  ;; and otherwise simulate dump-image, including quitting at the end.
+  ;; (standard-eval-thunk *image-postlude*) (call-image-dump-hook)
+  (check-type kind (member :binary :dll :lib :static-library :program :obj=
ect :fasl :program))
+  (apply 'c::builder
+         kind (pathname destination)
+         :lisp-files object-files
+         :init-name (c::compute-init-name (or output-name destination) :ki=
nd kind)
+         :prologue-code prologue-code
+         :epilogue-code
+         `(progn
+            ,epilogue-code
+            ,@(when (eq kind :program)
+                `((setf *image-dumped-p* :executable)
+                  (restore-image ;; default behavior would be (si::top-lev=
el)
+                   ,@(when preludep `(:prelude ',prelude))
+                   ,@(when entry-point-p `(:entry-point ',entry-point))))))
+         build-args))
+
+
+;;; Some universal image restore hooks
+(map () 'register-image-restore-hook
+     '(setup-temporary-directory setup-stderr setup-command-line-arguments
+       #+abcl detect-os))
 ;;;; ---------------------------------------------------------------------=
----
-;;;; load-op
-
-(defclass basic-load-op (operation) ())
-
-(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
-       #-(or ecl mkcl)
-       (input-files o c)
-       #+(or ecl mkcl)
-       (loop :for i :in (input-files o c)
-	     :unless (string=3D (pathname-type i) "fas")
-	     :collect (compile-file-pathname (lispize-pathname i)))))
-
-(defmethod perform ((operation load-op) (c static-file))
-  (declare (ignorable operation c))
-  nil)
-
-(defmethod operation-done-p ((operation load-op) (c static-file))
-  (declare (ignorable operation c))
-  t)
-
-(defmethod output-files ((operation operation) (c component))
-  (declare (ignorable operation c))
-  nil)
-
-(defmethod component-depends-on ((operation load-op) (c component))
-  (declare (ignorable operation))
-  (cons (list 'compile-op (component-name c))
-        (call-next-method)))
-
-(defmethod operation-description ((operation load-op) component)
-  (declare (ignorable operation))
-  (format nil (compatfmt "~@<loading ~3i~_~A~@:>")
-          component))
-
-(defmethod operation-description ((operation load-op) (component cl-source=
-file))
-  (declare (ignorable operation))
-  (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>")
-          component))
-
-(defmethod operation-description ((operation load-op) (component module))
-  (declare (ignorable operation))
-  (format nil (compatfmt "~@<loaded ~3i~_~A~@:>")
-          component))
+;;;; run-program initially from xcvb-driver.
+
+(asdf/package:define-package :asdf/run-program
+  (:recycle :asdf/run-program :xcvb-driver)
+  (:use :asdf/common-lisp :asdf/utility :asdf/pathname :asdf/os :asdf/file=
system :asdf/stream)
+  (:export
+   ;;; Escaping the command invocation madness
+   #:easy-sh-character-p #:escape-sh-token #:escape-sh-command
+   #:escape-windows-token #:escape-windows-command
+   #:escape-token #:escape-command
+
+   ;;; run-program
+   #:slurp-input-stream
+   #:run-program
+   #:subprocess-error
+   #:subprocess-error-code #:subprocess-error-command #:subprocess-error-p=
rocess
+   ))
+(in-package :asdf/run-program)
+
+;;;; ----- Escaping strings for the shell -----
+
+(defun* requires-escaping-p (token &key good-chars bad-chars)
+  "Does this token require escaping, given the specification of
+either good chars that don't need escaping or bad chars that do need escap=
ing,
+as either a recognizing function or a sequence of characters."
+  (some
+   (cond
+     ((and good-chars bad-chars)
+      (error "only one of good-chars and bad-chars can be provided"))
+     ((functionp good-chars)
+      (complement good-chars))
+     ((functionp bad-chars)
+      bad-chars)
+     ((and good-chars (typep good-chars 'sequence))
+      #'(lambda (c) (not (find c good-chars))))
+     ((and bad-chars (typep bad-chars 'sequence))
+      #'(lambda (c) (find c bad-chars)))
+     (t (error "requires-escaping-p: no good-char criterion")))
+   token))
+
+(defun* escape-token (token &key stream quote good-chars bad-chars escaper)
+  "Call the ESCAPER function on TOKEN string if it needs escaping as per
+REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOKEN,
+using STREAM as output (or returning result as a string if NIL)"
+  (if (requires-escaping-p token :good-chars good-chars :bad-chars bad-cha=
rs)
+      (with-output (stream)
+        (apply escaper token stream (when quote `(:quote ,quote))))
+      (output-string token stream)))
+
+(defun* escape-windows-token-within-double-quotes (x &optional s)
+  "Escape a string token X within double-quotes
+for use within a MS Windows command-line, outputing to S."
+  (labels ((issue (c) (princ c s))
+           (issue-backslash (n) (loop :repeat n :do (issue #\\))))
+    (loop
+      :initially (issue #\") :finally (issue #\")
+      :with l =3D (length x) :with i =3D 0
+      :for i+1 =3D (1+ i) :while (< i l) :do
+      (case (char x i)
+        ((#\") (issue-backslash 1) (issue #\") (setf i i+1))
+        ((#\\)
+         (let* ((j (and (< i+1 l) (position-if-not
+                                   #'(lambda (c) (eql c #\\)) x :start i+1=
)))
+                (n (- (or j l) i)))
+           (cond
+             ((null j)
+              (issue-backslash (* 2 n)) (setf i l))
+             ((and (< j l) (eql (char x j) #\"))
+              (issue-backslash (1+ (* 2 n))) (issue #\") (setf i (1+ j)))
+             (t
+              (issue-backslash n) (setf i j)))))
+        (otherwise
+         (issue (char x i)) (setf i i+1))))))
+
+(defun* escape-windows-token (token &optional s)
+  "Escape a string TOKEN within double-quotes if needed
+for use within a MS Windows command-line, outputing to S."
+  (escape-token token :stream s :bad-chars #(#\space #\tab #\") :quote nil
+                :escaper 'escape-windows-token-within-double-quotes))
+
+(defun* escape-sh-token-within-double-quotes (x s &key (quote t))
+  "Escape a string TOKEN within double-quotes
+for use within a POSIX Bourne shell, outputing to S;
+omit the outer double-quotes if key argument :QUOTE is NIL"
+  (when quote (princ #\" s))
+  (loop :for c :across x :do
+    (when (find c "$`\\\"") (princ #\\ s))
+    (princ c s))
+  (when quote (princ #\" s)))
+
+(defun* easy-sh-character-p (x)
+  (or (alphanumericp x) (find x "+-_.,%@:/")))
+
+(defun* escape-sh-token (token &optional s)
+  "Escape a string TOKEN within double-quotes if needed
+for use within a POSIX Bourne shell, outputing to S."
+  (escape-token token :stream s :quote #\" :good-chars
+                #'easy-sh-character-p
+                :escaper 'escape-sh-token-within-double-quotes))
+
+(defun* escape-shell-token (token &optional s)
+  (cond
+    ((os-unix-p) (escape-sh-token token s))
+    ((os-windows-p) (escape-windows-token token s))))
+
+(defun* escape-command (command &optional s
+                       (escaper 'escape-shell-token))
+  "Given a COMMAND as a list of tokens, return a string of the
+spaced, escaped tokens, using ESCAPER to escape."
+  (etypecase command
+    (string (output-string command s))
+    (list (with-output (s)
+            (loop :for first =3D t :then nil :for token :in command :do
+              (unless first (princ #\space s))
+              (funcall escaper token s))))))
+
+(defun* escape-windows-command (command &optional s)
+  "Escape a list of command-line arguments into a string suitable for pars=
ing
+by CommandLineToArgv in MS Windows"
+    ;; http://msdn.microsoft.com/en-us/library/bb776391(v=3Dvs.85).aspx
+    ;; http://msdn.microsoft.com/en-us/library/17w5ykft(v=3Dvs.85).aspx
+  (escape-command command s 'escape-windows-token))
+
+(defun* escape-sh-command (command &optional s)
+  "Escape a list of command-line arguments into a string suitable for pars=
ing
+by /bin/sh in POSIX"
+  (escape-command command s 'escape-sh-token))
+
+(defun* escape-shell-command (command &optional stream)
+  "Escape a command for the current operating system's shell"
+  (escape-command command stream 'escape-shell-token))
+
+
+;;;; Slurping a stream, typically the output of another program
+
+(defgeneric* slurp-input-stream (processor input-stream &key &allow-other-=
keys))
+
+#-(or gcl2.6 genera)
+(defmethod slurp-input-stream ((function function) input-stream &key &allo=
w-other-keys)
+  (funcall function input-stream))
+
+(defmethod slurp-input-stream ((list cons) input-stream &key &allow-other-=
keys)
+  (apply (first list) (cons input-stream (rest list))))
+
+#-(or gcl2.6 genera)
+(defmethod slurp-input-stream ((output-stream stream) input-stream
+                               &key linewise prefix (element-type 'charact=
er) buffer-size &allow-other-keys)
+  (copy-stream-to-stream
+   input-stream output-stream
+   :linewise linewise :prefix prefix :element-type element-type :buffer-si=
ze buffer-size))
+
+(defmethod slurp-input-stream ((x (eql 'string)) stream &key &allow-other-=
keys)
+  (declare (ignorable x))
+  (slurp-stream-string stream))
+
+(defmethod slurp-input-stream ((x (eql :string)) stream &key &allow-other-=
keys)
+  (declare (ignorable x))
+  (slurp-stream-string stream))
+
+(defmethod slurp-input-stream ((x (eql :lines)) stream &key count &allow-o=
ther-keys)
+  (declare (ignorable x))
+  (slurp-stream-lines stream :count count))
+
+(defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0) &allow-o=
ther-keys)
+  (declare (ignorable x))
+  (slurp-stream-line stream :at at))
+
+(defmethod slurp-input-stream ((x (eql :forms)) stream &key count &allow-o=
ther-keys)
+  (declare (ignorable x))
+  (slurp-stream-forms stream :count count))
+
+(defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0) &allow-o=
ther-keys)
+  (declare (ignorable x))
+  (slurp-stream-form stream :at at))
+
+(defmethod slurp-input-stream (x stream
+                               &key linewise prefix (element-type 'charact=
er) buffer-size
+                               &allow-other-keys)
+  (declare (ignorable stream linewise prefix element-type buffer-size))
+  (cond
+    #+(or gcl2.6 genera)
+    ((functionp x) (funcall x stream))
+    #+(or gcl2.6 genera)
+    ((output-stream-p x)
+     (copy-stream-to-stream
+      input-stream output-stream
+      :linewise linewise :prefix prefix :element-type element-type :buffer=
-size buffer-size))
+    (t
+     (error "Invalid ~S destination ~S" 'slurp-input-stream x))))
+
+
+;;;; ----- Running an external program -----
+;;; Simple variant of run-program with no input, and capturing output
+;;; On some implementations, may output to a temporary file...
+
+(define-condition subprocess-error (error)
+  ((code :initform nil :initarg :code :reader subprocess-error-code)
+   (command :initform nil :initarg :command :reader subprocess-error-comma=
nd)
+   (process :initform nil :initarg :process :reader subprocess-error-proce=
ss))
+  (:report (lambda (condition stream)
+             (format stream "Subprocess~@[ ~S~]~@[ run with command ~S~] e=
xited with error~@[ code ~D~]"
+                     (subprocess-error-process condition)
+                     (subprocess-error-command condition)
+                     (subprocess-error-code condition)))))
+
+(defun* run-program (command
+                     &key output ignore-error-status force-shell
+                     (element-type *default-stream-element-type*)
+                     (external-format :default)
+                     &allow-other-keys)
+  "Run program specified by COMMAND,
+either a list of strings specifying a program and list of arguments,
+or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Window=
s);
+have its output processed by the OUTPUT processor function
+as per SLURP-INPUT-STREAM,
+or merely output to the inherited standard output if it's NIL.
+Always call a shell (rather than directly execute the command)
+if FORCE-SHELL is specified.
+Issue an error if the process wasn't successful unless IGNORE-ERROR-STATUS
+is specified.
+Return the exit status code of the process that was called.
+Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT p=
rocessor."
+  (declare (ignorable ignore-error-status element-type external-format))
+  #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sb=
cl scl xcl)
+  (error "RUN-PROGRAM not implemented for this Lisp")
+  (labels (#+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbc=
l scl)
+           (run-program (command &key pipe interactive)
+             "runs the specified command (a list of program and arguments).
+              If using a pipe, returns two values: process and stream
+              If not using a pipe, returns one values: the process result;
+              also, inherits the output stream."
+             ;; NB: these implementations have unix vs windows set at comp=
ile-time.
+	     (assert (not (and pipe interactive)))
+             (let* ((wait (not pipe))
+                    #-(and clisp os-windows)
+                    (command
+                     (etypecase command
+                       #+os-unix (string `("/bin/sh" "-c" ,command))
+                       #+os-unix (list command)
+                       #+os-windows
+                       (string
+                        ;; NB: We do NOT add cmd /c here. You might want t=
o.
+                        #+allegro command
+			;; On ClozureCL for Windows, we assume you are using
+			;; r15398 or later in 1.9 or later,
+			;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858
+			#+clozure (cons "cmd" (strcat "/c " command))
+                        ;; NB: On other Windows implementations, this is u=
tterly bogus
+                        ;; except in the most trivial cases where no quoti=
ng is needed.
+                        ;; Use at your own risk.
+                        #-(or allegro clozure) (list "cmd" "/c" command))
+                       #+os-windows
+                       (list
+                        #+(or allegro clozure) (escape-windows-command com=
mand)
+                        #-(or allegro clozure) command)))
+                    #+(and clozure os-windows) (command (list command))
+                    (process*
+                     (multiple-value-list
+                      #+allegro
+                      (excl:run-shell-command
+                       #+os-unix (coerce (cons (first command) command) 'v=
ector)
+                       #+os-windows command
+                       :input interactive :output (or (and pipe :stream) i=
nteractive) :wait wait
+                       #+os-windows :show-window #+os-windows (and pipe :h=
ide))
+                      #+clisp
+                      (flet ((run (f &rest args)
+                               (apply f `(, at args :input ,(when interactive=
 :terminal) :wait ,wait :output
+                                          ,(if pipe :stream :terminal)))))
+                        (etypecase command
+                          #+os-windows (run 'ext:run-shell-command command)
+                          (list (run 'ext:run-program (car command)
+                                     :arguments (cdr command)))))
+                      #+lispworks
+                      (system:run-shell-command
+                       (cons "/usr/bin/env" command) ; lispworks wants a f=
ull path.
+                       :input interactive :output (or (and pipe :stream) i=
nteractive)
+                       :wait wait :save-exit-status (and pipe t))
+                      #+(or clozure cmu ecl sbcl scl)
+                      (#+(or cmu ecl scl) ext:run-program
+                       #+clozure ccl:run-program
+                       #+sbcl sb-ext:run-program
+                       (car command) (cdr command)
+                       :input interactive :wait wait
+                       :output (if pipe :stream t)
+                       . #.(append
+                            #+(or clozure cmu ecl sbcl scl) '(:error t)
+                            ;; note: :external-format requires a recent SB=
CL
+                            #+sbcl '(:search t :external-format external-f=
ormat)))))
+                    (process
+                     #+(or allegro lispworks) (if pipe (third process*) (f=
irst process*))
+                     #+ecl (third process*)
+                     #-(or allegro lispworks ecl) (first process*))
+                    (stream
+                     (when pipe
+                       #+(or allegro lispworks ecl) (first process*)
+                       #+clisp (first process*)
+                       #+clozure (ccl::external-process-output process)
+                       #+(or cmu scl) (ext:process-output process)
+                       #+sbcl (sb-ext:process-output process))))
+               (values process stream)))
+           #+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbc=
l scl)
+           (process-result (process pipe)
+             (declare (ignorable pipe))
+             ;; 1- wait
+             #+(and clozure os-unix) (ccl::external-process-wait process)
+             #+(or cmu scl) (ext:process-wait process)
+             #+(and ecl os-unix) (ext:external-process-wait process)
+             #+sbcl (sb-ext:process-wait process)
+             ;; 2- extract result
+             #+allegro (if pipe (sys:reap-os-subprocess :pid process :wait=
 t) process)
+             #+clisp process
+             #+clozure (nth-value 1 (ccl:external-process-status process))
+             #+(or cmu scl) (ext:process-exit-code process)
+             #+ecl (nth-value 1 (ext:external-process-status process))
+             #+lispworks (if pipe (system:pid-exit-status process :wait t)=
 process)
+             #+sbcl (sb-ext:process-exit-code process))
+           (check-result (exit-code process)
+             #+clisp
+             (setf exit-code
+                   (typecase exit-code (integer exit-code) (null 0) (t -1)=
))
+             (unless (or ignore-error-status
+                         (equal exit-code 0))
+               (error 'subprocess-error :command command :code exit-code :=
process process))
+	     exit-code)
+           (use-run-program ()
+             #-(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl=
 xcl)
+             (let* ((interactive (eq output :interactive))
+		    (pipe (and output (not interactive))))
+               (multiple-value-bind (process stream)
+                   (run-program command :pipe pipe :interactive interactiv=
e)
+                 (if (and output (not interactive))
+                     (unwind-protect
+                          (slurp-input-stream output stream)
+                       (when stream (close stream))
+                       (check-result (process-result process pipe) process=
))
+                     (unwind-protect
+                          (check-result
+                           #+(or allegro lispworks) ; when not capturing, =
returns the exit code!
+                           process
+                           #-(or allegro lispworks) (process-result proces=
s pipe)
+                           process))))))
+           (system-command (command)
+             (etypecase command
+               (string (if (os-windows-p) (format nil "cmd /c ~A" command)=
 command))
+               (list (escape-shell-command
+                      (if (os-unix-p) (cons "exec" command) command)))))
+           (redirected-system-command (command out)
+             (format nil (if (os-unix-p) "exec > ~*~A ; ~2:*~A" "~A > ~A")
+                     (system-command command) (native-namestring out)))
+           (system (command &key interactive)
+             (declare (ignorable interactive))
+             #+(or abcl xcl) (ext:run-shell-command command)
+             #+allegro
+             (excl:run-shell-command command :input interactive :output in=
teractive :wait t)
+             #+(or clisp clozure cmu (and lispworks os-unix) sbcl scl)
+             (process-result (run-program command :pipe nil :interactive i=
nteractive) nil)
+             #+ecl (ext:system command)
+             #+cormanlisp (win32:system command)
+             #+gcl (lisp:system command)
+             #+(and lispworks os-windows)
+             (system:call-system-showing-output
+              command :show-cmd interactive :prefix "" :output-stream nil)
+             #+mcl (ccl::with-cstrs ((%command command)) (_system %command=
))
+             #+mkcl (nth-value 2
+                               (mkcl:run-program #+windows command #+windo=
ws ()
+                                                 #-windows "/bin/sh" (list=
 "-c" command)
+                                                 :input nil :output nil)))
+           (call-system (command-string &key interactive)
+             (check-result (system command-string :interactive interactive=
) nil))
+           (use-system ()
+	     (let ((interactive (eq output :interactive)))
+	       (if (and output (not interactive))
+		   (with-temporary-file (:pathname tmp :direction :output)
+		     (call-system (redirected-system-command command tmp))
+		     (with-open-file (stream tmp
+					     :direction :input
+					     :if-does-not-exist :error
+					     :element-type element-type
+                                             #-gcl2.6 :external-format #-g=
cl2.6 external-format)
+		       (slurp-input-stream output stream)))
+		   (call-system (system-command command) :interactive interactive)))))
+    (if (and (not force-shell)
+             #+(or clisp ecl) ignore-error-status
+             #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl=
 xcl) nil)
+        (use-run-program)
+        (use-system))))
 =

 ;;;; ---------------------------------------------------------------------=
----
-;;;; load-source-op
-
-(defclass load-source-op (basic-load-op) ())
-
-(defmethod perform ((o load-source-op) (c cl-source-file))
-  (declare (ignorable o))
-  (let ((source (component-pathname c)))
-    (setf (component-property c 'last-loaded-as-source)
-          (and (call-with-around-compile-hook
-                c #'(lambda () (load source :external-format (component-ex=
ternal-format c))))
-               (get-universal-time)))))
-
-(defmethod perform ((operation load-source-op) (c static-file))
-  (declare (ignorable operation c))
-  nil)
-
-(defmethod output-files ((operation load-source-op) (c component))
-  (declare (ignorable operation c))
-  nil)
-
-;;; FIXME: We simply copy load-op's dependencies.  This is Just Not Right.
-(defmethod component-depends-on ((o load-source-op) (c component))
-  (declare (ignorable o))
-  (loop :with what-would-load-op-do =3D (component-depends-on 'load-op c)
-    :for (op . co) :in what-would-load-op-do
-    :when (eq op 'load-op) :collect (cons 'load-source-op co)))
-
-(defmethod operation-done-p ((o load-source-op) (c source-file))
-  (declare (ignorable o))
-  (if (or (not (component-property c 'last-loaded-as-source))
-          (> (safe-file-write-date (component-pathname c))
-             (component-property c 'last-loaded-as-source)))
-      nil t))
-
-(defmethod operation-description ((operation load-source-op) component)
-  (declare (ignorable operation))
-  (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>")
-          component))
-
-(defmethod operation-description ((operation load-source-op) (component mo=
dule))
-  (declare (ignorable operation))
-  (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") component))
-
-
-;;;; ---------------------------------------------------------------------=
----
-;;;; test-op
-
-(defclass test-op (operation) ())
-
-(defmethod perform ((operation test-op) (c component))
-  (declare (ignorable operation c))
-  nil)
-
-(defmethod operation-done-p ((operation test-op) (c system))
-  "Testing a system is _never_ done."
-  (declare (ignorable operation c))
-  nil)
-
-(defmethod component-depends-on :around ((o test-op) (c system))
-  (declare (ignorable o))
-  (cons `(load-op ,(component-name c)) (call-next-method)))
-
-
-;;;; ---------------------------------------------------------------------=
----
-;;;; Invoking Operations
-
-(defgeneric* operate (operation-class system &key &allow-other-keys))
-(defgeneric* perform-plan (plan &key))
-
-;;;; Separating this into a different function makes it more forward-compa=
tible
-(defun* cleanup-upgraded-asdf (old-version)
-  (let ((new-version (asdf-version)))
-    (unless (equal old-version new-version)
+;;;; Support to build (compile and load) Lisp files
+
+(asdf/package:define-package :asdf/lisp-build
+  (:recycle :asdf/interface :asdf :asdf/lisp-build)
+  (:use :asdf/common-lisp :asdf/package :asdf/utility
+   :asdf/os :asdf/pathname :asdf/filesystem :asdf/stream :asdf/image)
+  (:export
+   ;; Variables
+   #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour*
+   #:*output-translation-function*
+   #:*optimization-settings* #:*previous-optimization-settings*
+   #:compile-condition #:compile-file-error #:compile-warned-error #:compi=
le-failed-error
+   #:compile-warned-warning #:compile-failed-warning
+   #:check-lisp-compile-results #:check-lisp-compile-warnings
+   #:*uninteresting-compiler-conditions* #:*uninteresting-loader-condition=
s*
+   ;; Functions & Macros
+   #:get-optimization-settings #:proclaim-optimization-settings
+   #:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditi=
ons
+   #:call-with-muffled-loader-conditions #:with-muffled-loader-conditions
+   #:reify-simple-sexp #:unreify-simple-sexp
+   #:reify-deferred-warnings #:reify-undefined-warning #:unreify-deferred-=
warnings
+   #:reset-deferred-warnings #:save-deferred-warnings #:check-deferred-war=
nings
+   #:with-saved-deferred-warnings #:warnings-file-p #:warnings-file-type #=
:*warnings-file-type*
+   #:current-lisp-file-pathname #:load-pathname
+   #:lispize-pathname #:compile-file-type #:call-around-hook
+   #:compile-file* #:compile-file-pathname*
+   #:load* #:load-from-string #:combine-fasls)
+  (:intern #:defaults #:failure-p #:warnings-p #:s #:y #:body))
+(in-package :asdf/lisp-build)
+
+(defvar *compile-file-warnings-behaviour*
+  (or #+clisp :ignore :warn)
+  "How should ASDF react if it encounters a warning when compiling a file?
+Valid values are :error, :warn, and :ignore.")
+
+(defvar *compile-file-failure-behaviour*
+  (or #+(or mkcl sbcl) :error #+clisp :ignore :warn)
+  "How should ASDF react if it encounters a failure (per the ANSI spec of =
COMPILE-FILE)
+when compiling a file, which includes any non-style-warning warning.
+Valid values are :error, :warn, and :ignore.
+Note that ASDF ALWAYS raises an error if it fails to create an output file=
 when compiling.")
+
+
+;;; Optimization settings
+
+(defvar *optimization-settings* nil)
+(defvar *previous-optimization-settings* nil)
+(defun* get-optimization-settings ()
+  "Get current compiler optimization settings, ready to PROCLAIM again"
+  (let ((settings '(speed space safety debug compilation-speed #+(or cmu s=
cl) c::brevity)))
+    #-(or clisp clozure cmu ecl sbcl scl)
+    (warn "xcvb-driver::get-optimization-settings does not support your im=
plementation. Please help me fix that.")
+    #.`(loop :for x :in settings
+         ,@(or #+clozure '(:for v :in '(ccl::*nx-speed* ccl::*nx-space* cc=
l::*nx-safety* ccl::*nx-debug* ccl::*nx-cspeed*))
+               #+ecl '(:for v :in '(c::*speed* c::*space* c::*safety* c::*=
debug*))
+               #+(or cmu scl) '(:for f :in '(c::cookie-speed c::cookie-spa=
ce c::cookie-safety c::cookie-debug c::cookie-cspeed c::cookie-brevity)))
+         :for y =3D (or #+clisp (gethash x system::*optimize*)
+                      #+(or clozure ecl) (symbol-value v)
+                      #+(or cmu scl) (funcall f c::*default-cookie*)
+                      #+sbcl (cdr (assoc x sb-c::*policy*)))
+         :when y :collect (list x y))))
+(defun* proclaim-optimization-settings ()
+  "Proclaim the optimization settings in *OPTIMIZATION-SETTINGS*"
+  (proclaim `(optimize ,@*optimization-settings*))
+  (let ((settings (get-optimization-settings)))
+    (unless (equal *previous-optimization-settings* settings)
+      (setf *previous-optimization-settings* settings))))
+
+
+;;; Condition control
+
+#+sbcl
+(progn
+  (defun sb-grovel-unknown-constant-condition-p (c)
+    (and (typep c 'sb-int:simple-style-warning)
+         (string-enclosed-p
+          "Couldn't grovel for "
+          (simple-condition-format-control c)
+          " (unknown to the C compiler).")))
+  (deftype sb-grovel-unknown-constant-condition ()
+    '(and style-warning (satisfies sb-grovel-unknown-constant-condition-p)=
)))
+
+(defvar *uninteresting-compiler-conditions*
+  (append
+   ;;#+clozure '(ccl:compiler-warning)
+   #+cmu '("Deleting unreachable code.")
+   #+sbcl
+   '(sb-c::simple-compiler-note
+     "&OPTIONAL and &KEY found in the same lambda list: ~S"
+     sb-int:package-at-variance
+     sb-kernel:uninteresting-redefinition
+     sb-kernel:undefined-alien-style-warning
+     ;; sb-ext:implicit-generic-function-warning ; Controversial. Let's al=
low it by default.
+     sb-kernel:lexical-environment-too-complex
+     sb-grovel-unknown-constant-condition ; defined above.
+     ;; BEWARE: the below four are controversial to include here.
+     sb-kernel:redefinition-with-defun
+     sb-kernel:redefinition-with-defgeneric
+     sb-kernel:redefinition-with-defmethod
+     sb-kernel::redefinition-with-defmacro) ; not exported by old SBCLs
+   '("No generic function ~S present when encountering macroexpansion of d=
efmethod. Assuming it will be an instance of standard-generic-function.")) =
;; from closer2mop
+  "Conditions that may be skipped while compiling")
+
+(defvar *uninteresting-loader-conditions*
+  (append
+   '("Overwriting already existing readtable ~S." ;; from named-readtables
+     #(#:finalizers-off-warning :asdf-finalizers)) ;; from asdf-finalizers
+   #+clisp '(clos::simple-gf-replacing-method-warning))
+  "Additional conditions that may be skipped while loading")
+
+;;;; ----- Filtering conditions while building -----
+
+(defun* call-with-muffled-compiler-conditions (thunk)
+  (call-with-muffled-conditions
+    thunk *uninteresting-compiler-conditions*))
+(defmacro with-muffled-compiler-conditions ((&optional) &body body)
+  "Run BODY where uninteresting compiler conditions are muffled"
+  `(call-with-muffled-compiler-conditions #'(lambda () , at body)))
+(defun* call-with-muffled-loader-conditions (thunk)
+  (call-with-muffled-conditions
+   thunk (append *uninteresting-compiler-conditions* *uninteresting-loader=
-conditions*)))
+(defmacro with-muffled-loader-conditions ((&optional) &body body)
+  "Run BODY where uninteresting compiler and additional loader conditions =
are muffled"
+  `(call-with-muffled-loader-conditions #'(lambda () , at body)))
+
+
+;;;; Handle warnings and failures
+(define-condition compile-condition (condition)
+  ((context-format
+    :initform nil :reader compile-condition-context-format :initarg :conte=
xt-format)
+   (context-arguments
+    :initform nil :reader compile-condition-context-arguments :initarg :co=
ntext-arguments)
+   (description
+    :initform nil :reader compile-condition-description :initarg :descript=
ion))
+  (:report (lambda (c s)
+               (format s (compatfmt "~@<~A~@[ while ~?~]~@:>")
+                       (or (compile-condition-description c) (type-of c))
+                       (compile-condition-context-format c)
+                       (compile-condition-context-arguments c)))))
+(define-condition compile-file-error (compile-condition error) ())
+(define-condition compile-warned-warning (compile-condition warning) ())
+(define-condition compile-warned-error (compile-condition error) ())
+(define-condition compile-failed-warning (compile-condition warning) ())
+(define-condition compile-failed-error (compile-condition error) ())
+
+(defun* check-lisp-compile-warnings (warnings-p failure-p
+                                                &optional context-format c=
ontext-arguments)
+  (when failure-p
+    (case *compile-file-failure-behaviour*
+      (:warn (warn 'compile-failed-warning
+                   :description "Lisp compilation failed"
+                   :context-format context-format
+                   :context-arguments context-arguments))
+      (:error (error 'compile-failed-error
+                   :description "Lisp compilation failed"
+                   :context-format context-format
+                   :context-arguments context-arguments))
+      (:ignore nil)))
+  (when warnings-p
+    (case *compile-file-warnings-behaviour*
+      (:warn (warn 'compile-warned-warning
+                   :description "Lisp compilation had style-warnings"
+                   :context-format context-format
+                   :context-arguments context-arguments))
+      (:error (error 'compile-warned-error
+                   :description "Lisp compilation had style-warnings"
+                   :context-format context-format
+                   :context-arguments context-arguments))
+      (:ignore nil))))
+
+(defun* check-lisp-compile-results (output warnings-p failure-p
+                                           &optional context-format contex=
t-arguments)
+  (unless output
+    (error 'compile-file-error :context-format context-format :context-arg=
uments context-arguments))
+  (check-lisp-compile-warnings warnings-p failure-p context-format context=
-arguments))
+
+
+;;;; Deferred-warnings treatment, originally implemented by Douglas Katzma=
n.
+;;
+;; To support an implementation, three functions must be implemented:
+;; reify-deferred-warnings unreify-deferred-warnings reset-deferred-warnin=
gs
+;; See their respective docstrings.
+
+(defun reify-simple-sexp (sexp)
+  (etypecase sexp
+    (symbol (reify-symbol sexp))
+    ((or number character simple-string pathname) sexp)
+    (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sex=
p))))))
+(defun unreify-simple-sexp (sexp)
+  (etypecase sexp
+    ((or symbol number character simple-string pathname) sexp)
+    (cons (cons (unreify-simple-sexp (car sexp)) (unreify-simple-sexp (cdr=
 sexp))))
+    ((simple-vector 2) (unreify-symbol sexp))))
+
+#+clozure
+(progn
+  (defun reify-source-note (source-note)
+    (when source-note
+      (with-accessors ((source ccl::source-note-source) (filename ccl:sour=
ce-note-filename)
+                       (start-pos ccl:source-note-start-pos) (end-pos ccl:=
source-note-end-pos)) source-note
+          (declare (ignorable source))
+          (list :filename filename :start-pos start-pos :end-pos end-pos
+                #|:source (reify-source-note source)|#))))
+  (defun unreify-source-note (source-note)
+    (when source-note
+      (destructuring-bind (&key filename start-pos end-pos source) source-=
note
+        (ccl::make-source-note :filename filename :start-pos start-pos :en=
d-pos end-pos
+                               :source (unreify-source-note source)))))
+  (defun reify-deferred-warning (deferred-warning)
+    (with-accessors ((warning-type ccl::compiler-warning-warning-type)
+                     (args ccl::compiler-warning-args)
+                     (source-note ccl:compiler-warning-source-note)
+                     (function-name ccl:compiler-warning-function-name)) d=
eferred-warning
+      (list :warning-type warning-type :function-name (reify-simple-sexp f=
unction-name)
+            :source-note (reify-source-note source-note) :args (reify-simp=
le-sexp args))))
+  (defun unreify-deferred-warning (reified-deferred-warning)
+    (destructuring-bind (&key warning-type function-name source-note args)
+        reified-deferred-warning
+      (make-condition (or (cdr (ccl::assq warning-type ccl::*compiler-whin=
ing-conditions*))
+                          'ccl::compiler-warning)
+                      :function-name (unreify-simple-sexp function-name)
+                      :source-note (unreify-source-note source-note)
+                      :warning-type warning-type
+                      :args (unreify-simple-sexp args)))))
+
+#+sbcl
+(defun reify-undefined-warning (warning)
+  ;; Extracting undefined-warnings from the compilation-unit
+  ;; To be passed through the above reify/unreify link, it must be a "simp=
le-sexp"
+  (list*
+   (sb-c::undefined-warning-kind warning)
+   (sb-c::undefined-warning-name warning)
+   (sb-c::undefined-warning-count warning)
+   (mapcar
+    #'(lambda (frob)
+        ;; the lexenv slot can be ignored for reporting purposes
+        `(:enclosing-source ,(sb-c::compiler-error-context-enclosing-sourc=
e frob)
+          :source ,(sb-c::compiler-error-context-source frob)
+          :original-source ,(sb-c::compiler-error-context-original-source =
frob)
+          :context ,(sb-c::compiler-error-context-context frob)
+          :file-name ,(sb-c::compiler-error-context-file-name frob) ; a pa=
thname
+          :file-position ,(sb-c::compiler-error-context-file-position frob=
) ; an integer
+          :original-source-path ,(sb-c::compiler-error-context-original-so=
urce-path frob)))
+    (sb-c::undefined-warning-warnings warning))))
+
+(defun reify-deferred-warnings ()
+  "return a portable S-expression, portably readable and writeable in any =
Common Lisp implementation
+using READ within a WITH-SAFE-IO-SYNTAX, that represents the warnings curr=
ently deferred by
+WITH-COMPILATION-UNIT. One of three functions required for deferred-warnin=
gs support in ASDF."
+  #+clozure
+  (mapcar 'reify-deferred-warning
+          (if-let (dw ccl::*outstanding-deferred-warnings*)
+            (let ((mdw (ccl::ensure-merged-deferred-warnings dw)))
+              (ccl::deferred-warnings.warnings mdw))))
+  #+sbcl
+  (when sb-c::*in-compilation-unit*
+    ;; Try to send nothing through the pipe if nothing needs to be accumul=
ated
+    `(,@(when sb-c::*undefined-warnings*
+          `((sb-c::*undefined-warnings*
+             ,@(mapcar #'reify-undefined-warning sb-c::*undefined-warnings=
*))))
+      ,@(loop :for what :in '(sb-c::*aborted-compilation-unit-count*
+                              sb-c::*compiler-error-count*
+                              sb-c::*compiler-warning-count*
+                              sb-c::*compiler-style-warning-count*
+                              sb-c::*compiler-note-count*)
+              :for value =3D (symbol-value what)
+              :when (plusp value)
+                :collect `(,what . ,value)))))
+
+(defun unreify-deferred-warnings (reified-deferred-warnings)
+  "given a S-expression created by REIFY-DEFERRED-WARNINGS, reinstantiate =
the corresponding
+deferred warnings as to be handled at the end of the current WITH-COMPILAT=
ION-UNIT.
+Handle any warning that has been resolved already,
+such as an undefined function that has been defined since.
+One of three functions required for deferred-warnings support in ASDF."
+  (declare (ignorable reified-deferred-warnings))
+  #+clozure
+  (let ((dw (or ccl::*outstanding-deferred-warnings*
+                (setf ccl::*outstanding-deferred-warnings* (ccl::%defer-wa=
rnings t)))))
+    (appendf (ccl::deferred-warnings.warnings dw)
+             (mapcar 'unreify-deferred-warning reified-deferred-warnings)))
+  #+sbcl
+  (dolist (item reified-deferred-warnings)
+    ;; Each item is (symbol . adjustment) where the adjustment depends on =
the symbol.
+    ;; For *undefined-warnings*, the adjustment is a list of initargs.
+    ;; For everything else, it's an integer.
+    (destructuring-bind (symbol . adjustment) item
+      (case symbol
+        ((sb-c::*undefined-warnings*)
+         (setf sb-c::*undefined-warnings*
+               (nconc (mapcan
+                       #'(lambda (stuff)
+                           (destructuring-bind (kind name count . rest) st=
uff
+                             (unless (case kind (:function (fboundp name)))
+                               (list
+                                (sb-c::make-undefined-warning
+                                 :name name
+                                 :kind kind
+                                 :count count
+                                 :warnings
+                                 (mapcar #'(lambda (x)
+                                             (apply #'sb-c::make-compiler-=
error-context x))
+                                         rest))))))
+                       adjustment)
+                      sb-c::*undefined-warnings*)))
+        (otherwise
+         (set symbol (+ (symbol-value symbol) adjustment)))))))
+
+(defun reset-deferred-warnings ()
+  "Reset the set of deferred warnings to be handled at the end of the curr=
ent WITH-COMPILATION-UNIT.
+One of three functions required for deferred-warnings support in ASDF."
+  #+clozure
+  (if-let (dw ccl::*outstanding-deferred-warnings*)
+    (let ((mdw (ccl::ensure-merged-deferred-warnings dw)))
+      (setf (ccl::deferred-warnings.warnings mdw) nil)))
+  #+sbcl
+  (when sb-c::*in-compilation-unit*
+    (setf sb-c::*undefined-warnings* nil
+          sb-c::*aborted-compilation-unit-count* 0
+          sb-c::*compiler-error-count* 0
+          sb-c::*compiler-warning-count* 0
+          sb-c::*compiler-style-warning-count* 0
+          sb-c::*compiler-note-count* 0)))
+
+(defun* save-deferred-warnings (warnings-file)
+  "Save forward reference conditions so they may be issued at a latter tim=
e,
+possibly in a different process."
+  (with-open-file (s warnings-file :direction :output :if-exists :supersed=
e)
+    (with-safe-io-syntax ()
+      (write (reify-deferred-warnings) :stream s :pretty t :readably t)
+      (terpri s)))
+  (reset-deferred-warnings))
+
+(defun* warnings-file-type (&optional implementation-type)
+  (case (or implementation-type *implementation-type*)
+    (:sbcl "sbcl-warnings")
+    ((:clozure :ccl) "ccl-warnings")))
+
+(defvar *warnings-file-type* (warnings-file-type)
+  "Type for warnings files")
+
+(defun* warnings-file-p (file &optional implementation-type)
+  (if-let (type (if implementation-type
+                    (warnings-file-type implementation-type)
+                    *warnings-file-type*))
+    (equal (pathname-type file) type)))
+
+(defun* check-deferred-warnings (files &optional context-format context-ar=
guments)
+  (let ((file-errors nil)
+        (failure-p nil)
+        (warnings-p nil))
+    (handler-bind
+        ((warning #'(lambda (c)
+                      (setf warnings-p t)
+                      (unless (typep c 'style-warning)
+                        (setf failure-p t)))))
+      (with-compilation-unit (:override t)
+        (reset-deferred-warnings)
+        (dolist (file files)
+          (unreify-deferred-warnings
+           (handler-case (safe-read-file-form file)
+             (error (c)
+               (delete-file-if-exists file)
+               (push c file-errors)
+               nil))))))
+    (dolist (error file-errors) (error error))
+    (check-lisp-compile-warnings
+     (or failure-p warnings-p) failure-p context-format context-arguments)=
))
+
+
+;;;; Deferred warnings
+#|
+Mini-guide to adding support for deferred warnings on an implementation.
+
+First, look at what such a warning looks like:
+
+(describe
+ (handler-case
+     (and (eval '(lambda () (some-undefined-function))) nil)
+   (t (c) c)))
+
+Then you can grep for the condition type in your compiler sources
+and see how to catch those that have been deferred,
+and/or read, clear and restore the deferred list.
+
+ccl::
+undefined-function-reference
+verify-deferred-warning
+report-deferred-warnings
+
+|#
+
+(defun* call-with-saved-deferred-warnings (thunk warnings-file)
+  (if warnings-file
+      (with-compilation-unit (:override t)
+        (let (#+sbcl (sb-c::*undefined-warnings* nil))
+          (multiple-value-prog1
+              (with-muffled-compiler-conditions ()
+                (funcall thunk))
+            (save-deferred-warnings warnings-file)
+            (reset-deferred-warnings))))
+      (funcall thunk)))
+
+(defmacro with-saved-deferred-warnings ((warnings-file) &body body)
+  "If WARNINGS-FILE is not nil, records the deferred-warnings around the B=
ODY
+and saves those warnings to the given file for latter use,
+possibly in a different process. Otherwise just run the BODY."
+  `(call-with-saved-deferred-warnings #'(lambda () , at body) ,warnings-file))
+
+
+;;; from ASDF
+
+(defun* current-lisp-file-pathname ()
+  (or *compile-file-pathname* *load-pathname*))
+
+(defun* load-pathname ()
+  *load-pathname*)
+
+(defun* lispize-pathname (input-file)
+  (make-pathname :type "lisp" :defaults input-file))
+
+(defun* compile-file-type (&rest keys)
+  "pathname TYPE for lisp FASt Loading files"
+  (declare (ignorable keys))
+  #-(or ecl mkcl) (load-time-value (pathname-type (compile-file-pathname "=
foo.lisp")))
+  #+(or ecl mkcl) (pathname-type (apply 'compile-file-pathname "foo" keys)=
))
+
+(defun* call-around-hook (hook function)
+  (call-function (or hook 'funcall) function))
+
+(defun* compile-file-pathname* (input-file &rest keys &key output-file &al=
low-other-keys)
+  (let* ((keys
+           (remove-plist-keys `(#+(and allegro (not (version>=3D 8 2))) :e=
xternal-format
+                            ,@(unless output-file '(:output-file))) keys)))
+    (if (absolute-pathname-p output-file)
+        ;; what cfp should be doing, w/ mp* instead of mp
+        (let* ((type (pathname-type (apply 'compile-file-type keys)))
+               (defaults (make-pathname
+                          :type type :defaults (merge-pathnames* input-fil=
e))))
+          (merge-pathnames* output-file defaults))
+        (funcall *output-translation-function*
+                 (apply 'compile-file-pathname input-file keys)))))
+
+(defun* (compile-file*) (input-file &rest keys
+                                    &key compile-check output-file warning=
s-file
+                                    #+clisp lib-file #+(or ecl mkcl) objec=
t-file
+                                    &allow-other-keys)
+  "This function provides a portable wrapper around COMPILE-FILE.
+It ensures that the OUTPUT-FILE value is only returned and
+the file only actually created if the compilation was successful,
+even though your implementation may not do that, and including
+an optional call to an user-provided consistency check function COMPILE-CH=
ECK;
+it will call this function if not NIL at the end of the compilation
+with the arguments sent to COMPILE-FILE*, except with :OUTPUT-FILE TMP-FILE
+where TMP-FILE is the name of a temporary output-file.
+It also checks two flags (with legacy british spelling from ASDF1),
+*COMPILE-FILE-FAILURE-BEHAVIOUR* and *COMPILE-FILE-WARNINGS-BEHAVIOUR*
+with appropriate implementation-dependent defaults,
+and if a failure (respectively warnings) are reported by COMPILE-FILE
+with consider it an error unless the respective behaviour flag
+is one of :SUCCESS :WARN :IGNORE.
+If WARNINGS-FILE is defined, deferred warnings are saved to that file.
+On ECL or MKCL, it creates both the linkable object and loadable fasl file=
s.
+On implementations that erroneously do not recognize standard keyword argu=
ments,
+it will filter them appropriately."
+  #+ecl (when (and object-file (equal (compile-file-type) (pathname object=
-file)))
+          (format t "Whoa, some funky ASDF upgrade switched ~S calling con=
vention for ~S and ~S~%"
+                  'compile-file* output-file object-file)
+          (rotatef output-file object-file))
+  (let* ((keywords (remove-plist-keys
+                    `(:output-file :compile-check :warnings-file
+                      #+clisp :lib-file #+(or ecl mkcl) :object-file
+                      #+gcl2.6 ,@'(:external-format :print :verbose)) keys=
))
+         (output-file
+           (or output-file
+               (apply 'compile-file-pathname* input-file :output-file outp=
ut-file keywords)))
+         #+ecl
+         (object-file
+           (unless (use-ecl-byte-compiler-p)
+             (or object-file
+                 (compile-file-pathname output-file :type :object))))
+         #+mkcl
+         (object-file
+           (or object-file
+               (compile-file-pathname output-file :fasl-p nil)))
+         (tmp-file (tmpize-pathname output-file))
+         #+clisp
+         (tmp-lib (make-pathname :type "lib" :defaults tmp-file)))
+    (multiple-value-bind (output-truename warnings-p failure-p)
+        (with-saved-deferred-warnings (warnings-file)
+          (or #-(or ecl mkcl) (apply 'compile-file input-file :output-file=
 tmp-file keywords)
+              #+ecl (apply 'compile-file input-file :output-file
+                           (if object-file
+                               (list* object-file :system-p t keywords)
+                               (list* tmp-file keywords)))
+              #+mkcl (apply 'compile-file input-file
+                            :output-file object-file :fasl-p nil keywords)=
))
       (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 ve=
rsion ~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-bei=
ng-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.
-(defun* upgrade-asdf ()
-  (let ((version (asdf-version)))
-    (handler-bind (((or style-warning warning) #'muffle-warning))
-      (operate 'load-op :asdf :verbose nil))
-    (cleanup-upgraded-asdf version)))
-
-(defmethod perform-plan ((steps list) &key)
-  (let ((*package* *package*)
-        (*readtable* *readtable*))
-    (with-compilation-unit ()
-      (loop :for (op . component) :in steps :do
-        (perform-with-restarts op component)))))
-
-(defmethod operate (operation-class system &rest args
-                    &key ((:verbose *asdf-verbose*) *asdf-verbose*) versio=
n force
-                    &allow-other-keys)
-  (declare (ignore force))
-  (with-system-definitions ()
-    (let* ((op (apply 'make-instance operation-class
-                      :original-initargs args
-                      args))
-           (*verbose-out* (if *asdf-verbose* *standard-output* (make-broad=
cast-stream)))
-           (system (etypecase system
-                     (system system)
-                     ((or string symbol) (find-system system)))))
-      (unless (version-satisfies system version)
-        (error 'missing-component-of-version :requires system :version ver=
sion))
-      (let ((steps (traverse op system)))
-        (when (and (not (equal '("asdf") (component-find-path system)))
-                   (find '("asdf") (mapcar 'cdr steps)
-                         :test 'equal :key 'component-find-path)
-                   (upgrade-asdf))
-          ;; If we needed to upgrade ASDF to achieve our goal,
-          ;; then do it specially as the first thing, then
-          ;; invalidate all existing system
-          ;; retry the whole thing with the new OPERATE function,
-          ;; which on some implementations
-          ;; has a new symbol shadowing the current one.
-          (return-from operate
-            (apply (find-symbol* 'operate :asdf) operation-class system ar=
gs)))
-        (perform-plan steps)
-        (values op steps)))))
-
-(defun* oos (operation-class system &rest args &key force verbose version
-            &allow-other-keys)
-  (declare (ignore force verbose version))
-  (apply 'operate operation-class system args))
-
-(let ((operate-docstring
-  "Operate does three things:
-
-1. It creates an instance of OPERATION-CLASS using any keyword parameters
-as initargs.
-2. It finds the  asdf-system specified by SYSTEM (possibly loading
-it from disk).
-3. It then calls TRAVERSE with the operation and system as arguments
-
-The traverse operation is wrapped in WITH-COMPILATION-UNIT and error
-handling code. If a VERSION argument is supplied, then operate also
-ensures that the system found satisfies it using the VERSION-SATISFIES
-method.
-
-Note that dependencies may cause the operation to invoke other
-operations on the system or its components: the new operations will be
-created with the same initargs as the original one.
-"))
-  (setf (documentation 'oos 'function)
-        (format nil
-                "Short for _operate on system_ and an alias for the OPERAT=
E function.~%~%~a"
-                operate-docstring))
-  (setf (documentation 'operate 'function)
-        operate-docstring))
-
-(defun* load-system (system &rest keys &key force verbose version &allow-o=
ther-keys)
-  "Shorthand for `(operate 'asdf:load-op system)`.
-See OPERATE for details."
-  (declare (ignore force verbose version))
-  (apply 'operate *load-system-operation* system keys)
-  t)
-
-(defun* load-systems (&rest systems)
-  (map () 'load-system systems))
-
-(defun component-loaded-p (c)
-  (and (gethash 'load-op (component-operation-times (find-component c nil)=
)) t))
-
-(defun loaded-systems ()
-  (remove-if-not 'component-loaded-p (registered-systems)))
-
-(defun require-system (s &rest keys &key &allow-other-keys)
-  (apply 'load-system s :force-not (loaded-systems) keys))
-
-(defun* compile-system (system &rest args &key force verbose version
-                       &allow-other-keys)
-  "Shorthand for `(asdf:operate 'asdf:compile-op system)`. See OPERATE
-for details."
-  (declare (ignore force verbose version))
-  (apply 'operate 'compile-op system args)
-  t)
-
-(defun* test-system (system &rest args &key force verbose version
-                    &allow-other-keys)
-  "Shorthand for `(asdf:operate 'asdf:test-op system)`. See OPERATE for
-details."
-  (declare (ignore force verbose version))
-  (apply 'operate 'test-op system args)
-  t)
-
-;;;; ---------------------------------------------------------------------=
----
-;;;; Defsystem
-
-(defun* load-pathname ()
-  (resolve-symlinks* (or *load-pathname* *compile-file-pathname*)))
-
-(defun* determine-system-pathname (pathname)
-  ;; The defsystem macro calls us to determine
-  ;; the pathname of a system as follows:
-  ;; 1. the one supplied,
-  ;; 2. derived from *load-pathname* via load-pathname
-  ;; 3. taken from the *default-pathname-defaults* via default-directory
-  (let* ((file-pathname (load-pathname))
-         (directory-pathname (and file-pathname (pathname-directory-pathna=
me file-pathname))))
-    (or (and pathname (subpathname directory-pathname pathname :type :dire=
ctory))
-        directory-pathname
-        (default-directory))))
-
-(defun* find-class* (x &optional (errorp t) environment)
+        ((and output-truename
+              (flet ((check-flag (flag behaviour)
+                       (or (not flag) (member behaviour '(:success :warn :=
ignore)))))
+                (and (check-flag failure-p *compile-file-failure-behaviour=
*)
+                     (check-flag warnings-p *compile-file-warnings-behavio=
ur*)))
+              (progn
+                #+(or ecl mkcl)
+                (when (and #+ecl object-file)
+                  (setf output-truename
+                        (compiler::build-fasl
+                         tmp-file #+ecl :lisp-files #+mkcl :lisp-object-fi=
les
+                                  (list object-file))))
+                (or (not compile-check)
+                    (apply compile-check input-file :output-file tmp-file =
keywords))))
+         (delete-file-if-exists output-file)
+         (when output-truename
+           #+clisp (when lib-file (rename-file-overwriting-target tmp-lib =
lib-file))
+           (rename-file-overwriting-target output-truename output-file)
+           (setf output-truename (truename output-file)))
+         #+clisp (delete-file-if-exists tmp-lib))
+        (t ;; error or failed check
+         (delete-file-if-exists output-truename)
+         (setf output-truename nil)))
+      (values output-truename warnings-p failure-p))))
+
+(defun* load* (x &rest keys &key &allow-other-keys)
   (etypecase x
-    ((or standard-class built-in-class) x)
-    (symbol (find-class x errorp environment))))
-
-(defun* class-for-type (parent type)
-  (or (loop :for symbol :in (list
-                             type
-                             (find-symbol* type *package*)
-                             (find-symbol* type :asdf))
-        :for class =3D (and symbol (find-class symbol nil))
-        :when (and class
-                   (#-cormanlisp subtypep #+cormanlisp cl::subclassp
-                                 class (find-class 'component)))
-        :return class)
-      (and (eq type :file)
-           (find-class*
-            (or (loop :for module =3D parent :then (component-parent modul=
e) :while module
-                  :thereis (module-default-component-class module))
-                *default-component-class*) nil))
-      (sysdef-error "don't recognize component type ~A" type)))
-
-(defun* maybe-add-tree (tree op1 op2 c)
-  "Add the node C at /OP1/OP2 in TREE, unless it's there already.
-Returns the new tree (which probably shares structure with the old one)"
-  (let ((first-op-tree (assoc op1 tree)))
-    (if first-op-tree
-        (progn
-          (aif (assoc op2 (cdr first-op-tree))
-               (if (find c (cdr it) :test #'equal)
-                   nil
-                   (setf (cdr it) (cons c (cdr it))))
-               (setf (cdr first-op-tree)
-                     (acons op2 (list c) (cdr first-op-tree))))
-          tree)
-        (acons op1 (list (list op2 c)) tree))))
-
-(defun* union-of-dependencies (&rest deps)
-  (let ((new-tree nil))
-    (dolist (dep deps)
-      (dolist (op-tree dep)
-        (dolist (op  (cdr op-tree))
-          (dolist (c (cdr op))
-            (setf new-tree
-                  (maybe-add-tree new-tree (car op-tree) (car op) c))))))
-    new-tree))
-
-
-(defvar *serial-depends-on* nil)
-
-(defun* sysdef-error-component (msg type name value)
-  (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~=
) ~A is ~S~@:>"))
-                type name value))
-
-(defun* check-component-input (type name weakly-depends-on
-                              depends-on components in-order-to)
-  "A partial test of the values of a component."
-  (unless (listp depends-on)
-    (sysdef-error-component ":depends-on must be a list."
-                            type name depends-on))
-  (unless (listp weakly-depends-on)
-    (sysdef-error-component ":weakly-depends-on must be a list."
-                            type name weakly-depends-on))
-  (unless (listp components)
-    (sysdef-error-component ":components must be NIL or a list of componen=
ts."
-                            type name components))
-  (unless (and (listp in-order-to) (listp (car in-order-to)))
-    (sysdef-error-component ":in-order-to must be NIL or a list of compone=
nts."
-                            type name in-order-to)))
-
-(defun* %remove-component-inline-methods (component)
-  (dolist (name +asdf-methods+)
-    (map ()
-         ;; this is inefficient as most of the stored
-         ;; methods will not be for this particular gf
-         ;; But this is hardly performance-critical
-         #'(lambda (m)
-             (remove-method (symbol-function name) m))
-         (component-inline-methods component)))
-  ;; clear methods, then add the new ones
-  (setf (component-inline-methods component) nil))
-
-(defun* %define-component-inline-methods (ret rest)
-  (dolist (name +asdf-methods+)
-    (let ((keyword (intern (symbol-name name) :keyword)))
-      (loop :for data =3D rest :then (cddr data)
-        :for key =3D (first data)
-        :for value =3D (second data)
-        :while data
-        :when (eq key keyword) :do
-        (destructuring-bind (op qual (o c) &body body) value
-          (pushnew
-           (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
-                             , at body))
-           (component-inline-methods ret)))))))
-
-(defun* %refresh-component-inline-methods (component rest)
-  (%remove-component-inline-methods component)
-  (%define-component-inline-methods component rest))
-
-(defun* parse-component-form (parent options)
-  (destructuring-bind
-        (type name &rest rest &key
-              ;; the following list of keywords is reproduced below in the
-              ;; remove-keys form.  important to keep them in sync
-              components pathname
-              perform explain output-files operation-done-p
-              weakly-depends-on depends-on serial in-order-to
-              do-first
-              (version nil versionp)
-              ;; list ends
-              &allow-other-keys) options
-    (declare (ignorable perform explain output-files operation-done-p))
-    (check-component-input type name weakly-depends-on depends-on componen=
ts in-order-to)
-
-    (when (and parent
-               (find-component parent name)
-               ;; ignore the same object when rereading the defsystem
-               (not
-                (typep (find-component parent name)
-                       (class-for-type parent type))))
-      (error 'duplicate-names :name name))
-
-    (when versionp
-      (unless (parse-version version nil)
-        (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~=
]~@:>")
-              version name parent)))
-
-    (let* ((args (list* :name (coerce-name name)
-                        :pathname pathname
-                        :parent parent
-                        (remove-keys
-                         '(components pathname
-                           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 #'(lambda (x) (find-sys=
tem x nil))) weakly-depends-on)))
-      (when *serial-depends-on*
-        (push *serial-depends-on* depends-on))
-      (if ret ; preserve identity
-          (apply 'reinitialize-instance ret args)
-          (setf ret (apply 'make-instance (class-for-type parent type) arg=
s)))
-      (component-pathname ret) ; eagerly compute the absolute pathname
-      (when (typep ret 'module)
-        (let ((*serial-depends-on* nil))
-          (setf (module-components ret)
-                (loop
-                  :for c-form :in components
-                  :for c =3D (parse-component-form ret c-form)
-                  :for name =3D (component-name c)
-                  :collect c
-                  :when serial :do (setf *serial-depends-on* name))))
-        (compute-module-components-by-name ret))
-
-      (setf (component-load-dependencies ret) depends-on) ;; Used by POIU
-
-      (setf (component-in-order-to ret)
-            (union-of-dependencies
-             in-order-to
-             `((compile-op (compile-op , at depends-on))
-               (load-op (load-op , at depends-on)))))
-      (setf (component-do-first ret)
-            (union-of-dependencies
-             do-first
-             `((compile-op (load-op , at 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 (class 'system)
-                           defsystem-depends-on &allow-other-keys)
-  ;; The system must be registered before we parse the body,
-  ;; otherwise we recur when trying to find an existing system
-  ;; of the same name to reuse options (e.g. pathname) from.
-  ;; To avoid infinite recursion in cases where you defsystem a system
-  ;; that is registered to a different location to find-system,
-  ;; we also need to remember it in a special variable *systems-being-defi=
ned*.
-  (with-system-definitions ()
-    (let* ((name (coerce-name name))
-           (registered (system-registered-p 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)))
-      (setf (gethash name *systems-being-defined*) system)
-      (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.
-      (let ((class (class-for-type nil class)))
-        (unless (eq (type-of system) class)
-          (change-class system class)))
-      (parse-component-form
-       nil (list*
-            :module name
-            :pathname (determine-system-pathname pathname)
-            component-options)))))
-
-(defmacro defsystem (name &body options)
-  `(apply 'do-defsystem ',name ',options))
+    ((or pathname string #-(or allegro clozure gcl2.6 genera) stream)
+     (apply 'load x
+            #-gcl2.6 keys #+gcl2.6 (remove-plist-key :external-format keys=
)))
+    ;; GCL 2.6, Genera can't load from a string-input-stream
+    ;; ClozureCL 1.6 can only load from file input stream
+    ;; Allegro 5, I don't remember but it must have been broken when I tes=
ted.
+    #+(or allegro clozure gcl2.6 genera)
+    (stream ;; make do this way
+     (let ((*package* *package*)
+           (*readtable* *readtable*)
+           (*load-pathname* nil)
+           (*load-truename* nil))
+       (eval-input x)))))
+
+(defun* load-from-string (string)
+  "Portably read and evaluate forms from a STRING."
+  (with-input-from-string (s string) (load* s)))
+
+;;; Links FASLs together
+(defun* combine-fasls (inputs output)
+  #-(or allegro clisp clozure cmu lispworks sbcl scl xcl)
+  (error "~A does not support ~S~%inputs ~S~%output  ~S"
+         (implementation-type) 'combine-fasls inputs output)
+  #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede)
+  #+(or allegro clisp cmu sbcl scl xcl) (concatenate-files inputs output)
+  #+lispworks
+  (let (fasls)
+    (unwind-protect
+         (progn
+           (loop :for i :in inputs
+                 :for n :from 1
+                 :for f =3D (add-pathname-suffix
+                           output (format nil "-FASL~D" n))
+                 :do #-lispworks-personal-edition (lispworks:copy-file i f)
+                     #+lispworks-personal-edition (concatenate-files (list=
 i) f)
+                     (push f fasls))
+           (ignore-errors (lispworks:delete-system :fasls-to-concatenate))
+           (eval `(scm:defsystem :fasls-to-concatenate
+                    (:default-pathname ,(pathname-directory-pathname outpu=
t))
+                    :members
+                    ,(loop :for f :in (reverse fasls)
+                           :collect `(,(namestring f) :load-only t))))
+           (scm:concatenate-system output :fasls-to-concatenate))
+      (loop :for f :in fasls :do (ignore-errors (delete-file f)))
+      (ignore-errors (lispworks:delete-system :fasls-to-concatenate)))))
 =

 ;;;; ---------------------------------------------------------------------=
------
-;;;; run-shell-command
-;;;;
-;;;; run-shell-command functions for other lisp implementations will be
-;;;; gratefully accepted, if they do the same thing.
-;;;; 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 Un=
ix,
-;;;; which will hopefully use the shell /bin/sh (which we force in some ca=
ses)
-;;;; which is hopefully reasonably compatible with a POSIX *or* Bourne she=
ll.
-;;;; 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 depr=
ecate
-;;;; use of it from the asdf package. However, this would break unspecified
-;;;; existing software, so until a clear alternative exists, we can't depr=
ecate
-;;;; 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/ and its derivatives.
-
-(defun* run-shell-command (control-string &rest args)
-  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
-synchronously execute the result using a Bourne-compatible shell, with
-output to *VERBOSE-OUT*.  Returns the shell's exit code."
-  (let ((command (apply 'format nil control-string args)))
-    (asdf-message "; $ ~A~%" command)
-
-    #+abcl
-    (ext:run-shell-command command :output *verbose-out*)
-
-    #+allegro
-    ;; will this fail if command has embedded quotes - it seems to work
-    (multiple-value-bind (stdout stderr exit-code)
-        (excl.osi:command-output
-         #-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)
-      exit-code)
-
-    #+clisp
-    ;; CLISP returns NIL for exit status zero.
-    (if *verbose-out*
-        (let* ((new-command (format nil "( ~A ) ; r=3D$? ; echo ; echo ASD=
F-EXIT-STATUS $r"
-                                    command))
-               (outstream (ext:run-shell-command new-command :output :stre=
am :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
-                 (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)
-    (ext:process-exit-code
-     (ext:run-program
-      "/bin/sh"
-      (list "-c" command)
-      :input nil :output *verbose-out*))
-
-    #+cormanlisp
-    (win32:system command)
-
-    #+ecl ;; courtesy of Juan Jose Garcia Ripoll
-    (ext:system command)
-
-    #+gcl
-    (lisp:system command)
-
-    #+lispworks
-    (apply 'system:call-system-showing-output command
-           :show-cmd nil :prefix "" :output-stream *verbose-out*
-           (when (os-unix-p) '(:shell-type "/bin/sh")))
-
-    #+mcl
-    (ccl::with-cstrs ((%command command)) (_system %command))
-
-    #+mkcl
-    ;; This has next to no chance of working on basic Windows!
-    ;; Your best hope is that Cygwin or MSYS is somewhere in the PATH.
-    (multiple-value-bind (io process exit-code)
-	(apply #'mkcl:run-program #+windows "sh" #-windows "/bin/sh"
-                                  (list "-c" command)
-                                  :input nil :output t #|*verbose-out*|# ;=
; will be *verbose-out* when we support it
-                                  #-windows '(:search nil))
-      (declare (ignore io process))
-      exit-code)
-
-    #+sbcl
-    (sb-ext:process-exit-code
-     (apply 'sb-ext:run-program
-            #+win32 "sh" #-win32 "/bin/sh"
-            (list  "-c" command)
-            :input nil :output *verbose-out*
-            #+win32 '(:search t) #-win32 nil))
-
-    #+xcl
-    (ext:run-shell-command command)
-
-    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl mkcl sbcl s=
cl 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 speci=
ally-
-crafted output string to recover the exit status of the shell command and a
-list of lines of output."
-  (loop :with status-prefix =3D "ASDF-EXIT-STATUS "
-    :with prefix-length =3D (length status-prefix)
-    :with exit-status =3D -1 :with lines =3D ()
-    :for line =3D (read-line stream nil nil)
-    :while line :do (push line lines) :finally
-    (let* ((last (car lines))
-           (status (and last (>=3D (length last) prefix-length)
-                        (string-equal last status-prefix :end1 prefix-leng=
th)
-                        (parse-integer last :start prefix-length :junk-all=
owed t))))
-      (when status
-        (setf exit-status status)
-        (pop lines) (when (equal "" (car lines)) (pop lines)))
-      (return (values exit-status (reverse lines))))))
-
-;;;; ---------------------------------------------------------------------=
------
-;;;; system-relative-pathname
-
-(defun* system-definition-pathname (x)
-  ;; As of 2.014.8, we mean to make this function obsolete,
-  ;; but that won't happen until all clients have been updated.
-  ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
-  "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
-It used to expose ASDF internals with subtle differences with respect to
-user expectations, that have been refactored away since.
-We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
-for a mostly compatible replacement that we're supporting,
-or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
-if that's whay you mean." ;;)
-  (system-source-file x))
-
-(defmethod system-source-file ((system system))
-  ;; might be missing when upgrading from ASDF 1 and u-i-f-r-c failed
-  (unless (slot-boundp system 'source-file)
-    (%set-system-source-file
-     (probe-asd (component-name system) (component-pathname system)) syste=
m))
-  (%system-source-file system))
-(defmethod system-source-file ((system-name string))
-  (%system-source-file (find-system system-name)))
-(defmethod system-source-file ((system-name symbol))
-  (%system-source-file (find-system system-name)))
-
-(defun* system-source-directory (system-designator)
-  "Return a pathname object corresponding to the
-directory in which the system specification (.asd file) is
-located."
-  (pathname-directory-pathname (system-source-file system-designator)))
-
-(defun* relativize-directory (directory)
-  (cond
-    ((stringp directory)
-     (list :relative directory))
-    ((eq (car directory) :absolute)
-     (cons :relative (cdr directory)))
-    (t
-     directory)))
-
-(defun* relativize-pathname-directory (pathspec)
-  (let ((p (pathname pathspec)))
-    (make-pathname
-     :directory (relativize-directory (pathname-directory p))
-     :defaults p)))
-
-(defun* system-relative-pathname (system name &key type)
-  (subpathname (system-source-directory system) name :type type))
-
-
-;;; ----------------------------------------------------------------------=
-----
-;;; implementation-identifier
-;;;
-;;; produce a string to identify current implementation.
-;;; Initially stolen from SLIME's SWANK, rewritten since.
-;;; 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) :c=
mu
-     :ecl :gcl (:lw :lispworks) :mcl :mkcl :sbcl :scl :symbolics :xcl)))
-
-(defun operating-system ()
-  (first-feature
-   '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin firs=
t!
-     (: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=3D64 :pc3=
86))
-     (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx38=
6 :x8632-target)
-     (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powe=
rpc)
-     :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 JN=
I,
-     ;; 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 (let ((s 'ccl::target-fasl-version))
-        (and (fboundp s) (funcall s)))
-      (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)))
-    (car ; as opposed to OR, this idiom prevents some unreachable code war=
ning
-     (list
-      #+allegro
-      (format nil "~A~@[~A~]~@[~A~]~@[~A~]"
-              excl::*common-lisp-version-number*
-              ;; M means "modern", as opposed to ANSI-compatible mode (whi=
ch I consider default)
-              (and (eq excl:*current-case-mode* :case-sensitive-lower) "M")
-              ;; Note if not using International ACL
-              ;; see http://www.franz.com/support/documentation/8.1/doc/op=
erators/excl/ics-target-case.htm
-              (excl:ics-target-case (:-ics "8"))
-	      (and (member :smp *features*) "S"))
-      #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
-      #+clisp
-      (subseq s 0 (position #\space s)) ; strip build information (date, e=
tc.)
-      #+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 ()
-  (substitute-if
-   #\_ #'(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)))))
-
-(defun* hostname ()
-  ;; Note: untested on RMCL
-  #+(or abcl clozure cmucl ecl genera lispworks mcl mkcl sbcl scl xcl) (ma=
chine-instance)
-  #+cormanlisp "localhost" ;; is there a better way? Does it matter?
-  #+allegro (excl.osi:gethostname)
-  #+clisp (first (split-string (machine-instance) :separator " "))
-  #+gcl (system:gethostname))
-
-
-;;; ----------------------------------------------------------------------=
-----
-;;; Generic support for configuration files
-
-(defun inter-directory-separator ()
-  (if (os-unix-p) #\: #\;))
-
-(defun* user-homedir ()
-  (truenamize
-   (pathname-directory-pathname
-    #+cormanlisp (ensure-directory-pathname (user-homedir-pathname))
-    #+mcl (current-user-homedir-pathname)
-    #-(or cormanlisp mcl) (user-homedir-pathname))))
-
-(defun* ensure-pathname* (x want-absolute want-directory fmt &rest args)
-  (when (plusp (length x))
-    (let ((p (if want-directory (ensure-directory-pathname x) (pathname x)=
)))
-      (when want-absolute
-        (unless (absolute-pathname-p p)
-          (cerror "ignore relative pathname"
-                  "Invalid relative pathname ~A~@[ ~?~]" x fmt args)
-          (return-from ensure-pathname* nil)))
-      p)))
-(defun* split-pathnames* (x want-absolute want-directory fmt &rest args)
-  (loop :for dir :in (split-string
-                      x :separator (string (inter-directory-separator)))
-        :collect (apply 'ensure-pathname* dir want-absolute want-directory=
 fmt args)))
-(defun* getenv-pathname (x &key want-absolute want-directory &aux (s (gete=
nv x)))
-  (ensure-pathname* s want-absolute want-directory "from (getenv ~S)" x))
-(defun* getenv-pathnames (x &key want-absolute want-directory &aux (s (get=
env x)))
-  (and (plusp (length s))
-       (split-pathnames* s want-absolute want-directory "from (getenv ~S) =
=3D ~S" x s)))
-(defun* getenv-absolute-directory (x)
-  (getenv-pathname x :want-absolute t :want-directory t))
-(defun* getenv-absolute-directories (x)
-  (getenv-pathnames x :want-absolute t :want-directory t))
+;;;; Generic support for configuration files
+
+(asdf/package:define-package :asdf/configuration
+  (:recycle :asdf/configuration :asdf)
+  (:use :asdf/common-lisp :asdf/utility
+   :asdf/os :asdf/pathname :asdf/filesystem :asdf/stream :asdf/image)
+  (:export
+   #:get-folder-path
+   #:user-configuration-directories #:system-configuration-directories
+   #:in-first-directory
+   #:in-user-configuration-directory #:in-system-configuration-directory
+   #:validate-configuration-form #:validate-configuration-file #:validate-=
configuration-directory
+   #:configuration-inheritance-directive-p
+   #:report-invalid-form #:invalid-configuration #:*ignored-configuration-=
form*
+   #:*clear-configuration-hook* #:clear-configuration #:register-clear-con=
figuration-hook
+   #:resolve-location #:location-designator-p #:location-function-p #:*her=
e-directory*
+   #:resolve-relative-location #:resolve-absolute-location #:upgrade-confi=
guration))
+(in-package :asdf/configuration)
+
+(define-condition invalid-configuration ()
+  ((form :reader condition-form :initarg :form)
+   (location :reader condition-location :initarg :location)
+   (format :reader condition-format :initarg :format)
+   (arguments :reader condition-arguments :initarg :arguments :initform ni=
l))
+  (:report (lambda (c s)
+               (format s (compatfmt "~@<~? (will be skipped)~@:>")
+                       (condition-format c)
+                       (list* (condition-form c) (condition-location c)
+                              (condition-arguments c))))))
 =

 (defun* get-folder-path (folder)
   (or ;; this semi-portably implements a subset of the functionality of li=
spworks' sys:get-folder-path
@@ -3357,7 +4607,7 @@
     (:local-appdata (getenv-absolute-directory "LOCALAPPDATA"))
     (:appdata (getenv-absolute-directory "APPDATA"))
     (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA")
-			 (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Applicati=
on Data/"))))))
+                         (subpathname* (getenv-absolute-directory "ALLUSER=
SPROFILE") "Application Data/"))))))
 =

 (defun* user-configuration-directories ()
   (let ((dirs
@@ -3369,7 +4619,7 @@
            ,@(when (os-windows-p)
                `(,(subpathname* (get-folder-path :local-appdata) "common-l=
isp/config/")
                  ,(subpathname* (get-folder-path :appdata) "common-lisp/co=
nfig/")))
-           ,(subpathname (user-homedir) ".config/common-lisp/"))))
+           ,(subpathname (user-homedir-pathname) ".config/common-lisp/"))))
     (remove-duplicates (remove-if-not #'absolute-pathname-p dirs)
                        :from-end t :test 'equal)))
 =

@@ -3377,10 +4627,8 @@
   (cond
     ((os-unix-p) '(#p"/etc/common-lisp/"))
     ((os-windows-p)
-     (aif
-      ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windo=
ws\CurrentVersion\Explorer\User Shell Folders\Common AppData
-      (subpathname* (get-folder-path :common-appdata) "common-lisp/config/=
")
-      (list it)))))
+     (if-let (it (subpathname* (get-folder-path :common-appdata) "common-l=
isp/config/"))
+       (list it)))))
 =

 (defun* in-first-directory (dirs x &key (direction :input))
   (loop :with fun =3D (ecase direction
@@ -3448,26 +4696,14 @@
              description forms))
     (funcall validator (car forms) :location file)))
 =

-(defun* hidden-file-p (pathname)
-  (equal (first-char (pathname-name pathname)) #\.))
-
-(defun* directory* (pathname-spec &rest keys &key &allow-other-keys)
-  (apply 'directory pathname-spec
-         (append keys '#.(or #+allegro '(:directories-are-files nil :follo=
w-symbolic-links nil)
-                             #+clozure '(:follow-links nil)
-                             #+clisp '(:circle t :if-does-not-exist :ignor=
e)
-                             #+(or cmu scl) '(:follow-links nil :truenamep=
 nil)
-                             #+sbcl (when (find-symbol* :resolve-symlinks =
'#:sb-impl)
-                                      '(:resolve-symlinks nil))))))
-
 (defun* validate-configuration-directory (directory tag validator &key inv=
alid-form-reporter)
   "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will
 be applied to the results to yield a configuration form.  Current
 values of TAG include :source-registry and :output-translations."
   (let ((files (sort (ignore-errors
                        (remove-if
-                        'hidden-file-p
-                        (directory* (make-pathname :name :wild :type "conf=
" :defaults directory))))
+                        'hidden-pathname-p
+                        (directory* (make-pathname :name *wild* :type "con=
f" :defaults directory))))
                      #'string< :key #'namestring)))
     `(,tag
       ,@(loop :for file :in files :append
@@ -3485,13 +4721,2502 @@
                   :do (report-invalid-form invalid-form-reporter :form for=
m :location file)))
       :inherit-configuration)))
 =

-
-;;; ----------------------------------------------------------------------=
-----
-;;; asdf-output-translations
-;;;
-;;; this code is heavily inspired from
-;;; asdf-binary-translations, common-lisp-controller and cl-launch.
-;;; ----------------------------------------------------------------------=
-----
+(defun* resolve-relative-location (x &key ensure-directory wilden)
+  (ensure-pathname
+   (etypecase x
+     (pathname x)
+     (string (parse-unix-namestring
+              x :ensure-directory ensure-directory))
+     (cons
+      (if (null (cdr x))
+          (resolve-relative-location
+           (car x) :ensure-directory ensure-directory :wilden wilden)
+          (let* ((car (resolve-relative-location
+                       (car x) :ensure-directory t :wilden nil)))
+            (merge-pathnames*
+             (resolve-relative-location
+              (cdr x) :ensure-directory ensure-directory :wilden wilden)
+             car))))
+     ((eql :*/) *wild-directory*)
+     ((eql :**/) *wild-inferiors*)
+     ((eql :*.*.*) *wild-file*)
+     ((eql :implementation)
+      (parse-unix-namestring
+       (implementation-identifier) :ensure-directory t))
+     ((eql :implementation-type)
+      (parse-unix-namestring
+       (string-downcase (implementation-type)) :ensure-directory t))
+     ((eql :hostname)
+      (parse-unix-namestring (hostname) :ensure-directory t)))
+  :wilden (and wilden (not (pathnamep x)) (not (member x '(:*/ :**/ :*.*.*=
))))
+  :want-relative t))
+
+(defvar *here-directory* nil
+  "This special variable is bound to the currect directory during calls to
+PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here
+directive.")
+
+(defvar *user-cache* nil
+  "A specification as per RESOLVE-LOCATION of where the user keeps his FAS=
L cache")
+
+(defun compute-user-cache ()
+  (setf *user-cache*
+        (flet ((try (x &rest sub) (and x `(,x , at sub))))
+          (or
+           (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp"=
 :implementation)
+           (when (os-windows-p)
+             (try (or (get-folder-path :local-appdata)
+                      (get-folder-path :appdata))
+                  "common-lisp" "cache" :implementation))
+           '(:home ".cache" "common-lisp" :implementation)))))
+(register-image-restore-hook 'compute-user-cache)
+
+(defun* resolve-absolute-location (x &key ensure-directory wilden)
+  (ensure-pathname
+   (etypecase x
+     (pathname x)
+     (string
+      (let ((p #-mcl (parse-namestring x)
+               #+mcl (probe-posix x)))
+        #+mcl (unless p (error "POSIX pathname ~S does not exist" x))
+        (if ensure-directory (ensure-directory-pathname p) p)))
+     (cons
+      (return-from resolve-absolute-location
+        (if (null (cdr x))
+            (resolve-absolute-location
+             (car x) :ensure-directory ensure-directory :wilden wilden)
+            (merge-pathnames*
+             (resolve-relative-location
+              (cdr x) :ensure-directory ensure-directory :wilden wilden)
+             (resolve-absolute-location
+              (car x) :ensure-directory t :wilden nil)))))
+     ((eql :root)
+      ;; special magic! we return a relative pathname,
+      ;; but what it means to the output-translations is
+      ;; "relative to the root of the source pathname's host and device".
+      (return-from resolve-absolute-location
+        (let ((p (make-pathname* :directory '(:relative))))
+          (if wilden (wilden p) p))))
+     ((eql :home) (user-homedir-pathname))
+     ((eql :here) (resolve-absolute-location
+                   *here-directory* :ensure-directory t :wilden nil))
+     ((eql :user-cache) (resolve-absolute-location
+                         *user-cache* :ensure-directory t :wilden nil)))
+   :wilden (and wilden (not (pathnamep x)))
+   :resolve-symlinks *resolve-symlinks*
+   :want-absolute t))
+
+;; Try to override declaration in previous versions of ASDF.
+(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean)
+                             (:ensure-directory boolean)) t) resolve-locat=
ion))
+
+(defun* (resolve-location) (x &key ensure-directory wilden directory)
+  ;; :directory backward compatibility, until 2014-01-16: accept directory=
 as well as ensure-directory
+  (loop* :with dirp =3D (or directory ensure-directory)
+         :with (first . rest) =3D (if (atom x) (list x) x)
+         :with path =3D (resolve-absolute-location
+                       first :ensure-directory (and (or dirp rest) t)
+                             :wilden (and wilden (null rest)))
+         :for (element . morep) :on rest
+         :for dir =3D (and (or morep dirp) t)
+         :for wild =3D (and wilden (not morep))
+         :for sub =3D (merge-pathnames*
+                     (resolve-relative-location
+                      element :ensure-directory dir :wilden wild)
+                     path)
+         :do (setf path (if (absolute-pathname-p sub) (resolve-symlinks* s=
ub) sub))
+         :finally (return path)))
+
+(defun* location-designator-p (x)
+  (flet ((absolute-component-p (c)
+           (typep c '(or string pathname
+                      (member :root :home :here :user-cache))))
+         (relative-component-p (c)
+           (typep c '(or string pathname
+                      (member :*/ :**/ :*.*.* :implementation :implementat=
ion-type)))))
+    (or (typep x 'boolean)
+        (absolute-component-p x)
+        (and (consp x) (absolute-component-p (first x)) (every #'relative-=
component-p (rest x))))))
+
+(defun* location-function-p (x)
+  (and
+   (length=3Dn-p x 2)
+   (eq (car x) :function)
+   (or (symbolp (cadr x))
+       (and (consp (cadr x))
+            (eq (caadr x) 'lambda)
+            (length=3Dn-p (cadadr x) 2)))))
+
+(defvar *clear-configuration-hook* '())
+
+(defun* register-clear-configuration-hook (hook-function &optional call-no=
w-p)
+  (register-hook-function '*clear-configuration-hook* hook-function call-n=
ow-p))
+
+(defun* clear-configuration ()
+  (call-functions *clear-configuration-hook*))
+
+(register-image-dump-hook 'clear-configuration)
+
+;; If a previous version of ASDF failed to read some configuration, try ag=
ain.
+(defun* upgrade-configuration ()
+  (when *ignored-configuration-form*
+    (clear-configuration)
+    (setf *ignored-configuration-form* nil)))
+
+
+;;;; ---------------------------------------------------------------------=
----
+;;; Hacks for backward-compatibility of the driver
+
+(asdf/package:define-package :asdf/backward-driver
+  (:recycle :asdf/backward-driver :asdf)
+  (:use :asdf/common-lisp :asdf/package :asdf/utility
+   :asdf/pathname :asdf/stream :asdf/os :asdf/image
+   :asdf/run-program :asdf/lisp-build
+   :asdf/configuration)
+  (:export
+   #:coerce-pathname #:component-name-to-pathname-components
+   #+(or ecl mkcl) #:compile-file-keeping-object
+   ))
+(in-package :asdf/backward-driver)
+
+;;;; Backward compatibility with various pathname functions.
+
+(defun* coerce-pathname (name &key type defaults)
+  ;; For backward-compatibility only, for people using internals
+  ;; Reported users in quicklisp: hu.dwim.asdf, asdf-utils, xcvb
+  ;; Will be removed after 2014-01-16.
+  ;;(warn "Please don't use ASDF::COERCE-PATHNAME. Use ASDF/PATHNAME:PARSE=
-UNIX-NAMESTRING.")
+  (parse-unix-namestring name :type type :defaults defaults))
+
+(defun* component-name-to-pathname-components (unix-style-namestring
+                                               &key force-directory force-=
relative)
+  ;; Will be removed after 2014-01-16.
+  ;; (warn "Please don't use ASDF::COMPONENT-NAME-TO-PATHNAME-COMPONENTS, =
use SPLIT-UNIX-NAMESTRING-DIRECTORY-COMPONENTS")
+  (multiple-value-bind (relabs path filename file-only)
+      (split-unix-namestring-directory-components
+       unix-style-namestring :ensure-directory force-directory)
+    (declare (ignore file-only))
+    (when (and force-relative (not (eq relabs :relative)))
+      (error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~=
_~S~@:>")
+             unix-style-namestring))
+    (values relabs path filename)))
+
+#+(or ecl mkcl)
+(defun* compile-file-keeping-object (&rest args) (apply #'compile-file* ar=
gs))
+;;;; ---------------------------------------------------------------------=
------
+;;;; Re-export all the functionality in asdf/driver
+
+(asdf/package:define-package :asdf/driver
+  (:nicknames :d :asdf-driver :asdf-utils)
+  (:use :asdf/common-lisp :asdf/package :asdf/utility
+    :asdf/os :asdf/pathname :asdf/stream :asdf/filesystem :asdf/image
+   :asdf/run-program :asdf/lisp-build
+   :asdf/configuration :asdf/backward-driver)
+  (:reexport
+   ;; NB: excluding asdf/common-lisp
+   ;; which include all of CL with compatibility modifications on select p=
latforms.
+   :asdf/package :asdf/utility
+    :asdf/os :asdf/pathname :asdf/stream :asdf/filesystem :asdf/image
+   :asdf/run-program :asdf/lisp-build
+   :asdf/configuration :asdf/backward-driver))
+;;;; ---------------------------------------------------------------------=
----
+;;;; Handle upgrade as forward- and backward-compatibly as possible
+;; See https://bugs.launchpad.net/asdf/+bug/485687
+
+(asdf/package:define-package :asdf/upgrade
+  (:recycle :asdf/upgrade :asdf)
+  (:use :asdf/common-lisp :asdf/driver)
+  (:export
+   #:asdf-version #:*previous-asdf-versions* #:*asdf-version*
+   #:asdf-message #:*verbose-out*
+   #:upgrading-p #:when-upgrading #:upgrade-asdf #:asdf-upgrade-error
+   #:*post-upgrade-cleanup-hook* #:*post-upgrade-restart-hook* #:cleanup-u=
pgraded-asdf
+   ;; There will be no symbol left behind!
+   #:intern*)
+  (:import-from :asdf/package #:intern* #:find-symbol*))
+(in-package :asdf/upgrade)
+
+;;; Special magic to detect if this is an upgrade
+
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (defun asdf-version ()
+    "Exported interface to the version of ASDF currently installed. A stri=
ng.
+You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-=
VERSION) \"3.4.5.67\")."
+    (when (find-package :asdf)
+      (or (symbol-value (find-symbol (string :*asdf-version*) :asdf))
+          (let ((ver (symbol-value (find-symbol (string :*asdf-revision*) =
:asdf))))
+            (etypecase ver
+              (string ver)
+              (cons (format nil "~{~D~^.~}" ver))
+              (null "1.0"))))))
+  (defvar *asdf-version* nil)
+  (defvar *previous-asdf-versions* nil)
+  (defvar *verbose-out* nil)
+  (defun* asdf-message (format-string &rest format-args)
+    (when *verbose-out* (apply 'format *verbose-out* format-string format-=
args)))
+  (defvar *post-upgrade-cleanup-hook* ())
+  (defvar *post-upgrade-restart-hook* ())
+  (defun* upgrading-p ()
+    (and *previous-asdf-versions* (not (equal *asdf-version* (first *previ=
ous-asdf-versions*)))))
+  (defmacro when-upgrading ((&key (upgrading-p '(upgrading-p)) when) &body=
 body)
+    `(eval-when (:compile-toplevel :load-toplevel :execute)
+       (when (and ,upgrading-p ,@(when when `(,when)))
+         (handler-bind ((style-warning #'muffle-warning))
+           (eval '(progn , at body))))))
+  (let* (;; For bug reporting sanity, please always bump this version when=
 you modify this file.
+         ;; Please also modify asdf.asd to reflect this change. make bump-=
version v=3D3.4.5.67.8
+         ;; can help you do these changes in synch (look at the source for=
 documentation).
+         ;; Relying on its automation, the version is now redundantly pres=
ent on top of this file.
+         ;; "3.4" would be the general branch for major version 3, minor v=
ersion 4.
+         ;; "3.4.5" would be an official release in the 3.4 branch.
+         ;; "3.4.5.67" would be a development version in the official upst=
ream of 3.4.5.
+         ;; "3.4.5.0.8" would be your eighth local modification of officia=
l release 3.4.5
+         ;; "3.4.5.67.8" would be your eighth local modification of develo=
pment version 3.4.5.67
+         (asdf-version "2.28")
+         (existing-version (asdf-version)))
+    (setf *asdf-version* asdf-version)
+    (when (and existing-version (not (equal asdf-version existing-version)=
))
+      (push existing-version *previous-asdf-versions*)
+      (when (or *load-verbose* *verbose-out*)
+        (format *trace-output*
+                (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]=
to version ~A~@:>~%")
+                existing-version asdf-version)))))
+
+(when-upgrading ()
+  (let ((redefined-functions ;; gf signature and/or semantics changed inco=
mpatibly. Oops.
+          '(#:component-relative-pathname #:component-parent-pathname ;; c=
omponent
+            #:source-file-type
+            #:find-system #:system-source-file #:system-relative-pathname =
;; system
+             #:find-component ;; find-component
+             #:explain #:perform #:perform-with-restarts #:input-files #:o=
utput-files ;; action
+             #:component-depends-on #:component-self-dependencies #:operat=
ion-done-p
+             #:traverse ;; plan
+             #:operate  ;; operate
+             #:apply-output-translations ;; output-translations
+             #:process-output-translations-directive
+             #:inherit-source-registry #:process-source-registry ;; source=
-registry
+             #:process-source-registry-directive
+             #:trivial-system-p ;; bundle
+             ;; NB: it's too late to do anything about asdf-driver functio=
ns!
+             ))
+         (uninterned-symbols
+           '(#:*asdf-revision* #:around #:asdf-method-combination
+             #:split #:make-collector #:do-dep #:do-one-dep
+             #:resolve-relative-location-component #:resolve-absolute-loca=
tion-component
+             #:output-files-for-system-and-operation))) ; obsolete ASDF-BI=
NARY-LOCATION function
+    (declare (ignorable redefined-functions uninterned-symbols))
+    (loop :for name :in (append #-(or ecl) redefined-functions)
+          :for sym =3D (find-symbol* name :asdf nil) :do
+            (when sym
+              (fmakunbound sym)))
+    (loop :with asdf =3D (find-package :asdf)
+          :for name :in (append #+(or ecl) redefined-functions uninterned-=
symbols) ;XXX
+          :for sym =3D (find-symbol* name :asdf nil)
+          :for base-pkg =3D (and sym (symbol-package sym)) :do
+            (when sym
+              (cond
+                ((or (eq base-pkg asdf) (not base-pkg))
+                 (unintern* sym asdf)
+                 (intern* sym asdf))
+                (t
+                 (unintern* sym base-pkg)
+                 (let ((new (intern* sym base-pkg)))
+                   (shadowing-import new asdf))))))))
+
+
+;;; Self-upgrade functions
+
+(defun* asdf-upgrade-error ()
+  ;; Important notice for whom it concerns. The crux of the matter is that
+  ;; TRAVERSE can be completely refactored, and so after the find-system r=
eturns, it's too late.
+  (error "When a system transitively depends on ASDF, it must :defsystem-d=
epends-on (:asdf)~%~
+          Otherwise, when you upgrade from ASDF 2, you must do it before y=
ou operate on any system.~%"))
+
+(defun* cleanup-upgraded-asdf (&optional (old-version (first *previous-asd=
f-versions*)))
+  (let ((new-version (asdf-version)))
+    (unless (equal old-version new-version)
+      (push new-version *previous-asdf-versions*)
+      (when old-version
+        (cond
+          ((version-compatible-p new-version old-version)
+           (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version =
~A to version ~A~@:>~%")
+                         old-version new-version))
+          ((version-compatible-p 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)))
+        (call-functions (reverse *post-upgrade-cleanup-hook*))
+        t))))
+
+(defun* upgrade-asdf ()
+  "Try to upgrade of ASDF. If a different version was used, return T.
+   We need do that before we operate on anything that may possibly depend =
on ASDF."
+  (let ((*load-print* nil)
+        (*compile-print* nil))
+    (handler-bind (((or style-warning warning) #'muffle-warning))
+      (symbol-call :asdf :load-system :asdf :verbose nil))))
+
+(register-hook-function '*post-upgrade-cleanup-hook* 'upgrade-configuratio=
n)
+;;;; ---------------------------------------------------------------------=
----
+;;;; Components
+
+(asdf/package:define-package :asdf/component
+  (:recycle :asdf/component :asdf)
+  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
+  (:export
+   #:component #:component-find-path
+   #:component-name #:component-pathname #:component-relative-pathname
+   #:component-parent #:component-system #:component-parent-pathname
+   #:child-component #:parent-component #:module
+   #:file-component
+   #:source-file #:c-source-file #:java-source-file
+   #:static-file #:doc-file #:html-file
+   #:source-file-type ;; backward-compatibility
+   #:component-in-order-to #:component-sibling-dependencies
+   #:component-if-feature #:around-compile-hook
+   #:component-description #:component-long-description
+   #:component-version #:version-satisfies
+   #:component-inline-methods ;; backward-compatibility only. DO NOT USE!
+   #:component-operation-times ;; For internal use only.
+   ;; portable ASDF encoding and implementation-specific external-format
+   #:component-external-format #:component-encoding
+   #:component-children-by-name #:component-children #:compute-children-by=
-name
+   #:component-build-operation
+   #:module-default-component-class
+   #:module-components ;; backward-compatibility. DO NOT USE.
+   #:sub-components
+
+   ;; Internals we'd like to share with the ASDF package, especially for u=
pgrade purposes
+   #:name #:version #:description #:long-description #:author #:maintainer=
 #:licence
+   #:components-by-name #:components
+   #:children #:children-by-name #:default-component-class
+   #:author #:maintainer #:licence #:source-file #:defsystem-depends-on
+   #:sibling-dependencies #:if-feature #:in-order-to #:inline-methods
+   #:relative-pathname #:absolute-pathname #:operation-times #:around-comp=
ile
+   #:%encoding #:properties #:component-properties #:parent))
+(in-package :asdf/component)
+
+(defgeneric* component-name (component)
+  (:documentation "Name of the COMPONENT, unique relative to its parent"))
+(defgeneric* component-system (component)
+  (:documentation "Find the top-level system containing COMPONENT"))
+(defgeneric* component-pathname (component)
+  (:documentation "Extracts the pathname applicable for a particular compo=
nent."))
+(defgeneric* (component-relative-pathname) (component)
+  (:documentation "Returns a pathname for the component argument intended =
to be
+interpreted relative to the pathname of that component's parent.
+Despite the function's name, the return value may be an absolute
+pathname, because an absolute pathname may be interpreted relative to
+another pathname in a degenerate way."))
+(defgeneric* component-external-format (component))
+(defgeneric* component-encoding (component))
+(defgeneric* version-satisfies (component version))
+
+;;; Backward compatible way of computing the FILE-TYPE of a component.
+;;; TODO: find users, have them stop using that.
+(defgeneric* (source-file-type) (component system))
+
+(when-upgrading (:when (find-class 'component nil))
+  (defmethod reinitialize-instance :after ((c component) &rest initargs &k=
ey)
+    (declare (ignorable c initargs)) (values)))
+
+(defclass component ()
+  ((name :accessor component-name :initarg :name :type string :documentati=
on
+         "Component name: designator for a string composed of portable pat=
hname characters")
+   ;; We might want to constrain version with
+   ;; :type (and string (satisfies parse-version))
+   ;; but we cannot until we fix all systems that don't use it correctly!
+   (version :accessor component-version :initarg :version :initform nil)
+   (description :accessor component-description :initarg :description :ini=
tform nil)
+   (long-description :accessor component-long-description :initarg :long-d=
escription :initform nil)
+   (sibling-dependencies :accessor component-sibling-dependencies :initfor=
m nil)
+   (if-feature :accessor component-if-feature :initform nil :initarg :if-f=
eature)
+   ;; In the ASDF object model, dependencies exist between *actions*,
+   ;; where an action is a pair of an operation and a component.
+   ;; Dependencies are represented as alists of operations
+   ;; to a list where each entry is a pair of an operation and a list of c=
omponent specifiers.
+   ;; Up until ASDF 2.26.9, there used to be two kinds of dependencies:
+   ;; in-order-to and do-first, each stored in its own slot. Now there is =
only in-order-to.
+   ;; in-order-to used to represent things that modify the filesystem (suc=
h as compiling a fasl)
+   ;; and do-first things that modify the current image (such as loading a=
 fasl).
+   ;; These are now unified because we now correctly propagate timestamps =
between dependencies.
+   ;; Happily, no one seems to have used do-first too much (especially sin=
ce until ASDF 2.017,
+   ;; anything you specified was overridden by ASDF itself anyway), but th=
e name in-order-to remains.
+   ;; The names are bad, but they have been the official API since Dan Bar=
low's ASDF 1.52!
+   ;; LispWorks's defsystem has caused-by and requires for in-order-to and=
 do-first respectively.
+   ;; Maybe rename the slots in ASDF? But that's not very backward-compati=
ble.
+   ;; See our ASDF 2 paper for more complete explanations.
+   (in-order-to :initform nil :initarg :in-order-to
+                :accessor component-in-order-to)
+   ;; methods defined using the "inline" style inside a defsystem form:
+   ;; need to store them somewhere so we can delete them when the system
+   ;; is re-evaluated.
+   (inline-methods :accessor component-inline-methods :initform nil) ;; OB=
SOLETE! DELETE THIS IF NO ONE USES.
+   ;; ASDF4: rename it from relative-pathname to specified-pathname. It ne=
ed not be relative.
+   ;; There is no initform and no direct accessor for this specified pathn=
ame,
+   ;; so we only access the information through appropriate methods, after=
 it has been processed.
+   ;; Unhappily, some braindead systems directly access the slot. Make the=
m stop before ASDF4.
+   (relative-pathname :initarg :pathname)
+   ;; The absolute-pathname is computed based on relative-pathname and par=
ent pathname.
+   ;; The slot is but a cache used by component-pathname.
+   (absolute-pathname)
+   (operation-times :initform (make-hash-table)
+                    :accessor component-operation-times)
+   (around-compile :initarg :around-compile)
+   ;; Properties are for backward-compatibility with ASDF2 only. DO NOT US=
E!
+   (properties :accessor component-properties :initarg :properties
+               :initform nil)
+   (%encoding :accessor %component-encoding :initform nil :initarg :encodi=
ng)
+   ;; For backward-compatibility, this slot is part of component rather th=
an of child-component. ASDF4: stop it.
+   (parent :initarg :parent :initform nil :reader component-parent)
+   (build-operation
+    :initarg :build-operation :initform nil :reader component-build-operat=
ion)))
+
+(defun* component-find-path (component)
+  (check-type component (or null component))
+  (reverse
+   (loop :for c =3D component :then (component-parent c)
+         :while c :collect (component-name c))))
+
+(defmethod print-object ((c component) stream)
+  (print-unreadable-object (c stream :type t :identity nil)
+    (format stream "~{~S~^ ~}" (component-find-path c))))
+
+(defmethod component-system ((component component))
+  (if-let (system (component-parent component))
+    (component-system system)
+    component))
+
+
+;;;; Component hierarchy within a system
+;; The tree typically but not necessarily follows the filesystem hierarchy.
+
+(defclass child-component (component) ())
+
+(defclass file-component (child-component)
+  ((type :accessor file-type :initarg :type))) ; no default
+(defclass source-file (file-component)
+  ((type :initform nil))) ;; NB: many systems have come to rely on this de=
fault.
+(defclass c-source-file (source-file)
+  ((type :initform "c")))
+(defclass java-source-file (source-file)
+  ((type :initform "java")))
+(defclass static-file (source-file)
+  ((type :initform nil)))
+(defclass doc-file (static-file) ())
+(defclass html-file (doc-file)
+  ((type :initform "html")))
+
+(defclass parent-component (component)
+  ((children
+    :initform nil
+    :initarg :components
+    :reader module-components ; backward-compatibility
+    :accessor component-children)
+   (children-by-name
+    :reader module-components-by-name ; backward-compatibility
+    :accessor component-children-by-name)
+   (default-component-class
+    :initform nil
+    :initarg :default-component-class
+    :accessor module-default-component-class)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun* compute-children-by-name (parent &key only-if-needed-p)
+    (unless (and only-if-needed-p (slot-boundp parent 'children-by-name))
+      (let ((hash (make-hash-table :test 'equal)))
+        (setf (component-children-by-name parent) hash)
+        (loop :for c :in (component-children parent)
+              :for name =3D (component-name c)
+              :for previous =3D (gethash name hash)
+              :do (when previous (error 'duplicate-names :name name))
+                  (setf (gethash name hash) c))
+        hash))))
+
+(when-upgrading (:when (find-class 'module nil))
+  (defmethod reinitialize-instance :after ((m module) &rest initargs &key)
+    (declare (ignorable m initargs)) (values))
+  (defmethod update-instance-for-redefined-class :after
+      ((m module) added deleted plist &key)
+    (declare (ignorable m added deleted plist))
+    (when (and (member 'children added) (member 'components deleted))
+      (setf (slot-value m 'children)
+            ;; old ECLs provide an alist instead of a plist(!)
+            (if (or #+ecl (consp (first plist))) (or #+ecl (cdr (assoc 'co=
mponents plist)))
+                (getf plist 'components)))
+      (compute-children-by-name m))))
+
+(defclass module (child-component parent-component)
+  (#+clisp (components))) ;; backward compatibility during upgrade only
+
+
+;;;; component pathnames
+
+(defgeneric* (component-parent-pathname) (component))
+(defmethod component-parent-pathname (component)
+  (component-pathname (component-parent component)))
+
+(defmethod component-pathname ((component component))
+  (if (slot-boundp component 'absolute-pathname)
+      (slot-value component 'absolute-pathname)
+      (let ((pathname
+             (merge-pathnames*
+              (component-relative-pathname component)
+              (pathname-directory-pathname (component-parent-pathname comp=
onent)))))
+        (unless (or (null pathname) (absolute-pathname-p pathname))
+          (error (compatfmt "~@<Invalid relative pathname ~S for component=
 ~S~@:>")
+                 pathname (component-find-path component)))
+        (setf (slot-value component 'absolute-pathname) pathname)
+        pathname)))
+
+(defmethod component-relative-pathname ((component component))
+  ;; source-file-type is backward-compatibility with ASDF1;
+  ;; we ought to be able to extract this from the component alone with COM=
PONENT-TYPE.
+  ;; TODO: track who uses it, and have them not use it anymore.
+  (parse-unix-namestring
+   (or (and (slot-boundp component 'relative-pathname)
+            (slot-value component 'relative-pathname))
+       (component-name component))
+   :want-relative t
+   :type (source-file-type component (component-system component))
+   :defaults (component-parent-pathname component)))
+
+(defmethod source-file-type ((component parent-component) system)
+  (declare (ignorable component system))
+  :directory)
+
+(defmethod source-file-type ((component file-component) system)
+  (declare (ignorable system))
+  (file-type component))
+
+
+;;;; Encodings
+
+(defmethod component-encoding ((c component))
+  (or (loop :for x =3D c :then (component-parent x)
+        :while x :thereis (%component-encoding x))
+      (detect-encoding (component-pathname c))))
+
+(defmethod component-external-format ((c component))
+  (encoding-external-format (component-encoding c)))
+
+
+;;;; around-compile-hook
+
+(defgeneric* around-compile-hook (component))
+(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)))))
+
+
+;;;; version-satisfies
+
+(defmethod version-satisfies ((c component) version)
+  (unless (and version (slot-boundp c 'version))
+    (when version
+      (warn "Requested version ~S but component ~S has no version" version=
 c))
+    (return-from version-satisfies t))
+  (version-satisfies (component-version c) version))
+
+(defmethod version-satisfies ((cver string) version)
+  (version-compatible-p cver version))
+
+
+;;; all sub-components (of a given type)
+
+(defun* sub-components (component &key (type t))
+  (while-collecting (c)
+    (labels ((recurse (x)
+               (when (if-let (it (component-if-feature x)) (featurep it) t)
+                 (when (typep x type)
+                   (c x))
+                 (when (typep x 'parent-component)
+                   (map () #'recurse (component-children x))))))
+      (recurse component))))
+
+;;;; ---------------------------------------------------------------------=
----
+;;;; Systems
+
+(asdf/package:define-package :asdf/system
+  (:recycle :asdf :asdf/system)
+  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/component)
+  (:export
+   #:system #:proto-system
+   #:system-source-file #:system-source-directory #:system-relative-pathna=
me
+   #:reset-system
+   #:system-description #:system-long-description
+   #:system-author #:system-maintainer #:system-licence #:system-license
+   #:system-defsystem-depends-on
+   #:component-build-pathname #:build-pathname
+   #:component-entry-point #:entry-point
+   #:homepage #:system-homepage
+   #:bug-tracker #:system-bug-tracker
+   #:mailto #:system-mailto
+   #:long-name #:system-long-name
+   #:source-control #:system-source-control
+   #:find-system #:builtin-system-p)) ;; forward-reference, defined in fin=
d-system
+(in-package :asdf/system)
+
+(defgeneric* (find-system) (system &optional error-p))
+(defgeneric* (system-source-file) (system)
+  (:documentation "Return the source file in which system is defined."))
+(defgeneric* component-build-pathname (component))
+
+(defgeneric* component-entry-point (component))
+(defmethod component-entry-point ((c component))
+  (declare (ignorable c))
+  nil)
+
+
+;;;; The system class
+
+(defclass proto-system () ; slots to keep when resetting a system
+  ;; To preserve identity for all objects, we'd need keep the components s=
lots
+  ;; but also to modify parse-component-form to reset the recycled objects.
+  ((name) (source-file) #|(children) (children-by-names)|#))
+
+(defclass system (module proto-system)
+  ;; Backward-compatibility: inherit from module. ASDF4: only inherit from=
 parent-component.
+  (;; {,long-}description is now inherited from component, but we add the =
legacy accessors
+   (description :accessor system-description)
+   (long-description :accessor system-long-description)
+   (author :accessor system-author :initarg :author :initform nil)
+   (maintainer :accessor system-maintainer :initarg :maintainer :initform =
nil)
+   (licence :accessor system-licence :initarg :licence
+            :accessor system-license :initarg :license :initform nil)
+   (homepage :accessor system-homepage :initarg :homepage :initform nil)
+   (bug-tracker :accessor system-bug-tracker :initarg :bug-tracker :initfo=
rm nil)
+   (mailto :accessor system-mailto :initarg :mailto :initform nil)
+   (long-name :accessor system-long-name :initarg :long-name :initform nil)
+   ;; Conventions for this slot aren't clear yet as of ASDF 2.27, but when=
ever they are, they will be enforced.
+   ;; I'm introducing the slot before the conventions are set for maximum =
compatibility.
+   (source-control :accessor system-source-control :initarg :source-contro=
l :initform nil)
+   (builtin-system-p :accessor builtin-system-p :initform nil :initarg :bu=
iltin-system-p)
+   (build-pathname
+    :initform nil :initarg :build-pathname :accessor component-build-pathn=
ame)
+   (entry-point
+    :initform nil :initarg :entry-point :accessor component-entry-point)
+   (source-file :initform nil :initarg :source-file :accessor system-sourc=
e-file)
+   (defsystem-depends-on :reader system-defsystem-depends-on :initarg :def=
system-depends-on)))
+
+(defun* reset-system (system &rest keys &key &allow-other-keys)
+  (change-class (change-class system 'proto-system) 'system)
+  (apply 'reinitialize-instance system keys))
+
+
+;;;; Pathnames
+
+(defmethod system-source-file ((system-name string))
+  (system-source-file (find-system system-name)))
+(defmethod system-source-file ((system-name symbol))
+  (system-source-file (find-system system-name)))
+
+(defun* system-source-directory (system-designator)
+  "Return a pathname object corresponding to the directory
+in which the system specification (.asd file) is located."
+  (pathname-directory-pathname (system-source-file system-designator)))
+
+(defun* (system-relative-pathname) (system name &key type)
+  (subpathname (system-source-directory system) name :type type))
+
+(defmethod component-pathname ((system system))
+  (let ((pathname (or (call-next-method) (system-source-directory system))=
))
+    (unless (and (slot-boundp system 'relative-pathname) ;; backward-compa=
tibility with ASDF1-age
+                 (slot-value system 'relative-pathname)) ;; systems that d=
irectly access this slot.
+      (setf (slot-value system 'relative-pathname) pathname))
+    pathname))
+
+(defmethod component-relative-pathname ((system system))
+  (parse-unix-namestring
+   (and (slot-boundp system 'relative-pathname)
+        (slot-value system 'relative-pathname))
+   :want-relative t
+   :type :directory
+   :ensure-absolute t
+   :defaults (system-source-directory system)))
+
+(defmethod component-parent-pathname ((system system))
+  (system-source-directory system))
+
+(defmethod component-build-pathname ((c component))
+  (declare (ignorable c))
+  nil)
+;;;; ---------------------------------------------------------------------=
----
+;;;; Stamp cache
+
+(asdf/package:define-package :asdf/cache
+  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
+  (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp
+           #:consult-asdf-cache #:do-asdf-cache
+           #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*))
+(in-package :asdf/cache)
+
+;;; This stamp cache is useful for:
+;; * consistency of stamps used within a single run
+;; * fewer accesses to the filesystem
+;; * the ability to test with fake timestamps, without touching files
+
+(defvar *asdf-cache* nil)
+
+(defun set-asdf-cache-entry (key value-list)
+  (apply 'values
+         (if *asdf-cache*
+             (setf (gethash key *asdf-cache*) value-list)
+             value-list)))
+
+(defun consult-asdf-cache (key thunk)
+  (if *asdf-cache*
+      (multiple-value-bind (results foundp) (gethash key *asdf-cache*)
+        (if foundp
+            (apply 'values results)
+            (set-asdf-cache-entry key (multiple-value-list (funcall thunk)=
))))
+      (funcall thunk)))
+
+(defmacro do-asdf-cache (key &body body)
+  `(consult-asdf-cache ,key #'(lambda () , at body)))
+
+(defun call-with-asdf-cache (thunk &key override)
+  (if (and *asdf-cache* (not override))
+      (funcall thunk)
+      (let ((*asdf-cache* (make-hash-table :test 'equal)))
+        (funcall thunk))))
+
+(defmacro with-asdf-cache ((&key override) &body body)
+  `(call-with-asdf-cache #'(lambda () , at body) :override ,override))
+
+(defun compute-file-stamp (file)
+  (safe-file-write-date file))
+
+(defun register-file-stamp (file &optional (stamp (compute-file-stamp file=
)))
+  (set-asdf-cache-entry `(get-file-stamp ,file) (list stamp)))
+
+(defun get-file-stamp (file)
+  (do-asdf-cache `(get-file-stamp ,file) (compute-file-stamp file)))
+;;;; ---------------------------------------------------------------------=
----
+;;;; Finding systems
+
+(asdf/package:define-package :asdf/find-system
+  (:recycle :asdf/find-system :asdf)
+  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
+   :asdf/component :asdf/system :asdf/cache)
+  (:export
+   #:remove-entry-from-registry #:coerce-entry-to-directory
+   #:coerce-name #:primary-system-name
+   #:find-system #:locate-system #:load-asd #:with-system-definitions
+   #:system-registered-p #:register-system #:registered-systems #:clear-sy=
stem #:map-systems
+   #:system-definition-error #:missing-component #:missing-requires #:miss=
ing-parent
+   #:formatted-system-definition-error #:format-control #:format-arguments=
 #:sysdef-error
+   #:load-system-definition-error #:error-name #:error-pathname #:error-co=
ndition
+   #:*system-definition-search-functions* #:search-for-system-definition
+   #:*central-registry* #:probe-asd #:sysdef-central-registry-search
+   #:find-system-if-being-defined #:*systems-being-defined*
+   #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility sy=
mbols, functions removed
+   #:system-find-preloaded-system #:register-preloaded-system #:*preloaded=
-systems*
+   #:clear-defined-systems #:*defined-systems*
+   ;; defined in source-registry, but specially mentioned here:
+   #:initialize-source-registry #:sysdef-source-registry-search))
+(in-package :asdf/find-system)
+
+(declaim (ftype (function (&optional t) t) initialize-source-registry)) ; =
forward reference
+
+(define-condition system-definition-error (error) ()
+  ;; [this use of :report should be redundant, but unfortunately it's not.
+  ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-fun=
ction
+  ;; over print-object; this is always conditions::%print-condition for
+  ;; condition objects, which in turn does inheritance of :report options =
at
+  ;; run-time.  fortunately, inheritance means we only need this kludge he=
re in
+  ;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]
+  #+cmu (:report print-object))
+
+(define-condition missing-component (system-definition-error)
+  ((requires :initform "(unnamed)" :reader missing-requires :initarg :requ=
ires)
+   (parent :initform nil :reader missing-parent :initarg :parent)))
+
+(define-condition formatted-system-definition-error (system-definition-err=
or)
+  ((format-control :initarg :format-control :reader format-control)
+   (format-arguments :initarg :format-arguments :reader format-arguments))
+  (:report (lambda (c s)
+               (apply 'format s (format-control c) (format-arguments c)))))
+
+(define-condition load-system-definition-error (system-definition-error)
+  ((name :initarg :name :reader error-name)
+   (pathname :initarg :pathname :reader error-pathname)
+   (condition :initarg :condition :reader error-condition))
+  (:report (lambda (c s)
+             (format s (compatfmt "~@<Error while trying to load definitio=
n for system ~A from pathname ~A: ~3i~_~A~@:>")
+                     (error-name c) (error-pathname c) (error-condition c)=
))))
+
+(defun* sysdef-error (format &rest arguments)
+  (error 'formatted-system-definition-error :format-control
+         format :format-arguments arguments))
+
+(defvar *defined-systems* (make-hash-table :test 'equal)
+  "This is a hash table whose keys are strings, being the
+names of the systems, and whose values are pairs, the first
+element of which is a universal-time indicating when the
+system definition was last updated, and the second element
+of which is a system object.")
+
+(defun* clear-defined-systems ()
+  (setf *defined-systems* (make-hash-table :test 'equal)))
+
+(register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-system=
s nil)
+
+(defun* coerce-name (name)
+  (typecase name
+    (component (component-name name))
+    (symbol (string-downcase (symbol-name name)))
+    (string name)
+    (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~=
@:>") name))))
+
+(defun* primary-system-name (name)
+  ;; When a system name has slashes, the file with defsystem is named by
+  ;; the first of the slash-separated components.
+  (first (split-string (coerce-name name) :separator "/")))
+
+(defun* system-registered-p (name)
+  (gethash (coerce-name name) *defined-systems*))
+
+(defun* registered-systems ()
+  (loop :for registered :being :the :hash-values :of *defined-systems*
+    :collect (coerce-name (cdr registered))))
+
+(defun* register-system (system)
+  (check-type system system)
+  (let ((name (component-name system)))
+    (check-type name string)
+    (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system)
+    (unless (eq system (cdr (gethash name *defined-systems*)))
+      (setf (gethash name *defined-systems*)
+            (cons (if-let (file (ignore-errors (system-source-file system)=
))
+                    (get-file-stamp file))
+                  system)))))
+
+(defun* clear-system (name)
+  "Clear the entry for a system in the database of systems previously load=
ed.
+Note that this does NOT in any way cause the code of the system to be unlo=
aded."
+  ;; There is no "unload" operation in Common Lisp, and
+  ;; a general such operation cannot be portably written,
+  ;; considering how much CL relies on side-effects to global data structu=
res.
+  (remhash (coerce-name name) *defined-systems*))
+
+(defun* map-systems (fn)
+  "Apply FN to each defined system.
+
+FN should be a function of one argument. It will be
+called with an object of type asdf:system."
+  (loop :for registered :being :the :hash-values :of *defined-systems*
+     :do (funcall fn (cdr registered))))
+
+;;; for the sake of keeping things reasonably neat, we adopt a
+;;; convention that functions in this list are prefixed SYSDEF-
+
+(defvar *system-definition-search-functions* '())
+
+(defun cleanup-system-definition-search-functions ()
+  (setf *system-definition-search-functions*
+        (append
+         ;; Remove known-incompatible sysdef functions from old versions o=
f asdf.
+         (remove-if #'(lambda (x) (member x '(contrib-sysdef-search sysdef=
-find-asdf)))
+                    *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-func=
tions*))
+                    '(sysdef-central-registry-search
+                      sysdef-source-registry-search
+                      sysdef-find-preloaded-systems)))))
+(cleanup-system-definition-search-functions)
+
+(defun* search-for-system-definition (system)
+  (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
+"A list of 'system directory designators' ASDF uses to find systems.
+
+A 'system directory designator' is a pathname or an expression
+which evaluates to a pathname. For example:
+
+    (setf asdf:*central-registry*
+          (list '*default-pathname-defaults*
+                #p\"/home/me/cl/systems/\"
+                #p\"/usr/share/common-lisp/systems/\"))
+
+This is for backward compatibility.
+Going forward, we recommend new users should be using the source-registry.
+")
+
+(defun* probe-asd (name defaults &key truename)
+  (block nil
+    (when (directory-pathname-p defaults)
+      (if-let (file (probe-file*
+                     (ensure-absolute-pathname
+                      (parse-unix-namestring name :type "asd")
+                      #'(lambda () (ensure-absolute-pathname defaults 'get=
-pathname-defaults nil))
+                      nil)
+                     :truename truename))
+        (return file))
+      #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't ha=
ve read-sequence(!)
+      (when (os-windows-p)
+        (let ((shortcut
+               (make-pathname
+                :defaults defaults :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)
+  (let ((name (primary-system-name system))
+        (to-remove nil)
+        (to-replace nil))
+    (block nil
+      (unwind-protect
+           (dolist (dir *central-registry*)
+             (let ((defaults (eval dir))
+                   directorized)
+               (when defaults
+                 (cond ((directory-pathname-p defaults)
+                        (let* ((file (probe-asd name defaults :truename *r=
esolve-symlinks*)))
+                          (when file
+                            (return file))))
+                       (t
+                        (restart-case
+                            (let* ((*print-circle* nil)
+                                   (message
+                                    (format nil
+                                            (compatfmt "~@<While searching=
 for system ~S: ~3i~_~S evaluated to ~S which is not an absolute directory.=
~@:>")
+                                            system dir defaults)))
+                              (error message))
+                          (remove-entry-from-registry ()
+                            :report "Remove entry from *central-registry* =
and continue"
+                            (push dir to-remove))
+                          (coerce-entry-to-directory ()
+                            :test (lambda (c) (declare (ignore c))
+                                    (and (not (directory-pathname-p defaul=
ts))
+                                         (directory-pathname-p
+                                          (setf directorized
+                                                (ensure-directory-pathname=
 defaults)))))
+                            :report (lambda (s)
+                                      (format s (compatfmt "~@<Coerce entr=
y to ~a, replace ~a and continue.~@:>")
+                                              directorized dir))
+                            (push (cons dir directorized) to-replace))))))=
))
+        ;; cleanup
+        (dolist (dir to-remove)
+          (setf *central-registry* (remove dir *central-registry*)))
+        (dolist (pair to-replace)
+          (let* ((current (car pair))
+                 (new (cdr pair))
+                 (position (position current *central-registry*)))
+            (setf *central-registry*
+                  (append (subseq *central-registry* 0 position)
+                          (list new)
+                          (subseq *central-registry* (1+ position))))))))))
+
+(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~@:>"))))
+
+(defmethod find-system (name &optional (error-p t))
+  (find-system (coerce-name name) error-p))
+
+(defvar *systems-being-defined* nil
+  "A hash-table of systems currently being defined keyed by name, or NIL")
+
+(defun* find-system-if-being-defined (name)
+  (when *systems-being-defined*
+    (gethash (coerce-name name) *systems-being-defined*)))
+
+(defun* call-with-system-definitions (thunk)
+  (if *systems-being-defined*
+      (call-with-asdf-cache thunk)
+      (let ((*systems-being-defined* (make-hash-table :test 'equal)))
+        (call-with-asdf-cache thunk))))
+
+(defmacro with-system-definitions ((&optional) &body body)
+  `(call-with-system-definitions #'(lambda () , at body)))
+
+(defun* load-asd (pathname &key name (external-format (encoding-external-f=
ormat (detect-encoding pathname))))
+  ;; Tries to load system definition with canonical NAME from PATHNAME.
+  (with-system-definitions ()
+    (with-standard-io-syntax
+      (let ((*package* (find-package :asdf-user))
+            (*print-readably* nil)
+            (*default-pathname-defaults*
+              ;; resolve logical-pathnames so they won't wreak havoc in pa=
rsing namestrings.
+              (pathname-directory-pathname (translate-logical-pathname pat=
hname))))
+        (handler-bind
+            ((error #'(lambda (condition)
+                        (error 'load-system-definition-error
+                               :name name :pathname pathname
+                               :condition condition))))
+          (asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[=
 for ~A~] from ~A~@:>~%")
+                        name pathname)
+          (with-muffled-loader-conditions ()
+            (load* pathname :external-format external-format)))))))
+
+(defun* locate-system (name)
+  "Given a system NAME designator, try to locate where to load the system =
from.
+Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
+FOUNDP is true when a system 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,
+either 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 l=
oaded."
+  (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))))
+         (pathname (ensure-pathname (resolve-symlinks* pathname) :want-abs=
olute t))
+         (foundp (and (or found-system pathname previous) t)))
+    (check-type found (or null pathname system))
+    (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 prev=
ious-time)
+              (locate-system name)
+            (assert (eq foundp (and (or found-system pathname previous) t)=
))
+            (let ((previous-pathname (and previous (system-source-file pre=
vious)))
+                  (system (or previous found-system)))
+              (when (and found-system (not previous))
+                (register-system found-system))
+              (when (and system pathname)
+                (setf (system-source-file system) pathname))
+              (when (and pathname
+                         (let ((stamp (get-file-stamp pathname)))
+                           (and stamp
+                                (not (and previous
+                                          (or (pathname-equal pathname pre=
vious-pathname)
+                                              (and pathname previous-pathn=
ame
+                                                   (pathname-equal
+                                                    (translate-logical-pat=
hname pathname)
+                                                    (translate-logical-pat=
hname previous-pathname))))
+                                          (stamp<=3D stamp previous-time))=
))))
+                ;; only load when it's a pathname that is different or has=
 newer content
+                (load-asd pathname :name name)))
+            (let ((in-memory (system-registered-p name))) ; try again afte=
r loading from disk if needed
+              (return
+                (cond
+                  (in-memory
+                   (when pathname
+                     (setf (car in-memory) (get-file-stamp pathname)))
+                   (cdr in-memory))
+                  (error-p
+                   (error 'missing-component :requires name))))))
+        (reinitialize-source-registry-and-retry ()
+          :report (lambda (s)
+                    (format s (compatfmt "~@<Retry finding system ~A after=
 reinitializing the source-registry.~@:>") name))
+          (initialize-source-registry))))))
+
+(defvar *preloaded-systems* (make-hash-table :test 'equal))
+
+(defun* sysdef-find-preloaded-systems (requested)
+  (let ((name (coerce-name requested)))
+    (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*)
+      (when foundp
+        (apply 'make-instance 'system :name name :source-file (getf keys :=
source-file) keys)))))
+
+(defun register-preloaded-system (system-name &rest keys)
+  (setf (gethash (coerce-name system-name) *preloaded-systems*) keys))
+
+(register-preloaded-system "asdf")
+(register-preloaded-system "asdf-driver")
+
+
+;;;; ---------------------------------------------------------------------=
----
+;;;; Finding components
+
+(asdf/package:define-package :asdf/find-component
+  (:recycle :asdf/find-component :asdf)
+  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
+   :asdf/component :asdf/system :asdf/find-system)
+  (:export
+   #:find-component
+   #:resolve-dependency-name #:resolve-dependency-spec
+   #:resolve-dependency-combination
+   ;; Conditions
+   #:missing-component #:missing-component-of-version #:retry
+   #:missing-dependency #:missing-dependency-of-version
+   #:missing-requires #:missing-parent
+   #:missing-required-by #:missing-version))
+(in-package :asdf/find-component)
+
+;;;; Missing component conditions
+
+(define-condition missing-component-of-version (missing-component)
+  ((version :initform nil :reader missing-version :initarg :version)))
+
+(define-condition missing-dependency (missing-component)
+  ((required-by :initarg :required-by :reader missing-required-by)))
+
+(defmethod print-object ((c missing-dependency) s)
+  (format s (compatfmt "~@<~A, required by ~A~@:>")
+          (call-next-method c nil) (missing-required-by c)))
+
+(define-condition missing-dependency-of-version (missing-dependency
+                                                 missing-component-of-vers=
ion)
+  ())
+
+(defmethod print-object ((c missing-component) s)
+  (format s (compatfmt "~@<Component ~S not found~@[ in ~A~]~@:>")
+          (missing-requires c)
+          (when (missing-parent c)
+            (coerce-name (missing-parent c)))))
+
+(defmethod print-object ((c missing-component-of-version) s)
+  (format s (compatfmt "~@<Component ~S does not match version ~A~@[ in ~A=
~]~@:>")
+          (missing-requires c)
+          (missing-version c)
+          (when (missing-parent c)
+            (coerce-name (missing-parent c)))))
+
+
+;;;; Finding components
+
+(defgeneric* (find-component) (base path)
+  (:documentation "Find a component by resolving the PATH starting from BA=
SE parent"))
+(defgeneric* resolve-dependency-combination (component combinator argument=
s))
+
+(defmethod find-component ((base string) path)
+  (let ((s (find-system base nil)))
+    (and s (find-component s path))))
+
+(defmethod find-component ((base symbol) path)
+  (cond
+    (base (find-component (coerce-name base) path))
+    (path (find-component path nil))
+    (t    nil)))
+
+(defmethod find-component ((base cons) path)
+  (find-component (car base) (cons (cdr base) path)))
+
+(defmethod find-component ((parent parent-component) (name string))
+  (compute-children-by-name parent :only-if-needed-p t) ;; SBCL may miss t=
he u-i-f-r-c method!!!
+  (values (gethash name (component-children-by-name parent))))
+
+(defmethod find-component (base (name symbol))
+  (if name
+      (find-component base (coerce-name name))
+      base))
+
+(defmethod find-component ((c component) (name cons))
+  (find-component (find-component c (car name)) (cdr name)))
+
+(defmethod find-component (base (actual component))
+  (declare (ignorable base))
+  actual)
+
+(defun* resolve-dependency-name (component name &optional version)
+  (loop
+    (restart-case
+        (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 (compatfmt "~@<Retry loading ~3i~_~A.~@:>") na=
me))
+        :test
+        (lambda (c)
+          (or (null c)
+              (and (typep c 'missing-dependency)
+                   (eq (missing-required-by c) component)
+                   (equal (missing-requires c) name))))))))
+
+(defun* resolve-dependency-spec (component dep-spec)
+  (let ((component (find-component () component)))
+    (if (atom dep-spec)
+        (resolve-dependency-name component dep-spec)
+        (resolve-dependency-combination component (car dep-spec) (cdr dep-=
spec)))))
+
+(defmethod resolve-dependency-combination (component combinator arguments)
+  (error (compatfmt "~@<Bad dependency ~S for ~S~@:>")
+         (cons combinator arguments) component))
+
+(defmethod resolve-dependency-combination (component (combinator (eql :fea=
ture)) arguments)
+  (declare (ignorable combinator))
+  (when (featurep (first arguments))
+    (resolve-dependency-spec component (second arguments))))
+
+(defmethod resolve-dependency-combination (component (combinator (eql :ver=
sion)) arguments)
+  (declare (ignorable combinator)) ;; See https://bugs.launchpad.net/asdf/=
+bug/527788
+  (resolve-dependency-name component (first arguments) (second arguments)))
+
+;;;; ---------------------------------------------------------------------=
----
+;;;; Operations
+
+(asdf/package:define-package :asdf/operation
+  (:recycle :asdf/operation :asdf)
+  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
+  (:export
+   #:operation
+   #:operation-original-initargs ;; backward-compatibility only. DO NOT US=
E.
+   #:build-op ;; THE generic operation
+   #:*operations*
+   #:make-operation
+   #:find-operation))
+(in-package :asdf/operation)
+
+;;; Operation Classes
+
+(when-upgrading (:when (find-class 'operation nil))
+  (defmethod shared-initialize :after ((o operation) slot-names &rest init=
args &key)
+    (declare (ignorable o slot-names initargs)) (values)))
+
+(defclass operation ()
+  ((original-initargs ;; for backward-compat -- used by GBBopen and swank =
(via operation-forced)
+    :initform nil :initarg :original-initargs :accessor operation-original=
-initargs)))
+
+(defmethod initialize-instance :after ((o operation) &rest initargs
+                                       &key force force-not system verbose=
 &allow-other-keys)
+  (declare (ignorable force force-not system verbose))
+  (unless (slot-boundp o 'original-initargs)
+    (setf (operation-original-initargs o) initargs)))
+
+(defmethod print-object ((o operation) stream)
+  (print-unreadable-object (o stream :type t :identity nil)
+    (ignore-errors
+      (format stream "~{~S~^ ~}" (operation-original-initargs o)))))
+
+;;; make-operation, find-operation
+
+(defparameter *operations* (make-hash-table :test 'equal))
+(defun* make-operation (operation-class &rest initargs)
+  (let ((key (cons operation-class initargs)))
+    (multiple-value-bind (operation foundp) (gethash key *operations*)
+    (if foundp operation
+        (setf (gethash key *operations*)
+              (apply 'make-instance operation-class initargs))))))
+
+(defgeneric* find-operation (context spec)
+  (:documentation "Find an operation by resolving the SPEC in the CONTEXT"=
))
+(defmethod find-operation (context (spec operation))
+  (declare (ignorable context))
+  spec)
+(defmethod find-operation (context (spec symbol))
+  (apply 'make-operation spec (operation-original-initargs context)))
+(defmethod operation-original-initargs ((context symbol))
+  (declare (ignorable context))
+  nil)
+
+(defclass build-op (operation) ())
+
+;;;; ---------------------------------------------------------------------=
----
+;;;; Actions
+
+(asdf/package:define-package :asdf/action
+  (:nicknames :asdf-action)
+  (:recycle :asdf/action :asdf)
+  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
+   :asdf/component :asdf/system #:asdf/cache :asdf/find-system :asdf/find-=
component :asdf/operation)
+  (:export
+   #:action #:define-convenience-action-methods
+   #:explain #:action-description
+   #:downward-operation #:upward-operation #:sibling-operation
+   #:component-depends-on #:component-self-dependencies
+   #:input-files #:output-files #:output-file #:operation-done-p
+   #:action-status #:action-stamp #:action-done-p
+   #:component-operation-time #:mark-operation-done #:compute-action-stamp
+   #:perform #:perform-with-restarts #:retry #:accept #:feature
+   #:traverse-actions #:traverse-sub-actions #:required-components ;; in p=
lan
+   #:action-path #:find-action #:stamp #:done-p))
+(in-package :asdf/action)
+
+(deftype action () '(cons operation component)) ;; a step to be performed =
while building the system
+
+(defgeneric* traverse-actions (actions &key &allow-other-keys))
+(defgeneric* traverse-sub-actions (operation component &key &allow-other-k=
eys))
+(defgeneric* required-components (component &key &allow-other-keys))
+
+;;;; Reified representation for storage or debugging. Note: dropping origi=
nal-initags
+(defun action-path (action)
+  (destructuring-bind (o . c) action (cons (type-of o) (component-find-pat=
h c))))
+(defun find-action (path)
+  (destructuring-bind (o . c) path (cons (make-operation o) (find-componen=
t () c))))
+
+
+;;;; Convenience methods
+(defmacro define-convenience-action-methods
+  (function (operation component &optional keyp)
+   &key if-no-operation if-no-component operation-initargs)
+  (let* ((rest (gensym "REST"))
+         (found (gensym "FOUND"))
+         (more-args (when keyp `(&rest ,rest &key &allow-other-keys))))
+    (flet ((next-method (o c)
+             (if keyp
+                 `(apply ',function ,o ,c ,rest)
+                 `(,function ,o ,c))))
+      `(progn
+         (defmethod ,function ((,operation symbol) ,component , at more-args)
+           (if ,operation
+               ,(next-method
+                 (if operation-initargs ;backward-compatibility with ASDF1=
's operate. Yuck.
+                     `(apply 'make-operation ,operation :original-initargs=
 ,rest ,rest)
+                     `(make-operation ,operation))
+                 `(or (find-component () ,component) ,if-no-component))
+               ,if-no-operation))
+         (defmethod ,function ((,operation operation) ,component , at more-ar=
gs)
+           (if (typep ,component 'component)
+               (error "No defined method for ~S on ~/asdf-action:format-ac=
tion/"
+                      ',function (cons ,operation ,component))
+               (let ((,found (find-component () ,component)))
+                 (if ,found
+                     ,(next-method operation found)
+                     ,if-no-component))))))))
+
+
+;;;; self-description
+
+(defgeneric* action-description (operation component)
+  (:documentation "returns a phrase that describes performing this operati=
on
+on this component, e.g. \"loading /a/b/c\".
+You can put together sentences using this phrase."))
+(defmethod action-description (operation component)
+  (format nil (compatfmt "~@<~A on ~A~@:>")
+          (type-of operation) component))
+(defgeneric* (explain) (operation component))
+(defmethod explain ((o operation) (c component))
+  (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c)))
+(define-convenience-action-methods explain (operation component))
+
+(defun* format-action (stream action &optional colon-p at-sign-p)
+  (assert (null colon-p)) (assert (null at-sign-p))
+  (destructuring-bind (operation . component) action
+    (princ (action-description operation component) stream)))
+
+
+;;;; Dependencies
+
+(defgeneric* component-depends-on (operation component) ;; ASDF4: rename t=
o component-dependencies
+  (:documentation
+   "Returns a list of dependencies needed by the component to perform
+    the operation.  A dependency has one of the following forms:
+
+      (<operation> <component>*), where <operation> is a class
+        designator and each <component> is a component
+        designator, which means that the component depends on
+        <operation> having been performed on each <component>; or
+
+      (FEATURE <feature>), which means that the component depends
+        on <feature>'s presence in *FEATURES*.
+
+    Methods specialized on subclasses of existing component types
+    should usually append the results of CALL-NEXT-METHOD to the
+    list."))
+(defgeneric* component-self-dependencies (operation component))
+(define-convenience-action-methods component-depends-on (operation compone=
nt))
+(define-convenience-action-methods component-self-dependencies (operation =
component))
+
+(defmethod component-depends-on ((o operation) (c component))
+  (cdr (assoc (type-of o) (component-in-order-to c)))) ; User-specified in=
-order dependencies
+
+(defmethod component-self-dependencies ((o operation) (c component))
+  ;; NB: result in the same format as component-depends-on
+  (loop* :for (o-spec . c-spec) :in (component-depends-on o c)
+         :unless (eq o-spec 'feature) ;; avoid the FEATURE "feature"
+           :when (find c c-spec :key #'(lambda (dep) (resolve-dependency-s=
pec c dep)))
+             :collect (list o-spec c)))
+
+;;;; upward-operation, downward-operation
+;; These together handle actions that propagate along the component hierar=
chy.
+;; Downward operations like load-op or compile-op propagate down the hiera=
rchy:
+;; operation on a parent depends-on operation on its children.
+;; By default, an operation propagates itself, but it may propagate anothe=
r one instead.
+(defclass downward-operation (operation)
+  ((downward-operation
+    :initform nil :initarg :downward-operation :reader downward-operation)=
))
+(defmethod component-depends-on ((o downward-operation) (c parent-componen=
t))
+  `((,(or (downward-operation o) o) ,@(component-children c)) ,@(call-next=
-method)))
+;; Upward operations like prepare-op propagate up the component hierarchy:
+;; operation on a child depends-on operation on its parent.
+;; By default, an operation propagates itself, but it may propagate anothe=
r one instead.
+(defclass upward-operation (operation)
+  ((upward-operation
+    :initform nil :initarg :downward-operation :reader upward-operation)))
+;; For backward-compatibility reasons, a system inherits from module and i=
s a child-component
+;; so we must guard against this case. ASDF4: remove that.
+(defmethod component-depends-on ((o upward-operation) (c child-component))
+  `(,@(if-let (p (component-parent c))
+        `((,(or (upward-operation o) o) ,p))) ,@(call-next-method)))
+;; Sibling operations propagate to siblings in the component hierarchy:
+;; operation on a child depends-on operation on its parent.
+;; By default, an operation propagates itself, but it may propagate anothe=
r one instead.
+(defclass sibling-operation (operation)
+  ((sibling-operation
+    :initform nil :initarg :sibling-operation :reader sibling-operation)))
+(defmethod component-depends-on ((o sibling-operation) (c component))
+  `((,(or (sibling-operation o) o)
+     ,@(loop :for dep :in (component-sibling-dependencies c)
+             :collect (resolve-dependency-spec c dep)))
+    ,@(call-next-method)))
+
+
+;;;; Inputs, Outputs, and invisible dependencies
+(defgeneric* (output-files) (operation component))
+(defgeneric* (input-files) (operation component))
+(defgeneric* (operation-done-p) (operation component)
+  (:documentation "Returns a boolean, which is NIL if the action is forced=
 to be performed again"))
+(define-convenience-action-methods output-files (operation component))
+(define-convenience-action-methods input-files (operation component))
+(define-convenience-action-methods operation-done-p (operation component))
+
+(defmethod operation-done-p ((o operation) (c component))
+  (declare (ignorable o c))
+  t)
+
+(defmethod output-files :around (operation component)
+  "Translate output files, unless asked not to. Memoize the result."
+  operation component ;; hush genera, not convinced by declare ignorable(!)
+  (do-asdf-cache `(output-files ,operation ,component)
+    (values
+     (multiple-value-bind (pathnames fixedp) (call-next-method)
+       ;; 1- Make sure we have absolute pathnames
+       (let* ((directory (pathname-directory-pathname
+                          (component-pathname (find-component () component=
))))
+              (absolute-pathnames
+                (loop
+                  :for pathname :in pathnames
+                  :collect (ensure-absolute-pathname pathname directory))))
+         ;; 2- Translate those pathnames as required
+         (if fixedp
+             absolute-pathnames
+             (mapcar *output-translation-function* absolute-pathnames))))
+     t)))
+(defmethod output-files ((o operation) (c component))
+  (declare (ignorable o c))
+  nil)
+(defun* output-file (operation component)
+  "The unique output file of performing OPERATION on COMPONENT"
+  (let ((files (output-files operation component)))
+    (assert (length=3Dn-p files 1))
+    (first files)))
+
+(defmethod input-files :around (operation component)
+  "memoize input files."
+  (do-asdf-cache `(input-files ,operation ,component)
+    (call-next-method)))
+
+(defmethod input-files ((o operation) (c parent-component))
+  (declare (ignorable o c))
+  nil)
+
+(defmethod input-files ((o operation) (c component))
+  (or (loop* :for (dep-o) :in (component-self-dependencies o c)
+             :append (or (output-files dep-o c) (input-files dep-o c)))
+      ;; no non-trivial previous operations needed?
+      ;; I guess we work with the original source file, then
+      (if-let ((pathname (component-pathname c)))
+        (and (file-pathname-p pathname) (list pathname)))))
+
+
+;;;; Done performing
+
+(defgeneric* component-operation-time (operation component)) ;; ASDF4: hid=
e it behind plan-action-stamp
+(define-convenience-action-methods component-operation-time (operation com=
ponent))
+
+(defgeneric* mark-operation-done (operation component)) ;; ASDF4: hide it =
behind (setf plan-action-stamp)
+(defgeneric* compute-action-stamp (plan operation component &key just-done)
+  (:documentation "Has this action been successfully done already,
+and at what known timestamp has it been done at or will it be done at?
+Takes two keywords JUST-DONE and PLAN:
+JUST-DONE is a boolean that is true if the action was just successfully pe=
rformed,
+at which point we want compute the actual stamp and warn if files are miss=
ing;
+otherwise we are making plans, anticipating the effects of the action.
+PLAN is a plan object modelling future effects of actions,
+or NIL to denote what actually happened.
+Returns two values:
+* a STAMP saying when it was done or will be done,
+  or T if the action has involves files that need to be recomputed.
+* a boolean DONE-P that indicates whether the action has actually been don=
e,
+  and both its output-files and its in-image side-effects are up to date."=
))
+
+(defclass action-status ()
+  ((stamp
+    :initarg :stamp :reader action-stamp
+    :documentation "STAMP associated with the ACTION if it has been comple=
ted already
+in some previous image, or T if it needs to be done.")
+   (done-p
+    :initarg :done-p :reader action-done-p
+    :documentation "a boolean, true iff the action was already done (befor=
e any planned action)."))
+  (:documentation "Status of an action"))
+
+(defmethod print-object ((status action-status) stream)
+  (print-unreadable-object (status stream :type t)
+    (with-slots (stamp done-p) status
+      (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p))))
+
+(defmethod component-operation-time ((o operation) (c component))
+  (gethash (type-of o) (component-operation-times c)))
+
+(defmethod mark-operation-done ((o operation) (c component))
+  (setf (gethash (type-of o) (component-operation-times c))
+        (compute-action-stamp nil o c :just-done t)))
+
+
+;;;; Perform
+
+(defgeneric* (perform-with-restarts) (operation component))
+(defgeneric* (perform) (operation component))
+(define-convenience-action-methods perform (operation component))
+
+(defmethod perform :before ((o operation) (c component))
+  (ensure-all-directories-exist (output-files o c)))
+(defmethod perform :after ((o operation) (c component))
+  (mark-operation-done o c))
+(defmethod perform ((o operation) (c parent-component))
+  (declare (ignorable o c))
+  nil)
+(defmethod perform ((o operation) (c source-file))
+  (sysdef-error
+   (compatfmt "~@<Required method PERFORM not implemented for operation ~A=
, component ~A~@:>")
+   (class-of o) (class-of 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:
+  #|(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.~@:>")
+                  (action-description operation component))))
+      (accept ()
+        :report
+        (lambda (s)
+          (format s (compatfmt "~@<Continue, treating ~A as having been su=
ccessful.~@:>")
+                  (action-description operation component)))
+        (mark-operation-done operation component)
+        (return)))))
+
+;;; Generic build operation
+(defmethod component-depends-on ((o build-op) (c component))
+  `((,(or (component-build-operation c) 'load-op) ,c)))
+
+;;;; ---------------------------------------------------------------------=
----
+;;;; Actions to build Common Lisp software
+
+(asdf/package:define-package :asdf/lisp-action
+  (:recycle :asdf/lisp-action :asdf)
+  (:intern #:proclamations #:flags)
+  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
+   :asdf/cache :asdf/component :asdf/system :asdf/find-component :asdf/ope=
ration :asdf/action)
+  (:export
+   #:try-recompiling
+   #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp
+   #:basic-load-op #:basic-compile-op #:compile-op-flags #:compile-op-proc=
lamations
+   #:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepar=
e-source-op
+   #:call-with-around-compile-hook
+   #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load=
-source #:flags))
+(in-package :asdf/lisp-action)
+
+
+;;;; Component classes
+(defclass cl-source-file (source-file)
+  ((type :initform "lisp")))
+(defclass cl-source-file.cl (cl-source-file)
+  ((type :initform "cl")))
+(defclass cl-source-file.lsp (cl-source-file)
+  ((type :initform "lsp")))
+
+
+;;;; Operation classes
+(defclass basic-load-op (operation) ())
+(defclass basic-compile-op (operation)
+  ((proclamations :initarg :proclamations :accessor compile-op-proclamatio=
ns :initform nil)
+   (flags :initarg :flags :accessor compile-op-flags
+          :initform nil)))
+
+;;; Our default operations: loading into the current lisp image
+(defclass load-op (basic-load-op downward-operation sibling-operation) ())
+(defclass prepare-op (upward-operation sibling-operation)
+  ((sibling-operation :initform 'load-op :allocation :class)))
+(defclass compile-op (basic-compile-op downward-operation)
+  ((downward-operation :initform 'load-op :allocation :class)))
+
+(defclass load-source-op (basic-load-op downward-operation) ())
+(defclass prepare-source-op (upward-operation sibling-operation)
+  ((sibling-operation :initform 'load-source-op :allocation :class)))
+
+(defclass test-op (operation) ())
+
+
+;;;; prepare-op, compile-op and load-op
+
+;;; prepare-op
+(defmethod action-description ((o prepare-op) (c component))
+  (declare (ignorable o))
+  (format nil (compatfmt "~@<loading dependencies of ~3i~_~A~@:>") c))
+(defmethod perform ((o prepare-op) (c component))
+  (declare (ignorable o c))
+  nil)
+(defmethod input-files ((o prepare-op) (c component))
+  (declare (ignorable o c))
+  nil)
+(defmethod input-files ((o prepare-op) (s system))
+  (declare (ignorable o))
+  (if-let (it (system-source-file s)) (list it)))
+
+;;; compile-op
+(defmethod action-description ((o compile-op) (c component))
+  (declare (ignorable o))
+  (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") c))
+(defmethod action-description ((o compile-op) (c parent-component))
+  (declare (ignorable o))
+  (format nil (compatfmt "~@<completing compilation for ~3i~_~A~@:>") c))
+(defgeneric* call-with-around-compile-hook (component thunk))
+(defmethod call-with-around-compile-hook ((c component) function)
+  (call-around-hook (around-compile-hook c) function))
+(defun* perform-lisp-compilation (o c)
+  (let (;; Before 2.26.53, that was unfortunately component-pathname. Now,
+        ;; we consult input-files, the first of which should be the one to=
 compile-file
+        (input-file (first (input-files o c)))
+        ;; on some implementations, there are more than one output-file,
+        ;; but the first one should always be the primary fasl that gets l=
oaded.
+        (outputs (output-files o c)))
+    (multiple-value-bind (output warnings-p failure-p)
+        (destructuring-bind
+            (output-file
+             &optional
+               #+clisp lib-file
+               #+(or ecl mkcl) object-file
+               #+(or clozure sbcl) warnings-file) outputs
+          (call-with-around-compile-hook
+           c #'(lambda (&rest flags)
+                 (with-muffled-compiler-conditions ()
+                   (apply 'compile-file* input-file
+                          :output-file output-file
+                          :external-format (component-external-format c)
+                      (append
+                       #+clisp (list :lib-file lib-file)
+                       #+(or ecl mkcl) (list :object-file object-file)
+                       #+(or clozure sbcl) (list :warnings-file warnings-f=
ile)
+                       flags (compile-op-flags o)))))))
+      (check-lisp-compile-results output warnings-p failure-p
+                                  "~/asdf-action::format-action/" (list (c=
ons o c))))))
+
+(defun* report-file-p (f)
+  (equal (pathname-type f) "build-report"))
+(defun* perform-lisp-warnings-check (o c)
+  (let* ((expected-warnings-files (remove-if-not #'warnings-file-p (input-=
files o c)))
+         (actual-warnings-files (loop :for w :in expected-warnings-files
+                                      :when (get-file-stamp w)
+                                        :collect w
+                                      :else :do (warn "Missing warnings fi=
le ~S while ~A"
+                                                      w (action-descriptio=
n o c)))))
+    (check-deferred-warnings actual-warnings-files)
+    (let* ((output (output-files o c))
+           (report (find-if #'report-file-p output)))
+      (when report
+        (with-open-file (s report :direction :output :if-exists :supersede)
+          (format s ":success~%"))))))
+(defmethod perform ((o compile-op) (c cl-source-file))
+  (perform-lisp-compilation o c))
+(defmethod output-files ((o compile-op) (c cl-source-file))
+  (declare (ignorable o))
+  (let* ((i (first (input-files o c)))
+         (f (compile-file-pathname
+             i #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl)))
+    `(,f ;; the fasl is the primary output, in first position
+      #+clisp
+      ,@`(,(make-pathname :type "lib" :defaults f))
+      #+(or clozure sbcl)
+      ,@(let ((s (component-system c)))
+          (unless (builtin-system-p s) ; includes ASDF itself
+            `(,(make-pathname :type (warnings-file-type) :defaults f))))
+      #+ecl
+      ,@(unless (use-ecl-byte-compiler-p)
+          `(,(compile-file-pathname i :type :object)))
+      #+mkcl
+      ,(compile-file-pathname i :fasl-p nil)))) ;; object file
+(defmethod component-depends-on ((o compile-op) (c component))
+  (declare (ignorable o))
+  `((prepare-op ,c) ,@(call-next-method)))
+(defmethod perform ((o compile-op) (c static-file))
+  (declare (ignorable o c))
+  nil)
+(defmethod output-files ((o compile-op) (c static-file))
+  (declare (ignorable o c))
+  nil)
+(defmethod perform ((o compile-op) (c system))
+  (declare (ignorable o c))
+  #+(or clozure sbcl) (perform-lisp-warnings-check o c))
+#+(or clozure sbcl)
+(defmethod input-files ((o compile-op) (c system))
+  (declare (ignorable o c))
+  (when *warnings-file-type*
+    (unless (builtin-system-p c)
+      ;; The most correct way to do it would be to use:
+      ;; (traverse-sub-actions o c :other-systems nil :keep-operation 'com=
pile-op :keep-component 'cl-source-file)
+      ;; but it's expensive and we don't care too much about file order or=
 ASDF extensions.
+      (loop :for sub :in (sub-components c :type 'cl-source-file)
+            :nconc (remove-if-not 'warnings-file-p (output-files o sub))))=
))
+#+(or clozure sbcl)
+(defmethod output-files ((o compile-op) (c system))
+  (when (and *warnings-file-type* (not (builtin-system-p c)))
+    (if-let ((pathname (component-pathname c)))
+      (list (subpathname pathname (component-name c) :type "build-report")=
))))
+
+;;; load-op
+(defmethod action-description ((o load-op) (c cl-source-file))
+  (declare (ignorable o))
+  (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>") c))
+(defmethod action-description ((o load-op) (c parent-component))
+  (declare (ignorable o))
+  (format nil (compatfmt "~@<completing load for ~3i~_~A~@:>") c))
+(defmethod action-description ((o load-op) component)
+  (declare (ignorable o))
+  (format nil (compatfmt "~@<loading ~3i~_~A~@:>")
+          component))
+(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 (find-operation o 'compile-op) c)))))
+(defun* perform-lisp-load-fasl (o c)
+  (if-let (fasl (first (input-files o c)))
+    (with-muffled-loader-conditions () (load* fasl))))
+(defmethod perform ((o load-op) (c cl-source-file))
+  (perform-lisp-load-fasl o c))
+(defmethod perform ((o load-op) (c static-file))
+  (declare (ignorable o c))
+  nil)
+(defmethod component-depends-on ((o load-op) (c component))
+  (declare (ignorable o))
+  ;; NB: even though compile-op depends-on on prepare-op,
+  ;; it is not needed-in-image-p, whereas prepare-op is,
+  ;; so better not omit prepare-op and think it will happen.
+  `((prepare-op ,c) (compile-op ,c) ,@(call-next-method)))
+
+
+;;;; prepare-source-op, load-source-op
+
+;;; prepare-source-op
+(defmethod action-description ((o prepare-source-op) (c component))
+  (declare (ignorable o))
+  (format nil (compatfmt "~@<loading source for dependencies of ~3i~_~A~@:=
>") c))
+(defmethod input-files ((o prepare-source-op) (c component))
+  (declare (ignorable o c))
+  nil)
+(defmethod input-files ((o prepare-source-op) (s system))
+  (declare (ignorable o))
+  (if-let (it (system-source-file s)) (list it)))
+(defmethod perform ((o prepare-source-op) (c component))
+  (declare (ignorable o c))
+  nil)
+
+;;; load-source-op
+(defmethod action-description ((o load-source-op) c)
+  (declare (ignorable o))
+  (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>") c))
+(defmethod action-description ((o load-source-op) (c parent-component))
+  (declare (ignorable o))
+  (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") c))
+(defmethod component-depends-on ((o load-source-op) (c component))
+  (declare (ignorable o))
+  `((prepare-source-op ,c) ,@(call-next-method)))
+(defun* perform-lisp-load-source (o c)
+  (call-with-around-compile-hook
+   c #'(lambda ()
+         (with-muffled-loader-conditions ()
+           (load* (first (input-files o c))
+                  :external-format (component-external-format c))))))
+
+(defmethod perform ((o load-source-op) (c cl-source-file))
+  (perform-lisp-load-source o c))
+(defmethod perform ((o load-source-op) (c static-file))
+  (declare (ignorable o c))
+  nil)
+(defmethod output-files ((o load-source-op) (c component))
+  (declare (ignorable o c))
+  nil)
+
+
+;;;; test-op
+(defmethod perform ((o test-op) (c component))
+  (declare (ignorable o c))
+  nil)
+(defmethod operation-done-p ((o test-op) (c system))
+  "Testing a system is _never_ done."
+  (declare (ignorable o c))
+  nil)
+(defmethod component-depends-on ((o test-op) (c system))
+  (declare (ignorable o))
+  `((load-op ,c) ,@(call-next-method)))
+
+;;;; ---------------------------------------------------------------------=
----
+;;;; Plan
+
+(asdf/package:define-package :asdf/plan
+  (:recycle :asdf/plan :asdf)
+  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
+   :asdf/component :asdf/operation :asdf/system
+   :asdf/cache :asdf/find-system :asdf/find-component
+   :asdf/operation :asdf/action :asdf/lisp-action)
+  (:export
+   #:component-operation-time #:mark-operation-done
+   #:plan-traversal #:sequential-plan #:*default-plan-class*
+   #:planned-action-status #:plan-action-status #:action-already-done-p
+   #:circular-dependency #:circular-dependency-actions
+   #:node-for #:needed-in-image-p
+   #:action-index #:action-planned-p #:action-valid-p
+   #:plan-record-dependency #:visiting-action-p
+   #:normalize-forced-systems #:action-forced-p #:action-forced-not-p
+   #:map-direct-dependencies #:reduce-direct-dependencies #:direct-depende=
ncies
+   #:visit-dependencies #:compute-action-stamp #:traverse-action
+   #:circular-dependency #:circular-dependency-actions
+   #:call-while-visiting-action #:while-visiting-action
+   #:traverse #:plan-actions #:perform-plan #:plan-operates-on-p
+   #:planned-p #:index #:forced #:forced-not #:total-action-count
+   #:planned-action-count #:planned-output-action-count #:visited-actions
+   #:visiting-action-set #:visiting-action-list #:plan-actions-r
+   #:required-components #:filtered-sequential-plan
+   #:plan-system
+   #:plan-action-filter #:plan-component-type #:plan-keep-operation #:plan=
-keep-component
+   #:traverse-actions #:traverse-sub-actions))
+(in-package :asdf/plan)
+
+;;;; Generic plan traversal class
+
+(defclass plan-traversal ()
+  ((system :initform nil :initarg :system :accessor plan-system)
+   (forced :initform nil :initarg :force :accessor plan-forced)
+   (forced-not :initform nil :initarg :force-not :accessor plan-forced-not)
+   (total-action-count :initform 0 :accessor plan-total-action-count)
+   (planned-action-count :initform 0 :accessor plan-planned-action-count)
+   (planned-output-action-count :initform 0 :accessor plan-planned-output-=
action-count)
+   (visited-actions :initform (make-hash-table :test 'equal) :accessor pla=
n-visited-actions)
+   (visiting-action-set :initform (make-hash-table :test 'equal) :accessor=
 plan-visiting-action-set)
+   (visiting-action-list :initform () :accessor plan-visiting-action-list)=
))
+
+
+;;;; Planned action status
+
+(defgeneric* plan-action-status (plan operation component)
+  (:documentation "Returns the ACTION-STATUS associated to
+the action of OPERATION on COMPONENT in the PLAN"))
+
+(defgeneric* (setf plan-action-status) (new-status plan operation componen=
t)
+  (:documentation "Sets the ACTION-STATUS associated to
+the action of OPERATION on COMPONENT in the PLAN"))
+
+(defclass planned-action-status (action-status)
+  ((planned-p
+    :initarg :planned-p :reader action-planned-p
+    :documentation "a boolean, true iff the action was included in the pla=
n.")
+   (index
+    :initarg :index :reader action-index
+    :documentation "an integer, counting all traversed actions in traversa=
l order."))
+  (:documentation "Status of an action in a plan"))
+
+(defmethod print-object ((status planned-action-status) stream)
+  (print-unreadable-object (status stream :type t :identity nil)
+    (with-slots (stamp done-p planned-p index) status
+      (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p :planned-p p=
lanned-p :index index))))
+
+(defmethod action-planned-p (action-status)
+  (declare (ignorable action-status)) ; default method for non planned-act=
ion-status objects
+  t)
+
+;; TODO: eliminate NODE-FOR, use CONS.
+;; Supposes cleaner protocol for operation initargs passed to MAKE-OPERATI=
ON.
+;; However, see also component-operation-time and mark-operation-done
+(defun* node-for (o c) (cons (type-of o) c))
+
+(defun* action-already-done-p (plan operation component)
+  (action-done-p (plan-action-status plan operation component)))
+
+(defmethod plan-action-status ((plan null) (o operation) (c component))
+  (declare (ignorable plan))
+  (multiple-value-bind (stamp done-p) (component-operation-time o c)
+    (make-instance 'action-status :stamp stamp :done-p done-p)))
+
+(defmethod (setf plan-action-status) (new-status (plan null) (o operation)=
 (c component))
+  (declare (ignorable plan))
+  (let ((to (type-of o))
+        (times (component-operation-times c)))
+    (if (action-done-p new-status)
+        (remhash to times)
+        (setf (gethash to times) (action-stamp new-status))))
+  new-status)
+
+
+;;;; forcing
+
+(defgeneric* action-forced-p (plan operation component))
+(defgeneric* action-forced-not-p (plan operation component))
+
+(defun* normalize-forced-systems (x system)
+  (etypecase x
+    ((member nil :all) x)
+    (cons (list-to-hash-set (mapcar #'coerce-name x)))
+    ((eql t) (when system (list-to-hash-set (list (coerce-name system)))))=
))
+
+(defun* action-override-p (plan operation component override-accessor)
+  (declare (ignorable operation))
+  (let* ((override (funcall override-accessor plan)))
+    (and override
+         (if (typep override 'hash-table)
+             (gethash (coerce-name (component-system (find-component () co=
mponent))) override)
+             t))))
+
+(defmethod action-forced-p (plan operation component)
+  (and
+   ;; Did the user ask us to re-perform the action?
+   (action-override-p plan operation component 'plan-forced)
+   ;; You really can't force a builtin system and :all doesn't apply to it,
+   ;; except it it's the specifically the system currently being built.
+   (not (let ((system (component-system component)))
+          (and (builtin-system-p system)
+               (not (eq system (plan-system plan))))))))
+
+(defmethod action-forced-not-p (plan operation component)
+  (and
+   ;; Did the user ask us to not re-perform the action?
+   (action-override-p plan operation component 'plan-forced-not)
+   ;; Force takes precedence over force-not
+   (not (action-forced-p plan operation component))))
+
+(defmethod action-forced-p ((plan null) operation component)
+  (declare (ignorable plan operation component))
+  nil)
+
+(defmethod action-forced-not-p ((plan null) operation component)
+  (declare (ignorable plan operation component))
+  nil)
+
+
+;;;; action-valid-p
+
+(defgeneric action-valid-p (plan operation component)
+  (:documentation "Is this action valid to include amongst dependencies?"))
+(defmethod action-valid-p (plan operation (c component))
+  (declare (ignorable plan operation))
+  (if-let (it (component-if-feature c)) (featurep it) t))
+(defmethod action-valid-p (plan (o null) c) (declare (ignorable plan o c))=
 nil)
+(defmethod action-valid-p (plan o (c null)) (declare (ignorable plan o c))=
 nil)
+(defmethod action-valid-p ((plan null) operation component)
+  (declare (ignorable plan operation component))
+  (and operation component t))
+
+
+;;;; Is the action needed in this image?
+
+(defgeneric* needed-in-image-p (operation component)
+  (:documentation "Is the action of OPERATION on COMPONENT needed in the c=
urrent image to be meaningful,
+    or could it just as well have been done in another Lisp image?"))
+
+(defmethod needed-in-image-p ((o operation) (c component))
+  ;; We presume that actions that modify the filesystem don't need be run
+  ;; in the current image if they have already been done in another,
+  ;; and can be run in another process (e.g. a fork),
+  ;; whereas those that don't are meant to side-effect the current image a=
nd can't.
+  (not (output-files o c)))
+
+
+;;;; Visiting dependencies of an action and computing action stamps
+
+(defun* map-direct-dependencies (operation component fun)
+  (loop* :for (dep-o-spec . dep-c-specs) :in (component-depends-on operati=
on component)
+     :unless (eq dep-o-spec 'feature) ;; avoid the "FEATURE" misfeature
+        :do (loop :with dep-o =3D (find-operation operation dep-o-spec)
+                  :for dep-c-spec :in dep-c-specs
+                  :for dep-c =3D (resolve-dependency-spec component dep-c-=
spec)
+                  :do (funcall fun dep-o dep-c))))
+
+(defun* reduce-direct-dependencies (operation component combinator seed)
+  (map-direct-dependencies
+   operation component
+   #'(lambda (dep-o dep-c)
+       (setf seed (funcall combinator dep-o dep-c seed))))
+  seed)
+
+(defun* direct-dependencies (operation component)
+  (reduce-direct-dependencies operation component #'acons nil))
+
+(defun* visit-dependencies (plan operation component dependency-stamper &a=
ux stamp)
+  (map-direct-dependencies
+   operation component
+   #'(lambda (dep-o dep-c)
+       (when (action-valid-p plan dep-o dep-c)
+         (latest-stamp-f stamp (funcall dependency-stamper dep-o dep-c)))))
+  stamp)
+
+(defmethod compute-action-stamp (plan (o operation) (c component) &key jus=
t-done)
+  ;; In a distant future, get-file-stamp and component-operation-time
+  ;; shall also be parametrized by the plan, or by a second model object.
+  (let* ((stamp-lookup #'(lambda (o c)
+                           (if-let (it (plan-action-status plan o c)) (act=
ion-stamp it) t)))
+         (out-files (output-files o c))
+         (in-files (input-files o c))
+         ;; Three kinds of actions:
+         (out-op (and out-files t)) ; those that create files on the files=
ystem
+         ;(image-op (and in-files (null out-files))) ; those that load stu=
ff into the image
+         ;(null-op (and (null out-files) (null in-files))) ; dependency pl=
aceholders that do nothing
+         ;; When was the thing last actually done? (Now, or ask.)
+         (op-time (or just-done (component-operation-time o c)))
+         ;; Accumulated timestamp from dependencies (or T if forced or out=
-of-date)
+         (dep-stamp (visit-dependencies plan o c stamp-lookup))
+         ;; Time stamps from the files at hand, and whether any is missing
+         (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-=
stamp) out-files))
+         (in-stamps (mapcar #'get-file-stamp in-files))
+         (missing-in
+           (loop :for f :in in-files :for s :in in-stamps :unless s :colle=
ct f))
+         (missing-out
+           (loop :for f :in out-files :for s :in out-stamps :unless s :col=
lect f))
+         (all-present (not (or missing-in missing-out)))
+         ;; Has any input changed since we last generated the files?
+         (earliest-out (stamps-earliest out-stamps))
+         (latest-in (stamps-latest (cons dep-stamp in-stamps)))
+         (up-to-date-p (stamp<=3D latest-in earliest-out))
+         ;; If everything is up to date, the latest of inputs and outputs =
is our stamp
+         (done-stamp (stamps-latest (cons latest-in out-stamps))))
+    ;; Warn if some files are missing:
+    ;; either our model is wrong or some other process is messing with our=
 files.
+    (when (and just-done (not all-present))
+      (warn "~A completed without ~:[~*~;~*its input file~:p~2:*~{ ~S~}~*~=
]~
+             ~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]"
+            (action-description o c)
+            missing-in (length missing-in) (and missing-in missing-out)
+            missing-out (length missing-out)))
+    ;; Note that we use stamp<=3D instead of stamp< to play nice with gene=
rated files.
+    ;; Any race condition is intrinsic to the limited timestamp resolution.
+    (if (or just-done ;; The done-stamp is valid: if we're just done, or
+            ;; if all filesystem effects are up-to-date and there's no inv=
alidating reason.
+            (and all-present up-to-date-p (operation-done-p o c) (not (act=
ion-forced-p plan o c))))
+        (values done-stamp ;; return the hard-earned timestamp
+                (or just-done
+                    (or out-op ;; a file-creating op is done when all file=
s are up to date
+                        ;; a image-effecting a placeholder op is done when=
 it was actually run,
+                        (and op-time (eql op-time done-stamp))))) ;; with =
the matching stamp
+        ;; done-stamp invalid: return a timestamp in an indefinite future,=
 action not done yet
+        (values t nil))))
+
+;;;; Generic support for plan-traversal
+
+(defgeneric* plan-record-dependency (plan operation component))
+
+(defgeneric call-while-visiting-action (plan operation component function)
+  (:documentation "Detect circular dependencies"))
+
+(defmethod initialize-instance :after ((plan plan-traversal)
+                                       &key (force () fp) (force-not () fn=
p) system
+                                       &allow-other-keys)
+  (with-slots (forced forced-not) plan
+    (when fp (setf forced (normalize-forced-systems force system)))
+    (when fnp (setf forced-not (normalize-forced-systems force-not system)=
))))
+
+(defmethod (setf plan-action-status) (new-status (plan plan-traversal) (o =
operation) (c component))
+  (setf (gethash (node-for o c) (plan-visited-actions plan)) new-status))
+
+(defmethod plan-action-status ((plan plan-traversal) (o operation) (c comp=
onent))
+  (or (and (action-forced-not-p plan o c) (plan-action-status nil o c))
+      (values (gethash (node-for o c) (plan-visited-actions plan)))))
+
+(defmethod action-valid-p ((plan plan-traversal) (o operation) (s system))
+  (and (not (action-forced-not-p plan o s)) (call-next-method)))
+
+(defmethod call-while-visiting-action ((plan plan-traversal) operation com=
ponent fun)
+  (with-accessors ((action-set plan-visiting-action-set)
+                   (action-list plan-visiting-action-list)) plan
+    (let ((action (cons operation component)))
+      (when (gethash action action-set)
+        (error 'circular-dependency :actions
+               (member action (reverse action-list) :test 'equal)))
+      (setf (gethash action action-set) t)
+      (push action action-list)
+      (unwind-protect
+           (funcall fun)
+        (pop action-list)
+        (setf (gethash action action-set) nil)))))
+
+
+;;;; Actual traversal: traverse-action
+
+(define-condition circular-dependency (system-definition-error)
+  ((actions :initarg :actions :reader circular-dependency-actions))
+  (:report (lambda (c s)
+             (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
+                     (circular-dependency-actions c)))))
+
+(defmacro while-visiting-action ((p o c) &body body)
+  `(call-while-visiting-action ,p ,o ,c #'(lambda () , at body)))
+
+(defgeneric* traverse-action (plan operation component needed-in-image-p))
+
+(defmethod traverse-action (plan operation component needed-in-image-p)
+  (block nil
+    (unless (action-valid-p plan operation component) (return nil))
+    (plan-record-dependency plan operation component)
+    (let* ((aniip (needed-in-image-p operation component))
+           (eniip (and aniip needed-in-image-p))
+           (status (plan-action-status plan operation component)))
+      (when (and status (or (action-done-p status) (action-planned-p statu=
s) (not eniip)))
+        ;; Already visited with sufficient need-in-image level: just retur=
n the stamp.
+        (return (action-stamp status)))
+      (labels ((visit-action (niip)
+                 (visit-dependencies plan operation component
+                                     #'(lambda (o c) (traverse-action plan=
 o c niip)))
+                 (multiple-value-bind (stamp done-p)
+                     (compute-action-stamp plan operation component)
+                   (let ((add-to-plan-p (or (eql stamp t) (and niip (not d=
one-p)))))
+                     (cond
+                       ((and add-to-plan-p (not niip)) ;; if we need to do=
 it,
+                        (visit-action t)) ;; then we need to do it in the =
image!
+                       (t
+                        (setf (plan-action-status plan operation component)
+                              (make-instance
+                               'planned-action-status
+                               :stamp stamp
+                               :done-p (and done-p (not add-to-plan-p))
+                               :planned-p add-to-plan-p
+                               :index (if status (action-index status) (in=
cf (plan-total-action-count plan)))))
+                        (when add-to-plan-p
+                          (incf (plan-planned-action-count plan))
+                          (unless aniip
+                            (incf (plan-planned-output-action-count plan))=
))
+                        stamp))))))
+        (while-visiting-action (plan operation component) ; maintain conte=
xt, handle circularity.
+          (visit-action eniip))))))
+
+
+;;;; Sequential plans (the default)
+
+(defclass sequential-plan (plan-traversal)
+  ((actions-r :initform nil :accessor plan-actions-r)))
+
+(defgeneric* plan-actions (plan))
+(defmethod plan-actions ((plan sequential-plan))
+  (reverse (plan-actions-r plan)))
+
+(defmethod plan-record-dependency ((plan sequential-plan)
+                                   (operation operation) (component compon=
ent))
+  (declare (ignorable plan operation component))
+  (values))
+
+(defmethod (setf plan-action-status) :after
+    (new-status (p sequential-plan) (o operation) (c component))
+  (when (action-planned-p new-status)
+    (push (cons o c) (plan-actions-r p))))
+
+
+;;;; high-level interface: traverse, perform-plan, plan-operates-on-p
+
+(defgeneric* (traverse) (operation component &key &allow-other-keys)
+  (:documentation
+"Generate and return a plan for performing OPERATION on COMPONENT.
+
+The plan returned is a list of dotted-pairs. Each pair is the CONS
+of ASDF operation object and a COMPONENT object. The pairs will be
+processed in order by OPERATE."))
+(define-convenience-action-methods traverse (operation component &key))
+
+(defgeneric* perform-plan (plan &key))
+(defgeneric* plan-operates-on-p (plan component))
+
+(defparameter *default-plan-class* 'sequential-plan)
+
+(defmethod traverse ((o operation) (c component) &rest keys &key plan-clas=
s &allow-other-keys)
+  (let ((plan (apply 'make-instance
+                     (or plan-class *default-plan-class*)
+                     :system (component-system c) (remove-plist-key :plan-=
class keys))))
+    (traverse-action plan o c t)
+    (plan-actions plan)))
+
+(defmethod perform-plan :around (plan &key)
+  (declare (ignorable plan))
+  (let ((*package* *package*)
+        (*readtable* *readtable*))
+    (with-compilation-unit () ;; backward-compatibility.
+      (call-next-method))))   ;; Going forward, see deferred-warning suppo=
rt in lisp-build.
+
+(defmethod perform-plan ((steps list) &key)
+  (loop* :for (op . component) :in steps :do
+         (perform-with-restarts op component)))
+
+(defmethod plan-operates-on-p ((plan list) (component-path list))
+  (find component-path (mapcar 'cdr plan)
+        :test 'equal :key 'component-find-path))
+
+
+;;;; Incidental traversals =

+
+(defclass filtered-sequential-plan (sequential-plan)
+  ((action-filter :initform t :initarg :action-filter :reader plan-action-=
filter)
+   (component-type :initform t :initarg :component-type :reader plan-compo=
nent-type)
+   (keep-operation :initform t :initarg :keep-operation :reader plan-keep-=
operation)
+   (keep-component :initform t :initarg :keep-component :reader plan-keep-=
component)))
+
+(defmethod initialize-instance :after ((plan filtered-sequential-plan)
+                                       &key (force () fp) (force-not () fn=
p)
+                                         other-systems)
+  (declare (ignore force force-not))
+  (with-slots (forced forced-not action-filter system) plan
+    (unless fp (setf forced (normalize-forced-systems (if other-systems :a=
ll t) system)))
+    (unless fnp (setf forced-not (normalize-forced-systems (if other-syste=
ms nil :all) system)))
+    (setf action-filter (ensure-function action-filter))))
+
+(defmethod action-valid-p ((plan filtered-sequential-plan) o c)
+  (and (funcall (plan-action-filter plan) o c)
+       (typep c (plan-component-type plan))
+       (call-next-method)))
+
+(defmethod traverse-actions (actions &rest keys &key plan-class &allow-oth=
er-keys)
+  (let ((plan (apply 'make-instance (or plan-class 'filtered-sequential-pl=
an) keys)))
+    (loop* :for (o . c) :in actions :do
+      (traverse-action plan o c t))
+    (plan-actions plan)))
+
+(define-convenience-action-methods traverse-sub-actions (o c &key))
+(defmethod traverse-sub-actions ((operation operation) (component componen=
t) &rest keys &key &allow-other-keys)
+  (apply 'traverse-actions (direct-dependencies operation component)
+         :system (component-system component) keys))
+
+(defmethod plan-actions ((plan filtered-sequential-plan))
+  (with-slots (keep-operation keep-component) plan
+  (loop* :for (o . c) :in (call-next-method)
+         :when (and (typep o keep-operation)
+                    (typep c keep-component))
+           :collect (cons o c))))
+
+(defmethod required-components (system &rest keys &key (goal-operation 'lo=
ad-op) &allow-other-keys)
+  (remove-duplicates
+   (mapcar 'cdr (apply 'traverse-sub-actions goal-operation system keys))
+   :from-end t))
+
+;;;; ---------------------------------------------------------------------=
----
+;;;; Invoking Operations
+
+(asdf/package:define-package :asdf/operate
+  (:recycle :asdf/operate :asdf)
+  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
+   :asdf/component :asdf/system :asdf/operation :asdf/action
+   :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/plan)
+  (:export
+   #:operate #:oos
+   #:*systems-being-operated* #:*asdf-upgrade-already-attempted*
+   #:build-system
+   #:load-system #:load-systems #:compile-system #:test-system #:require-s=
ystem
+   #:*load-system-operation* #:module-provide-asdf
+   #:component-loaded-p #:already-loaded-systems
+   #:upgrade-asdf #:cleanup-upgraded-asdf #:*post-upgrade-hook*))
+(in-package :asdf/operate)
+
+(defgeneric* (operate) (operation component &key &allow-other-keys))
+(define-convenience-action-methods
+    operate (operation component &key)
+    :operation-initargs t ;; backward-compatibility with ASDF1. Yuck.
+    :if-no-component (error 'missing-component :requires component))
+
+(defvar *systems-being-operated* nil
+  "A boolean indicating that some systems are being operated on")
+
+(defmethod operate :around (operation component
+                            &key verbose
+                              (on-warnings *compile-file-warnings-behaviou=
r*)
+                              (on-failure *compile-file-failure-behaviour*=
) &allow-other-keys)
+  (declare (ignorable operation component))
+  ;; Setup proper bindings around any operate call.
+  (with-system-definitions ()
+    (let* ((*verbose-out* (and verbose *standard-output*))
+           (*compile-file-warnings-behaviour* on-warnings)
+           (*compile-file-failure-behaviour* on-failure))
+      (call-next-method))))
+
+(defmethod operate ((operation operation) (component component)
+                    &rest args &key version &allow-other-keys)
+  "Operate does three things:
+
+1. It creates an instance of OPERATION-CLASS using any keyword parameters =
as initargs.
+2. It finds the  asdf-system specified by SYSTEM (possibly loading it from=
 disk).
+3. It then calls TRAVERSE with the operation and system as arguments
+
+The traverse operation is wrapped in WITH-COMPILATION-UNIT and error handl=
ing code.
+If a VERSION argument is supplied, then operate also ensures that the syst=
em found
+satisfies it using the VERSION-SATISFIES method.
+
+Note that dependencies may cause the operation to invoke other operations =
on the system
+or its components: the new operations will be created with the same initar=
gs as the original one.
+
+The :FORCE or :FORCE-NOT argument to OPERATE can be:
+  T to force the inside of the specified system to be rebuilt (resp. not),
+    without recursively forcing the other systems we depend on.
+  :ALL to force all systems including other systems we depend on to be reb=
uilt (resp. not).
+  (SYSTEM1 SYSTEM2 ... SYSTEMN) to force systems named in a given list
+:FORCE has precedence over :FORCE-NOT; builtin systems cannot be forced."
+  (let* (;; I'd like to remove-plist-keys :force :force-not :verbose,
+         ;; but swank.asd relies on :force (!).
+         (systems-being-operated *systems-being-operated*)
+         (*systems-being-operated* (or systems-being-operated (make-hash-t=
able :test 'equal)))
+         (system (component-system component)))
+    (setf (gethash (coerce-name system) *systems-being-operated*) system)
+    (unless (version-satisfies component version)
+      (error 'missing-component-of-version :requires component :version ve=
rsion))
+    ;; Before we operate on any system, make sure ASDF is up-to-date,
+    ;; for if an upgrade is ever attempted at any later time, there may be=
 BIG trouble.
+    (unless systems-being-operated
+      (let ((operation-name (reify-symbol (type-of operation)))
+            (component-path (component-find-path component)))
+        (when (upgrade-asdf)
+          ;; If we were upgraded, restart OPERATE the hardest of ways, for
+          ;; its function may have been redefined, its symbol uninterned, =
its package deleted.
+          (return-from operate
+            (apply (find-symbol* 'operate :asdf)
+                   (unreify-symbol operation-name)
+                   component-path args)))))
+    (let ((plan (apply 'traverse operation system args)))
+      (perform-plan plan)
+      (values operation plan))))
+
+(defun* oos (operation component &rest args &key &allow-other-keys)
+  (apply 'operate operation component args))
+
+(setf (documentation 'oos 'function)
+      (format nil "Short for _operate on system_ and an alias for the OPER=
ATE function.~%~%~a"
+              (documentation 'operate 'function)))
+
+
+;;;; Common operations
+
+(defvar *load-system-operation* 'load-op
+  "Operation used by ASDF:LOAD-SYSTEM. By default, ASDF:LOAD-OP.
+You may override it with e.g. ASDF:LOAD-FASL-OP from asdf-bundle,
+or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.
+
+This may change in the future as we will implement component-based strategy
+for how to load or compile stuff")
+
+(defun* build-system (system &rest keys)
+  "Shorthand for `(operate 'asdf:build-op system)`."
+  (apply 'operate 'build-op system keys)
+  t)
+
+(defun* load-system (system &rest keys &key force force-not verbose versio=
n &allow-other-keys)
+  "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for details=
."
+  (declare (ignore force force-not verbose version))
+  (apply 'operate *load-system-operation* system keys)
+  t)
+
+(defun* load-systems (&rest systems)
+  "Loading multiple systems at once."
+  (map () 'load-system systems))
+
+(defun* compile-system (system &rest args &key force force-not verbose ver=
sion &allow-other-keys)
+  "Shorthand for `(asdf:operate 'asdf:compile-op system)`. See OPERATE for=
 details."
+  (declare (ignore force force-not verbose version))
+  (apply 'operate 'compile-op system args)
+  t)
+
+(defun* test-system (system &rest args &key force force-not verbose versio=
n &allow-other-keys)
+  "Shorthand for `(asdf:operate 'asdf:test-op system)`. See OPERATE for de=
tails."
+  (declare (ignore force force-not verbose version))
+  (apply 'operate 'test-op system args)
+  t)
+
+
+;;;; Define require-system, to be hooked into CL:REQUIRE when possible,
+;; i.e. for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL
+
+(defun* component-loaded-p (c)
+  (action-already-done-p nil (make-instance 'load-op) (find-component c ()=
)))
+
+(defun* already-loaded-systems ()
+  (remove-if-not 'component-loaded-p (registered-systems)))
+
+(defun* require-system (s &rest keys &key &allow-other-keys)
+  (apply 'load-system s :force-not (already-loaded-systems) keys))
+
+(defun* module-provide-asdf (name)
+  (handler-bind
+      ((style-warning #'muffle-warning)
+       (missing-component (constantly nil))
+       (error #'(lambda (e)
+                  (format *error-output* (compatfmt "~@<ASDF could not loa=
d ~(~A~) because ~A.~@:>~%")
+                          name e))))
+    (let ((*verbose-out* (make-broadcast-stream))
+          (system (find-system (string-downcase name) nil)))
+      (when system
+        (require-system system :verbose nil)
+        t))))
+
+
+;;;; Some upgrade magic
+
+(defun* restart-upgraded-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-def=
ined* :collect name)))
+      (clrhash *systems-being-defined*)
+      (dolist (s l) (find-system s nil)))))
+
+(pushnew 'restart-upgraded-asdf *post-upgrade-restart-hook*)
+;;;; ---------------------------------------------------------------------=
------
+;;;; asdf-output-translations
+
+(asdf/package:define-package :asdf/output-translations
+  (:recycle :asdf/output-translations :asdf)
+  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
+  (:export
+   #:*output-translations* #:*output-translations-parameter*
+   #:invalid-output-translation
+   #:output-translations #:output-translations-initialized-p
+   #:initialize-output-translations #:clear-output-translations
+   #:disable-output-translations #:ensure-output-translations
+   #:apply-output-translations
+   #:validate-output-translations-directive #:validate-output-translations=
-form
+   #:validate-output-translations-file #:validate-output-translations-dire=
ctory
+   #:parse-output-translations-string #:wrapping-output-translations
+   #:user-output-translations-pathname #:system-output-translations-pathna=
me
+   #:user-output-translations-directory-pathname #:system-output-translati=
ons-directory-pathname
+   #:environment-output-translations #:process-output-translations
+   #:compute-output-translations
+   #+abcl #:translate-jar-pathname
+   ))
+(in-package :asdf/output-translations)
+
+(when-upgrading () (undefine-function '(setf output-translations)))
+
+(define-condition invalid-output-translation (invalid-configuration warnin=
g)
+  ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ =
in ~S~]~@{ ~@?~}~@:>"))))
 =

 (defvar *output-translations* ()
   "Either NIL (for uninitialized), or a list of one element,
@@ -3499,20 +7224,10 @@
 Each mapping is a pair of a source pathname and destination pathname,
 and the order is by decreasing length of namestring of the source pathname=
.")
 =

-(defvar *user-cache*
-  (flet ((try (x &rest sub) (and x `(,x , at sub))))
-    (or
-     (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp" :impl=
ementation)
-     (when (os-windows-p)
-       (try (or (get-folder-path :local-appdata)
-                (get-folder-path :appdata))
-            "common-lisp" "cache" :implementation))
-     '(:home ".cache" "common-lisp" :implementation))))
-
 (defun* output-translations ()
   (car *output-translations*))
 =

-(defun* (setf output-translations) (new-value)
+(defun* set-output-translations (new-value)
   (setf *output-translations*
         (list
          (stable-sort (copy-list new-value) #'>
@@ -3523,131 +7238,16 @@
                                   (let ((directory (pathname-directory (ca=
r x))))
                                     (if (listp directory) (length director=
y) 0))))))))
   new-value)
+(defsetf output-translations set-output-translations) ; works with gcl 2.6
 =

 (defun* output-translations-initialized-p ()
   (and *output-translations* t))
 =

 (defun* clear-output-translations ()
-  "Undoes any initialization of the output translations.
-You might want to call that before you dump an image that would be resumed
-with a different configuration, so the configuration would be re-read then=
."
+  "Undoes any initialization of the output translations."
   (setf *output-translations* '())
   (values))
-
-(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean))
-                          (values (or null pathname) &optional))
-                resolve-location))
-
-(defun* resolve-relative-location-component (x &key directory wilden)
-  (let ((r (etypecase x
-             (pathname x)
-             (string (coerce-pathname x :type (when directory :directory)))
-             (cons
-              (if (null (cdr x))
-                  (resolve-relative-location-component
-                   (car x) :directory directory :wilden wilden)
-                  (let* ((car (resolve-relative-location-component
-                               (car x) :directory t :wilden nil)))
-                    (merge-pathnames*
-                     (resolve-relative-location-component
-                      (cdr x) :directory directory :wilden wilden)
-                     car))))
-             ((eql :default-directory)
-              (relativize-pathname-directory (default-directory)))
-             ((eql :*/) *wild-directory*)
-             ((eql :**/) *wild-inferiors*)
-             ((eql :*.*.*) *wild-file*)
-             ((eql :implementation)
-              (coerce-pathname (implementation-identifier) :type :director=
y))
-             ((eql :implementation-type)
-              (coerce-pathname (string-downcase (implementation-type)) :ty=
pe :directory))
-             ((eql :hostname)
-              (coerce-pathname (hostname) :type :directory)))))
-    (when (absolute-pathname-p r)
-      (error (compatfmt "~@<pathname ~S is not relative~@:>") x))
-    (if (or (pathnamep x) (not wilden)) r (wilden r))))
-
-(defvar *here-directory* nil
-  "This special variable is bound to the currect directory during calls to
-PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here
-directive.")
-
-(defun* resolve-absolute-location-component (x &key directory wilden)
-  (let* ((r
-          (etypecase x
-            (pathname x)
-            (string (let ((p (#+mcl probe-posix #-mcl parse-namestring x)))
-                      #+mcl (unless p (error "POSIX pathname ~S does not e=
xist" x))
-                      (if directory (ensure-directory-pathname p) p)))
-            (cons
-             (return-from resolve-absolute-location-component
-               (if (null (cdr x))
-                   (resolve-absolute-location-component
-                    (car x) :directory directory :wilden wilden)
-                   (merge-pathnames*
-                    (resolve-relative-location-component
-                     (cdr x) :directory directory :wilden wilden)
-                    (resolve-absolute-location-component
-                     (car x) :directory t :wilden nil)))))
-            ((eql :root)
-             ;; special magic! we encode such paths as relative pathnames,
-             ;; but it means "relative to the root of the source pathname'=
s host and device".
-             (return-from resolve-absolute-location-component
-               (let ((p (make-pathname :directory '(:relative))))
-                 (if wilden (wilden p) p))))
-            ((eql :home) (user-homedir))
-            ((eql :here)
-             (resolve-location (or *here-directory*
-                                   ;; give semantics in the case of use in=
teractively
-                                   :default-directory)
-                          :directory t :wilden nil))
-            ((eql :user-cache) (resolve-location *user-cache* :directory t=
 :wilden nil))
-            ((eql :system-cache)
-             (error "Using the :system-cache is deprecated. ~%~
-Please remove it from your ASDF configuration"))
-            ((eql :default-directory) (default-directory))))
-         (s (if (and wilden (not (pathnamep x)))
-                (wilden r)
-                r)))
-    (unless (absolute-pathname-p s)
-      (error (compatfmt "~@<Invalid designator for an absolute pathname: ~=
3i~_~S~@:>") x))
-    s))
-
-(defun* resolve-location (x &key directory wilden)
-  (if (atom x)
-      (resolve-absolute-location-component x :directory directory :wilden =
wilden)
-      (loop :with path =3D (resolve-absolute-location-component
-                          (car x) :directory (and (or directory (cdr x)) t)
-                          :wilden (and wilden (null (cdr x))))
-        :for (component . morep) :on (cdr x)
-        :for dir =3D (and (or morep directory) t)
-        :for wild =3D (and wilden (not morep))
-        :do (setf path (merge-pathnames*
-                        (resolve-relative-location-component
-                         component :directory dir :wilden wild)
-                        path))
-        :finally (return path))))
-
-(defun* location-designator-p (x)
-  (flet ((absolute-component-p (c)
-           (typep c '(or string pathname
-                      (member :root :home :here :user-cache :system-cache =
:default-directory))))
-         (relative-component-p (c)
-           (typep c '(or string pathname
-                      (member :default-directory :*/ :**/ :*.*.*
-                        :implementation :implementation-type)))))
-    (or (typep x 'boolean)
-        (absolute-component-p x)
-        (and (consp x) (absolute-component-p (first x)) (every #'relative-=
component-p (rest x))))))
-
-(defun* location-function-p (x)
-  (and
-   (length=3Dn-p x 2)
-   (eq (car x) :function)
-   (or (symbolp (cadr x))
-       (and (consp (cadr x))
-            (eq (caadr x) 'lambda)
-            (length=3Dn-p (cadadr x) 2)))))
+(register-clear-configuration-hook 'clear-output-translations)
 =

 (defun* validate-output-translations-directive (directive)
   (or (member directive '(:enable-user-cache :disable-cache nil))
@@ -3729,12 +7329,10 @@
   `(:output-translations
     ;; Some implementations have precompiled ASDF systems,
     ;; so we must disable translations for implementation paths.
-    #+sbcl ,(let ((h (getenv-pathname "SBCL_HOME" :want-directory t)))
-              (when h `((,(truenamize h) ,*wild-inferiors*) ())))
-    ;; The below two are not needed: no precompiled ASDF system there
-    #+(or ecl mkcl) (,(translate-logical-pathname "SYS:**;*.*") ())
+    #+(or #|clozure|# ecl mkcl sbcl)
+    ,@(let ((h (resolve-symlinks* (lisp-implementation-directory))))
+        (when h `(((,h ,*wild-path*) ()))))
     #+mkcl (,(translate-logical-pathname "CONTRIB:") ())
-    ;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-de=
faults* #p"")) (truename #p"ccl:"))) ()))
     ;; All-import, here is where we want user s