Changeset 12986

10/31/10 08:40:27 (12 years ago)
Mark Evenson

Upgrade to ASDF-2.010.1.

2 edited


  • trunk/abcl/doc/asdf/asdf.texinfo

    r12765 r12986  
    68 @title asdf: another system definition facility
     68@title ASDF: Another System Definition Facility
    7070@c The following two commands start the copyright page.
    207207Hopefully, ASDF 2 will soon be bundled with every Common Lisp implementation,
    208208and you can load it that way.
     209If it is not, see @pxref{Loading ASDF,,Loading an otherwise installed ASDF} below.
     210if you are using the latest version of your Lisp vendor's software,
     211you may also send a bug report to your Lisp vendor and complain about
     212their failing to provide ASDF.
    211214@section Checking whether ASDF is loaded
    240243If it returns @code{NIL} then ASDF is not installed.
    242 If you are running a version older than 2.000,
     245If you are running a version older than 2.008,
    243246we recommend that you load a newer ASDF using the method below.
    552555@end example
    554 On some implementations (namely ABCL, Clozure CL, CMUCL, ECL and SBCL),
     557On some implementations (namely recent versions of
     558ABCL, Clozure CL, CLISP, CMUCL, ECL, SBCL and SCL),
    555559ASDF hooks into the @code{CL:REQUIRE} facility
    556560and you can just use:
    565569we recommend that you upgrade to ASDF 2.
    566570@xref{Loading ASDF,,Loading an otherwise installed ASDF}.
     572Note the name of a system is specified as a string or a symbol,
     573typically a keyword.
     574If a symbol (including a keyword), its name is taken and lowercased.
     575The name must be a suitable value for the @code{:name} initarg
     576to @code{make-pathname} in whatever filesystem the system is to be found.
     577The lower-casing-symbols behaviour is unconventional,
     578but was selected after some consideration.
     579Observations suggest that the type of systems we want to support
     580either have lowercase as customary case (unix, mac, windows)
     581or silently convert lowercase to uppercase (lpns),
     582so this makes more sense than attempting to use @code{:case :common},
     583which is reported not to work on some implementations
    720737(defsystem "foo"
    721738  :version "1.0"
    722   :components ((:module "foo" :components ((:file "bar") (:file"baz")
    723                                            (:file "quux"))
    724                 :perform (compile-op :after (op c)
    725                           (do-something c))
    726                 :explain (compile-op :after (op c)
    727                           (explain-something c)))
    728                (:file "blah")))
     739  :components ((:module "mod"
     740                            :components ((:file "bar")
     741                                                  (:file"baz")
     742                                                  (:file "quux"))
     743                            :perform (compile-op :after (op c)
     744                                                  (do-something c))
     745                            :explain (compile-op :after (op c)
     746                                            (explain-something c)))
     747                         (:file "blah")))
    729748@end lisp
    731 The method-form tokens need explaining: essentially, this part:
     750The @code{:module} component named @code{"mod"} is a collection of three files,
     751which will be located in a subdirectory of the main code directory named
     752@file{mod} (this location can be overridden; see the discussion of the
     753@code{:pathname} option in @ref{The defsystem grammar}).
     755The method-form tokens provide a shorthand for defining methods on
     756particular components.  This part
    747772@end lisp
    749 where @code{...} is the component in question;
    750 note that although this also supports @code{:before} methods,
    751 they may not do what you want them to ---
    752 a @code{:before} method on perform @code{((op compile-op) (c (eql ...)))}
    753 will run after all the dependencies and sub-components have been processed,
    754 but before the component in question has been compiled.
     774where @code{...} is the component in question.
     775In this case @code{...} would expand to something like
     778(find-component (find-system "foo") "mod")
     779@end lisp
     781For more details on the syntax of such forms, see @ref{The defsystem
     783For more details on what these methods do, @pxref{Operations} in
     784@ref{The object model of ASDF}.
     786@c The following plunge into the weeds is not appropriate in this
     787@c location. [2010/10/03:rpg]
     788@c note that although this also supports @code{:before} methods,
     789@c they may not do what you want them to ---
     790@c a @code{:before} method on perform @code{((op compile-op) (c (eql ...)))}
     791@c will run after all the dependencies and sub-components have been processed,
     792@c but before the component in question has been compiled.
    756794@node  The defsystem grammar, Other code in .asd files, A more involved example, Defining systems with defsystem
    758796@section The defsystem grammar
     798@c FIXME: @var typesetting not consistently used here.  We should either expand
     799@c its use to everywhere, or we should kill it everywhere.
    761 system-definition := ( defsystem system-designator @var{option}* )
    763 option := :components component-list
     803system-definition := ( defsystem system-designator @var{system-option}* )
     805system-option := :defsystem-depends-on system-list
     806                 | module-option
     807                 | option
     809module-option := :components component-list
     810                 | :serial [ t | nil ]
     811                 | :if-component-dep-fails component-dep-fail-option
     813option :=
    764814        | :pathname pathname-specifier
    765         | :default-component-class
     815        | :default-component-class class-name
    766816        | :perform method-form
    767817        | :explain method-form
    769819        | :operation-done-p method-form
    770820        | :depends-on ( @var{dependency-def}* )
    771         | :serial [ t | nil ]
    772821        | :in-order-to ( @var{dependency}+ )
     824system-list := ( @var{simple-component-name}* )
    774826component-list := ( @var{component-def}* )
    797849method-form := (operation-name qual lambda-list @&rest body)
    798850qual := method qualifier
     852component-dep-fail-option := :fail | :try-next | :ignore
    799853@end example
    801857@subsection Component names
    811867the current package @code{my-system-asd} can be specified as
    812868@code{:my-component-type}, or @code{my-component-type}.
     870@subsection Defsystem depends on
     872The @code{:defsystem-depends-on} option to @code{defsystem} allows the
     873programmer to specify another ASDF-defined system or set of systems that
     874must be loaded @emph{before} the system definition is processed.
     875Typically this is used to load an ASDF extension that is used in the
     876system definition.
    814878@subsection Pathname specifiers
    881945and the cumbersome @code{#.(make-pathname ...)} syntax had to be used.
    883 Note that when specifying pathname objects, 
     947Note that when specifying pathname objects,
    884948ASDF does not do any special interpretation of the pathname
    885949influenced by the component type, unlike the procedure for
    894958@subsection Warning about logical pathnames
    895 @cindex logical pathnames 
     959@cindex logical pathnames
    897961We recommend that you not use logical pathnames
    917981with the logical pathname facility.
    918982The disadvantage is that if you do not define such translations, any
    919 system that uses logical pathnames will be have differently under
     983system that uses logical pathnames will behave differently under
    920984asdf-output-translations than other systems you use.
    931995If the @code{:serial t} option is specified for a module,
    932 ASDF will add dependencies for each each child component,
     996ASDF will add dependencies for each child component,
    933997on all the children textually preceding it.
    934998This is done as if by @code{:depends-on}.
    9931057from within an editor without clobbering its source location)
    9941058@end itemize
     1060@subsection if-component-dep-fails option
     1062This option is only appropriate for module components (including
     1063systems), not individual source files.
     1065For more information about this option, @pxref{Pre-defined subclasses of component}.
    9961067@node Other code in .asd files,  , The defsystem grammar, Defining systems with defsystem
    14521523This is detailed elsewhere. @xref{Defining systems with defsystem}.
    1454 The answer to the frequently asked question
    1455 ``how do I create a system definition
    1456 where all the source files have a @file{.cl} extension''
    1457 is thus
    1459 @lisp
    1460 (defmethod source-file-type ((c cl-source-file) (s (eql (find-system 'my-sys))))
    1461   "cl")
    1462 @end lisp
    14641526@subsubsection properties
    16721734@code{:directory} entries for @file{$XDG_DATA_DIRS/common-lisp/systems/} and
    16731735@code{:tree} entries for @file{$XDG_DATA_DIRS/common-lisp/source/}.
     1736For instance, SBCL will include directories for its contribs
     1737when it can find them; it will look for them where SBCL was installed,
     1738or at the location specified by the @code{SBCL_HOME} environment variable.
    16751740@end enumerate
    1677 Each of these configuration is specified as a SEXP
    1678 in a trival domain-specific language (defined below).
     1742Each of these configurations is specified as an s-expression
     1743in a trivial domain-specific language (defined below).
    16791744Additionally, a more shell-friendly syntax is available
    16801745for the environment variable (defined yet below).
    17051770we try to use folder configuration from the registry regarding
    17061771@code{Common AppData} and similar directories.
    1707 However, support querying the Windows registry is limited as of ASDF 2,
     1772However, support for querying the Windows registry is limited as of ASDF 2,
    17081773and on many implementations, we may fall back to always using the defaults
    17091774without consulting the registry.
    17121777@section Backward Compatibility
    1714 For backward compatibility as well as for a practical backdoor for hackers,
     1779For backward compatibility as well as to provide a practical backdoor for hackers,
    17151780ASDF will first search for @code{.asd} files in the directories specified in
    17261791@section Configuration DSL
    1728 Here is the grammar of the SEXP DSL for source-registry configuration:
     1793Here is the grammar of the s-expression (SEXP) DSL for source-registry configuration:
    1731 ;; A configuration is single SEXP starting with keyword :source-registry
     1796;; A configuration is a single SEXP starting with keyword :source-registry
    17321797;; followed by a list of directives.
    17331798CONFIGURATION := (:source-registry DIRECTIVE ...)
    17511816    ;; augment the defaults for exclusion patterns
    17521817    (:also-exclude PATTERN ...) |
     1818    ;; Note that the scope of a an exclude pattern specification is
     1819    ;; the rest of the current configuration expression or file.
    17541821    ;; splice the parsed contents of another config file
    17571824    ;; This directive specifies that some default must be spliced.
    17581825    :default-registry
     1828DIRECTORY-PATHNAME-DESIGNATOR := PATHNAME-DESIGNATOR ;; interpreted as a directory name
     1831    NULL | ;; Special: skip this entry.
     1836    STRING | ;; namestring (better be absolute or bust, directory assumed where applicable)
     1837    PATHNAME | ;; pathname (better be an absolute path, or bust)
     1838    :HOME | ;; designates the user-homedir-pathname ~/
     1839    :USER-CACHE | ;; designates the default location for the user cache
     1840    :SYSTEM-CACHE ;; designates the default location for the system cache
     1843    STRING | ;; namestring (directory assumed where applicable)
     1844    PATHNAME | ;; pathname
     1845    :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-
     1846    :IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl
     1847    :UID | ;; current UID -- not available on Windows
     1848    :USER ;; current USER name -- NOT IMPLEMENTED(!)
    17601850PATTERN := a string without wildcards, that will be matched exactly
    1770   (:tree "/home/fare/cl/")
     1860  (:tree (:home "cl")) ;; will expand to e.g. "/home/joeluser/cl/"
    17711861  :inherit-configuration)
    17721862@end example
    17751864@section Configuration Directories
    18361925@section Search Algorithm
     1926@vindex *default-source-registry-exclusions*
    18381928In case that isn't clear, the semantics of the configuration is that
    18971987   undoes any source registry configuration
    18981988   and clears any cache for the search algorithm.
    1899    You might want to call that before you
    1900    dump an image that would be resumed with a different configuration,
     1989   You might want to call this function
     1990   (or better, @code{clear-configuration})
     1991   before you dump an image that would be resumed
     1992   with a different configuration,
    19011993   and return an empty configuration.
    19021994   Note that this does not include clearing information about
    19092001   If not, initialize it with the given @var{PARAMETER}.
    19102002@end defun
     2004Every time you use ASDF's @code{find-system}, or
     2005anything that uses it (such as @code{operate}, @code{load-system}, etc.),
     2006@code{ensure-source-registry} is called with parameter NIL,
     2007which the first time around causes your configuration to be read.
     2008If you change a configuration file,
     2009you need to explicitly @code{initialize-source-registry} again,
     2010or maybe simply to @code{clear-source-registry} (or @code{clear-configuration})
     2011which will cause the initialization to happen next time around.
    21902291    :HOME | ;; designates the user-homedir-pathname ~/
    21912292    :USER-CACHE | ;; designates the default location for the user cache
    2192     :SYSTEM-CACHE | ;; designates the default location for the system cache
    2193     :CURRENT-DIRECTORY ;; the current directory
     2293    :SYSTEM-CACHE ;; designates the default location for the system cache
    21982298    :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-
    21992299    :IMPLEMENTATION-TYPE | ;; a directory based on lisp-implementation-type only, e.g. sbcl
    2200     :CURRENT-DIRECTORY | ;; all components of the current directory, without the :absolute
    22012300    :UID | ;; current UID -- not available on Windows
    22022301    :USER ;; current USER name -- NOT IMPLEMENTED(!)
    23812480   undoes any output translation configuration
    23822481   and clears any cache for the mapping algorithm.
    2383    You might want to call that before you
    2384    dump an image that would be resumed with a different configuration,
     2482   You might want to call this function
     2483   (or better, @code{clear-configuration})
     2484   before you dump an image that would be resumed
     2485   with a different configuration,
    23852486   and return an empty configuration.
    23862487   Note that this does not include clearing information about
    23992500   (calls @code{ensure-output-translations} for the translations).
    24002501@end defun
     2503Every time you use ASDF's @code{output-files}, or
     2504anything that uses it (that may compile, such as @code{operate}, @code{perform}, etc.),
     2505@code{ensure-output-translations} is called with parameter NIL,
     2506which the first time around causes your configuration to be read.
     2507If you change a configuration file,
     2508you need to explicitly @code{initialize-output-translations} again,
     2509or maybe @code{clear-output-translations} (or @code{clear-configuration}),
     2510which will cause the initialization to happen next time around.
    24952605@defun system-source-directory system-designator
    2497 ASDF does not provide a turnkey solution for locating data (or other
    2498 miscellaneous) files that are distributed together with the source code
    2499 of a system.  Programmers can use @code{system-source-directory} to find
    2500 such files.  Returns a pathname object.  The @var{system-designator} may
    2501 be a string, symbol, or ASDF system object.
     2607ASDF does not provide a turnkey solution for locating
     2608data (or other miscellaneous) files
     2609that are distributed together with the source code of a system.
     2610Programmers can use @code{system-source-directory} to find such files.
     2611Returns a pathname object.
     2612The @var{system-designator} may be a string, symbol, or ASDF system object.
    25022613@end defun
     2615@defun clear-system system-designator
     2617It is sometimes useful to force recompilation of a previously loaded system.
     2618In these cases, it may be useful to @code{(asdf:clear-system :foo)}
     2619to remove the system from the table of currently loaded systems;
     2620the next time the system @code{foo} or one that depends on it is re-loaded,
     2621@code{foo} will then be loaded again.
     2622Alternatively, you could touch @code{foo.asd} or
     2623remove the corresponding fasls from the output file cache.
     2624(It was once conceived that one should provide
     2625a list of systems the recompilation of which to force
     2626as the @code{:force} keyword argument to @code{load-system};
     2627but this has never worked, and though the feature was fixed in ASDF 2.000,
     2628it remains @code{cerror}'ed out as nobody ever used it.)
     2630Note that this does not and cannot by itself undo the previous loading
     2631of the system. Common Lisp has no provision for such an operation,
     2632and its reliance on irreversible side-effects to global datastructures
     2633makes such a thing impossible in the general case.
     2634If the software being re-loaded is not conceived with hot upgrade in mind,
     2635this re-loading may cause many errors, warnings or subtle silent problems,
     2636as packages, generic function signatures, structures, types, macros, constants, etc.
     2637are being redefined incompatibly.
     2638It is up to the user to make sure that reloading is possible and has the desired effect.
     2639In some cases, extreme measures such as recursively deleting packages,
     2640unregistering symbols, defining methods on @code{update-instance-for-redefined-class}
     2641and much more are necessary for reloading to happen smoothly.
     2642ASDF itself goes through notable pains to make such a hot upgrade possible
     2643with respect to its own code, and what it does is ridiculously complex;
     2644look at the beginning of @file{asdf.lisp} to see what it does.
     2645@end defun
    25052647@node Getting the latest version, FAQ, Miscellaneous additional functionality, Top
    25352677ASDF bugs are tracked on launchpad: @url{}.
    2537 If you're unsure about whether something is a bug, of for general discussion,
     2679If you're unsure about whether something is a bug, or for general discussion,
    25382680use the @url{,asdf-devel mailing list}
    2759 @subsection Pitfalls of ASDF 2
     2901@subsection Pitfalls of the transition to ASDF 2
    27612903The main pitfalls in upgrading to ASDF 2 seem to be related
    27832925@pxref{Controlling where ASDF saves compiled files,,Backward Compatibility}.
    27842926But thou shall not load ABL on top of ASDF 2.
     2928@end itemize
     2930Other issues include the following:
    27932941moreover when evaluation is desired @code{#.} must be used,
    27942942where it wasn't necessary in the toplevel @code{:pathname} argument.
    2796 @end itemize
    2798 Other issues include the following:
    2800 @itemize
    28182960On Windows, only LispWorks supports proper default configuration pathnames
    28192961based on the Windows registry.
    2820 Other implementations make do.
    2821 Windows support is largely untested, so please help report and fix bugs.
     2962Other implementations make do with environment variables.
     2963Windows support is somewhat less tested than Unix support.
     2964Please help report and fix bugs.
     2967The mechanism by which one customizes a system so that Lisp files
     2968may use a different extension from the default @file{.lisp} has changed.
     2969Previously, the pathname for a component was lazily computed when operating on a system,
     2970and you would
     2971@code{(defmethod source-file-type ((component cl-source-file) (system (eql (find-system 'foo))))
     2972  (declare (ignorable component system)) "cl")}.
     2973Now, the pathname for a component is eagerly computed when defining the system,
     2974and instead you will @code{(defclass my-cl-source-file (cl-source-file) ((type :iniform "cl")))}
     2975and use @code{:default-component-class my-cl-source-file} as argument to @code{defsystem},
     2976as detailed in a @pxref{FAQ,How do I create a system definition where all the source files have a .cl extension?} below.
     2978@findex source-file-type
    28232981@end itemize
    28412999Starting with current candidate releases of ASDF 2,
    2842 it should always be a good time to upgrade to a recent version of ASDF.
     3000it should always be a good time to upgrade to a recent ASDF.
    28433001You may consult with the maintainer for which specific version they recommend,
    28443002but the latest RELEASE should be correct.
    2853 If ASDF isn't installed yet, then @code{(require :asdf)}
     3011If ASDF isn't loaded yet, then @code{(require :asdf)}
    28543012should load the version of ASDF that is bundled with your system.
    28553013You may have it load some other version configured by the user,
    28593017If your system provides a mechanism to hook into @code{CL:REQUIRE},
    28603018then it would be nice to add ASDF to this hook the same way that
    2861 ABCL, CCL, CMUCL, ECL and SBCL do it.
     3019ABCL, CCL, CLISP, CMUCL, ECL, SBCL and SCL do it.
    28773035but @file{asdf.asd} if included at all,
    28783036should be secluded from the magic systems,
    2879 in a separate file hierarchy,
    2880 or you may otherwise rename the system and its file to e.g.
     3037in a separate file hierarchy;
     3038alternatively, you may provide the system
     3039after renaming it and its @file{.asd} file to e.g.
    28813040@code{asdf-ecl} and @file{asdf-ecl.asd}, or
    28823041@code{sb-asdf} and @file{sb-asdf.asd}.
    30873246(if the component class doesn't specifies a pathname type).
     3248@subsection How do I create a system definition where all the source files have a .cl extension?
     3250First, create a new @code{cl-source-file} subclass that provides an
     3251initform for the @code{type} slot:
     3254(defclass my-cl-source-file (cl-source-file)
     3255   ((type :initform "cl")))
     3256@end lisp
     3258To support both ASDF 1 and ASDF 2,
     3259you may omit the above @code{type} slot definition and instead define:
     3262(defmethod source-file-type ((f my-cl-source-file) (m module))
     3263  (declare (ignorable f m))
     3264  "cl")
     3265@end lisp
     3267Then make your system use this subclass in preference to the standard
     3271(defsystem my-cl-system
     3272  :default-component-class my-cl-source-file
     3273   ....
     3275@end lisp
     3277We assume that these definitions are loaded into a package that uses
    30903282@node  TODO list, Inspiration, FAQ, Top
    32643456whereas this one centres on a protocol for system introspection.
    3266 @section kmp's ``The Description of Large Systems'', MIT AI Memu 801
     3458@section kmp's ``The Description of Large Systems'', MIT AI Memo 801
    32683460Available in updated-for-CL form on the web at
  • trunk/abcl/src/org/armedbear/lisp/asdf.lisp

    r12818 r12986  
    4848#+xcvb (module ())
    50 (cl:in-package :cl)
    51 (defpackage :asdf-bootstrap (:use :cl))
    52 (in-package :asdf-bootstrap)
    54 ;; Implementation-dependent tweaks
     50(cl:in-package :cl-user)
     52#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this
    5554(eval-when (:compile-toplevel :load-toplevel :execute)
    56   ;; (declaim (optimize (speed 2) (debug 2) (safety 3)) ; NO: rely on the implementation defaults.
     55  ;;; make package if it doesn't exist yet.
     56  ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
     57  (unless (find-package :asdf)
     58    (make-package :asdf :use '(:cl)))
     59  ;;; Implementation-dependent tweaks
     60  ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults.
    5761  #+allegro
    5862  (setf excl::*autoload-package-name-alist*
    5963        (remove "asdf" excl::*autoload-package-name-alist*
    6064                :test 'equalp :key 'car))
    61   #+ecl (require :cmp)
    62   #+gcl
    63   (eval-when (:compile-toplevel :load-toplevel)
    64     (defpackage :asdf-utilities (:use :cl))
    65     (defpackage :asdf (:use :cl :asdf-utilities))))
     65  #+ecl (require :cmp))
     67(in-package :asdf)
    6769;;;; Create packages in a way that is compatible with hot-upgrade.
    7173(eval-when (:load-toplevel :compile-toplevel :execute)
    72   (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate
    73           (subseq "VERSION:2.004" (1+ (length "VERSION")))) ; NB: same as 2.111.
    74          (existing-asdf (find-package :asdf))
    75          (vername '#:*asdf-version*)
    76          (versym (and existing-asdf
    77                       (find-symbol (string vername) existing-asdf)))
    78          (existing-version (and versym (boundp versym) (symbol-value versym)))
     74  (defvar *asdf-version* nil)
     75  (defvar *upgraded-p* nil)
     76  (let* ((asdf-version "2.010.1") ;; bump this version when you modify this file. Same as 2.147
     77         (existing-asdf (fboundp 'find-system))
     78         (existing-version *asdf-version*)
    7979         (already-there (equal asdf-version existing-version)))
    8080    (unless (and existing-asdf already-there)
    81       #-gcl
    8281      (when existing-asdf
    83         (format *trace-output*
     82        (format *error-output*
    8483                "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
    8584                existing-version asdf-version))
    8685      (labels
    87           ((rename-away (package)
    88              (loop :with name = (package-name package)
    89                :for i :from 1 :for new = (format nil "~A.~D" name i)
    90                :unless (find-package new) :do
    91                (rename-package-name package name new)))
    92            (rename-package-name (package old new)
    93              (let* ((old-names (cons (package-name package)
    94                                      (package-nicknames package)))
    95                     (new-names (subst new old old-names :test 'equal))
    96                     (new-name (car new-names))
    97                     (new-nicknames (cdr new-names)))
    98                (rename-package package new-name new-nicknames)))
     86          ((unlink-package (package)
     87             (let ((u (find-package package)))
     88               (when u
     89                 (ensure-unintern u
     90                   (loop :for s :being :each :present-symbol :in u :collect s))
     91                 (loop :for p :in (package-used-by-list u) :do
     92                   (unuse-package u p))
     93                 (delete-package u))))
    9994           (ensure-exists (name nicknames use)
    100              (let* ((previous
    101                      (remove-duplicates
    102                       (remove-if
    103                        #'null
    104                        (mapcar #'find-package (cons name nicknames)))
    105                       :from-end t)))
    106                (cond
    107                  (previous
    108                   ;; do away with packages with conflicting (nick)names
    109                   (map () #'rename-away (cdr previous))
    110                   ;; reuse previous package with same name
    111                   (let ((p (car previous)))
     95             (let ((previous
     96                    (remove-duplicates
     97                     (mapcar #'find-package (cons name nicknames))
     98                     :from-end t)))
     99               ;; do away with packages with conflicting (nick)names
     100               (map () #'unlink-package (cdr previous))
     101               ;; reuse previous package with same name
     102               (let ((p (car previous)))
     103                 (cond
     104                   (p
    112105                    (rename-package p name nicknames)
    113106                    (ensure-use p use)
    114                     p))
    115                  (t
    116                   (make-package name :nicknames nicknames :use use)))))
     107                    p)
     108                   (t
     109                    (make-package name :nicknames nicknames :use use))))))
    117110           (find-sym (symbol package)
    118111             (find-symbol (string symbol) package))
    123116               (when sym
    124117                 (unexport sym package)
    125                  (unintern sym package))))
     118                 (unintern sym package)
     119                 sym)))
    126120           (ensure-unintern (package symbols)
    127              (dolist (sym symbols) (remove-symbol sym package)))
     121             (loop :with packages = (list-all-packages)
     122               :for sym :in symbols
     123               :for removed = (remove-symbol sym package)
     124               :when removed :do
     125               (loop :for p :in packages :do
     126                 (when (eq removed (find-sym sym p))
     127                   (unintern removed p)))))
    128128           (ensure-shadow (package symbols)
    129129             (shadow symbols package))
    139139               :when sym :do (fmakunbound sym)))
    140140           (ensure-export (package export)
    141              (let ((syms (loop :for x :in export :collect
    142                            (intern* x package))))
    143                (do-external-symbols (sym package)
    144                  (unless (member sym syms)
    145                    (remove-symbol sym package)))
    146                (dolist (sym syms)
    147                  (export sym package))))
     141             (let ((formerly-exported-symbols nil)
     142                   (bothly-exported-symbols nil)
     143                   (newly-exported-symbols nil))
     144               (loop :for sym :being :each :external-symbol :in package :do
     145                 (if (member sym export :test 'string-equal)
     146                     (push sym bothly-exported-symbols)
     147                     (push sym formerly-exported-symbols)))
     148               (loop :for sym :in export :do
     149                 (unless (member sym bothly-exported-symbols :test 'string-equal)
     150                   (push sym newly-exported-symbols)))
     151               (loop :for user :in (package-used-by-list package)
     152                 :for shadowing = (package-shadowing-symbols user) :do
     153                 (loop :for new :in newly-exported-symbols
     154                   :for old = (find-sym new user)
     155                   :when (and old (not (member old shadowing)))
     156                   :do (unintern old user)))
     157               (loop :for x :in newly-exported-symbols :do
     158                 (export (intern* x package)))))
    148159           (ensure-package (name &key nicknames use unintern fmakunbound shadow export)
    149              (let ((p (ensure-exists name nicknames use)))
     160             (let* ((p (ensure-exists name nicknames use)))
    150161               (ensure-unintern p unintern)
    151162               (ensure-shadow p shadow)
    162173                   :fmakunbound ',(append fmakunbound))))
    163174          (pkgdcl
    164            :asdf-utilities
    165            :nicknames (#:asdf-extensions)
    166            :use (#:common-lisp)
    167            :unintern (#:split #:make-collector)
    168            :export
    169            (#:absolute-pathname-p
    170             #:aif
    171             #:appendf
    172             #:asdf-message
    173             #:coerce-name
    174             #:directory-pathname-p
    175             #:ends-with
    176             #:ensure-directory-pathname
    177             #:getenv
    178             #:get-uid
    179             #:length=n-p
    180             #:merge-pathnames*
    181             #:pathname-directory-pathname
    182             #:read-file-forms
    183             #:remove-keys
    184             #:remove-keyword
    185             #:resolve-symlinks
    186             #:split-string
    187             #:component-name-to-pathname-components
    188             #:split-name-type
    189             #:system-registered-p
    190             #:truenamize
    191             #:while-collecting))
    192           (pkgdcl
    193175           :asdf
    194            :use (:common-lisp :asdf-utilities)
     176           :nicknames (:asdf-utilities) ;; DEPRECATED! Do not use, for backward compatibility only.
     177           :use (:common-lisp)
    195178           :redefined-functions
    196179           (#:perform #:explain #:output-files #:operation-done-p
    197180            #:perform-with-restarts #:component-relative-pathname
    198             #:system-source-file #:operate #:find-component)
     181            #:system-source-file #:operate #:find-component #:find-system
     182            #:apply-output-translations #:translate-pathname* #:resolve-location)
    199183           :unintern
    200184           (#:*asdf-revision* #:around #:asdf-method-combination
    208192           (#:defsystem #:oos #:operate #:find-system #:run-shell-command
    209193            #:system-definition-pathname #:find-component ; miscellaneous
    210             #:compile-system #:load-system #:test-system
     194            #:compile-system #:load-system #:test-system #:clear-system
    211195            #:compile-op #:load-op #:load-source-op
    212196            #:test-op
    216200            #:version-satisfies
    218             #:input-files #:output-files #:perform ; operation methods
     202            #:input-files #:output-files #:output-file #:perform ; operation methods
    219203            #:operation-done-p #:explain
    255239            #:operation-on-warnings
    256240            #:operation-on-failure
     241            #:component-visited-p
    257242            ;;#:*component-parent-pathname*
    258243            #:*system-definition-search-functions*
    284269            #:remove-entry-from-registry
     271            #:clear-configuration
    286272            #:initialize-output-translations
    287273            #:disable-output-translations
    292278            #:compile-file-pathname*
    293279            #:enable-asdf-binary-locations-compatibility
    295280            #:*default-source-registries*
    296281            #:initialize-source-registry
    298283            #:clear-source-registry
    299284            #:ensure-source-registry
    300             #:process-source-registry)))
    301         (let* ((version (intern* vername :asdf))
    302                (upvar (intern* '#:*upgraded-p* :asdf))
    303                (upval0 (and (boundp upvar) (symbol-value upvar)))
    304                (upval1 (if existing-version (cons existing-version upval0) upval0)))
    305           (eval `(progn
    306                    (defparameter ,version ,asdf-version)
    307                    (defparameter ,upvar ',upval1))))))))
    309 (in-package :asdf)
     285            #:process-source-registry
     286            #:system-registered-p
     287            #:asdf-message
     289            ;; Utilities
     290            #:absolute-pathname-p
     291      ;; #:aif #:it
     292            ;; #:appendf
     293            #:coerce-name
     294            #:directory-pathname-p
     295            ;; #:ends-with
     296            #:ensure-directory-pathname
     297            #:getenv
     298            ;; #:get-uid
     299            ;; #:length=n-p
     300            #:merge-pathnames*
     301            #:pathname-directory-pathname
     302            #:read-file-forms
     303      ;; #:remove-keys
     304      ;; #:remove-keyword
     305            #:resolve-symlinks
     306            #:split-string
     307            #:component-name-to-pathname-components
     308            #:split-name-type
     309            #:subdirectories
     310            #:truenamize
     311            #:while-collecting)))
     312        (setf *asdf-version* asdf-version
     313              *upgraded-p* (if existing-version
     314                               (cons existing-version *upgraded-p*)
     315                               *upgraded-p*))))))
    311317;; More cleanups in case of hot-upgrade. See
    312 #+gcl
    313 (eval-when (:compile-toplevel :load-toplevel)
    314   (defvar *asdf-version* nil)
    315   (defvar *upgraded-p* nil))
    316318(when *upgraded-p*
    317319   #+ecl
    327329           ((m module) added deleted plist &key)
    328330         (declare (ignorable deleted plist))
    329          (format *trace-output* "Updating ~A~%" m)
     331         (when *asdf-verbose* (format *trace-output* "Updating ~A~%" m))
    330332         (when (member 'components-by-name added)
    331            (compute-module-components-by-name m))))))
     333           (compute-module-components-by-name m))
     334         (when (and (typep m 'system) (member 'source-file added))
     335           (%set-system-source-file (probe-asd (component-name m) (component-pathname m)) m))))))
    333337;;;; -------------------------------------------------------------------------
    343347  "Determine whether or not ASDF resolves symlinks when defining systems.
    345 Defaults to `t`.")
    347 (defvar *compile-file-warnings-behaviour* :warn
    348   "How should ASDF react if it encounters a warning when compiling a
    349 file?  Valid values are :error, :warn, and :ignore.")
    351 (defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn
    352         "How should ASDF react if it encounters a failure \(per the
    353 ANSI spec of COMPILE-FILE\) when compiling a file?  Valid values are
    354 :error, :warn, and :ignore.  Note that ASDF ALWAYS raises an error
    355 if it fails to create an output file when compiling.")
     349Defaults to T.")
     351(defvar *compile-file-warnings-behaviour*
     352  (or #+clisp :ignore :warn)
     353  "How should ASDF react if it encounters a warning when compiling a file?
     354Valid values are :error, :warn, and :ignore.")
     356(defvar *compile-file-failure-behaviour*
     357  (or #+sbcl :error #+clisp :ignore :warn)
     358  "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
     359when compiling a file?  Valid values are :error, :warn, and :ignore.
     360Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.")
    357362(defvar *verbose-out* nil)
    372377;;;; -------------------------------------------------------------------------
    373378;;;; ASDF Interface, in terms of generic functions.
    374 (defmacro defgeneric* (name formals &rest options)
    375   `(progn
    376      #+(or gcl ecl) (fmakunbound ',name)
    377      (defgeneric ,name ,formals ,@options)))
     380    ((defdef (def* def)
     381       `(defmacro ,def* (name formals &rest rest)
     382          `(progn
     383             #+(or ecl gcl) (fmakunbound ',name)
     384             ,(when (and #+ecl (symbolp name))
     385                `(declaim (notinline ,name))) ; fails for setf functions on ecl
     386             (,',def ,name ,formals ,@rest)))))
     387  (defdef defgeneric* defgeneric)
     388  (defdef defun* defun))
     390(defgeneric* find-system (system &optional error-p))
    379391(defgeneric* perform-with-restarts (operation component))
    380392(defgeneric* perform (operation component))
    383395(defgeneric* output-files (operation component))
    384396(defgeneric* input-files (operation component))
    385 (defgeneric component-operation-time (operation component))
     397(defgeneric* component-operation-time (operation component))
     398(defgeneric* operation-description (operation component)
     399  (:documentation "returns a phrase that describes performing this operation
     400on this component, e.g. \"loading /a/b/c\".
     401You can put together sentences using this phrase."))
    387403(defgeneric* system-source-file (system)
    388404  (:documentation "Return the source file in which system is defined."))
    390 (defgeneric component-system (component)
     406(defgeneric* component-system (component)
    391407  (:documentation "Find the top-level system containing COMPONENT"))
    393 (defgeneric component-pathname (component)
     409(defgeneric* component-pathname (component)
    394410  (:documentation "Extracts the pathname applicable for a particular component."))
    396 (defgeneric component-relative-pathname (component)
     412(defgeneric* component-relative-pathname (component)
    397413  (:documentation "Returns a pathname for the component argument intended to be
    398414interpreted relative to the pathname of that component's parent.
    401417another pathname in a degenerate way."))
    403 (defgeneric component-property (component property))
    405 (defgeneric (setf component-property) (new-value component property))
    407 (defgeneric version-satisfies (component version))
     419(defgeneric* component-property (component property))
     421(defgeneric* (setf component-property) (new-value component property))
     423(defgeneric* version-satisfies (component version))
    409425(defgeneric* find-component (base path)
    411427if BASE is nil, then the component is assumed to be a system."))
    413 (defgeneric source-file-type (component system))
    415 (defgeneric operation-ancestor (operation)
     429(defgeneric* source-file-type (component system))
     431(defgeneric* operation-ancestor (operation)
    416432  (:documentation
    417433   "Recursively chase the operation's parent pointer until we get to
    418434the head of the tree"))
    420 (defgeneric component-visited-p (operation component)
     436(defgeneric* component-visited-p (operation component)
    421437  (:documentation "Returns the value stored by a call to
    422438VISIT-COMPONENT, if that has been called, otherwise NIL.
    431447operations needed to be performed."))
    433 (defgeneric visit-component (operation component data)
     449(defgeneric* visit-component (operation component data)
    434450  (:documentation "Record DATA as being associated with OPERATION
    435451and COMPONENT.  This is a side-effecting function:  the association
    439455non-NIL.  Using the data field is probably very risky; if there is
    440456already a record for OPERATION X COMPONENT, DATA will be quietly
    441 discarded instead of recorded."))
    443 (defgeneric (setf visiting-component) (new-value operation component))
    445 (defgeneric component-visiting-p (operation component))
    447 (defgeneric component-depends-on (operation component)
     457discarded instead of recorded.
     458  Starting with 2.006, TRAVERSE will store an integer in data,
     459so that nodes can be sorted in decreasing order of traversal."))
     462(defgeneric* (setf visiting-component) (new-value operation component))
     464(defgeneric* component-visiting-p (operation component))
     466(defgeneric* component-depends-on (operation component)
    448467  (:documentation
    449468   "Returns a list of dependencies needed by the component to perform
    462481    list."))
    464 (defgeneric component-self-dependencies (operation component))
    466 (defgeneric traverse (operation component)
     483(defgeneric* component-self-dependencies (operation component))
     485(defgeneric* traverse (operation component)
    467486  (:documentation
    468487"Generate and return a plan for performing OPERATION on COMPONENT.
    497516  `(let ((it ,test)) (if it ,then ,else)))
    499 (defun pathname-directory-pathname (pathname)
     518(defun* pathname-directory-pathname (pathname)
    500519  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
    501520and NIL NAME, TYPE and VERSION components"
    503522    (make-pathname :name nil :type nil :version nil :defaults pathname)))
    505 (defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
     524(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
    506525  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname
    507526does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS.
    512531         (defaults (pathname defaults))
    513532         (directory (pathname-directory specified))
    514          #-sbcl (directory (if (stringp directory) `(:absolute ,directory) directory))
     533         (directory
     534          (cond
     535            #-(or sbcl cmu scl)
     536            ((stringp directory) `(:absolute ,directory) directory)
     537            #+gcl
     538            ((and (consp directory) (not (member (first directory) '(:absolute :relative))))
     539             `(:relative ,@directory))
     540            ((or (null directory)
     541                 (and (consp directory) (member (first directory) '(:absolute :relative))))
     542             directory)
     543            (t
     544             (error "Unrecognized directory component ~S in pathname ~S" directory specified))))
    515545         (name (or (pathname-name specified) (pathname-name defaults)))
    516546         (type (or (pathname-type specified) (pathname-type defaults)))
    521551               (if (typep p 'logical-pathname) #'ununspecific #'identity)))
    522552      (multiple-value-bind (host device directory unspecific-handler)
    523           (#-gcl ecase #+gcl case (first directory)
     553          (ecase (first directory)
    524554            ((nil)
    525555             (values (pathname-host defaults)
    538568                         (append (pathname-directory defaults) (cdr directory))
    539569                         directory)
    540                      (unspecific-handler defaults)))
    541             #+gcl
    542             (t
    543              (assert (stringp (first directory)))
    544              (values (pathname-host defaults)
    545                      (pathname-device defaults)
    546                      (append (pathname-directory defaults) directory)
    547570                     (unspecific-handler defaults))))
    548571        (make-pathname :host host :device device :directory directory
    557580  or "or a flag")
    559 (defun first-char (s)
     582(defun* first-char (s)
    560583  (and (stringp s) (plusp (length s)) (char s 0)))
    562 (defun last-char (s)
     585(defun* last-char (s)
    563586  (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
    565 (defun asdf-message (format-string &rest format-args)
     588(defun* asdf-message (format-string &rest format-args)
    566589  (declare (dynamic-extent format-args))
    567590  (apply #'format *verbose-out* format-string format-args))
    569 (defun split-string (string &key max (separator '(#\Space #\Tab)))
     592(defun* split-string (string &key max (separator '(#\Space #\Tab)))
    570593  "Split STRING into a list of components separated by
    571594any of the characters in the sequence SEPARATOR.
    587610          (setf end start))))))
    589 (defun split-name-type (filename)
     612(defun* split-name-type (filename)
    590613  (let ((unspecific
    591614         ;; Giving :unspecific as argument to make-pathname is not portable.
    599622          (values name type)))))
    601 (defun component-name-to-pathname-components (s &optional force-directory)
     624(defun* component-name-to-pathname-components (s &key force-directory force-relative)
    602625  "Splits the path string S, returning three values:
    603626A flag that is either :absolute or :relative, indicating
    617640  (check-type s string)
     641  (when (find #\: s)
     642    (error "a portable ASDF pathname designator cannot include a #\: character: ~S" s))
    618643  (let* ((components (split-string s :separator "/"))
    619644         (last-comp (car (last components))))
    621646        (if (equal (first components) "")
    622647            (if (equal (first-char s) #\/)
    623                 (values :absolute (cdr components))
     648                (progn
     649                  (when force-relative
     650                    (error "absolute pathname designator not allowed: ~S" s))
     651                  (values :absolute (cdr components)))
    624652                (values :relative nil))
    625653          (values :relative components))
    633661         (values relative (butlast components) last-comp))))))
    635 (defun remove-keys (key-names args)
     663(defun* remove-keys (key-names args)
    636664  (loop :for (name val) :on args :by #'cddr
    637665    :unless (member (symbol-name name) key-names
    639667    :append (list name val)))
    641 (defun remove-keyword (key args)
     669(defun* remove-keyword (key args)
    642670  (loop :for (k v) :on args :by #'cddr
    643671    :unless (eq k key)
    644672    :append (list k v)))
    646 (defun getenv (x)
    647   #+abcl
    648   (ext:getenv x)
    649   #+sbcl
    650   (sb-ext:posix-getenv x)
    651   #+clozure
    652   (ccl:getenv x)
    653   #+clisp
    654   (ext:getenv x)
    655   #+cmu
    656   (cdr (assoc (intern x :keyword) ext:*environment-list*))
    657   #+lispworks
    658   (lispworks:environment-variable x)
    659   #+allegro
    660   (sys:getenv x)
    661   #+gcl
    662   (system:getenv x)
    663   #+ecl
    664   (si:getenv x))
    666 (defun directory-pathname-p (pathname)
     674(defun* getenv (x)
     675  (#+abcl ext:getenv
     676   #+allegro sys:getenv
     677   #+clisp ext:getenv
     678   #+clozure ccl:getenv
     679   #+(or cmu scl) (lambda (x) (cdr (assoc x ext:*environment-list* :test #'string=)))
     680   #+ecl si:getenv
     681   #+gcl system:getenv
     682   #+lispworks lispworks:environment-variable
     683   #+sbcl sb-ext:posix-getenv
     684   x))
     686(defun* directory-pathname-p (pathname)
    667687  "Does PATHNAME represent a directory?
    673693Note that this does _not_ check to see that PATHNAME points to an
    674694actually-existing directory."
    675   (flet ((check-one (x)
    676            (member x '(nil :unspecific "") :test 'equal)))
    677     (and (check-one (pathname-name pathname))
    678          (check-one (pathname-type pathname))
    679          t)))
    681 (defun ensure-directory-pathname (pathspec)
     695  (when pathname
     696    (let ((pathname (pathname pathname)))
     697      (flet ((check-one (x)
     698               (member x '(nil :unspecific "") :test 'equal)))
     699        (and (not (wild-pathname-p pathname))
     700             (check-one (pathname-name pathname))
     701             (check-one (pathname-type pathname))
     702             t)))))
     704(defun* ensure-directory-pathname (pathspec)
    682705  "Converts the non-wild pathname designator PATHSPEC to directory form."
    683706  (cond
    687710    (error "Invalid pathname designator ~S" pathspec))
    688711   ((wild-pathname-p pathspec)
    689     (error "Can't reliably convert wild pathnames."))
     712    (error "Can't reliably convert wild pathname ~S" pathspec))
    690713   ((directory-pathname-p pathspec)
    691714    pathspec)
    697720                   :defaults pathspec))))
    699 (defun absolute-pathname-p (pathspec)
    700   (eq :absolute (car (pathname-directory (pathname pathspec)))))
    702 (defun length=n-p (x n) ;is it that (= (length x) n) ?
     722(defun* absolute-pathname-p (pathspec)
     723  (and pathspec (eq :absolute (car (pathname-directory (pathname pathspec))))))
     725(defun* length=n-p (x n) ;is it that (= (length x) n) ?
    703726  (check-type n (integer 0 *))
    704727  (loop
    709732      ((not (consp l)) (return nil)))))
    711 (defun ends-with (s suffix)
     734(defun* ends-with (s suffix)
    712735  (check-type s string)
    713736  (check-type suffix string)
    716739         (string-equal s suffix :start1 start))))
    718 (defun read-file-forms (file)
     741(defun* read-file-forms (file)
    719742  (with-open-file (in file)
    720743    (loop :with eof = (list nil)
    725748#-(and (or win32 windows mswindows mingw32) (not cygwin))
    727 #+clisp (defun get-uid () (posix:uid))
    728 #+sbcl (defun get-uid () (sb-unix:unix-getuid))
    729 #+cmu (defun get-uid () (unix:unix-getuid))
    730 #+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601)
    731          '(ffi:clines "#include <sys/types.h>" "#include <unistd.h>"))
    732 #+ecl (defun get-uid ()
    733         #.(cl:if (cl:< ext:+ecl-version-number+ 100601)
    734             '(ffi:c-inline () () :int "getuid()" :one-liner t)
    735             '(ext::getuid)))
    736 #+allegro (defun get-uid () (excl.osi:getuid))
    737 #-(or cmu sbcl clisp allegro ecl)
    738 (defun get-uid ()
    739   (let ((uid-string
    740          (with-output-to-string (*verbose-out*)
    741            (run-shell-command "id -ur"))))
    742     (with-input-from-string (stream uid-string)
    743       (read-line stream)
    744       (handler-case (parse-integer (read-line stream))
    745         (error () (error "Unable to find out user ID")))))))
    747 (defun pathname-root (pathname)
     750  #+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601)
     751                  '(ffi:clines "#include <sys/types.h>" "#include <unistd.h>"))
     752  (defun* get-uid ()
     753    #+allegro (excl.osi:getuid)
     754    #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid")
     755            :for f = (ignore-errors (read-from-string s))
     756                  :when f :return (funcall f))
     757    #+(or cmu scl) (unix:unix-getuid)
     758    #+ecl #.(cl:if (cl:< ext:+ecl-version-number+ 100601)
     759                   '(ffi:c-inline () () :int "getuid()" :one-liner t)
     760                   '(ext::getuid))
     761    #+sbcl (sb-unix:unix-getuid)
     762    #-(or allegro clisp cmu ecl sbcl scl)
     763    (let ((uid-string
     764           (with-output-to-string (*verbose-out*)
     765             (run-shell-command "id -ur"))))
     766      (with-input-from-string (stream uid-string)
     767        (read-line stream)
     768        (handler-case (parse-integer (read-line stream))
     769          (error () (error "Unable to find out user ID")))))))
     771(defun* pathname-root (pathname)
    748772  (make-pathname :host (pathname-host pathname)
    749773                 :device (pathname-device pathname)
    751775                 :name nil :type nil :version nil))
    753 (defun truenamize (p)
     777(defun* probe-file* (p)
     778  "when given a pathname P, probes the filesystem for a file or directory
     779with given pathname and if it exists return its truename."
     780  (etypecase p
     781   (null nil)
     782   (string (probe-file* (parse-namestring p)))
     783   (pathname (unless (wild-pathname-p p)
     784               #.(or #+(or allegro clozure cmu ecl sbcl scl) '(probe-file p)
     785               #+clisp (aif (find-symbol (string :probe-pathname) :ext) `(ignore-errors (,it p)))
     786         '(ignore-errors (truename p)))))))
     788(defun* truenamize (p)
    754789  "Resolve as much of a pathname as possible"
    755790  (block nil
    758793           (directory (pathname-directory p)))
    759794      (when (typep p 'logical-pathname) (return p))
    760       (ignore-errors (return (truename p)))
    761       #-sbcl (when (stringp directory) (return p))
     795      (let ((found (probe-file* p)))
     796        (when found (return found)))
     797      #-(or sbcl cmu) (when (stringp directory) (return p))
    762798      (when (not (eq :absolute (car directory))) (return p))
    763       (let ((sofar (ignore-errors (truename (pathname-root p)))))
     799      (let ((sofar (probe-file* (pathname-root p))))
    764800        (unless sofar (return p))
    765801        (flet ((solution (directories)
    773809          (loop :for component :in (cdr directory)
    774810            :for rest :on (cdr directory)
    775             :for more = (ignore-errors
    776                           (truename
    777                            (merge-pathnames*
    778                             (make-pathname :directory `(:relative ,component))
    779                             sofar))) :do
     811            :for more = (probe-file*
     812                         (merge-pathnames*
     813                          (make-pathname :directory `(:relative ,component))
     814                          sofar)) :do
    780815            (if more
    781816                (setf sofar more)
    784819            (return (solution nil))))))))
    786 (defun resolve-symlinks (path)
     821(defun* resolve-symlinks (path)
    787822  #-allegro (truenamize path)
    788823  #+allegro (excl:pathname-resolve-symbolic-links path))
    790 (defun default-directory ()
     825(defun* default-directory ()
    791826  (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
    793 (defun lispize-pathname (input-file)
     828(defun* lispize-pathname (input-file)
    794829  (make-pathname :type "lisp" :defaults input-file))
    798833                 :name :wild :type :wild :version :wild))
    800 (defun wilden (path)
     835(defun* wilden (path)
    801836  (merge-pathnames* *wild-path* path))
    803 (defun directorize-pathname-host-device (pathname)
     838(defun* directorize-pathname-host-device (pathname)
    804839  (let* ((root (pathname-root pathname))
    805840         (wild-root (wilden root))
    814849                         root-namestring)))
    815850    (multiple-value-bind (relative path filename)
    816         (component-name-to-pathname-components root-string t)
     851        (component-name-to-pathname-components root-string :force-directory t)
    817852      (declare (ignore relative filename))
    818853      (let ((new-base
    838873                duplicate-names-name
    839874                error-component error-operation
    840                 module-components module-components-by-name)
     875                module-components module-components-by-name
     876                circular-dependency-components)
    841877         (ftype (function (t t) t) (setf module-components-by-name)))
    858894(define-condition circular-dependency (system-definition-error)
    859   ((components :initarg :components :reader circular-dependency-components)))
     895  ((components :initarg :components :reader circular-dependency-components))
     896  (:report (lambda (c s)
     897             (format s "~@<Circular dependency: ~S~@:>" (circular-dependency-components c)))))
    861899(define-condition duplicate-names (system-definition-error)
    893931         "Component name: designator for a string composed of portable pathname characters")
    894932   (version :accessor component-version :initarg :version)
     933   ;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to?
     934   ;; POIU is a parallel (multi-process build) extension of ASDF.  See
     935   ;;
     936   (load-dependencies :accessor component-load-dependencies :initform nil)
     937   ;; In the ASDF object model, dependencies exist between *actions*
     938   ;; (an action is a pair of operation and component). They are represented
     939   ;; alists of operations to dependencies (other actions) in each component.
     940   ;; There are two kinds of dependencies, each stored in its own slot:
     941   ;; in-order-to and do-first dependencies. These two kinds are related to
     942   ;; the fact that some actions modify the filesystem,
     943   ;; whereas other actions modify the current image, and
     944   ;; this implies a difference in how to interpret timestamps.
     945   ;; in-order-to dependencies will trigger re-performing the action
     946   ;; when the timestamp of some dependency
     947   ;; makes the timestamp of current action out-of-date;
     948   ;; do-first dependencies do not trigger such re-performing.
     949   ;; Therefore, a FASL must be recompiled if it is obsoleted
     950   ;; by any of its FASL dependencies (in-order-to); but
     951   ;; it needn't be recompiled just because one of these dependencies
     952   ;; hasn't yet been loaded in the current image (do-first).
     953   ;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52!
    895954   (in-order-to :initform nil :initarg :in-order-to
    896955                :accessor component-in-order-to)
    897    ;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to?
    898    (load-dependencies :accessor component-load-dependencies :initform nil)
    899    ;; XXX crap name, but it's an official API name!
    900956   (do-first :initform nil :initarg :do-first
    901957             :accessor component-do-first)
    916972               :initform nil)))
    918 (defun component-find-path (component)
     974(defun* component-find-path (component)
    919975  (reverse
    920976   (loop :for c = component :then (component-parent c)
    932988          (call-next-method c nil) (missing-required-by c)))
    934 (defun sysdef-error (format &rest arguments)
     990(defun* sysdef-error (format &rest arguments)
    935991  (error 'formatted-system-definition-error :format-control
    936992         format :format-arguments arguments))
    940996(defmethod print-object ((c missing-component) s)
    941    (format s "~@<component ~S not found~
    942              ~@[ in ~A~]~@:>"
     997  (format s "~@<component ~S not found~@[ in ~A~]~@:>"
    943998          (missing-requires c)
    944999          (when (missing-parent c)
    9471002(defmethod print-object ((c missing-component-of-version) s)
    948   (format s "~@<component ~S does not match version ~A~
    949               ~@[ in ~A~]~@:>"
    950            (missing-requires c)
    951            (missing-version c)
    952            (when (missing-parent c)
    953              (component-name (missing-parent c)))))
     1003  (format s "~@<component ~S does not match version ~A~@[ in ~A~]~@:>"
     1004          (missing-requires c)
     1005          (missing-version c)
     1006          (when (missing-parent c)
     1007            (component-name (missing-parent c)))))
    9551009(defmethod component-system ((component component))
    9601014(defvar *default-component-class* 'cl-source-file)
    962 (defun compute-module-components-by-name (module)
     1016(defun* compute-module-components-by-name (module)
    9631017  (let ((hash (make-hash-table :test 'equal)))
    9641018    (setf (module-components-by-name module) hash)
    9901044    :accessor module-default-component-class)))
    992 (defun component-parent-pathname (component)
     1046(defun* component-parent-pathname (component)
    9931047  ;; No default anymore (in particular, no *default-pathname-defaults*).
    9941048  ;; If you force component to have a NULL pathname, you better arrange
    10071061             (pathname-directory-pathname (component-parent-pathname component)))))
    10081062        (unless (or (null pathname) (absolute-pathname-p pathname))
    1009           (error "Invalid relative pathname ~S for component ~S" pathname component))
     1063          (error "Invalid relative pathname ~S for component ~S"
     1064                 pathname (component-find-path component)))
    10101065        (setf (slot-value component 'absolute-pathname) pathname)
    10111066        pathname)))
    10311086            :accessor system-license :initarg :license)
    10321087   (source-file :reader system-source-file :initarg :source-file
    1033                 :writer %set-system-source-file)))
     1088                :writer %set-system-source-file)
     1089   (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
    10351091;;;; -------------------------------------------------------------------------
    10581114;;;; Finding systems
    1060 (defun make-defined-systems-table ()
     1116(defun* make-defined-systems-table ()
    10611117  (make-hash-table :test 'equal))
    10681124of which is a system object.")
    1070 (defun coerce-name (name)
     1126(defun* coerce-name (name)
    10711127  (typecase name
    10721128    (component (component-name name))
    10751131    (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
    1077 (defun system-registered-p (name)
     1133(defun* system-registered-p (name)
    10781134  (gethash (coerce-name name) *defined-systems*))
    1080 (defun clear-system (name)
     1136(defun* clear-system (name)
    10811137  "Clear the entry for a system in the database of systems previously loaded.
    10821138Note that this does NOT in any way cause the code of the system to be unloaded."
    10891145  (setf (gethash (coerce-name name) *defined-systems*) nil))
    1091 (defun map-systems (fn)
     1147(defun* map-systems (fn)
    10921148  "Apply FN to each defined system.
    11071163  '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf))
    1109 (defun system-definition-pathname (system)
     1165(defun* system-definition-pathname (system)
    11101166  (let ((system-name (coerce-name system)))
    11111167    (or
    1133 (defun probe-asd (name defaults)
     1189(defun* probe-asd (name defaults)
    11341190  (block nil
    11351191    (when (directory-pathname-p defaults)
    11521208              (return (pathname target)))))))))
    1154 (defun sysdef-central-registry-search (system)
     1210(defun* sysdef-central-registry-search (system)
    11551211  (let ((name (coerce-name system))
    11561212        (to-remove nil)
    11701226                                   (message
    11711227                                    (format nil
    1172                                             "~@<While searching for system ~S: ~S evaluated ~
    1173 to ~S which is not a directory.~@:>"
     1228                                            "~@<While searching for system ~S: ~S evaluated to ~S which is not a directory.~@:>"
    11741229                                            system dir defaults)))
    11751230                              (error message))
    11941249                          (subseq *central-registry* (1+ position))))))))))
    1196 (defun make-temporary-package ()
     1251(defun* make-temporary-package ()
    11971252  (flet ((try (counter)
    11981253           (ignore-errors
    12031258         (package package))))
    1205 (defun safe-file-write-date (pathname)
     1260(defun* safe-file-write-date (pathname)
    12061261  ;; If FILE-WRITE-DATE returns NIL, it's possible that
    12071262  ;; the user or some other agent has deleted an input file.
    12141269  (or (and pathname (probe-file pathname) (file-write-date pathname))
    12151270      (progn
    1216         (when pathname
     1271        (when (and pathname *asdf-verbose*)
    12171272          (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero."
    12181273                pathname))
    12191274        0)))
    1221 (defun find-system (name &optional (error-p t))
     1276(defmethod find-system (name &optional (error-p t))
     1277  (find-system (coerce-name name) error-p))
     1279(defmethod find-system ((name string) &optional (error-p t))
    12221280  (catch 'find-system
    1223     (let* ((name (coerce-name name))
    1224            (in-memory (system-registered-p name))
     1281    (let* ((in-memory (system-registered-p name))
    12251282           (on-disk (system-definition-pathname name)))
    12261283      (when (and on-disk
    12411298            (delete-package package))))
    12421299      (let ((in-memory (system-registered-p name)))
    1243         (if in-memory
    1244             (progn (when on-disk (setf (car in-memory)
    1245                                        (safe-file-write-date on-disk)))
    1246                    (cdr in-memory))
    1247             (when error-p (error 'missing-component :requires name)))))))
    1249 (defun register-system (name system)
     1300        (cond
     1301          (in-memory
     1302           (when on-disk
     1303             (setf (car in-memory) (safe-file-write-date on-disk)))
     1304           (cdr in-memory))
     1305          (error-p
     1306           (error 'missing-component :requires name)))))))
     1308(defun* register-system (name system)
    12501309  (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
    12511310  (setf (gethash (coerce-name name) *defined-systems*)
    12521311        (cons (get-universal-time) system)))
    1254 (defun sysdef-find-asdf (system)
    1255   (let ((name (coerce-name system)))
    1256     (when (equal name "asdf")
    1257       (let* ((registered (cdr (gethash name *defined-systems*)))
    1258              (asdf (or registered
    1259                        (make-instance
    1260                         'system :name "asdf"
    1261                         :source-file (or *compile-file-truename* *load-truename*)))))
    1262         (unless registered
    1263           (register-system "asdf" asdf))
    1264         (throw 'find-system asdf)))))
     1313(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
     1314  (setf fallback (coerce-name fallback)
     1315        source-file (or source-file *compile-file-truename* *load-truename*)
     1316        requested (coerce-name requested))
     1317  (when (equal requested fallback)
     1318    (let* ((registered (cdr (gethash fallback *defined-systems*)))
     1319           (system (or registered
     1320                       (apply 'make-instance 'system
     1321            :name fallback :source-file source-file keys))))
     1322      (unless registered
     1323        (register-system fallback system))
     1324      (throw 'find-system system))))
     1326(defun* sysdef-find-asdf (name)
     1327  (find-system-fallback name "asdf")) ;; :version *asdf-version* wouldn't be updated when ASDF is updated.
    13181381  (source-file-explicit-type component))
    1320 (defun merge-component-name-type (name &key type defaults)
     1383(defun* merge-component-name-type (name &key type defaults)
    13211384  ;; The defaults are required notably because they provide the default host
    13221385  ;; to the below make-pathname, which may crucially matter to people using
    13251388  ;; but that should only matter if you either (a) use absolute pathnames, or
    13261389  ;; (b) later merge relative pathnames with CL:MERGE-PATHNAMES instead of
    13281391  (etypecase name
    13291392    (pathname
    13331396    (string
    13341397     (multiple-value-bind (relative path filename)
    1335          (component-name-to-pathname-components name (eq type :directory))
     1398         (component-name-to-pathname-components name :force-directory (eq type :directory)
     1399                                                :force-relative t)
    13361400       (multiple-value-bind (name type)
    13371401           (cond
    13701434   ;; (SYSTEM1 SYSTEM2 ... SYSTEMN)
    13711435   ;;   to force systems named in a given list
    1372    ;;   (but this feature never worked before ASDF 1.700 and is cerror'ed out.)
     1436   ;; However, but this feature never worked before ASDF 1.700 and is currently cerror'ed out.
    13731437   (forced :initform nil :initarg :force :accessor operation-forced)
    13741438   (original-initargs :initform nil :initarg :original-initargs
    13901454  (values))
    1392 (defun node-for (o c)
     1456(defun* node-for (o c)
    13931457  (cons (class-name (class-of o)) c))
    1401 (defun make-sub-operation (c o dep-c dep-o)
     1465(defun* make-sub-operation (c o dep-c dep-o)
    14021466  "C is a component, O is an operation, DEP-C is another
    14031467component, and DEP-O, confusingly enough, is an operation
    15441608recursive calls to traverse.")
    1546 (defgeneric do-traverse (operation component collect))
    1548 (defun %do-one-dep (operation c collect required-op required-c required-v)
     1610(defgeneric* do-traverse (operation component collect))
     1612(defun* %do-one-dep (operation c collect required-op required-c required-v)
    15491613  ;; collects a partial plan that results from performing required-op
    15501614  ;; on required-c, possibly with a required-vERSION
    15621626    (do-traverse op dep-c collect)))
    1564 (defun do-one-dep (operation c collect required-op required-c required-v)
    1565   ;; this function is a thin, error-handling wrapper around
    1566   ;; %do-one-dep.  Returns a partial plan per that function.
     1628(defun* do-one-dep (operation c collect required-op required-c required-v)
     1629  ;; this function is a thin, error-handling wrapper around %do-one-dep.
     1630  ;; Collects a partial plan per that function.
    15671631  (loop
    15681632    (restart-case
    15721636        :report (lambda (s)
    15731637                  (format s "~@<Retry loading component ~S.~@:>"
    1574                           required-c))
     1638                          (component-find-path required-c)))
    15751639        :test
    15761640        (lambda (c)
    1577           #|
    1578           (print (list :c1 c (typep c 'missing-dependency)))
    1579           (when (typep c 'missing-dependency)
    1580           (print (list :c2 (missing-requires c) required-c
    1581           (equalp (missing-requires c)
    1582           required-c))))
    1583           |#
    15841641          (or (null c)
    15851642              (and (typep c 'missing-dependency)
    15871644                           required-c))))))))
    1589 (defun do-dep (operation c collect op dep)
     1646(defun* do-dep (operation c collect op dep)
    15901647  ;; type of arguments uncertain:
    15911648  ;; op seems to at least potentially be a symbol, rather than an operation
    16261683           flag))))
    1628 (defun do-collect (collect x)
     1685(defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes
     1687(defun* do-collect (collect x)
    16291688  (funcall collect x))
    17111770                 (do-collect collect (cons operation c)))))
    17121771             (setf (visiting-component operation c) nil)))
    1713       (visit-component operation c flag)
     1772      (visit-component operation c (when flag (incf *visit-count*)))
    17141773      flag))
    1716 (defun flatten-tree (l)
     1775(defun* flatten-tree (l)
    17171776  ;; You collected things into a list.
    17181777  ;; Most elements are just things to collect again.
    17411800  (flatten-tree
    17421801   (while-collecting (collect)
    1743      (do-traverse operation c #'collect))))
     1802     (let ((*visit-count* 0))
     1803       (do-traverse operation c #'collect)))))
    17451805(defmethod perform ((operation operation) (c source-file))
    17461806  (sysdef-error
    1747    "~@<required method PERFORM not implemented ~
    1748     for operation ~A, component ~A~@:>"
     1807   "~@<required method PERFORM not implemented for operation ~A, component ~A~@:>"
    17491808   (class-of operation) (class-of c)))
    17551814(defmethod explain ((operation operation) (component component))
    1756   (asdf-message "~&;;; ~A on ~A~%" operation component))
     1815  (asdf-message "~&;;; ~A~%" (operation-description operation component)))
     1817(defmethod operation-description (operation component)
     1818  (format nil "~A on component ~S" (class-of operation) (component-find-path component)))
    17581820;;;; -------------------------------------------------------------------------
    17681830          :initform #-ecl nil #+ecl '(:system-p t))))
     1832(defun output-file (operation component)
     1833  "The unique output file of performing OPERATION on COMPONENT"
     1834  (let ((files (output-files operation component)))
     1835    (assert (length=n-p files 1))
     1836    (first files)))
    17701838(defmethod perform :before ((operation compile-op) (c source-file))
    17711839  (map nil #'ensure-directories-exist (output-files operation c)))
    17841852        (get-universal-time)))
    1786 (declaim (ftype (function ((or pathname string) &rest t &key &allow-other-keys)
     1854(declaim (ftype (function ((or pathname string)
     1855                           &rest t &key (:output-file t) &allow-other-keys)
    17871856                          (values t t t))
    17881857                compile-file*))
    17931862  #-:broken-fasl-loader
    17941863  (let ((source-file (component-pathname c))
    1795         (output-file (car (output-files operation c)))
     1864        ;; on some implementations, there are more than one output-file,
     1865        ;; but the first one should always be the primary fasl that gets loaded.
     1866        (output-file (first (output-files operation c)))
    17961867        (*compile-file-warnings-behaviour* (operation-on-warnings operation))
    17971868        (*compile-file-failure-behaviour* (operation-on-failure operation)))
    18361907  nil)
     1909(defmethod operation-description ((operation compile-op) component)
     1910  (declare (ignorable operation))
     1911  (format nil "compiling component ~S" (component-find-path component)))
    18391913;;;; -------------------------------------------------------------------------
    18461920(defmethod perform ((o load-op) (c cl-source-file))
    1847   #-ecl (mapcar #'load (input-files o c))
    1848   #+ecl (loop :for i :in (input-files o c)
    1849           :unless (string= (pathname-type i) "fas")
    1850           :collect (let ((output (compile-file-pathname (lispize-pathname i))))
    1851                      (load output))))
     1921  (map () #'load
     1922       #-ecl (input-files o c)
     1923       #+ecl (loop :for i :in (input-files o c)
     1924               :unless (string= (pathname-type i) "fas")
     1925               :collect (compile-file-pathname (lispize-pathname i)))))
    18531927(defmethod perform-with-restarts (operation component)
    19121986        (call-next-method)))
     1988(defmethod operation-description ((operation load-op) component)
     1989  (declare (ignorable operation))
     1990  (format nil "loading component ~S" (component-find-path component)))
    19141993;;;; -------------------------------------------------------------------------
    19151994;;;; load-source-op
    19492028             (component-property c 'last-loaded-as-source)))
    19502029      nil t))
     2031(defmethod operation-description ((operation load-source-op) component)
     2032  (declare (ignorable operation))
     2033  (format nil "loading component ~S" (component-find-path component)))
    19992082                :report
    20002083                (lambda (s)
    2001                   (format s "~@<Retry performing ~S on ~S.~@:>"
    2002                           op component)))
     2084                  (format s "~@<Retry ~A.~@:>" (operation-description op component))))
    20032085              (accept ()
    20042086                :report
    20052087                (lambda (s)
    2006                   (format s "~@<Continue, treating ~S on ~S as ~
    2007                                    having been successful.~@:>"
    2008                           op component))
     2088                  (format s "~@<Continue, treating ~A as having been successful.~@:>"
     2089                          (operation-description op component)))
    20092090                (setf (gethash (type-of op)
    20102091                               (component-operation-times component))
    20112092                      (get-universal-time))
    2012                 (return)))))))
    2013     op))
    2015 (defun oos (operation-class system &rest args &key force verbose version
     2093                (return))))))
     2094      (values op steps))))
     2096(defun* oos (operation-class system &rest args &key force verbose version
    20162097            &allow-other-keys)
    20172098  (declare (ignore force verbose version))
    20432124        operate-docstring))
    2045 (defun load-system (system &rest args &key force verbose version
     2126(defun* load-system (system &rest args &key force verbose version
    20462127                    &allow-other-keys)
    20472128  "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for
    20492130  (declare (ignore force verbose version))
    2050   (apply #'operate 'load-op system args))
    2052 (defun compile-system (system &rest args &key force verbose version
     2131  (apply #'operate 'load-op system args)
     2132  t)
     2134(defun* compile-system (system &rest args &key force verbose version
    20532135                       &allow-other-keys)
    20542136  "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE
    20552137for details."
    20562138  (declare (ignore force verbose version))
    2057   (apply #'operate 'compile-op system args))
    2059 (defun test-system (system &rest args &key force verbose version
     2139  (apply #'operate 'compile-op system args)
     2140  t)
     2142(defun* test-system (system &rest args &key force verbose version
    20602143                    &allow-other-keys)
    20612144  "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for
    20632146  (declare (ignore force verbose version))
    2064   (apply #'operate 'test-op system args))
     2147  (apply #'operate 'test-op system args)
     2148  t)
    20662150;;;; -------------------------------------------------------------------------
    20672151;;;; Defsystem
    2069 (defun load-pathname ()
     2153(defun* load-pathname ()
    20702154  (let ((pn (or *load-pathname* *compile-file-pathname*)))
    20712155    (if *resolve-symlinks*
    20732157        pn)))
    2075 (defun determine-system-pathname (pathname pathname-supplied-p)
     2159(defun* determine-system-pathname (pathname pathname-supplied-p)
    20762160  ;; The defsystem macro calls us to determine
    20772161  ;; the pathname of a system as follows:
    20822166         (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
    20832167    (or (and pathname-supplied-p (merge-pathnames* pathname directory-pathname))
    2084         file-pathname
     2168        directory-pathname
    20852169        (default-directory))))
    20892173                            defsystem-depends-on &allow-other-keys)
    20902174      options
    2091     (let ((component-options (remove-keys '(:defsystem-depends-on :class) options)))
     2175    (let ((component-options (remove-keys '(:class) options)))
    20922176      `(progn
    20932177         ;; system must be registered before we parse the body, otherwise
    21132197               ',component-options))))))
    2115 (defun class-for-type (parent type)
     2199(defun* class-for-type (parent type)
    21162200  (or (loop :for symbol :in (list
    21172201                             (unless (keywordp type) type)
    21262210      (sysdef-error "~@<don't recognize component type ~A~@:>" type)))
    2128 (defun maybe-add-tree (tree op1 op2 c)
     2212(defun* maybe-add-tree (tree op1 op2 c)
    21292213  "Add the node C at /OP1/OP2 in TREE, unless it's there already.
    21302214Returns the new tree (which probably shares structure with the old one)"
    21412225        (acons op1 (list (list op2 c)) tree))))
    2143 (defun union-of-dependencies (&rest deps)
     2227(defun* union-of-dependencies (&rest deps)
    21442228  (let ((new-tree nil))
    21452229    (dolist (dep deps)
    21542238(defvar *serial-depends-on* nil)
    2156 (defun sysdef-error-component (msg type name value)
     2240(defun* sysdef-error-component (msg type name value)
    21572241  (sysdef-error (concatenate 'string msg
    21582242                             "~&The value specified for ~(~A~) ~A is ~S")
    21592243                type name value))
    2161 (defun check-component-input (type name weakly-depends-on
     2245(defun* check-component-input (type name weakly-depends-on
    21622246                              depends-on components in-order-to)
    21632247  "A partial test of the values of a component."
    21752259                            type name in-order-to)))
    2177 (defun %remove-component-inline-methods (component)
     2261(defun* %remove-component-inline-methods (component)
    21782262  (dolist (name +asdf-methods+)
    21792263    (map ()
    21872271  (setf (component-inline-methods component) nil))
    2189 (defun %define-component-inline-methods (ret rest)
     2273(defun* %define-component-inline-methods (ret rest)
    21902274  (dolist (name +asdf-methods+)
    21912275    (let ((keyword (intern (symbol-name name) :keyword)))
    22012285           (component-inline-methods ret)))))))
    2203 (defun %refresh-component-inline-methods (component rest)
     2287(defun* %refresh-component-inline-methods (component rest)
    22042288  (%remove-component-inline-methods component)
    22052289  (%define-component-inline-methods component rest))
    2207 (defun parse-component-form (parent options)
     2291(defun* parse-component-form (parent options)
    22082292  (destructuring-bind
    22092293        (type name &rest rest &key
    22862370;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01
    2288 (defun run-shell-command (control-string &rest args)
     2372(defun* run-shell-command (control-string &rest args)
    22892373  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
    22902374synchronously execute the result using a Bourne-compatible shell, with
    23582442  (system-source-file (find-system system-name)))
    2360 (defun system-source-directory (system-designator)
     2444(defun* system-source-directory (system-designator)
    23612445  "Return a pathname object corresponding to the
    23622446directory in which the system specification (.asd file) is
    23662450                 :defaults (system-source-file system-designator)))
    2368 (defun relativize-directory (directory)
     2452(defun* relativize-directory (directory)
    23692453  (cond
    23702454    ((stringp directory)
    23752459     directory)))
    2377 (defun relativize-pathname-directory (pathspec)
     2461(defun* relativize-pathname-directory (pathspec)
    23782462  (let ((p (pathname pathspec)))
    23792463    (make-pathname
    23812465     :defaults p)))
    2383 (defun system-relative-pathname (system name &key type)
     2467(defun* system-relative-pathname (system name &key type)
    23842468  (merge-pathnames*
    23852469   (merge-component-name-type name :type type)
    23952479(defparameter *implementation-features*
    2396   '(:allegro :lispworks :sbcl :clozure :digitool :cmu :clisp
    2397     :corman :cormanlisp :armedbear :gcl :ecl :scl))
     2480  '((:acl :allegro)
     2481    (:lw :lispworks)
     2482    (:digitool) ; before clozure, so it won't get preempted by ccl
     2483    (:ccl :clozure)
     2484    (:corman :cormanlisp)
     2485    (:abcl :armedbear)
     2486    :sbcl :cmu :clisp :gcl :ecl :scl))
    23992488(defparameter *os-features*
    2400   '((:windows :mswindows :win32 :mingw32)
     2489  '((:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows
    24012490    (:solaris :sunos)
    2402     :linux ;; for GCL at least, must appear before :bsd.
    2403     :macosx :darwin :apple
     2491    (:linux :linux-target) ;; for GCL at least, must appear before :bsd.
     2492    (:macosx :darwin :darwin-target :apple)
    24042493    :freebsd :netbsd :openbsd :bsd
    24052494    :unix))
    24072496(defparameter *architecture-features*
    2408   '((:x86-64 :amd64 :x86_64 :x8664-target)
    2409     (:x86 :i686 :i586 :pentium3 :i486 :i386 :pc386 :iapx386 :x8632-target :pentium4)
    2410     :hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc
    2411     :java-1.4 :java-1.5 :java-1.6 :java-1.7))
    2414 (defun lisp-version-string ()
     2497  '((:amd64 :x86-64 :x86_64 :x8664-target)
     2498    (:x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
     2499    :hppa64
     2500    :hppa
     2501    (:ppc64 :ppc64-target)
     2502    (:ppc32 :ppc32-target :ppc :powerpc)
     2503    :sparc64
     2504    (:sparc32 :sparc)
     2505    (:arm :arm-target)
     2506    (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))
     2508(defun* lisp-version-string ()
    24152509  (let ((s (lisp-implementation-version)))
    24162510    (declare (ignorable s))
    24292523    #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
    24302524    #+clisp (subseq s 0 (position #\space s))
    2431     #+clozure (format nil "~d.~d-fasl~d"
     2525    #+clozure (format nil "~d.~d-f~d" ; shorten for windows
    24322526                      ccl::*openmcl-major-version*
    24332527                      ccl::*openmcl-minor-version*
    24472541          ecl gcl lispworks mcl sbcl scl) s))
    2449 (defun first-feature (features)
     2543(defun* first-feature (features)
    24502544  (labels
    24512545      ((fp (thing)
    24632557      :when (fp f) :return :it)))
    2465 (defun implementation-type ()
     2559(defun* implementation-type ()
    24662560  (first-feature *implementation-features*))
    2468 (defun implementation-identifier ()
     2562(defun* implementation-identifier ()
    24692563  (labels
    24702564      ((maybe-warn (value fstring &rest args)
    24812575                            *architecture-features*))
    24822576          (version (maybe-warn (lisp-version-string)
    2483                                "Don't know how to get Lisp ~
    2484                                           implementation version.")))
     2577                               "Don't know how to get Lisp implementation version.")))
    24852578      (substitute-if
    24862579       #\_ (lambda (x) (find x " /:\\(){}[]$#`'\""))
    24962589  #-(or unix cygwin) #\;)
    2498 (defun user-homedir ()
     2591(defun* user-homedir ()
    24992592  (truename (user-homedir-pathname)))
    2501 (defun try-directory-subpath (x sub &key type)
     2594(defun* try-directory-subpath (x sub &key type)
    25022595  (let* ((p (and x (ensure-directory-pathname x)))
    2503          (tp (and p (ignore-errors (truename p))))
     2596         (tp (and p (probe-file* p)))
    25042597         (sp (and tp (merge-pathnames* (merge-component-name-type sub :type type) p)))
    2505          (ts (and sp (ignore-errors (truename sp)))))
     2598         (ts (and sp (probe-file* sp))))
    25062599    (and ts (values sp ts))))
    2507 (defun user-configuration-directories ()
     2600(defun* user-configuration-directories ()
    25082601  (remove-if
    25092602   #'null
    25182611           ,(try (getenv "APPDATA") "common-lisp/config/"))
    25192612       ,(try (user-homedir) ".config/common-lisp/")))))
    2520 (defun system-configuration-directories ()
     2613(defun* system-configuration-directories ()
    25212614  (remove-if
    25222615   #'null
    25282621        ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
    25292622    (list #p"/etc/common-lisp/"))))
    2530 (defun in-first-directory (dirs x)
     2623(defun* in-first-directory (dirs x)
    25312624  (loop :for dir :in dirs
    2532     :thereis (and dir (ignore-errors
    2533                         (truename (merge-pathnames* x (ensure-directory-pathname dir)))))))
    2534 (defun in-user-configuration-directory (x)
     2625    :thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir))))))
     2626(defun* in-user-configuration-directory (x)
    25352627  (in-first-directory (user-configuration-directories) x))
    2536 (defun in-system-configuration-directory (x)
     2628(defun* in-system-configuration-directory (x)
    25372629  (in-first-directory (system-configuration-directories) x))
    2539 (defun configuration-inheritance-directive-p (x)
     2631(defun* configuration-inheritance-directive-p (x)
    25402632  (let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
    25412633    (or (member x kw)
    25422634        (and (length=n-p x 1) (member (car x) kw)))))
    2544 (defun validate-configuration-form (form tag directive-validator
     2636(defun* validate-configuration-form (form tag directive-validator
    25452637                                    &optional (description tag))
    25462638  (unless (and (consp form) (eq (car form) tag))
    25572649  form)
    2559 (defun validate-configuration-file (file validator description)
     2651(defun* validate-configuration-file (file validator description)
    25602652  (let ((forms (read-file-forms file)))
    25612653    (unless (length=n-p forms 1)
    25632655    (funcall validator (car forms))))
    2565 (defun hidden-file-p (pathname)
     2657(defun* hidden-file-p (pathname)
    25662658  (equal (first-char (pathname-name pathname)) #\.))
    2568 (defun validate-configuration-directory (directory tag validator)
     2660(defun* validate-configuration-directory (directory tag validator)
    25692661  (let ((files (sort (ignore-errors
    25702662                       (remove-if
    26042696  *user-cache*)
    2606 (defun output-translations ()
     2698(defun* output-translations ()
    26072699  (car *output-translations*))
    2609 (defun (setf output-translations) (new-value)
     2701(defun* (setf output-translations) (new-value)
    26102702  (setf *output-translations*
    26112703        (list
    26182710  new-value)
    2620 (defun output-translations-initialized-p ()
     2712(defun* output-translations-initialized-p ()
    26212713  (and *output-translations* t))
    2623 (defun clear-output-translations ()
     2715(defun* clear-output-translations ()
    26242716  "Undoes any initialization of the output translations.
    26252717You might want to call that before you dump an image that would be resumed
    26282720  (values))
    2630 (defparameter *wild-asd*
    2631   (make-pathname :directory '(:relative :wild-inferiors)
    2632                  :name :wild :type "asd" :version :newest))
    2635 (declaim (ftype (function (t &optional boolean) (or null pathname))
     2722(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean))
     2723                          (values (or null pathname) &optional))
    26362724                resolve-location))
    2638 (defun resolve-relative-location-component (super x &optional wildenp)
     2726(defun* resolve-relative-location-component (super x &key directory wilden)
    26392727  (let* ((r (etypecase x
    26402728              (pathname x)
    26412729              (string x)
    26422730              (cons
    2643                (let ((car (resolve-relative-location-component super (car x) nil)))
     2731               (return-from resolve-relative-location-component
    26442732                 (if (null (cdr x))
    2645                      car
    2646                      (let ((cdr (resolve-relative-location-component
    2647                                  (merge-pathnames* car super) (cdr x) wildenp)))
     2733                     (resolve-relative-location-component
     2734                      super (car x) :directory directory :wilden wilden)
     2735                     (let* ((car (resolve-relative-location-component
     2736                                  super (car x) :directory t :wilden nil))
     2737                            (cdr (resolve-relative-location-component
     2738                                  (merge-pathnames* car super) (cdr x)
     2739                                  :directory directory :wilden wilden)))
    26482740                       (merge-pathnames* cdr car)))))
    26492741              ((eql :default-directory)
    26532745              #-(and (or win32 windows mswindows mingw32) (not cygwin))
    26542746              ((eql :uid) (princ-to-string (get-uid)))))
    2655          (d (if (pathnamep x) r (ensure-directory-pathname r)))
    2656          (s (if (and wildenp (not (pathnamep x)))
    2657                 (wilden d)
    2658                 d)))
     2747         (d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r)))
     2748         (s (if (or (pathnamep x) (not wilden)) d (wilden d))))
    26592749    (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
    26602750      (error "pathname ~S is not relative to ~S" s super))
    26612751    (merge-pathnames* s super)))
    2663 (defun resolve-absolute-location-component (x wildenp)
     2753(defun* resolve-absolute-location-component (x &key directory wilden)
    26642754  (let* ((r
    26652755          (etypecase x
    26662756            (pathname x)
    2667             (string (ensure-directory-pathname x))
     2757            (string (if directory (ensure-directory-pathname x) (parse-namestring x)))
    26682758            (cons
    2669              (let ((car (resolve-absolute-location-component (car x) nil)))
     2759             (return-from resolve-absolute-location-component
    26702760               (if (null (cdr x))
    2671                    car
    2672                    (let ((cdr (resolve-relative-location-component
    2673                                car (cdr x) wildenp)))
    2674                      (merge-pathnames* cdr car)))))
     2761                   (resolve-absolute-location-component
     2762                    (car x) :directory directory :wilden wilden)
     2763                   (let* ((car (resolve-absolute-location-component
     2764                                (car x) :directory t :wilden nil))
     2765                          (cdr (resolve-relative-location-component
     2766                                car (cdr x) :directory directory :wilden wilden)))
     2767                     (merge-pathnames* cdr car))))) ; XXX why is this not just "cdr" ?
    26752768            ((eql :root)
    26762769             ;; special magic! we encode such paths as relative pathnames,
    26772770             ;; but it means "relative to the root of the source pathname's host and device".
    26782771             (return-from resolve-absolute-location-component
    2679                (make-pathname :directory '(:relative))))
     2772               (let ((p (make-pathname :directory '(:relative))))
     2773                 (if wilden (wilden p) p))))
    26802774            ((eql :home) (user-homedir))
    2681             ((eql :user-cache) (resolve-location *user-cache* nil))
    2682             ((eql :system-cache) (resolve-location *system-cache* nil))
     2775            ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
     2776            ((eql :system-cache) (resolve-location *system-cache* :directory t :wilden nil))
    26832777            ((eql :default-directory) (default-directory))))
    2684          (s (if (and wildenp (not (pathnamep x)))
     2778         (s (if (and wilden (not (pathnamep x)))
    26852779                (wilden r)
    26862780                r)))
    26892783    s))
    2691 (defun resolve-location (x &optional wildenp)
     2785(defun* resolve-location (x &key directory wilden)
    26922786  (if (atom x)
    2693       (resolve-absolute-location-component x wildenp)
    2694       (loop :with path = (resolve-absolute-location-component (car x) nil)
     2787      (resolve-absolute-location-component x :directory directory :wilden wilden)
     2788      (loop :with path = (resolve-absolute-location-component
     2789                          (car x) :directory (and (or directory (cdr x)) t)
     2790                          :wilden (and wilden (null (cdr x))))
    26952791        :for (component . morep) :on (cdr x)
     2792        :for dir = (and (or morep directory) t)
     2793        :for wild = (and wilden (not morep))
    26962794        :do (setf path (resolve-relative-location-component
    2697                         path component (and wildenp (not morep))))
     2795                        path component :directory dir :wilden wild))
    26982796        :finally (return path))))
    2700 (defun location-designator-p (x)
     2798(defun* location-designator-p (x)
    27012799  (flet ((componentp (c) (typep c '(or string pathname keyword))))
    27022800    (or (typep x 'boolean) (componentp x) (and (consp x) (every #'componentp x)))))
    2704 (defun location-function-p (x)
     2802(defun* location-function-p (x)
    27052803  (and
    27062804   (consp x)
    27122810            (length=n-p (second x) 2)))))
    2714 (defun validate-output-translations-directive (directive)
     2812(defun* validate-output-translations-directive (directive)
    27152813  (unless
    27162814      (or (member directive '(:inherit-configuration
    27172815                              :ignore-inherited-configuration
    2718                               :enable-user-cache :disable-cache))
     2816                              :enable-user-cache :disable-cache nil))
    27192817          (and (consp directive)
    27202818               (or (and (length=n-p directive 2)
    27292827  directive)
    2731 (defun validate-output-translations-form (form)
     2829(defun* validate-output-translations-form (form)
    27322830  (validate-configuration-form
    27332831   form
    27362834   "output translations"))
    2738 (defun validate-output-translations-file (file)
     2836(defun* validate-output-translations-file (file)
    27392837  (validate-configuration-file
    27402838   file 'validate-output-translations-form "output translations"))
    2742 (defun validate-output-translations-directory (directory)
     2840(defun* validate-output-translations-directory (directory)
    27432841  (validate-configuration-directory
    27442842   directory :output-translations 'validate-output-translations-directive))
    2746 (defun parse-output-translations-string (string)
     2844(defun* parse-output-translations-string (string)
    27472845  (cond
    27482846    ((or (null string) (equal string ""))
    27892887    system-output-translations-directory-pathname))
    2791 (defun wrapping-output-translations ()
     2889(defun* wrapping-output-translations ()
    27922890  `(:output-translations
    27932891    ;; Some implementations have precompiled ASDF systems,
    27942892    ;; so we must disable translations for implementation paths.
    2795     #+sbcl (,(getenv "SBCL_HOME") ())
     2893    #+sbcl ,(let ((h (getenv "SBCL_HOME"))) (when (plusp (length h)) `(,h ())))
    27962894    #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system
    2797     #+clozure (,(wilden (truename #p"ccl:")) ()) ; not needed: no precompiled ASDF system
     2895    #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ; not needed: no precompiled ASDF system
    27982896    ;; All-import, here is where we want user stuff to be:
    27992897    :inherit-configuration
    28012899    #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
    28022900    #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
    2803     ;; If we want to enable the user cache by default, here would be the place:
     2901    ;; We enable the user cache by default, and here is the place we do:
    28042902    :enable-user-cache))
    28072905(defparameter *output-translations-directory* #p"asdf-output-translations.conf.d/")
    2809 (defun user-output-translations-pathname ()
     2907(defun* user-output-translations-pathname ()
    28102908  (in-user-configuration-directory *output-translations-file* ))
    2811 (defun system-output-translations-pathname ()
     2909(defun* system-output-translations-pathname ()
    28122910  (in-system-configuration-directory *output-translations-file*))
    2813 (defun user-output-translations-directory-pathname ()
     2911(defun* user-output-translations-directory-pathname ()
    28142912  (in-user-configuration-directory *output-translations-directory*))
    2815 (defun system-output-translations-directory-pathname ()
     2913(defun* system-output-translations-directory-pathname ()
    28162914  (in-system-configuration-directory *output-translations-directory*))
    2817 (defun environment-output-translations ()
     2915(defun* environment-output-translations ()
    28182916  (getenv "ASDF_OUTPUT_TRANSLATIONS"))
    2820 (defgeneric process-output-translations (spec &key inherit collect))
     2918(defgeneric* process-output-translations (spec &key inherit collect))
    28212919(declaim (ftype (function (t &key (:collect (or symbol function))) t)
    28222920                inherit-output-translations))
    28482946    (process-output-translations-directive directive :inherit inherit :collect collect)))
    2850 (defun inherit-output-translations (inherit &key collect)
     2948(defun* inherit-output-translations (inherit &key collect)
    28512949  (when inherit
    28522950    (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
    2854 (defun process-output-translations-directive (directive &key inherit collect)
     2952(defun* process-output-translations-directive (directive &key inherit collect)
    28552953  (if (atom directive)
    28562954      (ecase directive
    28612959        ((:inherit-configuration)
    28622960         (inherit-output-translations inherit :collect collect))
    2863         ((:ignore-inherited-configuration)
     2961        ((:ignore-inherited-configuration nil)
    28642962         nil))
    28652963      (let ((src (first directive))
    28702968            (when src
    28712969              (let ((trusrc (or (eql src t)
    2872                                 (let ((loc (resolve-location src t)))
     2970                                (let ((loc (resolve-location src :directory t :wilden t)))
    28732971                                  (if (absolute-pathname-p loc) (truenamize loc) loc)))))
    28742972                (cond
    28832981                  (t
    28842982                   (let* ((trudst (make-pathname
    2885                                    :defaults (if dst (resolve-location dst t) trusrc)))
     2983                                   :defaults (if dst (resolve-location dst :directory t :wilden t) trusrc)))
    28862984                          (wilddst (make-pathname
    28872985                                    :name :wild :type :wild :version :wild
    28902988                     (funcall collect (list trusrc trudst)))))))))))
    2892 (defun compute-output-translations (&optional parameter)
     2990(defun* compute-output-translations (&optional parameter)
    28932991  "read the configuration, return it"
    28942992  (remove-duplicates
    28982996   :test 'equal :from-end t))
    2900 (defun initialize-output-translations (&optional parameter)
     2998(defun* initialize-output-translations (&optional parameter)
    29012999  "read the configuration, initialize the internal configuration variable,
    29023000return the configuration"
    29033001  (setf (output-translations) (compute-output-translations parameter)))
    2905 (defun disable-output-translations ()
     3003(defun* disable-output-translations ()
    29063004  "Initialize output translations in a way that maps every file to itself,
    29073005effectively disabling the output translation facility."
    29133011;; the latter, initialize.  ASDF will call this function at the start
    29143012;; of (asdf:find-system).
    2915 (defun ensure-output-translations ()
     3013(defun* ensure-output-translations ()
    29163014  (if (output-translations-initialized-p)
    29173015      (output-translations)
    29183016      (initialize-output-translations)))
    2920 (defun apply-output-translations (path)
     3018(defun* translate-pathname* (path absolute-source destination &optional root source)
     3019  (declare (ignore source))
     3020  (cond
     3021    ((functionp destination)
     3022     (funcall destination path absolute-source))
     3023    ((eq destination t)
     3024     path)
     3025    ((not (pathnamep destination))
     3026     (error "invalid destination"))
     3027    ((not (absolute-pathname-p destination))
     3028     (translate-pathname path absolute-source (merge-pathnames* destination root)))
     3029    (root
     3030     (translate-pathname (directorize-pathname-host-device path) absolute-source destination))
     3031    (t
     3032     (translate-pathname path absolute-source destination))))
     3034(defun* apply-output-translations (path)
    29213035  (etypecase path
    29223036    (logical-pathname
    29353049                                (t source))
    29363050       :when (or (eq source t) (pathname-match-p p absolute-source))
    2937        :return
    2938        (cond
    2939          ((functionp destination)
    2940           (funcall destination p absolute-source))
    2941          ((eq destination t)
    2942           p)
    2943          ((not (pathnamep destination))
    2944           (error "invalid destination"))
    2945          ((not (absolute-pathname-p destination))
    2946           (translate-pathname p absolute-source (merge-pathnames* destination root)))
    2947          (root
    2948           (translate-pathname (directorize-pathname-host-device p) absolute-source destination))
    2949          (t
    2950           (translate-pathname p absolute-source destination)))
     3051       :return (translate-pathname* p absolute-source destination root source)
    29513052       :finally (return p)))))
    29613062   t))
    2963 (defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
     3064(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
    29643065  (or output-file
    29653066      (apply-output-translations
    29683069              keys))))
    2970 (defun tmpize-pathname (x)
     3071(defun* tmpize-pathname (x)
    29713072  (make-pathname
    29723073   :name (format nil "ASDF-TMP-~A" (pathname-name x))
    29733074   :defaults x))
    2975 (defun delete-file-if-exists (x)
     3076(defun* delete-file-if-exists (x)
    29763077  (when (and x (probe-file x))
    29773078    (delete-file x)))
    2979 (defun compile-file* (input-file &rest keys &key &allow-other-keys)
    2980   (let* ((output-file (apply 'compile-file-pathname* input-file keys))
     3080(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys)
     3081  (let* ((output-file (or output-file (apply 'compile-file-pathname* input-file keys)))
    29813082         (tmp-file (tmpize-pathname output-file))
    29823083         (status :error))
    3004 (defun translate-jar-pathname (source wildcard)
     3105(defun* translate-jar-pathname (source wildcard)
    30053106  (declare (ignore wildcard))
    30063107  (let* ((p (pathname (first (pathname-device source))))
    30183119;;;; Compatibility mode for ASDF-Binary-Locations
    3020 (defun enable-asdf-binary-locations-compatibility
     3121(defun* enable-asdf-binary-locations-compatibility
    30213122    (&key
    30223123     (centralize-lisp-binaries nil)
    30263127                           (user-homedir)))
    30273128     (include-per-user-information nil)
    3028      (map-all-source-files nil)
     3129     (map-all-source-files (or #+(or ecl clisp) t nil))
    30293130     (source-to-target-mappings nil))
     3131  #+(or ecl clisp)
     3132  (when (null map-all-source-files)
     3133    (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP"))
    30303134  (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
    30313135         (wild-inferiors (make-pathname :directory '(:relative :wild-inferiors)))
     3160#+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
    30563162(defparameter *link-initial-dword* 76)
    30573163(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
    3059 (defun read-null-terminated-string (s)
     3165(defun* read-null-terminated-string (s)
    30603166  (with-output-to-string (out)
    30613167    (loop :for code = (read-byte s)
    30633169      :do (write-char (code-char code) out))))
    3065 (defun read-little-endian (s &optional (bytes 4))
     3171(defun* read-little-endian (s &optional (bytes 4))
    30663172  (loop
    30673173    :for i :from 0 :below bytes
    30683174    :sum (ash (read-byte s) (* 8 i))))
    3070 (defun parse-file-location-info (s)
     3176(defun* parse-file-location-info (s)
    30713177  (let ((start (file-position s))
    30723178        (total-length (read-little-endian s))
    30923198          (read-null-terminated-string s))))))
    3094 (defun parse-windows-shortcut (pathname)
     3200(defun* parse-windows-shortcut (pathname)
    30953201  (with-open-file (s pathname :element-type '(unsigned-byte 8))
    30963202    (handler-case
    31203226                    (map 'string #'code-char buffer)))))))
    31213227      (end-of-file ()
    3122         nil))))
     3228        nil)))))
    31243230;;;; -----------------------------------------------------------------
    31283234;; Using ack 1.2 exclusions
    31293235(defvar *default-source-registry-exclusions*
    3130   '(".bzr" ".cdv" "~.dep" "" "~.nib" "~.plst"
     3236  '(".bzr" ".cdv"
     3237    ;; "~.dep" "" "~.nib" "~.plst" ; we don't support ack wildcards
    31313238    ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
    3132     "_sgbak" "autom4te.cache" "cover_db" "_build"))
     3239    "_sgbak" "autom4te.cache" "cover_db" "_build"
     3240    "debian")) ;; debian often build stuff under the debian directory... BAD.
    31343242(defvar *source-registry-exclusions* *default-source-registry-exclusions*)
    31383246said element itself being a list of directory pathnames where to look for .asd files")
    3140 (defun source-registry ()
     3248(defun* source-registry ()
    31413249  (car *source-registry*))
    3143 (defun (setf source-registry) (new-value)
     3251(defun* (setf source-registry) (new-value)
    31443252  (setf *source-registry* (list new-value))
    31453253  new-value)
    3147 (defun source-registry-initialized-p ()
     3255(defun* source-registry-initialized-p ()
    31483256  (and *source-registry* t))
    3150 (defun clear-source-registry ()
     3258(defun* clear-source-registry ()
    31513259  "Undoes any initialization of the source registry.
    31523260You might want to call that before you dump an image that would be resumed
    31553263  (values))
    3157 (defun validate-source-registry-directive (directive)
     3265(defparameter *wild-asd*
     3266  (make-pathname :directory nil :name :wild :type "asd" :version :newest))
     3268(defun directory-has-asd-files-p (directory)
     3269  (and (ignore-errors
     3270         (directory (merge-pathnames* *wild-asd* directory)
     3271                    #+sbcl #+sbcl :resolve-symlinks nil
     3272                    #+ccl #+ccl :follow-links nil
     3273                    #+clisp #+clisp :circle t))
     3274       t))
     3276(defun subdirectories (directory)
     3277  (let* ((directory (ensure-directory-pathname directory))
     3278         #-cormanlisp
     3279         (wild (merge-pathnames*
     3280                #-(or abcl allegro lispworks scl)
     3281                (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil)
     3282                #+(or abcl allegro lispworks scl) "*.*"
     3283                directory))
     3284         (dirs
     3285          #-cormanlisp
     3286          (ignore-errors
     3287            (directory wild .
     3288              #.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
     3289                    #+ccl '(:follow-links nil :directories t :files nil)
     3290                    #+clisp '(:circle t :if-does-not-exist :ignore)
     3291                    #+(or cmu scl) '(:follow-links nil :truenamep nil)
     3292                    #+digitool '(:directories t)
     3293                    #+sbcl '(:resolve-symlinks nil))))
     3294          #+cormanlisp (cl::directory-subdirs directory))
     3295         #+(or abcl allegro lispworks scl)
     3296         (dirs (remove-if-not #+abcl #'extensions:probe-directory
     3297                              #+allegro #'excl:probe-directory
     3298                              #+lispworks #'lw:file-directory-p
     3299                              #-(or abcl allegro lispworks) #'directory-pathname-p
     3300                              dirs)))
     3301    dirs))
     3303(defun collect-sub*directories (directory collectp recursep collector)
     3304  (when (funcall collectp directory)
     3305    (funcall collector directory))
     3306  (dolist (subdir (subdirectories directory))
     3307    (when (funcall recursep subdir)
     3308      (collect-sub*directories subdir collectp recursep collector))))
     3310(defun collect-sub*directories-with-asd
     3311    (directory &key
     3312     (exclude *default-source-registry-exclusions*)
     3313     collect)
     3314  (collect-sub*directories
     3315   directory
     3316   #'directory-has-asd-files-p
     3317   #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal)))
     3318   collect))
     3320(defun* validate-source-registry-directive (directive)
    31583321  (unless
    31593322      (or (member directive '(:default-registry (:default-registry)) :test 'equal)
    31623325              ((:include :directory :tree)
    31633326               (and (length=n-p rest 1)
    3164                     (typep (car rest) '(or pathname string null))))
     3327                    (location-designator-p (first rest))))
    31653328              ((:exclude :also-exclude)
    31663329               (every #'stringp rest))
    31693332  directive)
    3171 (defun validate-source-registry-form (form)
     3334(defun* validate-source-registry-form (form)
    31723335  (validate-configuration-form
    31733336   form :source-registry 'validate-source-registry-directive "a source registry"))
    3175 (defun validate-source-registry-file (file)
     3338(defun* validate-source-registry-file (file)
    31763339  (validate-configuration-file
    31773340   file 'validate-source-registry-form "a source registry"))
    3179 (defun validate-source-registry-directory (directory)
     3342(defun* validate-source-registry-directory (directory)
    31803343  (validate-configuration-directory
    31813344   directory :source-registry 'validate-source-registry-directive))
    3183 (defun parse-source-registry-string (string)
     3346(defun* parse-source-registry-string (string)
    31843347  (cond
    31853348    ((or (null string) (equal string ""))
    32153378           (return `(:source-registry ,@(nreverse directives))))))))))
    3217 (defun register-asd-directory (directory &key recurse exclude collect)
     3380(defun* register-asd-directory (directory &key recurse exclude collect)
    32183381  (if (not recurse)
    32193382      (funcall collect directory)
    3220       (let* ((files
    3221               (handler-case
    3222                   (directory (merge-pathnames* *wild-asd* directory)
    3223                              #+sbcl #+sbcl :resolve-symlinks nil
    3224                              #+clisp #+clisp :circle t)
    3225                 (error (c)
    3226                   (warn "Error while scanning system definitions under directory ~S:~%~A"
    3227                         directory c)
    3228                   nil)))
    3229              (dirs (remove-duplicates (mapcar #'pathname-directory-pathname files)
    3230                                       :test #'equal :from-end t)))
    3231         (loop
    3232           :for dir :in dirs
    3233           :unless (loop :for x :in exclude
    3234                     :thereis (find x (pathname-directory dir) :test #'equal))
    3235           :do (funcall collect dir)))))
     3383      (collect-sub*directories-with-asd
     3384       directory :exclude exclude :collect collect)))
    32373386(defparameter *default-source-registries*
    32463395(defparameter *source-registry-directory* #p"source-registry.conf.d/")
    3248 (defun wrapping-source-registry ()
     3397(defun* wrapping-source-registry ()
    32493398  `(:source-registry
    32503399    #+sbcl (:tree ,(getenv "SBCL_HOME"))
    32513400    :inherit-configuration
    32523401    #+cmu (:tree #p"modules:")))
    3253 (defun default-source-registry ()
     3402(defun* default-source-registry ()
    32543403  (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
    32553404    `(:source-registry
    32773426           :collect `(:tree ,(try dir "common-lisp/source/"))))
    32783427      :inherit-configuration)))
    3279 (defun user-source-registry ()
     3428(defun* user-source-registry ()
    32803429  (in-user-configuration-directory *source-registry-file*))
    3281 (defun system-source-registry ()
     3430(defun* system-source-registry ()
    32823431  (in-system-configuration-directory *source-registry-file*))
    3283 (defun user-source-registry-directory ()
     3432(defun* user-source-registry-directory ()
    32843433  (in-user-configuration-directory *source-registry-directory*))
    3285 (defun system-source-registry-directory ()
     3434(defun* system-source-registry-directory ()
    32863435  (in-system-configuration-directory *source-registry-directory*))
    3287 (defun environment-source-registry ()
     3436(defun* environment-source-registry ()
    32883437  (getenv "CL_SOURCE_REGISTRY"))
    3290 (defgeneric process-source-registry (spec &key inherit register))
     3439(defgeneric* process-source-registry (spec &key inherit register))
    32913440(declaim (ftype (function (t &key (:register (or symbol function))) t)
    32923441                inherit-source-registry))
    33173466      (process-source-registry-directive directive :inherit inherit :register register))))
    3319 (defun inherit-source-registry (inherit &key register)
     3468(defun* inherit-source-registry (inherit &key register)
    33203469  (when inherit
    33213470    (process-source-registry (first inherit) :register register :inherit (rest inherit))))
    3323 (defun process-source-registry-directive (directive &key inherit register)
     3472(defun* process-source-registry-directive (directive &key inherit register)
    33243473  (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
    33253474    (ecase kw
    33263475      ((:include)
    33273476       (destructuring-bind (pathname) rest
    3328          (process-source-registry (pathname pathname) :inherit nil :register register)))
     3477         (process-source-registry (resolve-location pathname) :inherit nil :register register)))
    33293478      ((:directory)
    33303479       (destructuring-bind (pathname) rest
    33313480         (when pathname
    3332            (funcall register (ensure-directory-pathname pathname)))))
     3481           (funcall register (resolve-location pathname :directory t)))))
    33333482      ((:tree)
    33343483       (destructuring-bind (pathname) rest
    33353484         (when pathname
    3336            (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *source-registry-exclusions*))))
     3485           (funcall register (resolve-location pathname :directory t)
     3486                    :recurse t :exclude *source-registry-exclusions*))))
    33373487      ((:exclude)
    33383488       (setf *source-registry-exclusions* rest))
    33473497  nil)
    3349 (defun flatten-source-registry (&optional parameter)
     3499(defun* flatten-source-registry (&optional parameter)
    33503500  (remove-duplicates
    33513501   (while-collecting (collect)
    33603510;; Will read the configuration and initialize all internal variables,
    33613511;; and return the new configuration.
    3362 (defun compute-source-registry (&optional parameter)
     3512(defun* compute-source-registry (&optional parameter)
    33633513  (while-collecting (collect)
    33643514    (dolist (entry (flatten-source-registry parameter))
    33683518         :recurse recurse :exclude exclude :collect #'collect)))))
    3370 (defun initialize-source-registry (&optional parameter)
     3520(defun* initialize-source-registry (&optional parameter)
    33713521  (setf (source-registry) (compute-source-registry parameter)))
    33793529;; you may override the configuration explicitly by calling
    33803530;; initialize-source-registry directly with your parameter.
    3381 (defun ensure-source-registry (&optional parameter)
     3531(defun* ensure-source-registry (&optional parameter)
    33823532  (if (source-registry-initialized-p)
    33833533      (source-registry)
    33843534      (initialize-source-registry parameter)))
    3386 (defun sysdef-source-registry-search (system)
     3536(defun* sysdef-source-registry-search (system)
    33873537  (ensure-source-registry)
    33883538  (loop :with name = (coerce-name system)
    33913541    :when file :return file))
     3543(defun* clear-configuration ()
     3544  (clear-source-registry)
     3545  (clear-output-translations))
    33933547;;;; -----------------------------------------------------------------
    33943548;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL
    3396 #+(or abcl clozure cmu ecl sbcl)
    3397 (progn
    3398   (defun module-provide-asdf (name)
    3399     (handler-bind
    3400         ((style-warning #'muffle-warning)
    3401          (missing-component (constantly nil))
    3402          (error (lambda (e)
    3403                   (format *error-output* "ASDF could not load ~(~A~) because ~A.~%"
    3404                           name e))))
    3405       (let* ((*verbose-out* (make-broadcast-stream))
    3406              (system (find-system (string-downcase name) nil)))
    3407         (when system
    3408           (load-system system)
    3409           t))))
    3410   (pushnew 'module-provide-asdf
    3411            #+abcl sys::*module-provider-functions*
    3412            #+clozure ccl:*module-provider-functions*
    3413            #+cmu ext:*module-provider-functions*
    3414            #+ecl si:*module-provider-functions*
    3415            #+sbcl sb-ext:*module-provider-functions*))
     3550(defun* module-provide-asdf (name)
     3551  (handler-bind
     3552      ((style-warning #'muffle-warning)
     3553       (missing-component (constantly nil))
     3554       (error (lambda (e)
     3555                (format *error-output* "ASDF could not load ~(~A~) because ~A.~%"
     3556                        name e))))
     3557    (let* ((*verbose-out* (make-broadcast-stream))
     3558           (system (find-system (string-downcase name) nil)))
     3559      (when system
     3560        (load-system system)
     3561        t))))
     3563#+(or abcl clisp clozure cmu ecl sbcl)
     3564(let ((x (and #+clisp (find-symbol "*MODULE-PROVIDER-FUNCTIONS*" :custom))))
     3565  (when x
     3566    (eval `(pushnew 'module-provide-asdf
     3567            #+abcl sys::*module-provider-functions*
     3568            #+clisp ,x
     3569            #+clozure ccl:*module-provider-functions*
     3570            #+cmu ext:*module-provider-functions*
     3571            #+ecl si:*module-provider-functions*
     3572            #+sbcl sb-ext:*module-provider-functions*))))
    34173575;;;; -------------------------------------------------------------------------
Note: See TracChangeset for help on using the changeset viewer.