Changeset 12655


Ignore:
Timestamp:
05/06/10 20:15:20 (13 years ago)
Author:
Mark Evenson
Message:

Update to ASDF 1.719 as recommended by ASDF developers.

Location:
trunk/abcl
Files:
2 edited

Legend:

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

    r12618 r12655  
    3232This manual describes ASDF, a system definition facility
    3333for Common Lisp programs and libraries.
     34
     35You can find the latest version of this manual at
     36@url{http://common-lisp.net/project/asdf/asdf.html}.
    3437
    3538ASDF Copyright @copyright{} 2001-2010 Daniel Barlow and contributors.
     
    168171
    169172@emph{Nota Bene}:
    170 We are preparing for a release of ASDF 2,
     173We are preparing for a release of ASDF 2, hopefully for May 2010,
    171174which will have version 2.000 and later.
    172 Current releases, in the 1.600 series and beyond,
     175Current releases, in the 1.700 series and beyond,
    173176should be considered as release candidates.
    174177We're still working on polishing the code and documentation.
    175 @ref{FAQ,,``What has changed between ASDF 1 and ASDF 2?''}.
     178@xref{FAQ,,``What has changed between ASDF 1 and ASDF 2?''}.
    176179
    177180
     
    239242If it returns @code{NIL} then ASDF is not installed.
    240243
    241 If you are running a version older than 1.678,
     244If you are running a version older than 1.711,
    242245we recommend that you load a newer ASDF using the method below.
    243246
     
    533536ASDF-Binary-Locations, cl-launch, common-lisp-controller.
    534537ASDF-Binary-Locations is now not needed anymore and should not be used.
    535 cl-launch 3.0 and common-lisp-controller 7.1 have been updated
     538cl-launch 2.900 and common-lisp-controller 7.1 have been updated
    536539to just delegate this functionality to ASDF.
    537540
     
    550553@end example
    551554
    552 On some implementations (namely, SBCL and Clozure CL),
     555On some implementations (namely ABCL, Clozure CL, CMUCL, ECL and SBCL),
    553556ASDF hooks into the @code{CL:REQUIRE} facility
    554557and you can just use:
     
    13171320which doesn't provide any obvious way to specify required features.
    13181321Furthermore, in 2009, discussions on the
    1319 @uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}
     1322@url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}
    13201323suggested that the specification of required features may be broken,
    13211324and that no one may have been using them for a while.
    13221325Please contact the
    1323 @uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}
     1326@url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}
    13241327if you are interested in getting this features feature fixed.}
    13251328
     
    16721675Mentions of XDG variables refer to that document.
    16731676
    1674 @uref{http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html}
     1677@url{http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html}
    16751678
    16761679This specification allows the user to specify some environment variables
     
    24642467
    24652468You may get the ASDF source repository using git:
    2466 @kbd{git clone http://common-lisp.net/project/asdf/asdf.git}
     2469@kbd{git clone git://common-lisp.net/projects/asdf/asdf.git}
    24672470
    24682471You will find the above referenced tags in this repository.
     
    24732476mailing list
    24742477@kbd{asdf-devel@@common-lisp.net}.
    2475 @uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel}
     2478@url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel}
    24762479
    24772480
     
    24852488
    24862489If you're unsure about whether something is a bug, of for general discussion,
    2487 use the @uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}
     2490use the @url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}
    24882491
    24892492
     
    24972500we are still working on polishing them before release.
    24982501
    2499 Releases in the 1.600 series and beyond
     2502Releases in the 1.700 series and beyond
    25002503should be considered as release candidates.
    25012504For all practical purposes,
     
    25142517
    25152518
    2516 @subsection ASDF can portably name files inside systems and components
     2519@subsection ASDF can portably name files in subdirectories
    25172520
    25182521Common Lisp namestrings are not portable,
    25192522except maybe for logical pathnamestrings,
    2520 that themselves require a lot of setup that is itself ultimately non-portable.
    2521 The only portable ways to refer to pathnames inside systems and components
     2523that themselves have various limitations and require a lot of setup
     2524that is itself ultimately non-portable.
     2525
     2526In ASDF 1, the only portable ways to refer to pathnames inside systems and components
    25222527were very awkward, using @code{#.(make-pathname ...)} and
    25232528@code{#.(merge-pathnames ...)}.
     
    25352540@xref{The defsystem grammar,,Pathname specifiers}.
    25362541
     2542
    25372543@subsection Output translations
    25382544
     
    25722578and a coherent set of configuration files and hooks.
    25732579
     2580We believe it's a vast improvement because it decouples
     2581application distribution from library distribution.
     2582The application writer can avoid thinking where the libraries are,
     2583and the library distributor (dpkg, clbuild, advanced user, etc.)
     2584can configure them once and for every application.
     2585Yet settings can be easily overridden where needed,
     2586so whoever needs control has exactly as much as required.
     2587
    25742588At the same time, ASDF 2 remains compatible
    25752589with the old magic you may have in your build scripts
     2590(using @code{*central-registry*} and
     2591@code{*system-definition-search-functions*})
    25762592to tailor the ASDF configuration to your build automation needs,
    25772593and also allows for new magic, simpler and more powerful magic.
    25782594
    25792595@xref{Controlling where ASDF searches for systems}.
     2596
    25802597
    25812598@subsection Usual operations are made easier to the user
     
    25932610@subsection Many bugs have been fixed
    25942611
    2595 These issues and many others have been fixed,
    2596 including the following:
    2597 
    2598 Dependencies were not correctly propagated
    2599 across submodules within a system.
    2600 
     2612The following issues and many others have been fixed:
     2613
     2614@itemize
     2615@item
     2616The infamous TRAVERSE function has been revamped significantly,
     2617with many bugs squashed.
     2618In particular, dependencies were not correctly propagated
     2619across submodules within a system but now are.
     2620The :version and :feature features and
     2621the :force (system1 .. systemN) feature have been fixed.
     2622
     2623@item
     2624Performance has been notably improved for large systems
     2625(say with thousands of components) by using
     2626hash-tables instead of linear search,
     2627and linear-time list accumulation
     2628instead of quadratic-time recursive appends.
     2629
     2630@item
    26012631Many features used to not be portable,
    26022632especially where pathnames were involved.
    2603 
    2604 The internal test suite used to massively fail
    2605 in many implementations.
    2606 
    2607 Support was broken for some implementations (notably ABCL).
    2608 
     2633Windows support was notably quirky because of such non-portability.
     2634
     2635@item
     2636The internal test suite used to massively fail on many implementations.
     2637While still incomplete, it now fully passes
     2638on all implementations supported by the test suite.
     2639
     2640@item
     2641Support was lacking for some implementations.
     2642ABCL was notably wholly broken.
     2643ECL extensions were not integrated in the ASDF release.
     2644
     2645@item
    26092646The documentation was grossly out of date.
    26102647
    2611 ECL extensions were not integrated in the ASDF release.
     2648@end itemize
    26122649
    26132650
     
    26242661that everyone can rely on from now on.
    26252662Use @code{#+asdf2} to detect presence of ASDF 2,
    2626 @code{(asdf:version-satisfies (asdf:asdf-version) "1.678")}
     2663@code{(asdf:version-satisfies (asdf:asdf-version) "1.711")}
    26272664to check the availability of a version no earlier than required.
     2665
    26282666
    26292667@subsection ASDF can be upgraded
     
    26682706towards the latest version for everyone.
    26692707
     2708
     2709@subsection Pitfalls of ASDF 2
     2710
     2711The main pitfalls in upgrading to ASDF 2 seem to be related
     2712to the output translation mechanism.
     2713
     2714@itemize
     2715
     2716@item
     2717Output translations is enabled by default. This may surprise some users,
     2718most of them in pleasant way (we hope), a few of them in an unpleasant way.
     2719It is trivial to disable output translations.
     2720@xref{FAQ,,``How can I wholly disable the compiler output cache?''}.
     2721
     2722@item
     2723Some systems in the large have been known not to play well with output translations.
     2724They were relatively easy to fix.
     2725Once again, it is also easy to disable output translations,
     2726or to override its configuration.
     2727
     2728@item
     2729The new ASDF output translations are incompatible with ASDF-Binary-Locations.
     2730They replace A-B-L, and there is compatibility mode to emulate
     2731your previous A-B-L configuration.
     2732See @code{asdf:enable-asdf-binary-locations-compatibility} in
     2733@pxref{Controlling where ASDF saves compiled files,,Backward Compatibility}.
     2734But thou shall not load ABL on top of ASDF 2.
     2735
     2736@end itemize
     2737
     2738Other issues include the following:
     2739
     2740@itemize
     2741
     2742@item
     2743There is a slight performance bug, notably on SBCL,
     2744when initially searching for @file{asd} files,
     2745the implicit @code{(directory "/configured/path/**/*.asd")}
     2746for every configured path @code{(:tree "/configured/path/")}
     2747in your @code{source-registry} configuration can cause a slight pause.
     2748Try to @code{(time (asdf:initialize-source-registry))}
     2749to see how bad it is or isn't on your system.
     2750If you insist on not having this pause,
     2751you can avoid the pause by overriding the default source-registry configuration
     2752and not use any deep @code{:tree} entry but only @code{:directory} entries
     2753or shallow @code{:tree} entries.
     2754Or you can fix your implementation to not be quite that slow
     2755when recursing through directories.
     2756
     2757@item
     2758On Windows, only LispWorks supports proper default configuration pathnames
     2759based on the Windows registry.
     2760Other implementations make do.
     2761Windows support is largely untested, so please help report and fix bugs.
     2762
     2763@end itemize
     2764
     2765
    26702766@section Issues with installing the proper version of ASDF
    26712767
     
    26912787it's a bug that you should report upstream and that we will fix ASAP.
    26922788
    2693 As to how to include ASDF, we recommend that
    2694 if you do have a few magic systems in your implementation path,
    2695 that are specially treated in @code{wrapping-source-registry},
    2696 like SBCL does.
    2697 In this case, we explicitly ask you to @emph{NOT} distribute
    2698 @file{asdf.asd} together with your implementation's ASDF,
    2699 least you separate it from the other systems in this path,
    2700 or otherwise rename the system and its @file{asd} file
    2701 to e.g. @code{asdf-sbcl} and @file{asdf-sbcl.asd}.
    2702 
     2789As to how to include ASDF, we recommend the following:
     2790
     2791@itemize
     2792@item
     2793If ASDF isn't installed yet, then @code{(require :asdf)}
     2794should load the version of ASDF that is bundled with your system.
     2795You may have it load some other version configured by the user,
     2796if you allow such configuration.
     2797
     2798@item
     2799If your system provides a mechanism to hook into @code{CL:REQUIRE},
     2800then it would be nice to add ASDF to this hook the same way that
     2801ABCL, CCL, CMUCL, ECL and SBCL do it.
     2802
     2803@item
     2804You may, like SBCL, have ASDF be implicitly used to require systems
     2805that are bundled with your Lisp distribution.
     2806If you do have a few magic systems that come with your implementation
     2807in a precompiled way such that one should only use the binary version
     2808that goes with your distribution, like SBCL does,
     2809then you should add them in the beginning of @code{wrapping-source-registry}.
     2810
     2811@item
     2812If you have magic systems as above, like SBCL does,
     2813then we explicitly ask you to @emph{NOT} distribute
     2814@file{asdf.asd} as part of those magic systems.
     2815You should still include the file @file{asdf.lisp} in your source distribution
     2816and precompile it in your binary distribution,
     2817but @file{asdf.asd} if included at all,
     2818should be secluded from the magic systems,
     2819in a separate file hierarchy,
     2820or you may otherwise rename the system and its file to e.g.
     2821@code{asdf-ecl} and @file{asdf-ecl.asd}, or
     2822@code{sb-asdf} and @file{sb-asdf.asd}.
     2823Indeed, if you made @file{asdf.asd} a magic system,
     2824then users would no longer be able to upgrade ASDF using ASDF itself
     2825to some version of their preference that
     2826they maintain independently from your Lisp distribution.
     2827
     2828@item
    27032829If you do not have any such magic systems, or have other non-magic systems
    27042830that you want to bundle with your implementation,
     
    27062832and you are welcome to include @file{asdf.asd} amongst them.
    27072833
    2708 Please send upstream any patches you make to ASDF itself,
     2834@item
     2835Please send us upstream any patches you make to ASDF itself,
    27092836so we can merge them back in for the benefit of your users
    27102837when they upgrade to the upstream version.
     2838
     2839@end itemize
     2840
    27112841
    27122842
     
    27732903@code{test-op} has been
    27742904a topic of considerable discussion on the
    2775 @uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list},
     2905@url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list},
    27762906and on the
    2777 @uref{https://launchpad.net/asdf,launchpad bug-tracker}.
     2907@url{https://launchpad.net/asdf,launchpad bug-tracker}.
    27782908
    27792909Here are some guidelines:
  • trunk/abcl/src/org/armedbear/lisp/asdf.lisp

    r12644 r12655  
    5050(cl:in-package :cl-user)
    5151
    52 (declaim (optimize (speed 2) (debug 2) (safety 3)))
    53 
    54 #+ecl (require 'cmp)
     52(declaim (optimize (speed 2) (debug 2) (safety 3))
     53         #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
     54
     55#+ecl (require :cmp)
    5556
    5657;;;; Create packages in a way that is compatible with hot-upgrade.
     
    5859;;;; See more at the end of the file.
    5960
     61#+gcl
     62(eval-when (:compile-toplevel :load-toplevel)
     63  (defpackage :asdf-utilities (:use :cl))
     64  (defpackage :asdf (:use :cl :asdf-utilities)))
     65
    6066(eval-when (:load-toplevel :compile-toplevel :execute)
     67  #+allegro
     68  (setf excl::*autoload-package-name-alist*
     69        (remove "asdf" excl::*autoload-package-name-alist*
     70                :test 'equalp :key 'car))
    6171  (let* ((asdf-version
    62           ;; the 1+ hair is to ensure that we don't do an inadvertent find and replace
    63           (subseq "VERSION:1.679" (1+ (length "VERSION"))))
    64          #+allegro (excl::*autoload-package-name-alist* nil)
     72          ;; the 1+ helps the version bumping script discriminate
     73          (subseq "VERSION:1.719" (1+ (length "VERSION"))))
    6574         (existing-asdf (find-package :asdf))
    66          (versym '#:*asdf-version*)
    67          (existing-version (and existing-asdf (find-symbol (string versym) existing-asdf)))
    68          (redefined-functions
    69           '(#:perform #:explain #:output-files #:operation-done-p
     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)))
     79         (already-there (equal asdf-version existing-version)))
     80    (unless (and existing-asdf already-there)
     81      #-gcl
     82      (when existing-asdf
     83        (format *error-output*
     84                "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
     85                existing-version asdf-version))
     86      (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)))
     99           (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)))
     112                    (rename-package p name nicknames)
     113                    (ensure-use p use)
     114                    p))
     115                 (t
     116                  (make-package name :nicknames nicknames :use use)))))
     117           (find-sym (symbol package)
     118             (find-symbol (string symbol) package))
     119           (intern* (symbol package)
     120             (intern (string symbol) package))
     121           (remove-symbol (symbol package)
     122             (let ((sym (find-sym symbol package)))
     123               (when sym
     124                 (unexport sym package)
     125                 (unintern sym package))))
     126           (ensure-unintern (package symbols)
     127             (dolist (sym symbols) (remove-symbol sym package)))
     128           (ensure-shadow (package symbols)
     129             (shadow symbols package))
     130           (ensure-use (package use)
     131             (dolist (used (reverse use))
     132               (do-external-symbols (sym used)
     133                 (unless (eq sym (find-sym sym package))
     134                   (remove-symbol sym package)))
     135               (use-package used package)))
     136           (ensure-fmakunbound (package symbols)
     137             (loop :for name :in symbols
     138               :for sym = (find-sym name package)
     139               :when sym :do (fmakunbound sym)))
     140           (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))))
     148           (ensure-package (name &key nicknames use unintern fmakunbound shadow export)
     149             (let ((p (ensure-exists name nicknames use)))
     150               (ensure-unintern p unintern)
     151               (ensure-shadow p shadow)
     152               (ensure-export p export)
     153               (ensure-fmakunbound p fmakunbound)
     154               p)))
     155        (macrolet
     156            ((pkgdcl (name &key nicknames use export
     157                           redefined-functions unintern fmakunbound shadow)
     158               `(ensure-package
     159                 ',name :nicknames ',nicknames :use ',use :export ',export
     160                 :shadow ',shadow
     161                 :unintern ',(append #-(or gcl ecl) redefined-functions
     162                                     unintern)
     163                 :fmakunbound ',(append #+(or gcl ecl) redefined-functions
     164                                        fmakunbound))))
     165          (pkgdcl
     166           :asdf-utilities
     167           :nicknames (#:asdf-extensions)
     168           :use (#:common-lisp)
     169           :unintern (#:split #:make-collector)
     170           :export
     171           (#:absolute-pathname-p
     172            #:aif
     173            #:appendf
     174            #:asdf-message
     175            #:coerce-name
     176            #:directory-pathname-p
     177            #:ends-with
     178            #:ensure-directory-pathname
     179            #:getenv
     180            #:get-uid
     181            #:length=n-p
     182            #:merge-pathnames*
     183            #:pathname-directory-pathname
     184            #:read-file-forms
     185            #:remove-keys
     186            #:remove-keyword
     187            #:resolve-symlinks
     188            #:split-string
     189            #:component-name-to-pathname-components
     190            #:split-name-type
     191            #:system-registered-p
     192            #:truenamize
     193            #:while-collecting))
     194          (pkgdcl
     195           :asdf
     196           :use (:common-lisp :asdf-utilities)
     197           :redefined-functions
     198           (#:perform #:explain #:output-files #:operation-done-p
    70199            #:perform-with-restarts #:component-relative-pathname
    71             #:system-source-file)))
    72     (unless (equal asdf-version existing-version)
    73       (labels ((rename-away (package)
    74                  (loop :with name = (package-name package)
    75                    :for i :from 1 :for new = (format nil "~A.~D" name i)
    76                    :unless (find-package new) :do
    77                    (rename-package-name package name new)))
    78                (rename-package-name (package old new)
    79                  (let* ((old-names (cons (package-name package) (package-nicknames package)))
    80                         (new-names (subst new old old-names :test 'equal))
    81                         (new-name (car new-names))
    82                         (new-nicknames (cdr new-names)))
    83                    (rename-package package new-name new-nicknames)))
    84                (ensure-exists (name nicknames use)
    85                  (let* ((previous
    86                          (remove-duplicates
    87                           (remove-if
    88                            #'null
    89                            (mapcar #'find-package (cons name nicknames)))
    90                           :from-end t)))
    91                    (cond
    92                      (previous
    93                       (map () #'rename-away (cdr previous)) ;; packages with conflicting (nick)names
    94                       (let ((p (car previous))) ;; previous package with same name
    95                         (rename-package p name nicknames)
    96                         (ensure-use p use)
    97                         p))
    98                      (t
    99                       (make-package name :nicknames nicknames :use use)))))
    100                (find-sym (symbol package)
    101                  (find-symbol (string symbol) package))
    102                (remove-symbol (symbol package)
    103                  (let ((sym (find-sym symbol package)))
    104                    (when sym
    105                      (unexport sym package)
    106                      (unintern sym package))))
    107                (ensure-unintern (package symbols)
    108                  (dolist (sym symbols) (remove-symbol sym package)))
    109                (ensure-shadow (package symbols)
    110                  (shadow symbols package))
    111                (ensure-use (package use)
    112                  (dolist (used (reverse use))
    113                    (do-external-symbols (sym used)
    114                      (unless (eq sym (find-sym sym package))
    115                        (remove-symbol sym package)))
    116                    (use-package used package)))
    117                (ensure-fmakunbound (package symbols)
    118                  (loop :for name :in symbols
    119                    :for sym = (find-sym name package)
    120                    :when sym :do (fmakunbound sym)))
    121                (ensure-export (package export)
    122                  (let ((syms (loop :for x :in export :collect
    123                                (intern (string x) package))))
    124                    (do-external-symbols (sym package)
    125                      (unless (member sym syms)
    126                        (remove-symbol sym package)))
    127                    (dolist (sym syms)
    128                      (export sym package))))
    129                (ensure-package (name &key nicknames use unintern fmakunbound shadow export)
    130                  (let ((p (ensure-exists name nicknames use)))
    131                    (ensure-unintern p unintern)
    132                    (ensure-shadow p shadow)
    133                    (ensure-export p export)
    134                    (ensure-fmakunbound p fmakunbound)
    135                    p)))
    136         (ensure-package
    137          ':asdf-utilities
    138          :nicknames '(#:asdf-extensions)
    139          :use '(#:common-lisp)
    140          :unintern '(#:split #:make-collector)
    141          :export
    142          '(#:absolute-pathname-p
    143            #:aif
    144            #:appendf
    145            #:asdf-message
    146            #:coerce-name
    147            #:directory-pathname-p
    148            #:ends-with
    149            #:ensure-directory-pathname
    150            #:getenv
    151            #:get-uid
    152            #:length=n-p
    153            #:merge-pathnames*
    154            #:pathname-directory-pathname
    155            #:pathname-sans-name+type ;; deprecated. Use pathname-directory-pathname
    156            #:read-file-forms
    157            #:remove-keys
    158            #:remove-keyword
    159            #:resolve-symlinks
    160            #:split-string
    161            #:component-name-to-pathname-components
    162            #:split-name-type
    163            #:system-registered-p
    164            #:truenamize
    165            #:while-collecting))
    166         (ensure-package
    167          ':asdf
    168          :use '(:common-lisp :asdf-utilities)
    169          :unintern `(#-ecl ,@redefined-functions
    170                            #:*asdf-revision* #:around #:asdf-method-combination
    171                            #:split #:make-collector)
    172          :fmakunbound `(#+ecl ,@redefined-functions
    173                               #:system-source-file
    174                               #:component-relative-pathname #:system-relative-pathname
    175                               #:process-source-registry
    176                               #:inherit-source-registry #:process-source-registry-directive)
    177          :export
    178          '(#:defsystem #:oos #:operate #:find-system #:run-shell-command
    179            #:system-definition-pathname #:find-component ; miscellaneous
    180            #:compile-system #:load-system #:test-system
    181            #:compile-op #:load-op #:load-source-op
    182            #:test-op
    183            #:operation               ; operations
    184            #:feature                 ; sort-of operation
    185            #:version                 ; metaphorically sort-of an operation
    186            #:version-satisfies
    187 
    188            #:input-files #:output-files #:perform ; operation methods
    189            #:operation-done-p #:explain
    190 
    191            #:component #:source-file
    192            #:c-source-file #:cl-source-file #:java-source-file
    193            #:static-file
    194            #:doc-file
    195            #:html-file
    196            #:text-file
    197            #:source-file-type
    198            #:module                     ; components
    199            #:system
    200            #:unix-dso
    201 
    202            #:module-components          ; component accessors
    203            #:component-pathname
    204            #:component-relative-pathname
    205            #:component-name
    206            #:component-version
    207            #:component-parent
    208            #:component-property
    209            #:component-system
    210 
    211            #:component-depends-on
    212 
    213            #:system-description
    214            #:system-long-description
    215            #:system-author
    216            #:system-maintainer
    217            #:system-license
    218            #:system-licence
    219            #:system-source-file
    220            #:system-source-directory
    221            #:system-relative-pathname
    222            #:map-systems
    223 
    224            #:operation-on-warnings
    225            #:operation-on-failure
    226                                         ;#:*component-parent-pathname*
    227            #:*system-definition-search-functions*
    228            #:*central-registry*         ; variables
    229            #:*compile-file-warnings-behaviour*
    230            #:*compile-file-failure-behaviour*
    231            #:*resolve-symlinks*
    232 
    233            #:asdf-version
    234 
    235            #:operation-error #:compile-failed #:compile-warned #:compile-error
    236            #:error-name
    237            #:error-pathname
    238            #:load-system-definition-error
    239            #:error-component #:error-operation
    240            #:system-definition-error
    241            #:missing-component
    242            #:missing-component-of-version
    243            #:missing-dependency
    244            #:missing-dependency-of-version
    245            #:circular-dependency        ; errors
    246            #:duplicate-names
    247 
    248            #:try-recompiling
    249            #:retry
    250            #:accept                     ; restarts
    251            #:coerce-entry-to-directory
    252            #:remove-entry-from-registry
    253 
    254            #:initialize-output-translations
    255            #:disable-output-translations
    256            #:clear-output-translations
    257            #:ensure-output-translations
    258            #:apply-output-translations
    259            #:compile-file-pathname*
    260            #:enable-asdf-binary-locations-compatibility
    261 
    262            #:*default-source-registries*
    263            #:initialize-source-registry
    264            #:compute-source-registry
    265            #:clear-source-registry
    266            #:ensure-source-registry
    267            #:process-source-registry))
    268         (eval `(defparameter ,(intern (string versym) (find-package :asdf)) ,asdf-version))))))
    269 
    270 (in-package #:asdf)
     200            #:system-source-file #:operate #:find-component)
     201           :unintern
     202           (#:*asdf-revision* #:around #:asdf-method-combination
     203            #:split #:make-collector)
     204           :fmakunbound
     205           (#:system-source-file
     206            #:component-relative-pathname #:system-relative-pathname
     207            #:process-source-registry
     208            #:inherit-source-registry #:process-source-registry-directive)
     209           :export
     210           (#:defsystem #:oos #:operate #:find-system #:run-shell-command
     211            #:system-definition-pathname #:find-component ; miscellaneous
     212            #:compile-system #:load-system #:test-system
     213            #:compile-op #:load-op #:load-source-op
     214            #:test-op
     215            #:operation               ; operations
     216            #:feature                 ; sort-of operation
     217            #:version                 ; metaphorically sort-of an operation
     218            #:version-satisfies
     219
     220            #:input-files #:output-files #:perform ; operation methods
     221            #:operation-done-p #:explain
     222
     223            #:component #:source-file
     224            #:c-source-file #:cl-source-file #:java-source-file
     225            #:static-file
     226            #:doc-file
     227            #:html-file
     228            #:text-file
     229            #:source-file-type
     230            #:module                     ; components
     231            #:system
     232            #:unix-dso
     233
     234            #:module-components          ; component accessors
     235            #:module-components-by-name  ; component accessors
     236            #:component-pathname
     237            #:component-relative-pathname
     238            #:component-name
     239            #:component-version
     240            #:component-parent
     241            #:component-property
     242            #:component-system
     243
     244            #:component-depends-on
     245
     246            #:system-description
     247            #:system-long-description
     248            #:system-author
     249            #:system-maintainer
     250            #:system-license
     251            #:system-licence
     252            #:system-source-file
     253            #:system-source-directory
     254            #:system-relative-pathname
     255            #:map-systems
     256
     257            #:operation-on-warnings
     258            #:operation-on-failure
     259            ;;#:*component-parent-pathname*
     260            #:*system-definition-search-functions*
     261            #:*central-registry*         ; variables
     262            #:*compile-file-warnings-behaviour*
     263            #:*compile-file-failure-behaviour*
     264            #:*resolve-symlinks*
     265            #:*asdf-verbose*
     266
     267            #:asdf-version
     268
     269            #:operation-error #:compile-failed #:compile-warned #:compile-error
     270            #:error-name
     271            #:error-pathname
     272            #:load-system-definition-error
     273            #:error-component #:error-operation
     274            #:system-definition-error
     275            #:missing-component
     276            #:missing-component-of-version
     277            #:missing-dependency
     278            #:missing-dependency-of-version
     279            #:circular-dependency        ; errors
     280            #:duplicate-names
     281
     282            #:try-recompiling
     283            #:retry
     284            #:accept                     ; restarts
     285            #:coerce-entry-to-directory
     286            #:remove-entry-from-registry
     287
     288            #:initialize-output-translations
     289            #:disable-output-translations
     290            #:clear-output-translations
     291            #:ensure-output-translations
     292            #:apply-output-translations
     293            #:compile-file-pathname*
     294            #:enable-asdf-binary-locations-compatibility
     295
     296            #:*default-source-registries*
     297            #:initialize-source-registry
     298            #:compute-source-registry
     299            #:clear-source-registry
     300            #:ensure-source-registry
     301            #:process-source-registry)))
     302        (let* ((version (intern* vername :asdf))
     303               (upvar (intern* '#:*upgraded-p* :asdf))
     304               (upval0 (and (boundp upvar) (symbol-value upvar)))
     305               (upval1 (if existing-version (cons existing-version upval0) upval0)))
     306          (eval `(progn
     307                   (defparameter ,version ,asdf-version)
     308                   (defparameter ,upvar ',upval1))))))))
     309
     310(in-package :asdf)
     311
     312;; More cleanups in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
     313#+gcl
     314(eval-when (:compile-toplevel :load-toplevel)
     315  (defvar *asdf-version* nil)
     316  (defvar *upgraded-p* nil))
     317(when *upgraded-p*
     318   #+ecl
     319   (when (find-class 'compile-op nil)
     320     (defmethod update-instance-for-redefined-class :after
     321         ((c compile-op) added deleted plist &key)
     322       (declare (ignore added deleted))
     323       (let ((system-p (getf plist 'system-p)))
     324         (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p)))))
     325   (when (find-class 'module nil)
     326     (eval
     327      '(defmethod update-instance-for-redefined-class :after
     328           ((m module) added deleted plist &key)
     329         (declare (ignorable deleted plist))
     330         (when (member 'components-by-name added)
     331           (compute-module-components-by-name m))))))
    271332
    272333;;;; -------------------------------------------------------------------------
     
    276337  "Exported interface to the version of ASDF currently installed. A string.
    277338You can compare this string with e.g.:
    278 (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"1.661\")."
     339(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"1.704\")."
    279340  *asdf-version*)
    280341
     
    289350
    290351(defvar *verbose-out* nil)
     352
     353(defvar *asdf-verbose* t)
    291354
    292355(defparameter +asdf-methods+
     
    302365
    303366;;;; -------------------------------------------------------------------------
    304 ;;;; Cleanups before hot-upgrade.
    305 ;;;; Things to do in case we're upgrading from a previous version of ASDF.
    306 ;;;; See https://bugs.launchpad.net/asdf/+bug/485687
    307 ;;;; * define methods on UPDATE-INSTANCE-FOR-REDEFINED-CLASS
    308 ;;;;   for each of the classes we define that has changed incompatibly.
    309 (eval-when (:compile-toplevel :load-toplevel :execute)
    310   #+ecl
    311   (when (find-class 'compile-op nil)
    312     (defmethod update-instance-for-redefined-class :after
    313         ((c compile-op) added deleted plist &key)
    314       (format *trace-output* "~&UI4RC:a ~S~%" (list c added deleted plist))
    315       (let ((system-p (getf plist 'system-p)))
    316         (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p))))))
    317 
    318 ;;;; -------------------------------------------------------------------------
    319367;;;; ASDF Interface, in terms of generic functions.
    320368
     
    325373(defgeneric output-files (operation component))
    326374(defgeneric input-files (operation component))
     375(defgeneric component-operation-time (operation component))
    327376
    328377(defgeneric system-source-file (system)
     
    348397(defgeneric version-satisfies (component version))
    349398
    350 (defgeneric find-component (module name &optional version)
    351   (:documentation "Finds the component with name NAME present in the
    352 MODULE module; if MODULE is nil, then the component is assumed to be a
    353 system."))
     399(defgeneric find-component (base path)
     400  (:documentation "Finds the component with PATH starting from BASE module;
     401if BASE is nil, then the component is assumed to be a system."))
    354402
    355403(defgeneric source-file-type (component system))
     
    366414of which is a computed key, so not interesting.  The
    367415CDR wil be the DATA value stored by VISIT-COMPONENT; recover
    368 it as \(cdr \(component-visited-p op c\)\).
     416it as (cdr (component-visited-p op c)).
    369417  In the current form of ASDF, the DATA value retrieved is
    370418effectively a boolean, indicating whether some operations are
     
    422470        (initial-values (mapcar (constantly nil) collectors)))
    423471    `(let ,(mapcar #'list vars initial-values)
    424        (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v))) collectors vars)
     472       (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars)
    425473         ,@body
    426          (values ,@(mapcar #'(lambda (v) `(nreverse ,v)) vars))))))
     474         (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))
    427475
    428476(defmacro aif (test then &optional else)
    429477  `(let ((it ,test)) (if it ,then ,else)))
    430 
    431 (defun pathname-sans-name+type (pathname)
    432   "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
    433 and NIL NAME and TYPE components.
    434 Issue: doesn't override the VERSION component.
    435 
    436 Deprecated. Use PATHNAME-DIRECTORY-PATHNAME instead."
    437   (make-pathname :name nil :type nil :defaults pathname))
    438478
    439479(defun pathname-directory-pathname (pathname)
     
    463503               (if (typep p 'logical-pathname) #'ununspecific #'identity)))
    464504      (multiple-value-bind (host device directory unspecific-handler)
    465           (ecase (first directory)
     505          (#-gcl ecase #+gcl case (first directory)
    466506            ((nil)
    467507             (values (pathname-host defaults)
     
    478518                     (pathname-device defaults)
    479519                     (append (pathname-directory defaults) (cdr directory))
     520                     (unspecific-handler defaults)))
     521            #+gcl
     522            (t
     523             (assert (stringp (first directory)))
     524             (values (pathname-host defaults)
     525                     (pathname-device defaults)
     526                     (append (pathname-directory defaults) directory)
    480527                     (unspecific-handler defaults))))
    481528        (make-pathname :host host :device device :directory directory
     
    485532
    486533(define-modify-macro appendf (&rest args)
    487   append "Append onto list")
     534  append "Append onto list") ;; only to be used on short lists.
     535
     536(define-modify-macro orf (&rest args)
     537  or "or a flag")
    488538
    489539(defun asdf-message (format-string &rest format-args)
     
    516566         ;; See CLHS make-pathname and 19.2.2.2.3.
    517567         ;; We only use it on implementations that support it.
    518          (or #+(or sbcl ccl ecl lispworks) :unspecific)))
     568         (or #+(or ccl ecl gcl lispworks sbcl) :unspecific)))
    519569    (destructuring-bind (name &optional (type unspecific))
    520570        (split-string filename :max 2 :separator ".")
     
    650700     :collect form)))
    651701
    652 #-windows
     702#-(and (or win32 windows mswindows mingw32) (not cygwin))
    653703(progn
    654704#+clisp (defun get-uid () (posix:uid))
     
    661711(defun get-uid ()
    662712  (let ((uid-string
    663          (with-output-to-string (asdf::*VERBOSE-OUT*)
    664            (asdf:run-shell-command "id -ur"))))
     713         (with-output-to-string (*verbose-out*)
     714           (run-shell-command "id -ur"))))
    665715    (with-input-from-string (stream uid-string)
    666716      (read-line stream)
     
    688738      (let ((sofar (ignore-errors (truename (pathname-root p)))))
    689739        (unless sofar (return p))
    690         (loop :for component :in (cdr directory)
    691           :for rest :on (cdr directory)
    692           :for more = (ignore-errors
    693                         (truename
    694                          (merge-pathnames*
    695                           (make-pathname :directory `(:relative ,component))
    696                           sofar))) :do
    697           (if more
    698               (setf sofar more)
    699               (return
    700                 (merge-pathnames*
    701                  (make-pathname :host nil :device nil
    702                                 :directory `(:relative ,@rest)
    703                                 :defaults p)
    704                  sofar)))
    705           :finally
    706           (return
    707             (merge-pathnames*
    708              (make-pathname :host nil :device nil
    709                             :directory nil
    710                             :defaults p)
    711              sofar)))))))
     740        (flet ((solution (directories)
     741                 (merge-pathnames*
     742                  (make-pathname :host nil :device nil
     743                                 :directory `(:relative ,@directories)
     744                                 :name (pathname-name p)
     745                                 :type (pathname-type p)
     746                                 :version (pathname-version p))
     747                  sofar)))
     748          (loop :for component :in (cdr directory)
     749            :for rest :on (cdr directory)
     750            :for more = (ignore-errors
     751                          (truename
     752                           (merge-pathnames*
     753                            (make-pathname :directory `(:relative ,component))
     754                            sofar))) :do
     755            (if more
     756                (setf sofar more)
     757                (return (solution rest)))
     758            :finally
     759            (return (solution nil))))))))
    712760
    713761(defun lispize-pathname (input-file)
     
    779827   (in-order-to :initform nil :initarg :in-order-to
    780828                :accessor component-in-order-to)
    781    ;; XXX crap name
     829   ;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to?
     830   (load-dependencies :accessor component-load-dependencies :initform nil)
     831   ;; XXX crap name, but it's an official API name!
    782832   (do-first :initform nil :initarg :do-first
    783833             :accessor component-do-first)
     
    798848               :initform nil)))
    799849
     850(defun component-find-path (component)
     851  (reverse
     852   (loop :for c = component :then (component-parent c)
     853     :while c :collect (component-name c))))
     854
     855(defmethod print-object ((c component) stream)
     856  (print-unreadable-object (c stream :type t :identity nil)
     857    (format stream "~@<~{~S~^ ~}~@:>" (component-find-path c))))
     858
     859
    800860;;;; methods: conditions
    801861
     
    830890       component))
    831891
    832 (defmethod print-object ((c component) stream)
    833   (print-unreadable-object (c stream :type t :identity t)
    834     (ignore-errors
    835       (prin1 (component-name c) stream))))
     892(defvar *default-component-class* 'cl-source-file)
     893
     894(defun compute-module-components-by-name (module)
     895  (let ((hash (module-components-by-name module)))
     896    (clrhash hash)
     897    (loop :for c :in (module-components module)
     898      :for name = (component-name c)
     899      :for previous = (gethash name (module-components-by-name module))
     900      :do
     901      (when previous
     902        (error 'duplicate-names :name name))
     903      :do (setf (gethash name (module-components-by-name module)) c))
     904    hash))
    836905
    837906(defclass module (component)
    838   ((components :initform nil :accessor module-components :initarg :components)
    839    ;; what to do if we can't satisfy a dependency of one of this module's
    840    ;; components.  This allows a limited form of conditional processing
    841    (if-component-dep-fails :initform :fail
    842                            :accessor module-if-component-dep-fails
    843                            :initarg :if-component-dep-fails)
    844    (default-component-class :accessor module-default-component-class
    845      :initform 'cl-source-file :initarg :default-component-class)))
     907  ((components
     908    :initform nil
     909    :initarg :components
     910    :accessor module-components)
     911   (components-by-name
     912    :initform (make-hash-table :test 'equal)
     913    :accessor module-components-by-name)
     914   ;; What to do if we can't satisfy a dependency of one of this module's
     915   ;; components.  This allows a limited form of conditional processing.
     916   (if-component-dep-fails
     917    :initform :fail
     918    :initarg :if-component-dep-fails
     919    :accessor module-if-component-dep-fails)
     920   (default-component-class
     921    :initform *default-component-class*
     922    :initarg :default-component-class
     923    :accessor module-default-component-class)))
    846924
    847925(defun component-parent-pathname (component)
     
    9851063               (when defaults
    9861064                 (cond ((directory-pathname-p defaults)
    987                         (let ((file (and defaults
    988                                          (make-pathname
    989                                           :defaults defaults :version :newest
    990                                           :name name :type "asd" :case :local)))
    991                                #+(and (or win32 windows) (not :clisp))
    992                                (shortcut (make-pathname
    993                                           :defaults defaults :version :newest
    994                                           :name name :type "asd.lnk" :case :local)))
    995                           (if (and file (probe-file file))
    996                               (return file))
    997                           #+(and (or win32 windows) (not :clisp))
    998                           (when (probe-file shortcut)
    999                             (let ((target (parse-windows-shortcut shortcut)))
    1000                               (when target
    1001                                 (return (pathname target)))))))
     1065                        (let ((file (probe-asd name defaults)))
     1066                          (when file
     1067                            (return file))))
    10021068                       (t
    10031069                        (restart-case
     
    10321098  (flet ((try (counter)
    10331099           (ignore-errors
    1034              (make-package (format nil "~a~D" 'asdf counter)
     1100             (make-package (format nil "~A~D" :asdf counter)
    10351101                           :use '(:cl :asdf)))))
    10361102    (do* ((counter 0 (+ counter 1))
     
    10391105
    10401106(defun safe-file-write-date (pathname)
    1041            ;; if FILE-WRITE-DATE returns NIL, it's possible that the
    1042            ;; user or some other agent has deleted an input file.  If
    1043            ;; that's the case, well, that's not good, but as long as
    1044            ;; the operation is otherwise considered to be done we
    1045            ;; could continue and survive.
    1046   (or (and pathname (file-write-date pathname))
     1107  ;; If FILE-WRITE-DATE returns NIL, it's possible that
     1108  ;; the user or some other agent has deleted an input file.
     1109  ;; Also, generated files will not exist at the time planning is done
     1110  ;; and calls operation-done-p which calls safe-file-write-date.
     1111  ;; So it is very possible that we can't get a valid file-write-date,
     1112  ;; and we can survive and we will continue the planning
     1113  ;; as if the file were very old.
     1114  ;; (or should we treat the case in a different, special way?)
     1115  (or (and pathname (probe-file pathname) (file-write-date pathname))
    10471116      (progn
    1048         (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero."
    1049               pathname)
     1117        (when pathname
     1118          (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero."
     1119                pathname))
    10501120        0)))
    10511121
     
    10671137                 (asdf-message
    10681138                  "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
    1069                   ;; FIXME: This wants to be (ENOUGH-NAMESTRING
    1070                   ;; ON-DISK), but CMUCL barfs on that.
    1071                   on-disk
    1072                   *package*)
     1139                  on-disk *package*)
    10731140                 (load on-disk)))
    10741141          (delete-package package))))
     
    10891156;;;; Finding components
    10901157
    1091 (defmethod find-component ((module module) name &optional version)
    1092   (if (slot-boundp module 'components)
    1093       (let ((m (find name (module-components module)
    1094                      :test #'equal :key #'component-name)))
    1095         (if (and m (version-satisfies m version)) m))))
    1096 
    1097 
    1098 ;;; a component with no parent is a system
    1099 (defmethod find-component ((module (eql nil)) name &optional version)
    1100   (declare (ignorable module))
    1101   (let ((m (find-system name nil)))
    1102     (if (and m (version-satisfies m version)) m)))
     1158(defmethod find-component ((base string) path)
     1159  (let ((s (find-system base nil)))
     1160    (and s (find-component s path))))
     1161
     1162(defmethod find-component ((base symbol) path)
     1163  (cond
     1164    (base (find-component (coerce-name base) path))
     1165    (path (find-component path nil))
     1166    (t    nil)))
     1167
     1168(defmethod find-component ((base cons) path)
     1169  (find-component (car base) (cons (cdr base) path)))
     1170
     1171(defmethod find-component ((module module) (name string))
     1172  (when (slot-boundp module 'components-by-name)
     1173    (values (gethash name (module-components-by-name module)))))
     1174
     1175(defmethod find-component ((component component) (name symbol))
     1176  (if name
     1177      (find-component component (coerce-name name))
     1178      component))
     1179
     1180(defmethod find-component ((module module) (name cons))
     1181  (find-component (find-component module (car name)) (cdr name)))
     1182
    11031183
    11041184;;; component subclasses
     
    11181198  ((type :initform "html")))
    11191199
    1120 (defmethod source-file-type ((component module) (s module)) :directory)
     1200(defmethod source-file-type ((component module) (s module))
     1201  (declare (ignorable component s))
     1202  :directory)
    11211203(defmethod source-file-type ((component source-file) (s module))
     1204  (declare (ignorable s))
    11221205  (source-file-explicit-type component))
    11231206
     
    11671250(defclass operation ()
    11681251  (
    1169    ;; what is the TYPE of this slot?  seems like it should be boolean,
    1170    ;; but TRAVERSE checks to see if it's a list of component names...
    1171    ;; [2010/02/07:rpg]
     1252   ;; as of danb's 2003-03-16 commit e0d02781, :force can be:
     1253   ;; T to force the inside of existing system,
     1254   ;;   but not recurse to other systems we depend on.
     1255   ;; :ALL (or any other atom) to force all systems
     1256   ;;   including other systems we depend on.
     1257   ;; (SYSTEM1 SYSTEM2 ... SYSTEMN)
     1258   ;;   to force systems named in a given list
     1259   ;;   (but this feature never worked before ASDF 1.700 and is cerror'ed out.)
    11721260   (forced :initform nil :initarg :force :accessor operation-forced)
    11731261   (original-initargs :initform nil :initarg :original-initargs
    11741262                      :accessor operation-original-initargs)
    1175    (visited-nodes :initform nil :accessor operation-visited-nodes)
    1176    (visiting-nodes :initform nil :accessor operation-visiting-nodes)
     1263   (visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes)
     1264   (visiting-nodes :initform (make-hash-table :test 'equal) :accessor operation-visiting-nodes)
    11771265   (parent :initform nil :initarg :parent :accessor operation-parent)))
    11781266
     
    12231311(defmethod visit-component ((o operation) (c component) data)
    12241312  (unless (component-visited-p o c)
    1225     (push (cons (node-for o c) data)
    1226           (operation-visited-nodes (operation-ancestor o)))))
     1313    (setf (gethash (node-for o c)
     1314                   (operation-visited-nodes (operation-ancestor o)))
     1315          (cons t data))))
    12271316
    12281317(defmethod component-visited-p ((o operation) (c component))
    1229   (assoc (node-for o c)
    1230          (operation-visited-nodes (operation-ancestor o))
    1231          :test 'equal))
     1318  (gethash (node-for o c)
     1319           (operation-visited-nodes (operation-ancestor o))))
    12321320
    12331321(defmethod (setf visiting-component) (new-value operation component)
     
    12401328        (a (operation-ancestor o)))
    12411329    (if new-value
    1242         (pushnew node (operation-visiting-nodes a) :test 'equal)
    1243         (setf (operation-visiting-nodes a)
    1244               (remove node  (operation-visiting-nodes a) :test 'equal))))
    1245   new-value)
     1330        (setf (gethash node (operation-visiting-nodes a)) t)
     1331        (remhash node (operation-visiting-nodes a)))
     1332    new-value))
    12461333
    12471334(defmethod component-visiting-p ((o operation) (c component))
    12481335  (let ((node (node-for o c)))
    1249     (member node (operation-visiting-nodes (operation-ancestor o))
    1250             :test 'equal)))
     1336    (gethash node (operation-visiting-nodes (operation-ancestor o)))))
    12511337
    12521338(defmethod component-depends-on ((op-spec symbol) (c component))
     
    12761362        (list (component-pathname c)))))
    12771363
    1278 (defmethod input-files ((operation operation) (c module)) nil)
     1364(defmethod input-files ((operation operation) (c module))
     1365  (declare (ignorable operation c))
     1366  nil)
     1367
     1368(defmethod component-operation-time (o c)
     1369  (gethash (type-of o) (component-operation-times c)))
    12791370
    12801371(defmethod operation-done-p ((o operation) (c component))
    12811372  (let ((out-files (output-files o c))
    12821373        (in-files (input-files o c))
    1283         (op-time (gethash (type-of o) (component-operation-times c))))
     1374        (op-time (component-operation-time o c)))
    12841375    (flet ((earliest-out ()
    12851376             (reduce #'min (mapcar #'safe-file-write-date out-files)))
     
    13241415
    13251416
    1326 ;;; So you look at this code and think "why isn't it a bunch of
    1327 ;;; methods".  And the answer is, because standard method combination
    1328 ;;; runs :before methods most->least-specific, which is back to front
    1329 ;;; for our purposes.
     1417
     1418;;; For 1.700 I've done my best to refactor TRAVERSE
     1419;;; by splitting it up in a bunch of functions,
     1420;;; so as to improve the collection and use-detection algorithm. --fare
     1421;;; The protocol is as follows: we pass around operation, dependency,
     1422;;; bunch of other stuff, and a force argument. Return a force flag.
     1423;;; The returned flag is T if anything has changed that requires a rebuild.
     1424;;; The force argument is a list of components that will require a rebuild
     1425;;; if the flag is T, at which point whoever returns the flag has to
     1426;;; mark them all as forced, and whoever recurses again can use a NIL list
     1427;;; as a further argument.
    13301428
    13311429(defvar *forcing* nil
     
    13331431recursive calls to traverse.")
    13341432
    1335 (defmethod traverse ((operation operation) (c component))
    1336   (let ((forced nil))                   ;return value -- everyone side-effects onto this
    1337     (labels ((%do-one-dep (required-op required-c required-v)
    1338                ;; returns a partial plan that results from performing required-op
    1339                ;; on required-c, possibly with a required-vERSION
    1340                (let* ((dep-c (or (find-component
    1341                                   (component-parent c)
    1342                                   ;; XXX tacky.  really we should build the
    1343                                   ;; in-order-to slot with canonicalized
    1344                                   ;; names instead of coercing this late
    1345                                   (coerce-name required-c) required-v)
    1346                                  (if required-v
    1347                                      (error 'missing-dependency-of-version
    1348                                             :required-by c
    1349                                             :version required-v
    1350                                             :requires required-c)
    1351                                      (error 'missing-dependency
    1352                                             :required-by c
    1353                                             :requires required-c))))
    1354                       (op (make-sub-operation c operation dep-c required-op)))
    1355                  (traverse op dep-c)))
    1356              (do-one-dep (required-op required-c required-v)
    1357                ;; this function is a thin, error-handling wrapper around
    1358                ;; %do-one-dep.  Returns a partial plan per that function.
    1359                (loop
    1360                  (restart-case
    1361                      (return (%do-one-dep required-op required-c required-v))
    1362                    (retry ()
    1363                      :report (lambda (s)
    1364                                (format s "~@<Retry loading component ~S.~@:>"
    1365                                        required-c))
    1366                      :test
    1367                      (lambda (c)
    1368 #|
    1369                         (print (list :c1 c (typep c 'missing-dependency)))
    1370                         (when (typep c 'missing-dependency)
    1371                           (print (list :c2 (missing-requires c) required-c
    1372                                        (equalp (missing-requires c)
    1373                                                required-c))))
    1374 |#
    1375                        (or (null c)
    1376                            (and (typep c 'missing-dependency)
    1377                                 (equalp (missing-requires c)
    1378                                         required-c))))))))
    1379              (do-dep (op dep)
    1380                ;; type of arguments uncertain:  op seems to at least potentially be a
    1381                ;; symbol, rather than an operation
    1382                ;; dep is either a list of component names (?) or (we hope) a single
    1383                ;; component name.
    1384                ;; handle a single dependency, returns nothing of interest --- side-
    1385                ;; effects onto the FORCED variable, which is scoped over TRAVERSE
    1386                (cond ((eq op 'feature)
    1387                       (or (member (car dep) *features*)
    1388                           (error 'missing-dependency
    1389                                  :required-by c
    1390                                  :requires (car dep))))
    1391                      (t
    1392                       (dolist (d dep)
    1393                         ;; structured dependencies --- this parses keywords
    1394                         ;; the keywords could be broken out and cleanly (extensibly)
    1395                         ;; processed by EQL methods, but for the pervasive side-effecting
    1396                         ;; onto FORCED
    1397                         (cond ((consp d)
    1398                                (cond ((string-equal
    1399                                        (symbol-name (first d))
    1400                                        "VERSION")
    1401                                       ;; https://bugs.launchpad.net/asdf/+bug/527788
    1402                                       (appendf
    1403                                        forced
    1404                                        (do-one-dep op (second d) (third d))))
    1405                                      ;; this particular subform is not documented, indeed
    1406                                      ;; clashes with the documentation, since it assumes a
    1407                                      ;; third component.
    1408                                      ;; See https://bugs.launchpad.net/asdf/+bug/518467
    1409                                      ((and (string-equal
    1410                                             (symbol-name (first d))
    1411                                             "FEATURE")
    1412                                            (find (second d) *features*
    1413                                                  :test 'string-equal))
    1414                                       (appendf
    1415                                        forced
    1416                                        (do-one-dep op (third d) nil)))
    1417                                      (t
    1418                                       (error "Bad dependency ~a.  Dependencies must be (:version <version>), (:feature <feature> [version]), or a name" d))))
    1419                               (t
    1420                                (appendf forced (do-one-dep op d nil)))))))))
     1433(defgeneric do-traverse (operation component collect))
     1434
     1435(defun %do-one-dep (operation c collect required-op required-c required-v)
     1436  ;; collects a partial plan that results from performing required-op
     1437  ;; on required-c, possibly with a required-vERSION
     1438  (let* ((dep-c (or (let ((d (find-component (component-parent c) required-c)))
     1439                      (and d (version-satisfies d required-v) d))
     1440                    (if required-v
     1441                        (error 'missing-dependency-of-version
     1442                               :required-by c
     1443                               :version required-v
     1444                               :requires required-c)
     1445                        (error 'missing-dependency
     1446                               :required-by c
     1447                               :requires required-c))))
     1448         (op (make-sub-operation c operation dep-c required-op)))
     1449    (do-traverse op dep-c collect)))
     1450
     1451(defun do-one-dep (operation c collect required-op required-c required-v)
     1452  ;; this function is a thin, error-handling wrapper around
     1453  ;; %do-one-dep.  Returns a partial plan per that function.
     1454  (loop
     1455    (restart-case
     1456        (return (%do-one-dep operation c collect
     1457                             required-op required-c required-v))
     1458      (retry ()
     1459        :report (lambda (s)
     1460                  (format s "~@<Retry loading component ~S.~@:>"
     1461                          required-c))
     1462        :test
     1463        (lambda (c)
     1464          #|
     1465          (print (list :c1 c (typep c 'missing-dependency)))
     1466          (when (typep c 'missing-dependency)
     1467          (print (list :c2 (missing-requires c) required-c
     1468          (equalp (missing-requires c)
     1469          required-c))))
     1470          |#
     1471          (or (null c)
     1472              (and (typep c 'missing-dependency)
     1473                   (equalp (missing-requires c)
     1474                           required-c))))))))
     1475
     1476(defun do-dep (operation c collect op dep)
     1477  ;; type of arguments uncertain:
     1478  ;; op seems to at least potentially be a symbol, rather than an operation
     1479  ;; dep is a list of component names
     1480  (cond ((eq op 'feature)
     1481         (if (member (car dep) *features*)
     1482             nil
     1483             (error 'missing-dependency
     1484                    :required-by c
     1485                    :requires (car dep))))
     1486        (t
     1487         (let ((flag nil))
     1488           (flet ((dep (op comp ver)
     1489                    (when (do-one-dep operation c collect
     1490                                      op comp ver)
     1491                      (setf flag t))))
     1492             (dolist (d dep)
     1493               (if (atom d)
     1494                   (dep op d nil)
     1495                   ;; structured dependencies --- this parses keywords
     1496                   ;; the keywords could be broken out and cleanly (extensibly)
     1497                   ;; processed by EQL methods
     1498                   (cond ((eq :version (first d))
     1499                          ;; https://bugs.launchpad.net/asdf/+bug/527788
     1500                          (dep op (second d) (third d)))
     1501                         ;; This particular subform is not documented and
     1502                         ;; has always been broken in the past.
     1503                         ;; Therefore no one uses it, and I'm cerroring it out,
     1504                         ;; after fixing it
     1505                         ;; See https://bugs.launchpad.net/asdf/+bug/518467
     1506                         ((eq :feature (first d))
     1507                          (cerror "Continue nonetheless."
     1508                                  "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.")
     1509                          (when (find (second d) *features* :test 'string-equal)
     1510                            (dep op (third d) nil)))
     1511                         (t
     1512                          (error "Bad dependency ~a.  Dependencies must be (:version <version>), (:feature <feature> [version]), or a name" d))))))
     1513           flag))))
     1514
     1515(defun do-collect (collect x)
     1516  (funcall collect x))
     1517
     1518(defmethod do-traverse ((operation operation) (c component) collect)
     1519  (let ((flag nil)) ;; return value: must we rebuild this and its dependencies?
     1520    (labels
     1521        ((update-flag (x)
     1522           (when x
     1523             (setf flag t)))
     1524         (dep (op comp)
     1525           (update-flag (do-dep operation c collect op comp))))
     1526      ;; Have we been visited yet? If so, just process the result.
    14211527      (aif (component-visited-p operation c)
    1422            (return-from traverse
    1423              (if (cdr it) (list (cons 'pruned-op c)) nil)))
     1528           (progn
     1529             (update-flag (cdr it))
     1530             (return-from do-traverse flag)))
    14241531      ;; dependencies
    1425       (if (component-visiting-p operation c)
    1426           (error 'circular-dependency :components (list c)))
     1532      (when (component-visiting-p operation c)
     1533        (error 'circular-dependency :components (list c)))
    14271534      (setf (visiting-component operation c) t)
    14281535      (unwind-protect
    1429           (progn
    1430             ;; first we check and do all the dependencies for the
    1431             ;; module.  Operations planned in this loop will show up
    1432             ;; in the contents of the FORCED variable, and are consumed
    1433             ;; downstream (watch out for the shadowing FORCED variable
    1434             ;; around the DOLIST below!)
    1435             (let ((*forcing* nil))
    1436               ;; upstream dependencies are never forced to happen just because
    1437               ;; the things that depend on them are....
    1438               (loop :for (required-op . deps) :in
    1439                                               (component-depends-on operation c)
    1440                     :do (do-dep required-op deps)))
    1441             ;; constituent bits
    1442             (let ((module-ops
    1443                    (when (typep c 'module)
    1444                      (let ((at-least-one nil)
    1445                            (forced nil)
    1446                            ;; this is set based on the results of the
    1447                            ;; dependencies and whether we are in the
    1448                            ;; context of a *forcing* call...
    1449                            (must-operate (or *forcing*
    1450                                              ;; inter-system dependencies do NOT trigger
    1451                                              ;; building components
    1452                                              (and
    1453                                               (not (typep c 'system))
    1454                                               forced)))
    1455                            (error nil))
    1456                        (dolist (kid (module-components c))
    1457                            (handler-case
    1458                                (let ((*forcing* must-operate))
    1459                                  (appendf forced (traverse operation kid)))
    1460                              (missing-dependency (condition)
    1461                                (when (eq (module-if-component-dep-fails c)
    1462                                        :fail)
    1463                                    (error condition))
    1464                                (setf error condition))
    1465                              (:no-error (c)
    1466                                (declare (ignore c))
    1467                                (setf at-least-one t))))
    1468                        (when (and (eq (module-if-component-dep-fails c)
    1469                                       :try-next)
    1470                                   (not at-least-one))
    1471                          (error error))
    1472                        forced))))
    1473               ;; now the thing itself
    1474               ;; the test here is a bit oddly written.  FORCED here doesn't
    1475               ;; mean that this operation is forced on this component, but that
    1476               ;; something upstream of this component has been forced.
    1477               (when (or forced module-ops
    1478                         *forcing*
    1479                         (not (operation-done-p operation c))
    1480                         (let ((f (operation-forced
    1481                                   (operation-ancestor operation))))
    1482                           ;; does anyone fully understand the following condition?
    1483                           ;; if so, please add a comment to explain it...
    1484                           (and f (or (not (consp f))
    1485                                      (member (component-name
    1486                                               (operation-ancestor operation))
    1487                                              (mapcar #'coerce-name f)
    1488                                              ;; this was string=, but for the benefit
    1489                                              ;; of mlisp, we use string-equal for this
    1490                                              ;; purpose.
    1491                                              :test #'string-equal)))))
    1492                 (let ((do-first (cdr (assoc (class-name (class-of operation))
    1493                                             (component-do-first c)))))
    1494                   (loop :for (required-op . deps) :in do-first
    1495                         :do (do-dep required-op deps)))
    1496                 (setf forced (append (delete 'pruned-op forced :key #'car)
    1497                                      (delete 'pruned-op module-ops :key #'car)
    1498                                      (list (cons operation c)))))))
    1499         (setf (visiting-component operation c) nil))
    1500       (visit-component operation c (and forced t))
    1501       forced)))
    1502 
     1536           (progn
     1537             ;; first we check and do all the dependencies for the module.
     1538             ;; Operations planned in this loop will show up
     1539             ;; in the results, and are consumed below.
     1540             (let ((*forcing* nil))
     1541               ;; upstream dependencies are never forced to happen just because
     1542               ;; the things that depend on them are....
     1543               (loop
     1544                 :for (required-op . deps) :in (component-depends-on operation c)
     1545                 :do (dep required-op deps)))
     1546             ;; constituent bits
     1547             (let ((module-ops
     1548                    (when (typep c 'module)
     1549                      (let ((at-least-one nil)
     1550                            ;; This is set based on the results of the
     1551                            ;; dependencies and whether we are in the
     1552                            ;; context of a *forcing* call...
     1553                            ;; inter-system dependencies do NOT trigger
     1554                            ;; building components
     1555                            (*forcing*
     1556                             (or *forcing*
     1557                                 (and flag (not (typep c 'system)))))
     1558                            (error nil))
     1559                        (while-collecting (internal-collect)
     1560                          (dolist (kid (module-components c))
     1561                            (handler-case
     1562                                (update-flag
     1563                                 (do-traverse operation kid #'internal-collect))
     1564                              (missing-dependency (condition)
     1565                                (when (eq (module-if-component-dep-fails c)
     1566                                          :fail)
     1567                                  (error condition))
     1568                                (setf error condition))
     1569                              (:no-error (c)
     1570                                (declare (ignore c))
     1571                                (setf at-least-one t))))
     1572                          (when (and (eq (module-if-component-dep-fails c)
     1573                                         :try-next)
     1574                                     (not at-least-one))
     1575                            (error error)))))))
     1576               (update-flag
     1577                (or
     1578                 *forcing*
     1579                 (not (operation-done-p operation c))
     1580                 ;; For sub-operations, check whether
     1581                 ;; the original ancestor operation was forced,
     1582                 ;; or names us amongst an explicit list of things to force...
     1583                 ;; except that this check doesn't distinguish
     1584                 ;; between all the things with a given name. Sigh.
     1585                 ;; BROKEN!
     1586                 (let ((f (operation-forced
     1587                           (operation-ancestor operation))))
     1588                   (and f (or (not (consp f)) ;; T or :ALL
     1589                              (and (typep c 'system) ;; list of names of systems to force
     1590                                   (member (component-name c) f
     1591                                           :test #'string=)))))))
     1592               (when flag
     1593                 (let ((do-first (cdr (assoc (class-name (class-of operation))
     1594                                             (component-do-first c)))))
     1595                   (loop :for (required-op . deps) :in do-first
     1596                     :do (do-dep operation c collect required-op deps)))
     1597                 (do-collect collect (vector module-ops))
     1598                 (do-collect collect (cons operation c)))))
     1599             (setf (visiting-component operation c) nil)))
     1600      (visit-component operation c flag)
     1601      flag))
     1602
     1603(defmethod traverse ((operation operation) (c component))
     1604  ;; cerror'ing a feature that seems to have NEVER EVER worked
     1605  ;; ever since danb created it in his 2003-03-16 commit e0d02781.
     1606  ;; It was both fixed and disabled in the 1.700 rewrite.
     1607  (when (consp (operation-forced operation))
     1608    (cerror "Continue nonetheless."
     1609            "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.")
     1610    (setf (operation-forced operation)
     1611          (mapcar #'coerce-name (operation-forced operation))))
     1612  (flatten-tree
     1613   (while-collecting (collect)
     1614     (do-traverse operation c #'collect))))
     1615
     1616(defun flatten-tree (l)
     1617  ;; You collected things into a list.
     1618  ;; Most elements are just things to collect again.
     1619  ;; A (simple-vector 1) indicate that you should recurse into its contents.
     1620  ;; This way, in two passes (rather than N being the depth of the tree),
     1621  ;; you can collect things with marginally constant-time append,
     1622  ;; achieving linear time collection instead of quadratic time.
     1623  (while-collecting (c)
     1624    (labels ((r (x)
     1625               (if (typep x '(simple-vector 1))
     1626                   (r* (svref x 0))
     1627                   (c x)))
     1628             (r* (l)
     1629               (dolist (x l) (r x))))
     1630      (r* l))))
    15031631
    15041632(defmethod perform ((operation operation) (c source-file))
     
    15091637
    15101638(defmethod perform ((operation operation) (c module))
     1639  (declare (ignorable operation c))
    15111640  nil)
    15121641
     
    15331662  ;; Note how we use OUTPUT-FILES to find the binary locations
    15341663  ;; This allows the user to override the names.
    1535   (let* ((input (output-files o c))
    1536          (output (compile-file-pathname (lispize-pathname (first input)) :type :fasl)))
    1537     (c:build-fasl output :lisp-files (remove "fas" input :key #'pathname-type :test #'string=))))
     1664  (let* ((files (output-files o c))
     1665         (object (first files))
     1666         (fasl (second files)))
     1667    (c:build-fasl fasl :lisp-files (list object))))
    15381668
    15391669(defmethod perform :after ((operation operation) (c component))
     
    15681698
    15691699(defmethod output-files ((operation compile-op) (c cl-source-file))
     1700  (declare (ignorable operation))
    15701701  (let ((p (lispize-pathname (component-pathname c))))
    15711702    #-:broken-fasl-loader
    1572     (list #-ecl (compile-file-pathname p)
    1573           #+ecl (compile-file-pathname p :type :object)
     1703    (list (compile-file-pathname p #+ecl :type #+ecl :object)
    15741704          #+ecl (compile-file-pathname p :type :fasl))
    15751705    #+:broken-fasl-loader (list p)))
    15761706
    15771707(defmethod perform ((operation compile-op) (c static-file))
     1708  (declare (ignorable operation c))
    15781709  nil)
    15791710
    15801711(defmethod output-files ((operation compile-op) (c static-file))
     1712  (declare (ignorable operation c))
    15811713  nil)
    15821714
    1583 (defmethod input-files ((op compile-op) (c static-file))
     1715(defmethod input-files ((operation compile-op) (c static-file))
     1716  (declare (ignorable operation c))
    15841717  nil)
    15851718
     
    16031736
    16041737(defmethod perform-with-restarts ((o load-op) (c cl-source-file))
    1605   (let ((state :initial))
    1606     (loop :until (or (eq state :success)
    1607                      (eq state :failure)) :do
    1608          (case state
    1609            (:recompiled
    1610             (setf state :failure)
    1611             (call-next-method)
    1612             (setf state :success))
    1613            (:failed-load
    1614             (setf state :recompiled)
    1615             (perform (make-instance 'compile-op) c))
    1616            (t
    1617             (with-simple-restart
    1618                 (try-recompiling "Recompile ~a and try loading it again"
    1619                                   (component-name c))
    1620               (setf state :failed-load)
    1621               (call-next-method)
    1622               (setf state :success)))))))
     1738  (declare (ignorable o))
     1739  (loop :with state = :initial
     1740    :until (or (eq state :success)
     1741               (eq state :failure)) :do
     1742    (case state
     1743      (:recompiled
     1744       (setf state :failure)
     1745       (call-next-method)
     1746       (setf state :success))
     1747      (:failed-load
     1748       (setf state :recompiled)
     1749       (perform (make-instance 'compile-op) c))
     1750      (t
     1751       (with-simple-restart
     1752           (try-recompiling "Recompile ~a and try loading it again"
     1753                            (component-name c))
     1754         (setf state :failed-load)
     1755         (call-next-method)
     1756         (setf state :success))))))
     1757
     1758(defmethod perform-with-restarts ((o compile-op) (c cl-source-file))
     1759  (loop :with state = :initial
     1760    :until (or (eq state :success)
     1761               (eq state :failure)) :do
     1762    (case state
     1763      (:recompiled
     1764       (setf state :failure)
     1765       (call-next-method)
     1766       (setf state :success))
     1767      (:failed-compile
     1768       (setf state :recompiled)
     1769       (perform-with-restarts o c))
     1770      (t
     1771       (with-simple-restart
     1772           (try-recompiling "Try recompiling ~a"
     1773                            (component-name c))
     1774         (setf state :failed-compile)
     1775         (call-next-method)
     1776         (setf state :success))))))
    16231777
    16241778(defmethod perform ((operation load-op) (c static-file))
     1779  (declare (ignorable operation c))
    16251780  nil)
    16261781
    16271782(defmethod operation-done-p ((operation load-op) (c static-file))
     1783  (declare (ignorable operation c))
    16281784  t)
    16291785
    1630 (defmethod output-files ((o operation) (c component))
     1786(defmethod output-files ((operation operation) (c component))
     1787  (declare (ignorable operation c))
    16311788  nil)
    16321789
    16331790(defmethod component-depends-on ((operation load-op) (c component))
     1791  (declare (ignorable operation))
    16341792  (cons (list 'compile-op (component-name c))
    16351793        (call-next-method)))
     
    16411799
    16421800(defmethod perform ((o load-source-op) (c cl-source-file))
     1801  (declare (ignorable o))
    16431802  (let ((source (component-pathname c)))
    16441803    (setf (component-property c 'last-loaded-as-source)
     
    16471806
    16481807(defmethod perform ((operation load-source-op) (c static-file))
     1808  (declare (ignorable operation c))
    16491809  nil)
    16501810
    16511811(defmethod output-files ((operation load-source-op) (c component))
     1812  (declare (ignorable operation c))
    16521813  nil)
    16531814
    16541815;;; FIXME: we simply copy load-op's dependencies.  this is Just Not Right.
    16551816(defmethod component-depends-on ((o load-source-op) (c component))
     1817  (declare (ignorable o))
    16561818  (let ((what-would-load-op-do (cdr (assoc 'load-op
    16571819                                           (component-in-order-to c)))))
     
    16631825
    16641826(defmethod operation-done-p ((o load-source-op) (c source-file))
     1827  (declare (ignorable o))
    16651828  (if (or (not (component-property c 'last-loaded-as-source))
    16661829          (> (safe-file-write-date (component-pathname c))
     
    16751838
    16761839(defmethod perform ((operation test-op) (c component))
     1840  (declare (ignorable operation c))
    16771841  nil)
    16781842
    16791843(defmethod operation-done-p ((operation test-op) (c system))
    16801844  "Testing a system is _never_ done."
     1845  (declare (ignorable operation c))
    16811846  nil)
    16821847
    16831848(defmethod component-depends-on :around ((o test-op) (c system))
     1849  (declare (ignorable o))
    16841850  (cons `(load-op ,(component-name c)) (call-next-method)))
    16851851
     
    16881854;;;; Invoking Operations
    16891855
    1690 (defun operate (operation-class system &rest args &key (verbose t) version force
    1691                 &allow-other-keys)
     1856(defgeneric operate (operation-class system &key &allow-other-keys))
     1857
     1858(defmethod operate (operation-class system &rest args
     1859                    &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force
     1860                    &allow-other-keys)
    16921861  (declare (ignore force))
    16931862  (let* ((*package* *package*)
     
    16961865                    :original-initargs args
    16971866                    args))
    1698          (*verbose-out* (if verbose *standard-output* (make-broadcast-stream)))
     1867         (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
    16991868         (system (if (typep system 'component) system (find-system system))))
    17001869    (unless (version-satisfies system version)
     
    17051874          (loop
    17061875            (restart-case
    1707                 (progn (perform-with-restarts op component)
    1708                        (return))
     1876                (progn
     1877                  (perform-with-restarts op component)
     1878                  (return))
    17091879              (retry ()
    17101880                :report
     
    17241894    op))
    17251895
    1726 (defun oos (operation-class system &rest args &key force (verbose t) version
     1896(defun oos (operation-class system &rest args &key force verbose version
    17271897            &allow-other-keys)
    17281898  (declare (ignore force verbose version))
     
    17541924        operate-docstring))
    17551925
    1756 (defun load-system (system &rest args &key force (verbose t) version
     1926(defun load-system (system &rest args &key force verbose version
    17571927                    &allow-other-keys)
    17581928  "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for
     
    17611931  (apply #'operate 'load-op system args))
    17621932
    1763 (defun compile-system (system &rest args &key force (verbose t) version
     1933(defun compile-system (system &rest args &key force verbose version
    17641934                       &allow-other-keys)
    17651935  "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE
     
    17681938  (apply #'operate 'compile-op system args))
    17691939
    1770 (defun test-system (system &rest args &key force (verbose t) version
     1940(defun test-system (system &rest args &key force verbose version
    17711941                    &allow-other-keys)
    17721942  "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for
     
    18011971(defmacro defsystem (name &body options)
    18021972  (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
    1803                             &allow-other-keys)
     1973                            defsystem-depends-on &allow-other-keys)
    18041974      options
    1805     (let ((component-options (remove-keyword :class options)))
     1975    (let ((component-options (remove-keys '(:defsystem-depends-on :class) options)))
    18061976      `(progn
    18071977         ;; system must be registered before we parse the body, otherwise
    18081978         ;; we recur when trying to find an existing system of the same name
    18091979         ;; to reuse options (e.g. pathname) from
     1980         ,@(loop :for system :in defsystem-depends-on
     1981             :collect `(load-system ,system))
    18101982         (let ((s (system-registered-p ',name)))
    18111983           (cond ((and s (eq (type-of (cdr s)) ',class))
     
    18191991                                    (cdr (system-registered-p ',name))))
    18201992         (parse-component-form
    1821           nil (apply
    1822                #'list
     1993          nil (list*
    18231994               :module (coerce-name ',name)
    18241995               :pathname
     
    18712042
    18722043
    1873 (defvar *serial-depends-on*)
     2044(defvar *serial-depends-on* nil)
    18742045
    18752046(defun sysdef-error-component (msg type name value)
    18762047  (sysdef-error (concatenate 'string msg
    1877                              "~&The value specified for ~(~A~) ~A is ~W")
     2048                             "~&The value specified for ~(~A~) ~A is ~S")
    18782049                type name value))
    18792050
     
    19252096
    19262097(defun parse-component-form (parent options)
    1927 
    19282098  (destructuring-bind
    19292099        (type name &rest rest &key
     
    19572127                (make-instance (class-for-type parent type)))))
    19582128      (when weakly-depends-on
    1959         (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on))))
    1960       (when (boundp '*serial-depends-on*)
    1961         (setf depends-on
    1962               (concatenate 'list *serial-depends-on* depends-on)))
     2129        (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on)))
     2130      (when *serial-depends-on*
     2131        (push *serial-depends-on* depends-on))
    19632132      (apply #'reinitialize-instance ret
    19642133             :name (coerce-name name)
     
    19742143        (let ((*serial-depends-on* nil))
    19752144          (setf (module-components ret)
    1976                 (loop :for c-form :in components
     2145                (loop
     2146                  :for c-form :in components
    19772147                  :for c = (parse-component-form ret c-form)
     2148                  :for name = (component-name c)
    19782149                  :collect c
    1979                   :if serial
    1980                   :do (push (component-name c) *serial-depends-on*))))
    1981 
    1982         ;; check for duplicate names
    1983         (let ((name-hash (make-hash-table :test #'equal)))
    1984           (loop :for c in (module-components ret) :do
    1985             (if (gethash (component-name c)
    1986                          name-hash)
    1987                 (error 'duplicate-names :name (component-name c))
    1988                 (setf (gethash (component-name c)
    1989                                name-hash)
    1990                       t)))))
     2150                  :when serial :do (setf *serial-depends-on* name))))
     2151        (compute-module-components-by-name ret))
     2152
     2153      (setf (component-load-dependencies ret) depends-on) ;; Used by POIU
    19912154
    19922155      (setf (component-in-order-to ret)
     
    19942157             in-order-to
    19952158             `((compile-op (compile-op ,@depends-on))
    1996                (load-op (load-op ,@depends-on))))
    1997             (component-do-first ret) `((compile-op (load-op ,@depends-on))))
     2159               (load-op (load-op ,@depends-on)))))
     2160      (setf (component-do-first ret) `((compile-op (load-op ,@depends-on))))
    19982161
    19992162      (%refresh-component-inline-methods ret rest)
     
    20192182  (let ((command (apply #'format nil control-string args)))
    20202183    (asdf-message "; $ ~A~%" command)
    2021     #+sbcl
    2022     (sb-ext:process-exit-code
    2023      (apply #'sb-ext:run-program
    2024             #+win32 "sh" #-win32 "/bin/sh"
    2025             (list  "-c" command)
    2026             :input nil :output *verbose-out*
    2027             #+win32 '(:search t) #-win32 nil))
    2028 
    2029     #+(or cmu scl)
    2030     (ext:process-exit-code
    2031      (ext:run-program
    2032       "/bin/sh"
    2033       (list  "-c" command)
    2034       :input nil :output *verbose-out*))
     2184
     2185    #+abcl
     2186    (ext:run-shell-command command :output *verbose-out*)
    20352187
    20362188    #+allegro
     
    20462198      exit-code)
    20472199
     2200    #+clisp                     ;XXX not exactly *verbose-out*, I know
     2201    (ext:run-shell-command  command :output :terminal :wait t)
     2202
     2203    #+clozure
     2204    (nth-value 1
     2205               (ccl:external-process-status
     2206                (ccl:run-program "/bin/sh" (list "-c" command)
     2207                                 :input nil :output *verbose-out*
     2208                                 :wait t)))
     2209
     2210    #+ecl ;; courtesy of Juan Jose Garcia Ripoll
     2211    (si:system command)
     2212
     2213    #+gcl
     2214    (lisp:system command)
     2215
    20482216    #+lispworks
    20492217    (system:call-system-showing-output
     
    20542222     :output-stream *verbose-out*)
    20552223
    2056     #+clisp                     ;XXX not exactly *verbose-out*, I know
    2057     (ext:run-shell-command  command :output :terminal :wait t)
    2058 
    2059     #+openmcl
    2060     (nth-value 1
    2061                (ccl:external-process-status
    2062                 (ccl:run-program "/bin/sh" (list "-c" command)
    2063                                  :input nil :output *verbose-out*
    2064                                  :wait t)))
    2065 
    2066     #+ecl ;; courtesy of Juan Jose Garcia Ripoll
    2067     (si:system command)
    2068 
    2069     #+abcl
    2070     (ext:run-shell-command command :output *verbose-out*)
    2071 
    2072     #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl abcl)
    2073     (error "RUN-SHELL-COMMAND not implemented for this Lisp")
    2074     ))
     2224    #+sbcl
     2225    (sb-ext:process-exit-code
     2226     (apply #'sb-ext:run-program
     2227            #+win32 "sh" #-win32 "/bin/sh"
     2228            (list  "-c" command)
     2229            :input nil :output *verbose-out*
     2230            #+win32 '(:search t) #-win32 nil))
     2231
     2232    #+(or cmu scl)
     2233    (ext:process-exit-code
     2234     (ext:run-program
     2235      "/bin/sh"
     2236      (list  "-c" command)
     2237      :input nil :output *verbose-out*))
     2238
     2239    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl)
     2240    (error "RUN-SHELL-COMMAND not implemented for this Lisp")))
    20752241
    20762242;;;; ---------------------------------------------------------------------------
     
    20912257
    20922258(defun relativize-directory (directory)
    2093   (if (eq (car directory) :absolute)
    2094       (cons :relative (cdr directory))
    2095       directory))
     2259  (cond
     2260    ((stringp directory)
     2261     (list :relative directory))
     2262    ((eq (car directory) :absolute)
     2263     (cons :relative (cdr directory)))
     2264    (t
     2265     directory)))
    20962266
    20972267(defun relativize-pathname-directory (pathspec)
     
    21202290  '((:windows :mswindows :win32 :mingw32)
    21212291    (:solaris :sunos)
     2292    :linux ;; for GCL at least, must appear before :bsd.
    21222293    :macosx :darwin :apple
    21232294    :freebsd :netbsd :openbsd :bsd
    2124     :linux :unix))
     2295    :unix))
    21252296
    21262297(defparameter *architecture-features*
     
    21322303  (let ((s (lisp-implementation-version)))
    21332304    (declare (ignorable s))
    2134     #+(or scl sbcl ecl armedbear cormanlisp mcl) s
    2135     #+cmu (substitute #\- #\/ s)
    2136     #+clozure (format nil "~d.~d~@[-~d~]"
    2137                       ccl::*openmcl-major-version*
    2138                       ccl::*openmcl-minor-version*
    2139                       #+ppc64-target 64
    2140                       #-ppc64-target nil)
    2141     #+lispworks (format nil "~A~@[~A~]" s
    2142                         (when (member :lispworks-64bit *features*) "-64bit"))
    21432305    #+allegro (format nil
    21442306                      "~A~A~A~A"
     
    21532315                       (:+ics ""))
    21542316                      (if (member :64bit *features*) "-64bit" ""))
    2155     #+(or clisp gcl) (subseq s 0 (position #\space s))
    2156     #+digitool (subseq s 8)))
     2317    #+clisp (subseq s 0 (position #\space s))
     2318    #+clozure (format nil "~d.~d-fasl~d"
     2319                      ccl::*openmcl-major-version*
     2320                      ccl::*openmcl-minor-version*
     2321                      (logand ccl::fasl-version #xFF))
     2322    #+cmu (substitute #\- #\/ s)
     2323    #+digitool (subseq s 8)
     2324    #+ecl (format nil "~A~@[-~A~]" s
     2325                  (let ((vcs-id (ext:lisp-implementation-vcs-id)))
     2326                    (when (>= (length vcs-id) 8)
     2327                      (subseq vcs-id 0 8))))
     2328    #+gcl (subseq s (1+ (position #\space s)))
     2329    #+lispworks (format nil "~A~@[~A~]" s
     2330                        (when (member :lispworks-64bit *features*) "-64bit"))
     2331    ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; fasl-f-v is redundant
     2332    #+(or armedbear cormanlisp mcl sbcl scl) s
     2333    #-(or allegro armedbear clisp clozure cmu cormanlisp digitool
     2334          ecl gcl lispworks mcl sbcl scl) s))
    21572335
    21582336(defun first-feature (features)
     
    22222400           :for dir :in (split-string dirs :separator ":")
    22232401           :collect (try dir "common-lisp/"))
    2224        #+windows
     2402       #+(and (or win32 windows mswindows mingw32) (not cygwin))
    22252403        ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/")
    22262404            ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
    2227            #+(not cygwin)
    2228            ,(try (or (getenv "USERPROFILE") (user-homedir))
    2229                  "Application Data/common-lisp/config/"))
     2405           ,(try (getenv "APPDATA") "common-lisp/config/"))
    22302406       ,(try (user-homedir) ".config/common-lisp/")))))
    22312407(defun system-configuration-directories ()
     
    22332409   #'null
    22342410   (append
    2235     #+windows
     2411    #+(and (or win32 windows mswindows mingw32) (not cygwin))
    22362412    (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
    2237       `(
    2238        ,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")
     2413      `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")
    22392414           ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
    2240            #+(not cygwin)
    2241            ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
     2415        ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
    22422416    (list #p"/etc/"))))
    22432417(defun in-first-directory (dirs x)
    22442418  (loop :for dir :in dirs
    2245     :thereis (and dir (ignore-errors (truename (merge-pathnames* x (ensure-directory-pathname dir)))))))
     2419    :thereis (and dir (ignore-errors
     2420                        (truename (merge-pathnames* x (ensure-directory-pathname dir)))))))
    22462421(defun in-user-configuration-directory (x)
    22472422  (in-first-directory (user-configuration-directories) x))
     
    23002475
    23012476(defvar *user-cache*
    2302   (or
    2303    (let ((h (getenv "XDG_CACHE_HOME")))
    2304      (and h `(,h "common-lisp" :implementation)))
    2305    #+(and windows lispworks)
    2306    (let ((h (sys:get-folder-path :common-appdata))) ;; no :common-caches in Windows???
    2307      (and h `(,h "common-lisp" "cache")))
    2308    #+(and windows (not cygwin))
    2309    ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Cache
    2310    (let ((h (or (getenv "USERPROFILE") (user-homedir))))
    2311      (and h `(,h "Local Settings" "Temporary Internet Files" "common-lisp")))
    2312    '(:home ".cache" "common-lisp" :implementation)))
     2477  (flet ((try (x &rest sub) (and x `(,x ,@sub))))
     2478    (or
     2479     (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation)
     2480     #+(and (or win32 windows mswindows mingw32) (not cygwin))
     2481     (try (getenv "APPDATA") "common-lisp" "cache" :implementation)
     2482     '(:home ".cache" "common-lisp" :implementation))))
    23132483(defvar *system-cache*
    2314   (or
    2315    #+(and windows lispworks)
    2316    (let ((h (sys:get-folder-path :common-appdata))) ;; no :common-caches in Windows???
    2317      (and h `(,h "common-lisp" "cache")))
    2318    #+windows
    2319    (let ((h (or (getenv "USERPROFILE") (user-homedir))))
    2320      (and h `(,h "Local Settings" "Temporary Internet Files" "common-lisp")))
    2321    #+(or unix cygwin)
    2322    '("/var/cache/common-lisp" :uid :implementation)))
     2484  ;; No good default, plus there's a security problem
     2485  ;; with other users messing with such directories.
     2486  *user-cache*)
    23232487
    23242488(defun output-translations ()
     
    25162680    #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; only needed if LPNs are resolved manually.
    25172681    #+clozure (,(wilden (ccl::ccl-directory)) ()) ; not needed: no precompiled ASDF system
    2518     #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
    2519     #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
    25202682    ;; All-import, here is where we want user stuff to be:
    25212683    :inherit-configuration
     2684    ;; These are for convenience, and can be overridden by the user:
     2685    #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
     2686    #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
    25222687    ;; If we want to enable the user cache by default, here would be the place:
    25232688    :enable-user-cache))
     
    27072872(defun translate-jar-pathname (source wildcard)
    27082873  (declare (ignore wildcard))
    2709   (let* ((p (first (pathname-device source)))
    2710    (r (concatenate 'string 
    2711        (if (and (find :windows *features*)
    2712           (not (null (pathname-device p))))
    2713            (format nil "~A/" (pathname-device p))
    2714            "")
    2715        (namestring (make-pathname :directory (pathname-directory p)
    2716                 :name (pathname-name p)
    2717                 :type (pathname-type p)))))
    2718    (root (apply-output-translations
    2719     (format nil "/___jar___file___root___/~A" r)))
    2720    (entry (make-pathname :directory (pathname-directory source)
    2721              :name (pathname-name source)
    2722              :type (pathname-type source))))
    2723     (concatenate 'string (namestring root) (namestring entry))))
     2874  (let* ((p (pathname (first (pathname-device source))))
     2875         (root (format nil "/___jar___file___root___/~@[~A/~]"
     2876                       (and (find :windows *features*)
     2877                            (pathname-device p)))))
     2878    (apply-output-translations
     2879     (merge-pathnames*
     2880      (relativize-pathname-directory source)
     2881      (merge-pathnames*
     2882       (relativize-pathname-directory (ensure-directory-pathname p))
     2883       root)))))
    27242884
    27252885;;;; -----------------------------------------------------------------
     
    28613021  (values))
    28623022
     3023(defun probe-asd (name defaults)
     3024  (block nil
     3025    (when (directory-pathname-p defaults)
     3026      (let ((file
     3027             (make-pathname
     3028              :defaults defaults :version :newest :case :local
     3029              :name name
     3030              :type "asd")))
     3031        (when (probe-file file)
     3032          (return file)))
     3033      #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
     3034      (let ((shortcut
     3035             (make-pathname
     3036              :defaults defaults :version :newest :case :local
     3037              :name (concatenate 'string name ".asd")
     3038              :type "lnk")))
     3039        (when (probe-file shortcut)
     3040          (let ((target (parse-windows-shortcut shortcut)))
     3041            (when target
     3042              (return (pathname target)))))))))
     3043
    28633044(defun sysdef-source-registry-search (system)
    28643045  (ensure-source-registry)
    2865   (let ((name (coerce-name system)))
    2866     (block nil
    2867       (dolist (dir (source-registry))
    2868         (let ((defaults (eval dir)))
    2869           (when defaults
    2870             (cond ((directory-pathname-p defaults)
    2871                    (let ((file (and defaults
    2872                                     (make-pathname
    2873                                      :defaults defaults :version :newest
    2874                                      :name name :type "asd" :case :local)))
    2875                          #+(and (or win32 windows) (not :clisp))
    2876                          (shortcut (make-pathname
    2877                                     :defaults defaults :version :newest
    2878                                     :name name :type "asd.lnk" :case :local)))
    2879                      (when (and file (probe-file file))
    2880                        (return file))
    2881                      #+(and (or win32 windows) (not :clisp))
    2882                      (when (probe-file shortcut)
    2883                        (let ((target (parse-windows-shortcut shortcut)))
    2884                          (when target
    2885                            (return (pathname target))))))))))))))
     3046  (loop :with name = (coerce-name system)
     3047    :for defaults :in (source-registry)
     3048    :for file = (probe-asd name defaults)
     3049    :when file :return file))
    28863050
    28873051(defun validate-source-registry-directive (directive)
     
    29483112  (if (not recurse)
    29493113      (funcall collect directory)
    2950       (let* ((files (ignore-errors
    2951                       (directory (merge-pathnames* *wild-asd* directory)
    2952                                  #+sbcl #+sbcl :resolve-symlinks nil
    2953                                  #+clisp #+clisp :circle t)))
     3114      (let* ((files
     3115              (handler-case
     3116                  (directory (merge-pathnames* *wild-asd* directory)
     3117                             #+sbcl #+sbcl :resolve-symlinks nil
     3118                             #+clisp #+clisp :circle t)
     3119                (error (c)
     3120                  (warn "Error while scanning system definitions under directory ~S:~%~A"
     3121                        directory c)
     3122                  nil)))
    29543123             (dirs (remove-duplicates (mapcar #'pathname-directory-pathname files)
    29553124                                      :test #'equal :from-end t)))
     
    29883157           (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share"))
    29893158          (dirs (cons datahome (split-string datadirs :separator ":"))))
    2990          #+(and windows (not cygwin))
    2991          ((datahome
    2992            #+lispworks (sys:get-folder-path :common-appdata)
    2993            #-lispworks (try (or (getenv "USERPROFILE") (user-homedir))
    2994                             "Application Data"))
     3159         #+(and (or win32 windows mswindows mingw32) (not cygwin))
     3160         ((datahome (getenv "APPDATA"))
    29953161          (datadir
    29963162           #+lispworks (sys:get-folder-path :local-appdata)
     
    29983164                            "Application Data"))
    29993165          (dirs (list datahome datadir)))
    3000          #+(and (not unix) (not windows) (not cygwin))
     3166         #-(or unix win32 windows mswindows mingw32 cygwin)
    30013167         ((dirs ()))
    30023168         (loop :for dir :in dirs
     
    31003266
    31013267;;;; -----------------------------------------------------------------
    3102 ;;;; SBCL and ClozureCL hook into REQUIRE
     3268;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL
    31033269;;;;
    3104 #+(or sbcl clozure abcl)
     3270#+(or abcl clozure cmu ecl sbcl)
    31053271(progn
    31063272  (defun module-provide-asdf (name)
     
    31123278                          name e))))
    31133279      (let* ((*verbose-out* (make-broadcast-stream))
    3114              (system (asdf:find-system name nil)))
     3280             (system (find-system name nil)))
    31153281        (when system
    3116           (asdf:operate 'asdf:load-op name)
     3282          (load-system name)
    31173283          t))))
    31183284  (pushnew 'module-provide-asdf
    3119            #+sbcl sb-ext:*module-provider-functions*
     3285           #+abcl sys::*module-provider-functions*
    31203286           #+clozure ccl::*module-provider-functions*
    3121            #+abcl sys::*module-provider-functions*))
     3287           #+cmu ext:*module-provider-functions*
     3288           #+ecl si:*module-provider-functions*
     3289           #+sbcl sb-ext:*module-provider-functions*))
    31223290
    31233291;;;; -------------------------------------------------------------------------
Note: See TracChangeset for help on using the changeset viewer.