Changeset 12986


Ignore:
Timestamp:
10/31/10 08:40:27 (11 years ago)
Author:
Mark Evenson
Message:

Upgrade to ASDF-2.010.1.

Location:
trunk/abcl
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/doc/asdf/asdf.texinfo

    r12765 r12986  
    6666
    6767@titlepage
    68 @title asdf: another system definition facility
     68@title ASDF: Another System Definition Facility
    6969
    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.
    209 
     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.
    210213
    211214@section Checking whether ASDF is loaded
     
    240243If it returns @code{NIL} then ASDF is not installed.
    241244
    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.
    244247
     
    552555@end example
    553556
    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}.
     571
     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
    567584
    568585
     
    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
    730749
    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}).
     754
     755The method-form tokens provide a shorthand for defining methods on
     756particular components.  This part
    732757
    733758@lisp
     
    747772@end lisp
    748773
    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
     776
     777@lisp
     778(find-component (find-system "foo") "mod")
     779@end lisp
     780
     781For more details on the syntax of such forms, see @ref{The defsystem
     782grammar}.
     783For more details on what these methods do, @pxref{Operations} in
     784@ref{The object model of ASDF}.
     785
     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.
    755793
    756794@node  The defsystem grammar, Other code in .asd files, A more involved example, Defining systems with defsystem
     
    758796@section The defsystem grammar
    759797
     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.
     800
     801
    760802@example
    761 system-definition := ( defsystem system-designator @var{option}* )
    762 
    763 option := :components component-list
     803system-definition := ( defsystem system-designator @var{system-option}* )
     804
     805system-option := :defsystem-depends-on system-list
     806                 | module-option
     807                 | option
     808
     809module-option := :components component-list
     810                 | :serial [ t | nil ]
     811                 | :if-component-dep-fails component-dep-fail-option
     812
     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}+ )
     822
     823
     824system-list := ( @var{simple-component-name}* )
    773825
    774826component-list := ( @var{component-def}* )
     
    797849method-form := (operation-name qual lambda-list @&rest body)
    798850qual := method qualifier
     851
     852component-dep-fail-option := :fail | :try-next | :ignore
    799853@end example
     854
     855
    800856
    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}.
     869
     870@subsection Defsystem depends on
     871
     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.
    813877
    814878@subsection Pathname specifiers
     
    881945and the cumbersome @code{#.(make-pathname ...)} syntax had to be used.
    882946
    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
     
    893957
    894958@subsection Warning about logical pathnames
    895 @cindex logical pathnames 
     959@cindex logical pathnames
    896960
    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.
    921985
     
    930994
    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
     1059
     1060@subsection if-component-dep-fails option
     1061
     1062This option is only appropriate for module components (including
     1063systems), not individual source files.
     1064
     1065For more information about this option, @pxref{Pre-defined subclasses of component}.
    9951066
    9961067@node Other code in .asd files,  , The defsystem grammar, Defining systems with defsystem
     
    14521523This is detailed elsewhere. @xref{Defining systems with defsystem}.
    14531524
    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
    1458 
    1459 @lisp
    1460 (defmethod source-file-type ((c cl-source-file) (s (eql (find-system 'my-sys))))
    1461   "cl")
    1462 @end lisp
    14631525
    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.
    16741739
    16751740@end enumerate
    16761741
    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
    17131778
    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
    17161781@code{asdf:*central-registry*}
     
    17261791@section Configuration DSL
    17271792
    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:
    17291794
    17301795@example
    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.
    17531820
    17541821    ;; splice the parsed contents of another config file
     
    17571824    ;; This directive specifies that some default must be spliced.
    17581825    :default-registry
     1826
     1827REGULAR-FILE-PATHNAME-DESIGNATOR := PATHNAME-DESIGNATOR ;; interpreted as a file
     1828DIRECTORY-PATHNAME-DESIGNATOR := PATHNAME-DESIGNATOR ;; interpreted as a directory name
     1829
     1830PATHNAME-DESIGNATOR :=
     1831    NULL | ;; Special: skip this entry.
     1832    ABSOLUTE-COMPONENT-DESIGNATOR |
     1833    (ABSOLUTE-COMPONENT-DESIGNATOR RELATIVE-COMPONENT-DESIGNATOR ...)
     1834
     1835ABSOLUTE-COMPONENT-DESIGNATOR :=
     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
     1841
     1842RELATIVE-COMPONENT-DESIGNATOR :=
     1843    STRING | ;; namestring (directory assumed where applicable)
     1844    PATHNAME | ;; pathname
     1845    :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.32.30-linux-x86-64
     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(!)
    17591849
    17601850PATTERN := a string without wildcards, that will be matched exactly
     
    17681858@example
    17691859(:source-registry
    1770   (:tree "/home/fare/cl/")
     1860  (:tree (:home "cl")) ;; will expand to e.g. "/home/joeluser/cl/"
    17711861  :inherit-configuration)
    17721862@end example
    1773 
    17741863
    17751864@section Configuration Directories
     
    18351924
    18361925@section Search Algorithm
     1926@vindex *default-source-registry-exclusions*
    18371927
    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
     2003
     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.
    19112012
    19122013
     
    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
    21942294
    21952295RELATIVE-COMPONENT-DESIGNATOR :=
     
    21982298    :IMPLEMENTATION | ;; a directory based on implementation, e.g. sbcl-1.0.32.30-linux-x86-64
    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
     2502
     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.
    24012511
    24022512
     
    24952605@defun system-source-directory system-designator
    24962606
    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
    25032614
     2615@defun clear-system system-designator
     2616
     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.)
     2629
     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
    25042646
    25052647@node Getting the latest version, FAQ, Miscellaneous additional functionality, Top
     
    25352677ASDF bugs are tracked on launchpad: @url{https://launchpad.net/asdf}.
    25362678
    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{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}
    25392681
     
    27572899
    27582900
    2759 @subsection Pitfalls of ASDF 2
     2901@subsection Pitfalls of the transition to ASDF 2
    27602902
    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.
     2927
     2928@end itemize
     2929
     2930Other issues include the following:
     2931
     2932@itemize
    27852933
    27862934@item
     
    27932941moreover when evaluation is desired @code{#.} must be used,
    27942942where it wasn't necessary in the toplevel @code{:pathname} argument.
    2795 
    2796 @end itemize
    2797 
    2798 Other issues include the following:
    2799 
    2800 @itemize
    28012943
    28022944@item
     
    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.
     2965
     2966@item
     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.
     2977
     2978@findex source-file-type
     2979
    28222980
    28232981@end itemize
     
    28402998
    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.
     
    28513009@itemize
    28523010@item
    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.
    28623020
    28633021@item
     
    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).
    30883247
     3248@subsection How do I create a system definition where all the source files have a .cl extension?
     3249
     3250First, create a new @code{cl-source-file} subclass that provides an
     3251initform for the @code{type} slot:
     3252
     3253@lisp
     3254(defclass my-cl-source-file (cl-source-file)
     3255   ((type :initform "cl")))
     3256@end lisp
     3257
     3258To support both ASDF 1 and ASDF 2,
     3259you may omit the above @code{type} slot definition and instead define:
     3260
     3261@lisp
     3262(defmethod source-file-type ((f my-cl-source-file) (m module))
     3263  (declare (ignorable f m))
     3264  "cl")
     3265@end lisp
     3266
     3267Then make your system use this subclass in preference to the standard
     3268one:
     3269
     3270@lisp
     3271(defsystem my-cl-system
     3272  :default-component-class my-cl-source-file
     3273   ....
     3274)
     3275@end lisp
     3276
     3277We assume that these definitions are loaded into a package that uses
     3278@code{ASDF}.
     3279
     3280
    30893281
    30903282@node  TODO list, Inspiration, FAQ, Top
     
    32643456whereas this one centres on a protocol for system introspection.
    32653457
    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
    32673459
    32683460Available in updated-for-CL form on the web at
  • trunk/abcl/src/org/armedbear/lisp/asdf.lisp

    r12818 r12986  
    4848#+xcvb (module ())
    4949
    50 (cl:in-package :cl)
    51 (defpackage :asdf-bootstrap (:use :cl))
    52 (in-package :asdf-bootstrap)
    53 
    54 ;; Implementation-dependent tweaks
     50(cl:in-package :cl-user)
     51
     52#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this
     53
    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))
     66
     67(in-package :asdf)
    6668
    6769;;;; Create packages in a way that is compatible with hot-upgrade.
     
    7072
    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
    217201
    218             #:input-files #:output-files #:perform ; operation methods
     202            #:input-files #:output-files #:output-file #:perform ; operation methods
    219203            #:operation-done-p #:explain
    220204
     
    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
    285270
     271            #:clear-configuration
    286272            #:initialize-output-translations
    287273            #:disable-output-translations
     
    292278            #:compile-file-pathname*
    293279            #:enable-asdf-binary-locations-compatibility
    294 
    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))))))))
    308 
    309 (in-package :asdf)
     285            #:process-source-registry
     286            #:system-registered-p
     287            #:asdf-message
     288
     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*))))))
    310316
    311317;; More cleanups in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
    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))))))
    332336
    333337;;;; -------------------------------------------------------------------------
     
    343347  "Determine whether or not ASDF resolves symlinks when defining systems.
    344348
    345 Defaults to `t`.")
    346 
    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.")
    350 
    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.")
     350
     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.")
     355
     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.")
    356361
    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)))
    378 
     379(macrolet
     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))
     389
     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."))
    386402
    387403(defgeneric* system-source-file (system)
    388404  (:documentation "Return the source file in which system is defined."))
    389405
    390 (defgeneric component-system (component)
     406(defgeneric* component-system (component)
    391407  (:documentation "Find the top-level system containing COMPONENT"))
    392408
    393 (defgeneric component-pathname (component)
     409(defgeneric* component-pathname (component)
    394410  (:documentation "Extracts the pathname applicable for a particular component."))
    395411
    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."))
    402418
    403 (defgeneric component-property (component property))
    404 
    405 (defgeneric (setf component-property) (new-value component property))
    406 
    407 (defgeneric version-satisfies (component version))
     419(defgeneric* component-property (component property))
     420
     421(defgeneric* (setf component-property) (new-value component property))
     422
     423(defgeneric* version-satisfies (component version))
    408424
    409425(defgeneric* find-component (base path)
     
    411427if BASE is nil, then the component is assumed to be a system."))
    412428
    413 (defgeneric source-file-type (component system))
    414 
    415 (defgeneric operation-ancestor (operation)
     429(defgeneric* source-file-type (component system))
     430
     431(defgeneric* operation-ancestor (operation)
    416432  (:documentation
    417433   "Recursively chase the operation's parent pointer until we get to
    418434the head of the tree"))
    419435
    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."))
    432448
    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."))
    442 
    443 (defgeneric (setf visiting-component) (new-value operation component))
    444 
    445 (defgeneric component-visiting-p (operation component))
    446 
    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."))
     460
     461
     462(defgeneric* (setf visiting-component) (new-value operation component))
     463
     464(defgeneric* component-visiting-p (operation component))
     465
     466(defgeneric* component-depends-on (operation component)
    448467  (:documentation
    449468   "Returns a list of dependencies needed by the component to perform
     
    462481    list."))
    463482
    464 (defgeneric component-self-dependencies (operation component))
    465 
    466 (defgeneric traverse (operation component)
     483(defgeneric* component-self-dependencies (operation component))
     484
     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)))
    498517
    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)))
    504523
    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")
    558581
    559 (defun first-char (s)
     582(defun* first-char (s)
    560583  (and (stringp s) (plusp (length s)) (char s 0)))
    561584
    562 (defun last-char (s)
     585(defun* last-char (s)
    563586  (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
    564587
    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))
    568591
    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))))))
    588611
    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)))))
    600623
    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
     
    616639pathnames."
    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))))))
    634662
    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)))
    640668
    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)))
    645673
    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))
    665 
    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))
     685
     686(defun* directory-pathname-p (pathname)
    667687  "Does PATHNAME represent a directory?
    668688
     
    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)))
    680 
    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)))))
     703
     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))))
    698721
    699 (defun absolute-pathname-p (pathspec)
    700   (eq :absolute (car (pathname-directory (pathname pathspec)))))
    701 
    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))))))
     724
     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)))))
    710733
    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))))
    717740
    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))
    726749(progn
    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")))))))
    746 
    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")))))))
     770
     771(defun* pathname-root (pathname)
    748772  (make-pathname :host (pathname-host pathname)
    749773                 :device (pathname-device pathname)
     
    751775                 :name nil :type nil :version nil))
    752776
    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)))))))
     787
     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))))))))
    785820
    786 (defun resolve-symlinks (path)
     821(defun* resolve-symlinks (path)
    787822  #-allegro (truenamize path)
    788823  #+allegro (excl:pathname-resolve-symbolic-links path))
    789824
    790 (defun default-directory ()
     825(defun* default-directory ()
    791826  (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
    792827
    793 (defun lispize-pathname (input-file)
     828(defun* lispize-pathname (input-file)
    794829  (make-pathname :type "lisp" :defaults input-file))
    795830
     
    798833                 :name :wild :type :wild :version :wild))
    799834
    800 (defun wilden (path)
     835(defun* wilden (path)
    801836  (merge-pathnames* *wild-path* path))
    802837
    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)))
    842878
     
    857893
    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)))))
    860898
    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   ;; http://www.cliki.net/poiu
     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)))
    917973
    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)))
    933989
    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))
     
    939995
    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)
     
    9461001
    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)))))
    9541008
    9551009(defmethod component-system ((component component))
     
    9601014(defvar *default-component-class* 'cl-source-file)
    9611015
    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)))
    9911045
    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)))
    10341090
    10351091;;;; -------------------------------------------------------------------------
     
    10581114;;;; Finding systems
    10591115
    1060 (defun make-defined-systems-table ()
     1116(defun* make-defined-systems-table ()
    10611117  (make-hash-table :test 'equal))
    10621118
     
    10681124of which is a system object.")
    10691125
    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))))
    10761132
    1077 (defun system-registered-p (name)
     1133(defun* system-registered-p (name)
    10781134  (gethash (coerce-name name) *defined-systems*))
    10791135
    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))
    10901146
    1091 (defun map-systems (fn)
     1147(defun* map-systems (fn)
    10921148  "Apply FN to each defined system.
    10931149
     
    11071163  '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf))
    11081164
    1109 (defun system-definition-pathname (system)
     1165(defun* system-definition-pathname (system)
    11101166  (let ((system-name (coerce-name system)))
    11111167    (or
     
    11311187")
    11321188
    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)))))))))
    11531209
    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))))))))))
    11951250
    1196 (defun make-temporary-package ()
     1251(defun* make-temporary-package ()
    11971252  (flet ((try (counter)
    11981253           (ignore-errors
     
    12031258         (package package))))
    12041259
    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)))
    12201275
    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))
     1278
     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)))))))
    1248 
    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)))))))
     1307
     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)))
    12531312
    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))))
     1325
     1326(defun* sysdef-find-asdf (name)
     1327  (find-system-fallback name "asdf")) ;; :version *asdf-version* wouldn't be updated when ASDF is updated.
    12651328
    12661329
     
    13181381  (source-file-explicit-type component))
    13191382
    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
    1327   ;; ASDF-UTILITIES:MERGE-PATHNAMES*
     1390  ;; ASDF:MERGE-PATHNAMES*
    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))
    13911455
    1392 (defun node-for (o c)
     1456(defun* node-for (o c)
    13931457  (cons (class-name (class-of o)) c))
    13941458
     
    13991463
    14001464
    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.")
    15451609
    1546 (defgeneric do-traverse (operation component collect))
    1547 
    1548 (defun %do-one-dep (operation c collect required-op required-c required-v)
     1610(defgeneric* do-traverse (operation component collect))
     1611
     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)))
    15631627
    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))))))))
    15881645
    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))))
    16271684
    1628 (defun do-collect (collect x)
     1685(defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes
     1686
     1687(defun* do-collect (collect x)
    16291688  (funcall collect x))
    16301689
     
    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))
    17151774
    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)))))
    17441804
    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)))
    17501809
     
    17541813
    17551814(defmethod explain ((operation operation) (component component))
    1756   (asdf-message "~&;;; ~A on ~A~%" operation component))
     1815  (asdf-message "~&;;; ~A~%" (operation-description operation component)))
     1816
     1817(defmethod operation-description (operation component)
     1818  (format nil "~A on component ~S" (class-of operation) (component-find-path component)))
    17571819
    17581820;;;; -------------------------------------------------------------------------
     
    17681830          :initform #-ecl nil #+ecl '(:system-p t))))
    17691831
     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)))
     1837
    17701838(defmethod perform :before ((operation compile-op) (c source-file))
    17711839  (map nil #'ensure-directories-exist (output-files operation c)))
     
    17841852        (get-universal-time)))
    17851853
    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)
    18371908
     1909(defmethod operation-description ((operation compile-op) component)
     1910  (declare (ignorable operation))
     1911  (format nil "compiling component ~S" (component-find-path component)))
    18381912
    18391913;;;; -------------------------------------------------------------------------
     
    18451919
    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)))))
    18521926
    18531927(defmethod perform-with-restarts (operation component)
     
    19121986        (call-next-method)))
    19131987
     1988(defmethod operation-description ((operation load-op) component)
     1989  (declare (ignorable operation))
     1990  (format nil "loading component ~S" (component-find-path component)))
     1991
     1992
    19141993;;;; -------------------------------------------------------------------------
    19151994;;;; load-source-op
     
    19492028             (component-property c 'last-loaded-as-source)))
    19502029      nil t))
     2030
     2031(defmethod operation-description ((operation load-source-op) component)
     2032  (declare (ignorable operation))
     2033  (format nil "loading component ~S" (component-find-path component)))
    19512034
    19522035
     
    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))
    2014 
    2015 (defun oos (operation-class system &rest args &key force verbose version
     2093                (return))))))
     2094      (values op steps))))
     2095
     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))
    20442125
    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
    20482129details."
    20492130  (declare (ignore force verbose version))
    2050   (apply #'operate 'load-op system args))
    2051 
    2052 (defun compile-system (system &rest args &key force verbose version
     2131  (apply #'operate 'load-op system args)
     2132  t)
     2133
     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))
    2058 
    2059 (defun test-system (system &rest args &key force verbose version
     2139  (apply #'operate 'compile-op system args)
     2140  t)
     2141
     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
    20622145details."
    20632146  (declare (ignore force verbose version))
    2064   (apply #'operate 'test-op system args))
     2147  (apply #'operate 'test-op system args)
     2148  t)
    20652149
    20662150;;;; -------------------------------------------------------------------------
    20672151;;;; Defsystem
    20682152
    2069 (defun load-pathname ()
     2153(defun* load-pathname ()
    20702154  (let ((pn (or *load-pathname* *compile-file-pathname*)))
    20712155    (if *resolve-symlinks*
     
    20732157        pn)))
    20742158
    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))))
    20862170
     
    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))))))
    21142198
    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)))
    21272211
    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))))
    21422226
    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)
    21552239
    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))
    21602244
    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)))
    21762260
    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))
    21882272
    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)))))))
    22022286
    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))
    22062290
    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
    22872371
    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)))
    23592443
    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)))
    23672451
    2368 (defun relativize-directory (directory)
     2452(defun* relativize-directory (directory)
    23692453  (cond
    23702454    ((stringp directory)
     
    23752459     directory)))
    23762460
    2377 (defun relativize-pathname-directory (pathspec)
     2461(defun* relativize-pathname-directory (pathspec)
    23782462  (let ((p (pathname pathspec)))
    23792463    (make-pathname
     
    23812465     :defaults p)))
    23822466
    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)
     
    23942478
    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))
    23982487
    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))
    24062495
    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))
    2412 
    2413 
    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)))
     2507
     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))
    24482542
    2449 (defun first-feature (features)
     2543(defun* first-feature (features)
    24502544  (labels
    24512545      ((fp (thing)
     
    24632557      :when (fp f) :return :it)))
    24642558
    2465 (defun implementation-type ()
     2559(defun* implementation-type ()
    24662560  (first-feature *implementation-features*))
    24672561
    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) #\;)
    24972590
    2498 (defun user-homedir ()
     2591(defun* user-homedir ()
    24992592  (truename (user-homedir-pathname)))
    25002593
    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))
    25382630
    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)))))
    25432635
    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)
    25582650
    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))))
    25642656
    2565 (defun hidden-file-p (pathname)
     2657(defun* hidden-file-p (pathname)
    25662658  (equal (first-char (pathname-name pathname)) #\.))
    25672659
    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*)
    26052697
    2606 (defun output-translations ()
     2698(defun* output-translations ()
    26072699  (car *output-translations*))
    26082700
    2609 (defun (setf output-translations) (new-value)
     2701(defun* (setf output-translations) (new-value)
    26102702  (setf *output-translations*
    26112703        (list
     
    26182710  new-value)
    26192711
    2620 (defun output-translations-initialized-p ()
     2712(defun* output-translations-initialized-p ()
    26212713  (and *output-translations* t))
    26222714
    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))
    26292721
    2630 (defparameter *wild-asd*
    2631   (make-pathname :directory '(:relative :wild-inferiors)
    2632                  :name :wild :type "asd" :version :newest))
    2633 
    2634 
    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))
    26372725
    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)))
    26622752
    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))
    26902784
    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))))
    26992797
    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)))))
    27032801
    2704 (defun location-function-p (x)
     2802(defun* location-function-p (x)
    27052803  (and
    27062804   (consp x)
     
    27122810            (length=n-p (second x) 2)))))
    27132811
    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)
    27302828
    2731 (defun validate-output-translations-form (form)
     2829(defun* validate-output-translations-form (form)
    27322830  (validate-configuration-form
    27332831   form
     
    27362834   "output translations"))
    27372835
    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"))
    27412839
    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))
    27452843
    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))
    27902888
    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))
    28052903
     
    28072905(defparameter *output-translations-directory* #p"asdf-output-translations.conf.d/")
    28082906
    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"))
    28192917
    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)))
    28492947
    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))))
    28532951
    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)))))))))))
    28912989
    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))
    28992997
    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)))
    29043002
    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)))
    29193017
    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))))
     3033
     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)))))
    29523053
     
    29613062   t))
    29623063
    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))))
    29693070
    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))
    29743075
    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)))
    29783079
    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))
     
    30023103
    30033104#+abcl
    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
    30193120
    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)))
     
    30543158;;;; http://www.wotsit.org/list.asp?fc=13
    30553159
     3160#+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
     3161(progn
    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))
    30583164
    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))))
    30643170
    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))))
    30693175
    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))))))
    30933199
    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)))))
    31233229
    31243230;;;; -----------------------------------------------------------------
     
    31283234;; Using ack 1.2 exclusions
    31293235(defvar *default-source-registry-exclusions*
    3130   '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst"
     3236  '(".bzr" ".cdv"
     3237    ;; "~.dep" "~.dot" "~.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.
    31333241
    31343242(defvar *source-registry-exclusions* *default-source-registry-exclusions*)
     
    31383246said element itself being a list of directory pathnames where to look for .asd files")
    31393247
    3140 (defun source-registry ()
     3248(defun* source-registry ()
    31413249  (car *source-registry*))
    31423250
    3143 (defun (setf source-registry) (new-value)
     3251(defun* (setf source-registry) (new-value)
    31443252  (setf *source-registry* (list new-value))
    31453253  new-value)
    31463254
    3147 (defun source-registry-initialized-p ()
     3255(defun* source-registry-initialized-p ()
    31483256  (and *source-registry* t))
    31493257
    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))
    31563264
    3157 (defun validate-source-registry-directive (directive)
     3265(defparameter *wild-asd*
     3266  (make-pathname :directory nil :name :wild :type "asd" :version :newest))
     3267
     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))
     3275
     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))
     3302
     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))))
     3309
     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))
     3319
     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)
    31703333
    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"))
    31743337
    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"))
    31783341
    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))
    31823345
    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))))))))))
    32163379
    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)))
    32363385
    32373386(defparameter *default-source-registries*
     
    32463395(defparameter *source-registry-directory* #p"source-registry.conf.d/")
    32473396
    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"))
    32893438
    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))))
    33183467
    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))))
    33223471
    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)
    33483498
    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)))))
    33693519
    3370 (defun initialize-source-registry (&optional parameter)
     3520(defun* initialize-source-registry (&optional parameter)
    33713521  (setf (source-registry) (compute-source-registry parameter)))
    33723522
     
    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)))
    33853535
    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))
    33923542
     3543(defun* clear-configuration ()
     3544  (clear-source-registry)
     3545  (clear-output-translations))
     3546
    33933547;;;; -----------------------------------------------------------------
    33943548;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL
    33953549;;;;
    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))))
     3562
     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*))))
     3573
    34163574
    34173575;;;; -------------------------------------------------------------------------
Note: See TracChangeset for help on using the changeset viewer.