Changeset 13311

06/08/11 05:23:25 (12 years ago)
Mark Evenson

Update to asdf-2.016.

2 edited


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

    r13253 r13311  
    172172@emph{Nota Bene}:
    173173We have released ASDF 2.000 on May 31st 2010.
    174 It hopefully will have been it included
    175 in all CL maintained implementations shortly afterwards.
     174Subsequent releases of ASDF 2 have since then been included
     175in all actively maintained CL implementations that used to bundle ASDF 1,
     176plus some implementations that didn't use to,
     177and has been made to work with all actively used CL implementations and a few more.
    176178@xref{FAQ,,``What has changed between ASDF 1 and ASDF 2?''}.
     179Furthermore, it is possible to upgrade from ASDF 1 to ASDF 2 on the fly.
     180For this reason, we have stopped supporting ASDF 1;
     181if you are using ASDF 1 and are experiencing any kind of issues or limitations,
     182we recommend you upgrade to ASDF 2
     183--- and we explain how to do that. @xref{Loading ASDF}.
     185Also note that ASDF is not to be confused with ASDF-Install.
     186ASDF-Install is not part of ASDF, but a separate piece of software.
     187ASDF-Install is also unmaintained and obsolete.
     188We recommend you use Quicklisp instead,
     189which works great and is being actively maintained.
     190If you want to download software from version control instead of tarballs,
     191so you may more easily modify it, we recommend clbuild.
    202 (require :asdf)
     217(require "asdf")
    203218@end lisp
    205 Consult your Lisp implementation's documentation for details.
    207 Hopefully, ASDF 2 will soon be bundled with every Common Lisp implementation,
    208 and you can load it that way.
    209 If it is not, see @pxref{Loading ASDF,,Loading an otherwise installed ASDF} below.
    210 if you are using the latest version of your Lisp vendor's software,
    211 you may also send a bug report to your Lisp vendor and complain about
    212 their failing to provide ASDF.
     220As of the writing of this manual,
     221the following implementations provide ASDF 2 this way:
     222abcl allegro ccl clisp cmucl ecl sbcl xcl.
     223The following implementations don't provide it yet but will in a future release:
     224lispworks scl.
     225The following implementations are obsolete and most probably will never bundle it:
     226cormancl gcl genera mcl.
     228If the implementation you are using doesn't provide ASDF 2,
     229see @pxref{Loading ASDF,,Loading an otherwise installed ASDF} below.
     230If that implementation is still actively maintained,
     231you may also send a bug report to your Lisp vendor and complain
     232about their failing to provide ASDF.
     234NB: all implementations except clisp also accept
     235@code{(require "ASDF")}, @code{(require 'asdf)} and @code{(require :asdf)}.
     236For portability's sake, you probably want to use @code{(require "asdf")}.
    214239@section Checking whether ASDF is loaded
    243268If it returns @code{NIL} then ASDF is not installed.
    245 If you are running a version older than 2.008,
    246 we recommend that you load a newer ASDF using the method below.
     270If you are experiencing problems with ASDF,
     271please try upgrading to the latest released version,
     272using the method below,
     273before you contact us and raise an issue.
    259 (require :asdf)
     286(require "asdf")
    260287(asdf:load-system :asdf)
    261288@end lisp
    267 (require :asdf)
     294(require "asdf")
    268295(push #p"@var{/path/to/new/asdf/}" asdf:*central-registry*)
    269296(asdf:oos 'asdf:load-op :asdf)
    280307At worst, you may have to have multiple copies of the new ASDF,
    281308e.g. one per implementation installation, to avoid clashes.
     309Note that to our knowledge all implementations that provide ASDF
     310provide ASDF 2 in their latest release, so
     311you may want to upgrade your implementation rather than go through that hoop.
    283313Finally, note that there are some limitations to upgrading ASDF:
    286 Any ASDF extension is invalidated, and will need to be reloaded.
    287 @item
    288 It is safer if you upgrade ASDF and its extensions as a special step
     316Any ASDF extension becomes invalid, and will need to be reloaded.
     317This applies to e.g. CFFI-Grovel, or to hacks used by ironclad, etc.
     318Starting with ASDF 2.014.8, ASDF will actually invalidate
     319all previously loaded systems when it is loaded on top of
     320a different ASDF version.
     322Until all implementations provide ASDF 2.015 or later,
     323it is safer if you upgrade ASDF and its extensions as a special step
    289324at the very beginning of whatever script you are running,
    290325before you start using ASDF to load anything else.
     327Until all implementations provide ASDF 2.015 or later,
     328it is unsafe to upgrade ASDF as part of loading a system
     329that depends on a more recent version of ASDF,
     330since the new one might shadow the old one while the old one is running,
     331and the running old one will be confused
     332when extensions are loaded into the new one.
     333In the meantime, we recommend that your systems should @emph{not} specify
     334@code{:depends-on (:asdf)}, or @code{:depends-on ((:version :asdf "2.010"))},
     335but instead that they check that a recent enough ASDF is installed,
     336with such code as:
     338(unless (or #+asdf2 (asdf:version-satisfies
     339                     (asdf:asdf-version) *required-asdf-version*))
     340  (error "FOO requires ASDF ~A or later." *required-asdf-version*))
     341@end example
    291342@end itemize
    338389If you're installing software yourself at a location that isn't standard,
    339390you have to tell ASDF where you installed it. See below.
    340 If you're using some tool to install software,
     391If you're using some tool to install software (e.g. Quicklisp),
    341392the authors of that tool should already have configured ASDF.
    345396is to create the directory
    347 and there create a file with any name of your choice but the type @file{conf},
     398and there create a file with any name of your choice,
     399and with the type @file{conf},
    348400for instance @file{42-asd-link-farm.conf}
    349401containing the line:
    405457For instance, if you wanted ASDF to find the @file{.asd} file
    406458@file{/home/me/src/foo/foo.asd} your initialization script
    407 could after it loads ASDF with @code{(require :asdf)}
     459could after it loads ASDF with @code{(require "asdf")}
    408460configure it with:
    614666Load ASDF itself into your Lisp image, either through
    615 @code{(require :asdf)} or else through
     667@code{(require "asdf")} or else through
    616668@code{(load "/path/to/asdf.lisp")}.
    947999and that the behavior of @code{parse-namestring} is completely non-portable,
    9481000unless you are using Common Lisp @code{logical-pathname}s
    949 (@pxref{The defsystem grammar,,Warning about logical pathnames}, below).
     1001(@pxref{The defsystem grammar,,Using logical pathnames}, below).
    9501002Pathnames made with @code{#.(make-pathname ...)}
    9511003can usually be done more easily with the string syntax above.
    986 @subsection Warning about logical pathnames
     1038@subsection Using logical pathnames
    9871039@cindex logical pathnames
    989 We recommend that you not use logical pathnames
    990 in your asdf system definitions at this point,
    991 but logical pathnames @emph{are} supported.
     1041We do not generally recommend the use of logical pathnames,
     1042especially not so to newcomers to Common Lisp.
     1043However, we do support the use of logical pathnames by old timers,
     1044when such is their preference.
    9931046To use logical pathnames,
    998 You only have to specify such logical pathname for your system or
    999 some top-level component.  Sub-components' relative pathnames, specified
    1000 using the string syntax
    1001 for names, will be properly merged with the pathnames of their parents.
     1051You only have to specify such logical pathname
     1052for your system or some top-level component.
     1053Sub-components' relative pathnames,
     1054specified using the string syntax for names,
     1055will be properly merged with the pathnames of their parents.
    10021056The specification of a logical pathname host however is @emph{not}
    10031057otherwise directly supported in the ASDF syntax
    10061060The @code{asdf-output-translation} layer will
    1007 avoid trying to resolve and translate logical-pathnames.
    1008 The advantage of this is that you can define yourself what translations you want to use
     1061avoid trying to resolve and translate logical pathnames.
     1062The advantage of this is that
     1063you can define yourself what translations you want to use
    10091064with the logical pathname facility.
    1010 The disadvantage is that if you do not define such translations, any
    1011 system that uses logical pathnames will behave differently under
     1065The disadvantage is that if you do not define such translations,
     1066any system that uses logical pathnames will behave differently under
    10121067asdf-output-translations than other systems you use.
    10161071ASDF currently provides no specific support
    10171072for defining logical pathname translations.
     1074Note that the reasons we do not recommend logical pathnames are that
     1075(1) there is no portable way to set up logical pathnames before they are used,
     1076(2) logical pathnames are limited to only portably use
     1077a single character case, digits and hyphens.
     1078While you can solve the first issue on your own,
     1079describing how to do it on each of fifteen implementations supported by ASDF
     1080is more than we can document.
     1081As for the second issue, mind that the limitation is notably enforced on SBCL,
     1082and that you therefore can't portably violate the limitations
     1083but must instead define some encoding of your own and add individual mappings
     1084to name physical pathnames that do not fit the restrictions.
     1085This can notably be a problem when your Lisp files are part of a larger project
     1086in which it is common to name files or directories in a way that
     1087includes the version numbers of supported protocols,
     1088or in which files are shared with software written
     1089in different programming languages where conventions include the use of
     1090underscores, dots or CamelCase in pathnames.
    13641437To find and update systems, @code{find-system} funcalls each element
    13651438in the @code{*system-definition-search-functions*} list,
    1366 expecting a pathname to be returned.
    1367 The resulting pathname is loaded if either of the following conditions is true:
     1439expecting a pathname to be returned, or a system object,
     1440from which a pathname may be extracted, and that will be registered.
     1441The resulting pathname (if any) is loaded
     1442if one of the following conditions is true:
    13711446there is no system of that name in memory
     1448the pathname is different from that which was previously loaded
    13731450the file's @code{last-modified} time exceeds the @code{last-modified} time
    16861763@end lisp
    1688 A hypothetical function @code{system-dependent-dirname}
     1765Function @code{asdf:implementation-type} (exported since 2.014.14)
    16891766gives us the name of the subdirectory.
    16901767All that's left is to define how to calculate the pathname
    16941771(defmethod component-pathname ((component unportable-cl-source-file))
    1695   (let ((pathname (call-next-method))
    1696         (name (string-downcase (system-dependent-dirname))))
    1697     (merge-pathnames*
    1698      (make-pathname :directory (list :relative name))
    1699      pathname)))
     1772  (merge-pathnames*
     1773   (coerce-pathname (format nil "~(~A~)/" (asdf:implementation-type)))
     1774   (call-next-method)))
    17001775@end lisp
    27052780@defun coerce-pathname name @&key type defaults
    2707 This function takes an argument, and portably interprets it as a pathname.
     2782This function (available starting with ASDF 2.012.11)
     2783takes an argument, and portably interprets it as a pathname.
    27082784If the argument @var{name} is a pathname or @code{nil}, it is passed through;
    27092785if it's a symbol, it's interpreted as a string by downcasing it;
    30053081that everyone can rely on from now on.
    30063082Use @code{#+asdf2} to detect presence of ASDF 2,
    3007 @code{(asdf:version-satisfies (asdf:asdf-version) "2.000")}
     3083@code{(asdf:version-satisfies (asdf:asdf-version) "2.345.67")}
    30083084to check the availability of a version no earlier than required.
    30143090it was very hard to upgrade ASDF in your current image
    30153091without breaking everything.
    3016 Instead you have to exit the Lisp process and
     3092Instead you had to exit the Lisp process and
    30173093somehow arrange to start a new one from a simpler image.
    30183094Something that can't be done from within Lisp,
    31083184Or you can fix your implementation to not be quite that slow
    31093185when recursing through directories.
     3186@underline{Update}: performance bug fixed the hard way in 2.010.
    31123189On Windows, only LispWorks supports proper default configuration pathnames
    31133190based on the Windows registry.
    3114 Other implementations make do with environment variables.
     3191Other implementations make do with environment variables,
     3192that you may have to define yourself if you're using an older version of Windows.
    31153193Windows support is somewhat less tested than Unix support.
    31163194Please help report and fix bugs.
    31223200and you would
    31233201@code{(defmethod source-file-type ((component cl-source-file) (system (eql (find-system 'foo))))
    3124   (declare (ignorable component system)) "cl")}.
     3202  (declare (ignorable component system)) "lis")}.
    31253203Now, the pathname for a component is eagerly computed when defining the system,
    3126 and instead you will @code{(defclass my-cl-source-file (cl-source-file) ((type :initform "cl")))}
    3127 and use @code{:default-component-class my-cl-source-file} as argument to @code{defsystem},
     3204and instead you will @code{(defclass cl-source-file.lis (cl-source-file) ((type :initform "lis")))}
     3205and use @code{:default-component-class cl-source-file.lis} as argument to @code{defsystem},
    31283206as detailed in a @pxref{FAQ,How do I create a system definition where all the source files have a .cl extension?} below.
    3163 If ASDF isn't loaded yet, then @code{(require :asdf)}
     3241If ASDF isn't loaded yet, then @code{(require "asdf")}
    31643242should load the version of ASDF that is bundled with your system.
    31653243You may have it load some other version configured by the user,
    34003478@subsection How do I create a system definition where all the source files have a .cl extension?
    3402 First, create a new @code{cl-source-file} subclass that provides an
    3403 initform for the @code{type} slot:
    3405 @lisp
    3406 (defclass my-cl-source-file (cl-source-file)
    3407    ((type :initform "cl")))
    3408 @end lisp
    3410 To support both ASDF 1 and ASDF 2,
    3411 you may omit the above @code{type} slot definition and instead define:
    3413 @lisp
    3414 (defmethod source-file-type ((f my-cl-source-file) (m module))
    3415   (declare (ignorable f m))
    3416   "cl")
    3417 @end lisp
    3419 Then make your system use this subclass in preference to the standard
    3420 one:
     3480Starting with ASDF 2.014.14, you may just pass
     3481the builtin class @code{} as
     3482the @code{:default-component-class} argument to @code{defsystem}:
    34233485(defsystem my-cl-system
    3424   :default-component-class my-cl-source-file
    3425    ....
    3426 )
     3486  :default-component-class
     3487  ...)
    34273488@end lisp
    3429 We assume that these definitions are loaded into a package that uses
    3430 @code{ASDF}.
     3490Another builtin class @code{cl-source-file.lsp} is offered
     3491for files ending in @file{.lsp}.
     3493If you want to use a different extension
     3494for which ASDF doesn't provide builtin support,
     3495or want to support versions of ASDF
     3496earlier than 2.014.14 (but later than 2.000),
     3497you can define a class as follows:
     3500;; Prologue: make sure we're using a sane package.
     3501(defpackage :my-asdf-extension
     3502   (:use :asdf :common-lisp)
     3503   (:export #:cl-source-file.lis))
     3504(in-package :my-asdf-extension)
     3506(defclass cl-source-file.lis (cl-source-file)
     3507   ((type :initform "lis")))
     3508@end lisp
     3510Then you can use it as follows:
     3512(defsystem my-cl-system
     3513  :default-component-class my-asdf-extension:cl-source-file.lis
     3514  ...)
     3515@end lisp
     3517Of course, if you're in the same package, e.g. in the same file,
     3518you won't need to use the package qualifier before @code{cl-source-file.lis}.
     3519Actually, if all you're doing is defining this class
     3520and using it in the same file without other fancy definitions,
     3521you might skip package complications:
     3524(in-package :asdf)
     3525(defclass cl-source-file.lis (cl-source-file)
     3526   ((type :initform "lis")))
     3527(defsystem my-cl-system
     3528  :default-component-class cl-source-file.lis
     3529  ...)
     3530@end lisp
     3532It is possible to achieve the same effect
     3533in a way that supports both ASDF 1 and ASDF 2,
     3534but really, friends don't let friends use ASDF 1.
     3535Please upgrade to ASDF 2.
     3536In short, though: do same as above, but
     3537@emph{before} you use the class in a @code{defsystem},
     3538you also define the following method:
     3541(defmethod source-file-type ((f cl-source-file.lis) (m module))
     3542  (declare (ignorable f m))
     3543  "lis")
     3544@end lisp
  • trunk/abcl/src/org/armedbear/lisp/asdf.lisp

    r13258 r13311  
    11;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
    2 ;;; This is ASDF 2.014: Another System Definition Facility.
     2;;; This is ASDF 2.016: Another System Definition Facility.
    44;;; Feedback, bug reports, and patches are all welcome:
    2020;;;  Monday; July 13, 2009)
    22 ;;; Copyright (c) 2001-2010 Daniel Barlow and contributors
     22;;; Copyright (c) 2001-2011 Daniel Barlow and contributors
    2424;;; Permission is hereby granted, free of charge, to any person obtaining
    5050(cl:in-package #-genera :common-lisp-user #+genera :future-common-lisp-user)
     52#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
     53(error "ASDF is not supported on your implementation. Please help us with it.")
    5255#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this
    5457(eval-when (:compile-toplevel :load-toplevel :execute)
    55   ;;; make package if it doesn't exist yet.
    56   ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
    57   (unless (find-package :asdf)
    58     (make-package :asdf :use '(:common-lisp)))
    5958  ;;; Implementation-dependent tweaks
    6059  ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults.
    6261  (setf excl::*autoload-package-name-alist*
    6362        (remove "asdf" excl::*autoload-package-name-alist*
    64                 :test 'equalp :key 'car))
     63                :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below
    6564  #+(and ecl (not ecl-bytecmp)) (require :cmp)
    6665  #+(and (or win32 windows mswindows mingw32) (not cygwin)) (pushnew :asdf-windows *features*)
    67   #+(or unix cygwin) (pushnew :asdf-unix *features*))
     66  #+(or unix cygwin) (pushnew :asdf-unix *features*)
     67  ;;; make package if it doesn't exist yet.
     68  ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
     69  (unless (find-package :asdf)
     70    (make-package :asdf :use '(:common-lisp))))
    6972(in-package :asdf)
    71 ;;; Strip out formating that is not supported on Genera.
    72 (defmacro compatfmt (format)
    73   #-genera format
    74   #+genera
    75   (let ((r '(("~@<" . "")
    76        ("; ~@;" . "; ")
    77        ("~3i~_" . "")
    78        ("~@:>" . "")
    79        ("~:>" . ""))))
    80     (dolist (i r)
    81       (loop :for found = (search (car i) format) :while found :do
    82         (setf format (concatenate 'simple-string (subseq format 0 found)
    83                                   (cdr i)
    84                                   (subseq format (+ found (length (car i))))))))
    85     format))
    8774;;;; Create packages in a way that is compatible with hot-upgrade.
    9279  (defvar *asdf-version* nil)
    9380  (defvar *upgraded-p* nil)
     81  (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12.
     82  (defun find-symbol* (s p)
     83    (find-symbol (string s) p))
     84  ;; Strip out formatting that is not supported on Genera.
     85  ;; Has to be inside the eval-when to make Lispworks happy (!)
     86  (defmacro compatfmt (format)
     87    #-genera format
     88    #+genera
     89    (loop :for (unsupported . replacement) :in
     90      '(("~@<" . "")
     91        ("; ~@;" . "; ")
     92        ("~3i~_" . "")
     93        ("~@:>" . "")
     94        ("~:>" . "")) :do
     95      (loop :for found = (search unsupported format) :while found :do
     96        (setf format
     97              (concatenate 'simple-string
     98                           (subseq format 0 found) replacement
     99                           (subseq format (+ found (length unsupported)))))))
     100    format)
    94101  (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
    95102         ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version
    100107         ;; "2.345.0.7" would be your seventh local modification of official release 2.345
    101108         ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
    102          (asdf-version "2.014")
    103          (existing-asdf (fboundp 'find-system))
     109         (asdf-version "2.016")
     110         (existing-asdf (find-class 'component nil))
    104111         (existing-version *asdf-version*)
    105112         (already-there (equal asdf-version existing-version)))
    106113    (unless (and existing-asdf already-there)
    107       (when existing-asdf
     114      (when (and existing-asdf *asdf-verbose*)
    108115        (format *trace-output*
    109     (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
    110     existing-version asdf-version))
     116                (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
     117                existing-version asdf-version))
    111118      (labels
    112119          ((present-symbol-p (symbol package)
    113              (member (nth-value 1 (find-sym symbol package)) '(:internal :external)))
     120             (member (nth-value 1 (find-symbol* symbol package)) '(:internal :external)))
    114121           (present-symbols (package)
    115122             ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera
    141148                   (t
    142149                    (make-package name :nicknames nicknames :use use))))))
    143            (find-sym (symbol package)
    144              (find-symbol (string symbol) package))
    145150           (intern* (symbol package)
    146151             (intern (string symbol) package))
    147152           (remove-symbol (symbol package)
    148              (let ((sym (find-sym symbol package)))
     153             (let ((sym (find-symbol* symbol package)))
    149154               (when sym
    150                  (unexport sym package)
     155                 #-cormanlisp (unexport sym package)
    151156                 (unintern sym package)
    152157                 sym)))
    157162               :when removed :do
    158163               (loop :for p :in packages :do
    159                  (when (eq removed (find-sym sym p))
     164                 (when (eq removed (find-symbol* sym p))
    160165                   (unintern removed p)))))
    161166           (ensure-shadow (package symbols)
    164169             (dolist (used (reverse use))
    165170               (do-external-symbols (sym used)
    166                  (unless (eq sym (find-sym sym package))
     171                 (unless (eq sym (find-symbol* sym package))
    167172                   (remove-symbol sym package)))
    168173               (use-package used package)))
    169174           (ensure-fmakunbound (package symbols)
    170175             (loop :for name :in symbols
    171                :for sym = (find-sym name package)
     176               :for sym = (find-symbol* name package)
    172177               :when sym :do (fmakunbound sym)))
    173178           (ensure-export (package export)
    185190                 :for shadowing = (package-shadowing-symbols user) :do
    186191                 (loop :for new :in newly-exported-symbols
    187                    :for old = (find-sym new user)
     192                   :for old = (find-symbol* new user)
    188193                   :when (and old (not (member old shadowing)))
    189194                   :do (unintern old user)))
    214219            #:system-source-file #:operate #:find-component #:find-system
    215220            #:apply-output-translations #:translate-pathname* #:resolve-location
    216             #:compile-file*)
     221            #:compile-file* #:source-file-type)
    217222           :unintern
    218223           (#:*asdf-revision* #:around #:asdf-method-combination
    226231           :export
    227232           (#:defsystem #:oos #:operate #:find-system #:run-shell-command
    228             #:system-definition-pathname #:find-component ; miscellaneous
     233            #:system-definition-pathname #:with-system-definitions
     234            #:search-for-system-definition #:find-component ; miscellaneous
    229235            #:compile-system #:load-system #:test-system #:clear-system
    230236            #:compile-op #:load-op #:load-source-op
    234240            #:version                 ; metaphorically sort-of an operation
    235241            #:version-satisfies
     242            #:upgrade-asdf
     243            #:implementation-identifier #:implementation-type
    237245            #:input-files #:output-files #:output-file #:perform ; operation methods
    240248            #:component #:source-file
    241249            #:c-source-file #:cl-source-file #:java-source-file
     250   #:cl-source-file.lsp
    242251            #:static-file
    243252            #:doc-file
    350359            #:truenamize
    351360            #:while-collecting)))
    352   #+genera (import 'scl:boolean :asdf)
     361        #+genera (import 'scl:boolean :asdf)
    353362        (setf *asdf-version* asdf-version
    354363              *upgraded-p* (if existing-version
    362371  "Exported interface to the version of ASDF currently installed. A string.
    363372You can compare this string with e.g.:
    365374  *asdf-version*)
    383392(defvar *verbose-out* nil)
    385 (defvar *asdf-verbose* t)
    387394(defparameter +asdf-methods+
    398405;;;; -------------------------------------------------------------------------
     406;;;; Resolve forward references
     408(declaim (ftype (function (t) t)
     409                format-arguments format-control
     410                error-name error-pathname error-condition
     411                duplicate-names-name
     412                error-component error-operation
     413                module-components module-components-by-name
     414                circular-dependency-components
     415                condition-arguments condition-form
     416                condition-format condition-location
     417                coerce-name)
     418         #-cormanlisp
     419         (ftype (function (t t) t) (setf module-components-by-name)))
     421;;;; -------------------------------------------------------------------------
     422;;;; Compatibility with Corman Lisp
     425  (deftype logical-pathname () nil)
     426  (defun make-broadcast-stream () *error-output*)
     427  (defun file-namestring (p)
     428    (setf p (pathname p))
     429    (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))
     430  (defparameter *count* 3)
     431  (defun dbg (&rest x)
     432    (format *error-output* "~S~%" x)))
     434(defun maybe-break ()
     435  (decf *count*)
     436  (unless (plusp *count*)
     437    (setf *count* 3)
     438    (break)))
     440;;;; -------------------------------------------------------------------------
    399441;;;; General Purpose Utilities
    404446          `(progn
    405447             #+(or ecl gcl) (fmakunbound ',name)
    406              ,(when (and #+ecl (symbolp name))
    407                 `(declaim (notinline ,name))) ; fails for setf functions on ecl
     448             #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
     449             ,(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
     450                `(declaim (notinline ,name)))
    408451             (,',def ,name ,formals ,@rest)))))
    409452  (defdef defgeneric* defgeneric)
    513556  (when pathname
    514557    (make-pathname :name nil :type nil :version nil
    515                    :directory (merge-pathname-directory-components '(:relative :back) (pathname-directory pathname))
     558                   :directory (merge-pathname-directory-components
     559                               '(:relative :back) (pathname-directory pathname))
    516560                   :defaults pathname)))
    529573  (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
    532576(defun* asdf-message (format-string &rest format-args)
    533577  (declare (dynamic-extent format-args))
    534   (apply #'format *verbose-out* format-string format-args))
     578  (apply 'format *verbose-out* format-string format-args))
    536580(defun* split-string (string &key max (separator '(#\Space #\Tab)))
    540584starting the separation from the end, e.g. when called with arguments
    541585 \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
    542   (block nil
     586  (catch nil
    543587    (let ((list nil) (words 0) (end (length string)))
    544588      (flet ((separatorp (char) (find char separator))
    545              (done () (return (cons (subseq string 0 end) list))))
     589             (done () (throw nil (cons (subseq string 0 end) list))))
    546590        (loop
    547591          :for start = (if (and max (>= words (1- max)))
    623667(defun* getenv (x)
    624668  (declare (ignorable x))
    625   #+(or abcl clisp) (ext:getenv x)
     669  #+(or abcl clisp xcl) (ext:getenv x)
    626670  #+allegro (sys:getenv x)
    627671  #+clozure (ccl:getenv x)
    628672  #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
     673  #+cormanlisp
     674  (let* ((buffer (ct:malloc 1))
     675         (cname (ct:lisp-string-to-c-string x))
     676         (needed-size (win:getenvironmentvariable cname buffer 0))
     677         (buffer1 (ct:malloc (1+ needed-size))))
     678    (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
     679               nil
     680               (ct:c-string-to-lisp-string buffer1))
     681      (ct:free buffer)
     682      (ct:free buffer1)))
    629683  #+ecl (si:getenv x)
    630684  #+gcl (system:getenv x)
    636690              (ccl:%get-cstring value))))
    637691  #+sbcl (sb-ext:posix-getenv x)
    638   #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl sbcl scl)
    639   (error "getenv not available on your implementation"))
     692  #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
     693  (error "~S is not supported on your implementation" 'getenv))
    641695(defun* directory-pathname-p (pathname)
    713767  (defun* get-uid ()
    714768    #+allegro (excl.osi:getuid)
     769    #+ccl (ccl::getuid)
    715770    #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid")
    716771                  :for f = (ignore-errors (read-from-string s))
    721776                   '(ext::getuid))
    722777    #+sbcl (sb-unix:unix-getuid)
    723     #-(or allegro clisp cmu ecl sbcl scl)
     778    #-(or allegro ccl clisp cmu ecl sbcl scl)
    724779    (let ((uid-string
    725780           (with-output-to-string (*verbose-out*)
    733788  (make-pathname :directory '(:absolute)
    734789                 :name nil :type nil :version nil
    735                  :defaults pathname ;; host device, and on scl scheme scheme-specific-part port username password
     790                 :defaults pathname ;; host device, and on scl, *some*
     791                 ;; scheme-specific parts: port username password, not others:
    736792                 . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
    738 (defun* find-symbol* (s p)
    739   (find-symbol (string s) p))
    741794(defun* probe-file* (p)
    743796with given pathname and if it exists return its truename."
    744797  (etypecase p
    745    (null nil)
    746    (string (probe-file* (parse-namestring p)))
    747    (pathname (unless (wild-pathname-p p)
    748                #.(or #+(or allegro clozure cmu ecl sbcl scl) '(probe-file p)
    749                      #+clisp (aif (find-symbol (string '#:probe-pathname) :ext) `(ignore-errors (,it p)))
    750                      '(ignore-errors (truename p)))))))
     798    (null nil)
     799    (string (probe-file* (parse-namestring p)))
     800    (pathname (unless (wild-pathname-p p)
     801                #.(or #+(or allegro clozure cmu cormanlisp ecl sbcl scl) '(probe-file p)
     802                      #+clisp (aif (find-symbol* '#:probe-pathname :ext)
     803                                   `(ignore-errors (,it p)))
     804                      '(ignore-errors (truename p)))))))
    752806(defun* truenamize (p)
    789843                (excl:pathname-resolve-symbolic-links path)))
     845(defun* resolve-symlinks* (path)
     846  (if *resolve-symlinks*
     847      (and path (resolve-symlinks path))
     848      path))
     850(defun ensure-pathname-absolute (path)
     851  (cond
     852    ((absolute-pathname-p path) path)
     853    ((stringp path) (ensure-pathname-absolute (pathname path)))
     854    ((not (pathnamep path)) (error "not a valid pathname designator ~S" path))
     855    (t (let ((resolved (resolve-symlinks path)))
     856         (assert (absolute-pathname-p resolved))
     857         resolved))))
    791859(defun* default-directory ()
    792860  (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
    795863  (make-pathname :type "lisp" :defaults input-file))
     865(defparameter *wild* #-cormanlisp :wild #+cormanlisp "*")
    797866(defparameter *wild-file*
    798   (make-pathname :name :wild :type :wild :version :wild :directory nil))
     867  (make-pathname :name *wild* :type *wild*
     868                 :version (or #-(or abcl xcl) *wild*) :directory nil))
    799869(defparameter *wild-directory*
    800   (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil))
     870  (make-pathname :directory `(:relative ,*wild*) :name nil :type nil :version nil))
    801871(defparameter *wild-inferiors*
    802872  (make-pathname :directory '(:relative :wild-inferiors) :name nil :type nil :version nil))
    835905(defun* directorize-pathname-host-device (pathname)
    836906  (let ((scheme (ext:pathname-scheme pathname))
    837   (host (pathname-host pathname))
    838   (port (ext:pathname-port pathname))
    839   (directory (pathname-directory pathname)))
     907        (host (pathname-host pathname))
     908        (port (ext:pathname-port pathname))
     909        (directory (pathname-directory pathname)))
    840910    (flet ((not-unspecific (component)
    841        (and (not (eq component :unspecific)) component)))
     911             (and (not (eq component :unspecific)) component)))
    842912      (cond ((or (not-unspecific port)
    843     (and (not-unspecific host) (plusp (length host)))
    844     (not-unspecific scheme))
    845        (let ((prefix ""))
    846          (when (not-unspecific port)
    847     (setf prefix (format nil ":~D" port)))
    848          (when (and (not-unspecific host) (plusp (length host)))
    849     (setf prefix (concatenate 'string host prefix)))
    850          (setf prefix (concatenate 'string ":" prefix))
    851          (when (not-unspecific scheme)
    852          (setf prefix (concatenate 'string scheme prefix)))
    853          (assert (and directory (eq (first directory) :absolute)))
    854          (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
    855             :defaults pathname)))
    856       (t
    857        pathname)))))
     913                (and (not-unspecific host) (plusp (length host)))
     914                (not-unspecific scheme))
     915             (let ((prefix ""))
     916               (when (not-unspecific port)
     917                (setf prefix (format nil ":~D" port)))
     918               (when (and (not-unspecific host) (plusp (length host)))
     919                (setf prefix (concatenate 'string host prefix)))
     920               (setf prefix (concatenate 'string ":" prefix))
     921               (when (not-unspecific scheme)
     922               (setf prefix (concatenate 'string scheme prefix)))
     923               (assert (and directory (eq (first directory) :absolute)))
     924               (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
     925                              :defaults pathname)))
     926            (t
     927             pathname)))))
    859929;;;; -------------------------------------------------------------------------
    892962(defgeneric* (setf component-property) (new-value component property))
     964(eval-when (:compile-toplevel :load-toplevel :execute)
     965  (defgeneric* (setf module-components-by-name) (new-value module)))
    894967(defgeneric* version-satisfies (component version))
    9681041   (when (find-class 'module nil)
    9691042     (eval
    970       `(defmethod update-instance-for-redefined-class :after
     1043      '(defmethod update-instance-for-redefined-class :after
    9711044           ((m module) added deleted plist &key)
    9721045         (declare (ignorable deleted plist))
    973          (when (or *asdf-verbose* *load-verbose*)
     1046         (when *asdf-verbose*
    9741047           (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%")
    975        m ,(asdf-version)))
     1048                         m (asdf-version)))
    9761049         (when (member 'components-by-name added)
    9771050           (compute-module-components-by-name m))
    9951068  #+cmu (:report print-object))
    997 (declaim (ftype (function (t) t)
    998                 format-arguments format-control
    999                 error-name error-pathname error-condition
    1000                 duplicate-names-name
    1001                 error-component error-operation
    1002                 module-components module-components-by-name
    1003                 circular-dependency-components
    1004                 condition-arguments condition-form
    1005                 condition-format condition-location
    1006                 coerce-name)
    1007          (ftype (function (t t) t) (setf module-components-by-name)))
    10101070(define-condition formatted-system-definition-error (system-definition-error)
    10111071  ((format-control :initarg :format-control :reader format-control)
    10121072   (format-arguments :initarg :format-arguments :reader format-arguments))
    10131073  (:report (lambda (c s)
    1014                (apply #'format s (format-control c) (format-arguments c)))))
     1074               (apply 'format s (format-control c) (format-arguments c)))))
    10161076(define-condition load-system-definition-error (system-definition-error)
    10191079   (condition :initarg :condition :reader error-condition))
    10201080  (:report (lambda (c s)
    1021        (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>")
    1022          (error-name c) (error-pathname c) (error-condition c)))))
     1081             (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>")
     1082                     (error-name c) (error-pathname c) (error-condition c)))))
    10241084(define-condition circular-dependency (system-definition-error)
    10251085  ((components :initarg :components :reader circular-dependency-components))
    10261086  (:report (lambda (c s)
    1027        (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
    1028          (circular-dependency-components c)))))
     1087             (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
     1088                     (circular-dependency-components c)))))
    10301090(define-condition duplicate-names (system-definition-error)
    10311091  ((name :initarg :name :reader duplicate-names-name))
    10321092  (:report (lambda (c s)
    1033        (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>")
    1034          (duplicate-names-name c)))))
     1093             (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>")
     1094                     (duplicate-names-name c)))))
    10361096(define-condition missing-component (system-definition-error)
    10751135(defclass component ()
    1076   ((name :accessor component-name :initarg :name :documentation
     1136  ((name :accessor component-name :initarg :name :type string :documentation
    10771137         "Component name: designator for a string composed of portable pathname characters")
     1138   ;; We might want to constrain version with
     1139   ;; :type (and string (satisfies parse-version))
     1140   ;; but we cannot until we fix all systems that don't use it correctly!
    10781141   (version :accessor component-version :initarg :version)
    10791142   (description :accessor component-description :initarg :description)
    11551218          (missing-version c)
    11561219          (when (missing-parent c)
    1157             (component-name (missing-parent c)))))
     1220            (coerce-name (missing-parent c)))))
    11591222(defmethod component-system ((component component))
    12451308(defmethod version-satisfies ((c component) version)
    12461309  (unless (and version (slot-boundp c 'version))
     1310    (when version
     1311      (warn "Requested version ~S but component ~S has no version" version c))
    12471312    (return-from version-satisfies t))
    12481313  (version-satisfies (component-version c) version))
     1315(defun parse-version (string &optional on-error)
     1316  "Parse a version string as a series of natural integers separated by dots.
     1317Return a (non-null) list of integers if the string is valid, NIL otherwise.
     1318If on-error is error, warn, or designates a function of compatible signature,
     1319the function is called with an explanation of what is wrong with the argument.
     1320NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3"
     1321  (and
     1322   (or (stringp string)
     1323       (when on-error
     1324         (funcall on-error "~S: ~S is not a string"
     1325                  'parse-version string)) nil)
     1326   (or (loop :for prev = nil :then c :for c :across string
     1327         :always (or (digit-char-p c)
     1328                     (and (eql c #\.) prev (not (eql prev #\.))))
     1329         :finally (return (and c (digit-char-p c))))
     1330       (when on-error
     1331         (funcall on-error "~S: ~S doesn't follow asdf version numbering convention"
     1332                  'parse-version string)) nil)
     1333   (mapcar #'parse-integer (split-string string :separator "."))))
    12501335(defmethod version-satisfies ((cver string) version)
    1251   (let ((x (mapcar #'parse-integer
    1252                    (split-string cver :separator ".")))
    1253         (y (mapcar #'parse-integer
    1254                    (split-string version :separator "."))))
     1336  (let ((x (parse-version cver 'warn))
     1337        (y (parse-version version 'warn)))
    12551338    (labels ((bigger (x y)
    12561339               (cond ((not y) t)
    12591342                     ((= (car x) (car y))
    12601343                      (bigger (cdr x) (cdr y))))))
    1261       (and (= (car x) (car y))
     1344      (and x y (= (car x) (car y))
    12621345           (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
    12851368  (gethash (coerce-name name) *defined-systems*))
     1370(defun* register-system (system)
     1371  (check-type system system)
     1372  (let ((name (component-name system)))
     1373    (check-type name string)
     1374    (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system)
     1375    (unless (eq system (cdr (gethash name *defined-systems*)))
     1376      (setf (gethash name *defined-systems*)
     1377            (cons (get-universal-time) system)))))
    12871379(defun* clear-system (name)
    12881380  "Clear the entry for a system in the database of systems previously loaded.
    12891381Note that this does NOT in any way cause the code of the system to be unloaded."
    1290   ;; There is no "unload" operation in Common Lisp, and a general such operation
    1291   ;; cannot be portably written, considering how much CL relies on side-effects
    1292   ;; to global data structures.
     1382  ;; There is no "unload" operation in Common Lisp, and
     1383  ;; a general such operation cannot be portably written,
     1384  ;; considering how much CL relies on side-effects to global data structures.
    12931385  (remhash (coerce-name name) *defined-systems*))
    13101402(defparameter *system-definition-search-functions*
    1311   '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf))
    1313 (defun* system-definition-pathname (system)
     1403  '(sysdef-central-registry-search
     1404    sysdef-source-registry-search
     1405    sysdef-find-asdf))
     1407(defun* search-for-system-definition (system)
    13141408  (let ((system-name (coerce-name system)))
    1315     (or
    1316      (some #'(lambda (x) (funcall x system-name))
    1317            *system-definition-search-functions*)
    1318      (let ((system-pair (system-registered-p system-name)))
    1319        (and system-pair
    1320             (system-source-file (cdr system-pair)))))))
     1409    (some #'(lambda (x) (funcall x system-name))
     1410          (cons 'find-system-if-being-defined *system-definition-search-functions*))))
    13221412(defvar *central-registry* nil
    13821472                          (coerce-entry-to-directory ()
    13831473                            :report (lambda (s)
    1384               (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>")
    1385                 (ensure-directory-pathname defaults) dir))
     1474                                      (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>")
     1475                                              (ensure-directory-pathname defaults) dir))
    13861476                            (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
    13871477        ;; cleanup
    14151505  ;; as if the file were very old.
    14161506  ;; (or should we treat the case in a different, special way?)
    1417   (or (and pathname (probe-file* pathname) (file-write-date pathname))
     1507  (or (and pathname (probe-file* pathname) (ignore-errors (file-write-date pathname)))
    14181508      (progn
    14191509        (when (and pathname *asdf-verbose*)
    14221512        0)))
     1514(defmethod find-system ((name null) &optional (error-p t))
     1515  (when error-p
     1516    (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
    14241518(defmethod find-system (name &optional (error-p t))
    14251519  (find-system (coerce-name name) error-p))
    1427 (defun load-sysdef (name pathname)
     1521(defvar *systems-being-defined* nil
     1522  "A hash-table of systems currently being defined keyed by name, or NIL")
     1524(defun* find-system-if-being-defined (name)
     1525  (when *systems-being-defined*
     1526    (gethash (coerce-name name) *systems-being-defined*)))
     1528(defun* call-with-system-definitions (thunk)
     1529  (if *systems-being-defined*
     1530      (funcall thunk)
     1531      (let ((*systems-being-defined* (make-hash-table :test 'equal)))
     1532        (funcall thunk))))
     1534(defmacro with-system-definitions (() &body body)
     1535  `(call-with-system-definitions #'(lambda () ,@body)))
     1537(defun* load-sysdef (name pathname)
    14281538  ;; Tries to load system definition with canonical NAME from PATHNAME.
    1429   (let ((package (make-temporary-package)))
    1430     (unwind-protect
    1431          (handler-bind
    1432              ((error #'(lambda (condition)
    1433                          (error 'load-system-definition-error
    1434                                 :name name :pathname pathname
    1435                                 :condition condition))))
    1436            (let ((*package* package))
    1437              (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
    1438          pathname package)
    1439              (load pathname)))
    1440       (delete-package package))))
     1539  (with-system-definitions ()
     1540    (let ((package (make-temporary-package)))
     1541      (unwind-protect
     1542           (handler-bind
     1543               ((error #'(lambda (condition)
     1544                           (error 'load-system-definition-error
     1545                                  :name name :pathname pathname
     1546                                  :condition condition))))
     1547             (let ((*package* package))
     1548               (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
     1549                             pathname package)
     1550               (load pathname)))
     1551        (delete-package package)))))
    14421553(defmethod find-system ((name string) &optional (error-p t))
    1443   (catch 'find-system
     1554  (with-system-definitions ()
    14441555    (let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
    1445            (on-disk (system-definition-pathname name)))
    1446       (when (and on-disk
    1447                  (or (not in-memory)
     1556           (previous (cdr in-memory))
     1557           (previous (and (typep previous 'system) previous))
     1558           (previous-time (car in-memory))
     1559           (found (search-for-system-definition name))
     1560           (found-system (and (typep found 'system) found))
     1561           (pathname (or (and (typep found '(or pathname string)) (pathname found))
     1562                         (and found-system (system-source-file found-system))
     1563                         (and previous (system-source-file previous)))))
     1564      (setf pathname (resolve-symlinks* pathname))
     1565      (when (and pathname (not (absolute-pathname-p pathname)))
     1566        (setf pathname (ensure-pathname-absolute pathname))
     1567        (when found-system
     1568          (%set-system-source-file pathname found-system)))
     1569      (when (and previous (not (#-cormanlisp equal #+cormanlisp equalp
     1570                                             (system-source-file previous) pathname)))
     1571        (%set-system-source-file pathname previous)
     1572        (setf previous-time nil))
     1573      (when (and found-system (not previous))
     1574        (register-system found-system))
     1575      (when (and pathname
     1576                 (or (not previous-time)
    14481577                     ;; don't reload if it's already been loaded,
    14491578                     ;; or its filestamp is in the future which means some clock is skewed
    14501579                     ;; and trying to load might cause an infinite loop.
    1451                      (< (car in-memory) (safe-file-write-date on-disk) (get-universal-time))))
    1452         (load-sysdef name on-disk))
     1580                     (< previous-time (safe-file-write-date pathname) (get-universal-time))))
     1581        (load-sysdef name pathname))
    14531582      (let ((in-memory (system-registered-p name))) ; try again after loading from disk
    14541583        (cond
    14551584          (in-memory
    1456            (when on-disk
    1457              (setf (car in-memory) (safe-file-write-date on-disk)))
     1585           (when pathname
     1586             (setf (car in-memory) (safe-file-write-date pathname)))
    14581587           (cdr in-memory))
    14591588          (error-p
    14601589           (error 'missing-component :requires name)))))))
    1462 (defun* register-system (name system)
    1463   (setf name (coerce-name name))
    1464   (assert (equal name (component-name system)))
    1465   (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system)
    1466   (setf (gethash name *defined-systems*) (cons (get-universal-time) system)))
    14681591(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
    14691592  (setf fallback (coerce-name fallback)
    1470         source-file (or source-file
    1471                         (if *resolve-symlinks*
    1472                             (or *compile-file-truename* *load-truename*)
    1473                             (or *compile-file-pathname* *load-pathname*)))
    14741593        requested (coerce-name requested))
    14751594  (when (equal requested fallback)
    1476     (let* ((registered (cdr (gethash fallback *defined-systems*)))
    1477            (system (or registered
    1478                        (apply 'make-instance 'system
    1479                               :name fallback :source-file source-file keys))))
    1480       (unless registered
    1481         (register-system fallback system))
    1482       (throw 'find-system system))))
     1595    (let ((registered (cdr (gethash fallback *defined-systems*))))
     1596      (or registered
     1597          (apply 'make-instance 'system
     1598                 :name fallback :source-file source-file keys)))))
    14841600(defun* sysdef-find-asdf (name)
    15241640(defclass cl-source-file (source-file)
    15251641  ((type :initform "lisp")))
     1642(defclass (cl-source-file)
     1643  ((type :initform "cl")))
     1644(defclass cl-source-file.lsp (cl-source-file)
     1645  ((type :initform "lsp")))
    15261646(defclass c-source-file (source-file)
    15271647  ((type :initform "c")))
    15731693             (t
    15741694              (split-name-type filename)))
    1575          (make-pathname :directory `(,relative ,@path) :name name :type type
    1576                         :defaults (or defaults *default-pathname-defaults*)))))))
     1695         (apply 'make-pathname :directory (cons relative path) :name name :type type
     1696                (when defaults `(:defaults ,defaults))))))))
    15781698(defun* merge-component-name-type (name &key type defaults)
    15791699  ;; For backwards compatibility only, for people using internals.
    1580   ;; Will be removed in a future release, e.g. 2.014.
     1700  ;; Will be removed in a future release, e.g. 2.016.
     1701  (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.")
    15811702  (coerce-pathname name :type type :defaults defaults))
    15951716(defclass operation ()
    1596   (
    1597    ;; as of danb's 2003-03-16 commit e0d02781, :force can be:
    1598    ;; T to force the inside of existing system,
     1717  (;; as of danb's 2003-03-16 commit e0d02781, :force can be:
     1718   ;; T to force the inside of the specified system,
    15991719   ;;   but not recurse to other systems we depend on.
    16001720   ;; :ALL (or any other atom) to force all systems
    16021722   ;; (SYSTEM1 SYSTEM2 ... SYSTEMN)
    16031723   ;;   to force systems named in a given list
    1604    ;; However, but this feature never worked before ASDF 1.700 and is currently cerror'ed out.
     1724   ;; However, but this feature has only ever worked but starting with ASDF 2.014.5
    16051725   (forced :initform nil :initarg :force :accessor operation-forced)
    16061726   (original-initargs :initform nil :initarg :original-initargs
    16441764           (when (eql force-p t)
    16451765             (setf (getf args :force) nil))
    1646            (apply #'make-instance dep-o
     1766           (apply 'make-instance dep-o
    16471767                  :parent o
    16481768                  :original-initargs args args))
    16501770           o)
    16511771          (t
    1652            (apply #'make-instance dep-o
     1772           (apply 'make-instance dep-o
    16531773                  :parent o :original-initargs args args)))))
    16831803(defmethod component-depends-on ((op-spec symbol) (c component))
     1804  ;; Note: we go from op-spec to operation via make-instance
     1805  ;; to allow for specialization through defmethod's, even though
     1806  ;; it's a detour in the default case below.
    16841807  (component-depends-on (make-instance op-spec) c))
    16861809(defmethod component-depends-on ((o operation) (c component))
    1687   (cdr (assoc (class-name (class-of o))
    1688               (component-in-order-to c))))
     1810  (cdr (assoc (type-of o) (component-in-order-to c))))
    16901812(defmethod component-self-dependencies ((o operation) (c component))
    18031925      (retry ()
    18041926        :report (lambda (s)
    1805       (format s "~@<Retry loading component ~3i~_~S.~@:>" required-c))
     1927                  (format s "~@<Retry loading ~3i~_~A.~@:>" required-c))
    18061928        :test
    18071929        (lambda (c)
    1808     (or (null c)
    1809         (and (typep c 'missing-dependency)
    1810        (equalp (missing-requires c)
    1811          required-c))))))))
     1930          (or (null c)
     1931              (and (typep c 'missing-dependency)
     1932                   (equalp (missing-requires c)
     1933                           required-c))))))))
    18131935(defun* do-dep (operation c collect op dep)
    18571979(defmethod do-traverse ((operation operation) (c component) collect)
    1858   (let ((flag nil)) ;; return value: must we rebuild this and its dependencies?
     1980  (let ((*forcing* *forcing*)
     1981        (flag nil)) ;; return value: must we rebuild this and its dependencies?
    18591982    (labels
    18601983        ((update-flag (x)
    1861            (when x
    1862              (setf flag t)))
     1984           (orf flag x))
    18631985         (dep (op comp)
    18641986           (update-flag (do-dep operation c collect op comp))))
    18741996      (unwind-protect
    18751997           (progn
     1998             (let ((f (operation-forced
     1999                       (operation-ancestor operation))))
     2000               (when (and f (or (not (consp f)) ;; T or :ALL
     2001                                (and (typep c 'system) ;; list of names of systems to force
     2002                                     (member (component-name c) f
     2003                                             :test #'string=))))
     2004                 (setf *forcing* t)))
    18762005             ;; first we check and do all the dependencies for the module.
    18772006             ;; Operations planned in this loop will show up
    19132042                                     (not at-least-one))
    19142043                            (error error)))))))
    1915                (update-flag
    1916                 (or
    1917                  *forcing*
    1918                  (not (operation-done-p operation c))
     2044               (update-flag (or *forcing* (not (operation-done-p operation c))))
    19192045                 ;; For sub-operations, check whether
    19202046                 ;; the original ancestor operation was forced,
    19232049                 ;; between all the things with a given name. Sigh.
    19242050                 ;; BROKEN!
    1925                  (let ((f (operation-forced
    1926                            (operation-ancestor operation))))
    1927                    (and f (or (not (consp f)) ;; T or :ALL
    1928                               (and (typep c 'system) ;; list of names of systems to force
    1929                                    (member (component-name c) f
    1930                                            :test #'string=)))))))
    19312051               (when flag
    19322052                 (let ((do-first (cdr (assoc (class-name (class-of operation))
    19582078(defmethod traverse ((operation operation) (c component))
    1959   ;; cerror'ing a feature that seems to have NEVER EVER worked
    1960   ;; ever since danb created it in his 2003-03-16 commit e0d02781.
    1961   ;; It was both fixed and disabled in the 1.700 rewrite.
    19622079  (when (consp (operation-forced operation))
    1963     (cerror "Continue nonetheless."
    1964             "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.")
    19652080    (setf (operation-forced operation)
    19662081          (mapcar #'coerce-name (operation-forced operation))))
    19812096(defmethod explain ((operation operation) (component component))
    1982   (asdf-message "~&;;; ~A~%" (operation-description operation component)))
     2097  (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%")
     2098                (operation-description operation component)))
    19842100(defmethod operation-description (operation component)
    1985   (format nil (compatfmt "~@<~A on component ~S~@:>")
    1986     (class-of operation) (component-find-path component)))
     2101  (format nil (compatfmt "~@<~A on ~A~@:>")
     2102          (class-of operation) component))
    19882104;;;; -------------------------------------------------------------------------
    20312147        (apply *compile-op-compile-file-function* source-file :output-file output-file
    20322148               (compile-op-flags operation))
    2033       (when warnings-p
    2034         (case (operation-on-warnings operation)
    2035           (:warn (warn
    2036                   (compatfmt "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>")
    2037                   operation c))
    2038           (:error (error 'compile-warned :component c :operation operation))
    2039           (:ignore nil)))
     2149      (unless output
     2150        (error 'compile-error :component c :operation operation))
    20402151      (when failure-p
    20412152        (case (operation-on-failure operation)
    20452156          (:error (error 'compile-failed :component c :operation operation))
    20462157          (:ignore nil)))
    2047       (unless output
    2048         (error 'compile-error :component c :operation operation)))))
     2158      (when warnings-p
     2159        (case (operation-on-warnings operation)
     2160          (:warn (warn
     2161                  (compatfmt "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>")
     2162                  operation c))
     2163          (:error (error 'compile-warned :component c :operation operation))
     2164          (:ignore nil))))))
    20502166(defmethod output-files ((operation compile-op) (c cl-source-file))
    20682184(defmethod operation-description ((operation compile-op) component)
    20692185  (declare (ignorable operation))
    2070   (format nil "compiling component ~S" (component-find-path component)))
     2186  (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") component))
     2188(defmethod operation-description ((operation compile-op) (component module))
     2189  (declare (ignorable operation))
     2190  (format nil (compatfmt "~@<compiled ~3i~_~A~@:>") component))
    20722193;;;; -------------------------------------------------------------------------
    20822203(defmethod perform-with-restarts (operation component)
     2204  ;;(when *asdf-verbose* (explain operation component)) ; TOO verbose, especially as the default.
    20832205  (perform operation component))
    20952217      (:failed-load
    20962218       (setf state :recompiled)
    2097        (perform (make-instance 'compile-op) c))
     2219       (perform (make-sub-operation c o c 'compile-op) c))
    20982220      (t
    20992221       (with-simple-restart
    21432265(defmethod operation-description ((operation load-op) component)
    21442266  (declare (ignorable operation))
    2145   (format nil (compatfmt "~@<Loading component: ~3i~_~S~@:>")
    2146     (component-find-path component)))
     2267  (format nil (compatfmt "~@<loading ~3i~_~A~@:>")
     2268          component))
     2270(defmethod operation-description ((operation load-op) (component cl-source-file))
     2271  (declare (ignorable operation))
     2272  (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>")
     2273          component))
     2275(defmethod operation-description ((operation load-op) (component module))
     2276  (declare (ignorable operation))
     2277  (format nil (compatfmt "~@<loaded ~3i~_~A~@:>")
     2278          component))
    21492280;;;; -------------------------------------------------------------------------
    21672298  nil)
    2169 ;;; FIXME: we simply copy load-op's dependencies.  this is Just Not Right.
     2300;;; FIXME: We simply copy load-op's dependencies.  This is Just Not Right.
    21702301(defmethod component-depends-on ((o load-source-op) (c component))
    21712302  (declare (ignorable o))
    2172   (let ((what-would-load-op-do (cdr (assoc 'load-op
    2173                                            (component-in-order-to c)))))
    2174     (mapcar #'(lambda (dep)
    2175                 (if (eq (car dep) 'load-op)
    2176                     (cons 'load-source-op (cdr dep))
    2177                     dep))
    2178             what-would-load-op-do)))
     2303  (loop :with what-would-load-op-do = (component-depends-on 'load-op c)
     2304    :for (op . co) :in what-would-load-op-do
     2305    :when (eq op 'load-op) :collect (cons 'load-source-op co)))
    21802307(defmethod operation-done-p ((o load-source-op) (c source-file))
    21872314(defmethod operation-description ((operation load-source-op) component)
    21882315  (declare (ignorable operation))
    2189   (format nil (compatfmt "~@<Loading component: ~3i~_~S~@:>")
    2190     (component-find-path component)))
     2316  (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>")
     2317          component))
     2319(defmethod operation-description ((operation load-source-op) (component module))
     2320  (declare (ignorable operation))
     2321  (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") component))
    22152346(defgeneric* operate (operation-class system &key &allow-other-keys))
     2347(defgeneric* perform-plan (plan &key))
     2349;;;; Try to upgrade of ASDF. If a different version was used, return T.
     2350;;;; We need do that before we operate on anything that depends on ASDF.
     2351(defun* upgrade-asdf ()
     2352  (let ((version (asdf:asdf-version)))
     2353    (handler-bind (((or style-warning warning) #'muffle-warning))
     2354      (operate 'load-op :asdf :verbose nil))
     2355    (let ((new-version (asdf:asdf-version)))
     2356      (block nil
     2357        (cond
     2358          ((equal version new-version)
     2359           (return nil))
     2360          ((version-satisfies new-version version)
     2361           (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
     2362                         version new-version))
     2363          ((version-satisfies version new-version)
     2364           (warn (compatfmt "~&~@<Downgraded ASDF from version ~A to version ~A~@:>~%")
     2365                 version new-version))
     2366          (t
     2367           (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
     2368                         version new-version)))
     2369        (let ((asdf (find-system :asdf)))
     2370          ;; invalidate all systems but ASDF itself
     2371          (setf *defined-systems* (make-defined-systems-table))
     2372          (register-system asdf)
     2373          t)))))
     2375(defmethod perform-plan ((steps list) &key)
     2376  (let ((*package* *package*)
     2377        (*readtable* *readtable*))
     2378    (with-compilation-unit ()
     2379      (loop :for (op . component) :in steps :do
     2380        (loop
     2381          (restart-case
     2382              (progn
     2383                (perform-with-restarts op component)
     2384                (return))
     2385            (retry ()
     2386              :report
     2387              (lambda (s)
     2388                (format s (compatfmt "~@<Retry ~A.~@:>")
     2389                        (operation-description op component))))
     2390            (accept ()
     2391              :report
     2392              (lambda (s)
     2393                (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
     2394                        (operation-description op component)))
     2395              (setf (gethash (type-of op)
     2396                             (component-operation-times component))
     2397                    (get-universal-time))
     2398              (return))))))))
    22172400(defmethod operate (operation-class system &rest args
    22192402                    &allow-other-keys)
    22202403  (declare (ignore force))
    2221   (let* ((*package* *package*)
    2222          (*readtable* *readtable*)
    2223          (op (apply #'make-instance operation-class
    2224                     :original-initargs args
    2225                     args))
    2226          (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
    2227          (system (if (typep system 'component) system (find-system system))))
    2228     (unless (version-satisfies system version)
    2229       (error 'missing-component-of-version :requires system :version version))
    2230     (let ((steps (traverse op system)))
    2231       (with-compilation-unit ()
    2232         (loop :for (op . component) :in steps :do
    2233           (loop
    2234             (restart-case
    2235                 (progn
    2236                   (perform-with-restarts op component)
    2237                   (return))
    2238               (retry ()
    2239                 :report
    2240                 (lambda (s)
    2241       (format s (compatfmt "~@<Retry ~A.~@:>")
    2242         (operation-description op component))))
    2243               (accept ()
    2244                 :report
    2245                 (lambda (s)
    2246       (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
    2247         (operation-description op component)))
    2248                 (setf (gethash (type-of op)
    2249                                (component-operation-times component))
    2250                       (get-universal-time))
    2251                 (return))))))
    2252       (values op steps))))
     2404  (with-system-definitions ()
     2405    (let* ((op (apply 'make-instance operation-class
     2406                      :original-initargs args
     2407                      args))
     2408           (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
     2409           (system (etypecase system
     2410                     (system system)
     2411                     ((or string symbol) (find-system system)))))
     2412      (unless (version-satisfies system version)
     2413        (error 'missing-component-of-version :requires system :version version))
     2414      (let ((steps (traverse op system)))
     2415        (when (and (not (equal '("asdf") (component-find-path system)))
     2416                   (find '("asdf") (mapcar 'cdr steps)
     2417                         :test 'equal :key 'component-find-path)
     2418                   (upgrade-asdf))
     2419          ;; If we needed to upgrade ASDF to achieve our goal,
     2420          ;; then do it specially as the first thing, then
     2421          ;; invalidate all existing system
     2422          ;; retry the whole thing with the new OPERATE function,
     2423          ;; which on some implementations
     2424          ;; has a new symbol shadowing the current one.
     2425          (return-from operate
     2426            (apply (find-symbol* 'operate :asdf) operation-class system args)))
     2427        (perform-plan steps)
     2428        (values op steps)))))
    22542430(defun* oos (operation-class system &rest args &key force verbose version
    22552431            &allow-other-keys)
    22562432  (declare (ignore force verbose version))
    2257   (apply #'operate operation-class system args))
     2433  (apply 'operate operation-class system args))
    22592435(let ((operate-docstring
    22822458        operate-docstring))
    2284 (defun* load-system (system &rest args &key force verbose version
    2285                     &allow-other-keys)
    2286   "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for
    2287 details."
     2460(defun* load-system (system &rest args &key force verbose version &allow-other-keys)
     2461  "Shorthand for `(operate 'asdf:load-op system)`.
     2462See OPERATE for details."
    22882463  (declare (ignore force verbose version))
    2289   (apply #'operate 'load-op system args)
     2464  (apply 'operate 'load-op system args)
    22902465  t)
    22952470for details."
    22962471  (declare (ignore force verbose version))
    2297   (apply #'operate 'compile-op system args)
     2472  (apply 'operate 'compile-op system args)
    22982473  t)
    23042479  (declare (ignore force verbose version))
    2305   (apply #'operate 'test-op system args)
     2480  (apply 'operate 'test-op system args)
    23062481  t)
    23112486(defun* load-pathname ()
    2312   (let ((pn (or *load-pathname* *compile-file-pathname*)))
    2313     (if *resolve-symlinks*
    2314         (and pn (resolve-symlinks pn))
    2315         pn)))
     2487  (resolve-symlinks* (or *load-pathname* *compile-file-pathname*)))
    23172489(defun* determine-system-pathname (pathname pathname-supplied-p)
    23292501        (default-directory))))
    2331 (defmacro defsystem (name &body options)
    2332   (setf name (coerce-name name))
    2333   (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
    2334                             defsystem-depends-on &allow-other-keys)
    2335       options
    2336     (let ((component-options (remove-keys '(:class) options)))
    2337       `(progn
    2338          ;; system must be registered before we parse the body, otherwise
    2339          ;; we recur when trying to find an existing system of the same name
    2340          ;; to reuse options (e.g. pathname) from
    2341          ,@(loop :for system :in defsystem-depends-on
    2342              :collect `(load-system ',(coerce-name system)))
    2343          (let ((s (system-registered-p ',name)))
    2344            (cond ((and s (eq (type-of (cdr s)) ',class))
    2345                   (setf (car s) (get-universal-time)))
    2346                  (s
    2347                   (change-class (cdr s) ',class))
    2348                  (t
    2349                   (register-system (quote ,name)
    2350                                    (make-instance ',class :name ',name))))
    2351            (%set-system-source-file (load-pathname)
    2352                                     (cdr (system-registered-p ',name))))
    2353          (parse-component-form
    2354           nil (list*
    2355                :module (coerce-name ',name)
    2356                :pathname
    2357                ,(determine-system-pathname pathname pathname-arg-p)
    2358                ',component-options))))))
    23602503(defun* class-for-type (parent type)
    23612504  (or (loop :for symbol :in (list
    23642507                             (find-symbol* type :asdf))
    23652508        :for class = (and symbol (find-class symbol nil))
    2366         :when (and class (subtypep class 'component))
     2509        :when (and class
     2510                   (#-cormanlisp subtypep #+cormanlisp cl::subclassp
     2511                                 class (find-class 'component)))
    23672512        :return class)
    23682513      (and (eq type :file)
    2369            (or (module-default-component-class parent)
     2514           (or (and parent (module-default-component-class parent))
    23702515               (find-class *default-component-class*)))
    23712516      (sysdef-error "don't recognize component type ~A" type)))
    24592604              weakly-depends-on
    24602605              depends-on serial in-order-to
     2606              (version nil versionp)
    24612607              ;; list ends
    24622608              &allow-other-keys) options
    24712617                       (class-for-type parent type))))
    24722618      (error 'duplicate-names :name name))
     2620    (when versionp
     2621      (unless (parse-version version nil)
     2622        (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>")
     2623              version name parent)))
    24742625    (let* ((other-args (remove-keys
    24852636      (when *serial-depends-on*
    24862637        (push *serial-depends-on* depends-on))
    2487       (apply #'reinitialize-instance ret
     2638      (apply 'reinitialize-instance ret
    24882639             :name (coerce-name name)
    24892640             :pathname pathname
    25182669      ret)))
     2671(defun* do-defsystem (name &rest options
     2672                           &key (pathname nil pathname-arg-p) (class 'system)
     2673                           defsystem-depends-on &allow-other-keys)
     2674  ;; The system must be registered before we parse the body,
     2675  ;; otherwise we recur when trying to find an existing system
     2676  ;; of the same name to reuse options (e.g. pathname) from.
     2677  ;; To avoid infinite recursion in cases where you defsystem a system
     2678  ;; that is registered to a different location to find-system,
     2679  ;; we also need to remember it in a special variable *systems-being-defined*.
     2680  (with-system-definitions ()
     2681    (let* ((name (coerce-name name))
     2682           (registered (system-registered-p name))
     2683           (system (cdr (or registered
     2684                            (register-system (make-instance 'system :name name)))))
     2685           (component-options (remove-keys '(:class) options)))
     2686      (%set-system-source-file (load-pathname) system)
     2687      (setf (gethash name *systems-being-defined*) system)
     2688      (when registered
     2689        (setf (car registered) (get-universal-time)))
     2690      (map () 'load-system defsystem-depends-on)
     2691      ;; We change-class (when necessary) AFTER we load the defsystem-dep's
     2692      ;; since the class might not be defined as part of those.
     2693      (let ((class (class-for-type nil class)))
     2694        (unless (eq (type-of system) class)
     2695          (change-class system class)))
     2696      (parse-component-form
     2697       nil (list*
     2698            :module name
     2699            :pathname (determine-system-pathname pathname pathname-arg-p)
     2700            component-options)))))
     2702(defmacro defsystem (name &body options)
     2703  `(apply 'do-defsystem ',name ',options))
    25202705;;;; ---------------------------------------------------------------------------
    25212706;;;; run-shell-command
    25352720synchronously execute the result using a Bourne-compatible shell, with
    25362721output to *VERBOSE-OUT*.  Returns the shell's exit code."
    2537   (let ((command (apply #'format nil control-string args)))
     2722  (let ((command (apply 'format nil control-string args)))
    25382723    (asdf-message "; $ ~A~%" command)
    25532738      exit-code)
    2555     #+clisp                     ;XXX not exactly *verbose-out*, I know
    2556     (or (ext:run-shell-command  command :output :terminal :wait t) 0)
     2740    #+clisp                    ;XXX not exactly *verbose-out*, I know
     2741    (or (ext:run-shell-command command :output (and *verbose-out* :terminal) :wait t) 0)
    25582743    #+clozure
    25792764    #+sbcl
    25802765    (sb-ext:process-exit-code
    2581      (apply #'sb-ext:run-program
     2766     (apply 'sb-ext:run-program
    25822767            #+win32 "sh" #-win32 "/bin/sh"
    25832768            (list  "-c" command)
    25922777      :input nil :output *verbose-out*))
    2594     #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl)
     2779    #+xcl
     2780    (ext:run-shell-command command)
     2782    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl xcl)
    25952783    (error "RUN-SHELL-COMMAND not implemented for this Lisp")))
    25972785;;;; ---------------------------------------------------------------------------
    25982786;;;; system-relative-pathname
     2788(defun* system-definition-pathname (x)
     2789  ;; As of 2.014.8, we mean to make this function obsolete,
     2790  ;; but that won't happen until all clients have been updated.
     2791  ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
     2792  "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
     2793It used to expose ASDF internals with subtle differences with respect to
     2794user expectations, that have been refactored away since.
     2795We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
     2796for a mostly compatible replacement that we're supporting,
     2798if that's whay you mean." ;;)
     2799  (system-source-file x))
    26002801(defmethod system-source-file ((system-name string))
    26452846    (:corman :cormanlisp)
    26462847    (:lw :lispworks)
    2647     :clisp :cmu :ecl :gcl :sbcl :scl :symbolics))
     2848    :clisp :cmu :ecl :gcl :sbcl :scl :symbolics :xcl))
    26492850(defparameter *os-features*
    2650   '((:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows
     2851  '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows
    26512852    (:solaris :sunos)
    26522853    (:linux :linux-target) ;; for GCL at least, must appear before :bsd.
    26582859(defparameter *architecture-features*
    2659   '((:amd64 :x86-64 :x86_64 :x8664-target)
     2860  '((:x64 :amd64 :x86-64 :x86_64 :x8664-target #+(and clisp word-size=64) :pc386)
    26602861    (:x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
    2661     :hppa64
    2662     :hppa
    2663     (:ppc64 :ppc64-target)
    2664     (:ppc32 :ppc32-target :ppc :powerpc)
    2665     :sparc64
    2666     (:sparc32 :sparc)
     2862    :hppa64 :hppa
     2863    (:ppc64 :ppc64-target) (:ppc32 :ppc32-target :ppc :powerpc)
     2864    :sparc64 (:sparc32 :sparc)
    26672865    (:arm :arm-target)
    26682866    (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)
     2867    :mipsel :mipseb :mips
     2868    :alpha
    26692869    :imach))
    26712871(defun* lisp-version-string ()
    26722872  (let ((s (lisp-implementation-version)))
    2673     (declare (ignorable s))
    2674     #+allegro (format nil
    2675                       "~A~A~A~A"
    2676                       excl::*common-lisp-version-number*
    2677                       ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
    2678                       (if (eq excl:*current-case-mode*
    2679                               :case-sensitive-lower) "M" "A")
    2680                       ;; Note if not using International ACL
    2681                       ;; see
    2682                       (excl:ics-target-case
    2683                        (:-ics "8")
    2684                        (:+ics ""))
    2685                       (if (member :64bit *features*) "-64bit" ""))
    2686     #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
    2687     #+clisp (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
    2688     #+clozure (format nil "~d.~d-f~d" ; shorten for windows
    2689                       ccl::*openmcl-major-version*
    2690                       ccl::*openmcl-minor-version*
    2691                       (logand ccl::fasl-version #xFF))
    2692     #+cmu (substitute #\- #\/ s)
    2693     #+ecl (format nil "~A~@[-~A~]" s
    2694                   (let ((vcs-id (ext:lisp-implementation-vcs-id)))
    2695                     (when (>= (length vcs-id) 8)
    2696                       (subseq vcs-id 0 8))))
    2697     #+gcl (subseq s (1+ (position #\space s)))
    2698     #+genera (multiple-value-bind (major minor) (sct:get-system-version "System")
    2699                (format nil "~D.~D" major minor))
    2700     #+lispworks (format nil "~A~@[~A~]" s
    2701                         (when (member :lispworks-64bit *features*) "-64bit"))
    2702     ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version
    2703     #+mcl (subseq s 8) ; strip the leading "Version "
    2704     #+(or cormanlisp sbcl scl) s
    2705     #-(or allegro armedbear clisp clozure cmu cormanlisp
    2706           ecl gcl genera lispworks mcl sbcl scl) s))
     2873    (or
     2874     #+allegro (format nil
     2875                       "~A~A~A"
     2876                       excl::*common-lisp-version-number*
     2877                       ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
     2878                       (if (eq excl:*current-case-mode*
     2879                               :case-sensitive-lower) "M" "A")
     2880                       ;; Note if not using International ACL
     2881                       ;; see
     2882                       (excl:ics-target-case
     2883                        (:-ics "8")
     2884                        (:+ics ""))) ; redundant? (if (member :64bit *features*) "-64bit" ""))
     2885     #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
     2886     #+clisp (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
     2887     #+clozure (format nil "~d.~d-f~d" ; shorten for windows
     2888                       ccl::*openmcl-major-version*
     2889                       ccl::*openmcl-minor-version*
     2890                       (logand ccl::fasl-version #xFF))
     2891     #+cmu (substitute #\- #\/ s)
     2892     #+ecl (format nil "~A~@[-~A~]" s
     2893                   (let ((vcs-id (ext:lisp-implementation-vcs-id)))
     2894                     (when (>= (length vcs-id) 8)
     2895                       (subseq vcs-id 0 8))))
     2896     #+gcl (subseq s (1+ (position #\space s)))
     2897     #+genera (multiple-value-bind (major minor) (sct:get-system-version "System")
     2898                (format nil "~D.~D" major minor))
     2899     ;; #+lispworks (format nil "~A~@[~A~]" s (when (member :lispworks-64bit *features*) "-64bit")     #+mcl (subseq s 8) ; strip the leading "Version "
     2900     ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version
     2901     s)))
    27082903(defun* first-feature (features)
    27292924      ((maybe-warn (value fstring &rest args)
    27302925         (cond (value)
    2731                (t (apply #'warn fstring args)
     2926               (t (apply 'warn fstring args)
    27322927                  "unknown"))))
    27332928    (let ((lisp (maybe-warn (implementation-type)
    27542949  #-asdf-unix #\;)
     2951;; Note: ASDF may expect user-homedir-pathname to provide the pathname of
     2952;; the current user's home directory, while MCL by default provides the
     2953;; directory from which MCL was started.
     2954;; See
     2955#.(or #+mcl ;; the #$ doesn't work on other implementations, even inside #+mcl
     2956      `(defun current-user-homedir-pathname ()
     2957         ,(read-from-string "(ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))")))
    27562959(defun* user-homedir ()
    2757   (truenamize (pathname-directory-pathname (user-homedir-pathname))))
     2960  (truenamize
     2961   (pathname-directory-pathname
     2962    #+mcl (current-user-homedir-pathname)
     2963    #-mcl (user-homedir-pathname))))
    27592965(defun* try-directory-subpath (x sub &key type)
    27642970    (and ts (values sp ts))))
    27652971(defun* user-configuration-directories ()
    2766   (remove-if
    2767    #'null
    2768    (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
    2769      `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/")
    2770        ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")
    2771            :for dir :in (split-string dirs :separator ":")
    2772            :collect (try dir "common-lisp/"))
    2773        #+asdf-windows
    2774         ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/")
    2775             ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
    2776            ,(try (getenv "APPDATA") "common-lisp/config/"))
    2777        ,(try (user-homedir) ".config/common-lisp/")))))
     2972  (let ((dirs
     2973         (flet ((try (x sub) (try-directory-subpath x sub)))
     2974           `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/")
     2975             ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")
     2976                 :for dir :in (split-string dirs :separator ":")
     2977                 :collect (try dir "common-lisp/"))
     2978             #+asdf-windows
     2979             ,@`(,(try (or #+lispworks (sys:get-folder-path :local-appdata)
     2980                           (getenv "LOCALAPPDATA"))
     2981                       "common-lisp/config/")
     2982                 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
     2983                 ,(try (or #+lispworks (sys:get-folder-path :appdata)
     2984                           (getenv "APPDATA"))
     2985                           "common-lisp/config/"))
     2986             ,(try (user-homedir) ".config/common-lisp/")))))
     2987    (remove-duplicates (remove-if #'null dirs) :from-end t :test 'equal)))
    27782988(defun* system-configuration-directories ()
    27792989  (remove-if
    27802990   #'null
    2781    (append
    2782     #+asdf-windows
    2783     (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
    2784       `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")
    2785            ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
    2786         ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
    2787     #+asdf-unix
    2788     (list #p"/etc/common-lisp/"))))
     2991   `(#+asdf-windows
     2992     ,(flet ((try (x sub) (try-directory-subpath x sub)))
     2993        ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
     2994        (try (or #+lispworks (sys:get-folder-path :common-appdata)
     2995                 (getenv "ALLUSERSAPPDATA")
     2996                 (try (getenv "ALLUSERSPROFILE") "Application Data/"))
     2997             "common-lisp/config/"))
     2998     #+asdf-unix #p"/etc/common-lisp/")))
    27893000(defun* in-first-directory (dirs x)
    27903001  (loop :for dir :in dirs
    28463057    (unless (length=n-p forms 1)
    28473058      (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%")
    2848        description forms))
     3059             description forms))
    28493060    (funcall validator (car forms) :location file)))
    28583069                             #+clisp '(:circle t :if-does-not-exist :ignore)
    28593070                             #+(or cmu scl) '(:follow-links nil :truenamep nil)
    2860                              #+sbcl (when (find-symbol "RESOLVE-SYMLINKS" "SB-IMPL") '(:resolve-symlinks nil))))))
     3071                             #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl)
     3072                                      '(:resolve-symlinks nil))))))
    28623074(defun* validate-configuration-directory (directory tag validator &key invalid-form-reporter)
    29043116     (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation)
    29053117     #+asdf-windows
    2906      (try (getenv "APPDATA") "common-lisp" "cache" :implementation)
     3118     (try (or #+lispworks (sys:get-folder-path :local-appdata)
     3119              (getenv "LOCALAPPDATA")
     3120              #+lispworks (sys:get-folder-path :appdata)
     3121              (getenv "APPDATA"))
     3122          "common-lisp" "cache" :implementation)
    29073123     '(:home ".cache" "common-lisp" :implementation))))
    29083124(defvar *system-cache*
    30033219                          :directory t :wilden nil))
    30043220            ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
    3005             ((eql :system-cache) (resolve-location *system-cache* :directory t :wilden nil))
     3221            ((eql :system-cache)
     3222             (warn "Using the :system-cache is deprecated. ~%~
     3223Please remove it from your ASDF configuration")
     3224             (resolve-location *system-cache* :directory t :wilden nil))
    30063225            ((eql :default-directory) (default-directory))))
    30073226         (s (if (and wilden (not (pathnamep x)))
    31023321           (when inherit
    31033322             (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
    3104         string))
     3323                    string))
    31053324           (setf inherit t)
    31063325           (push :inherit-configuration directives))
    31113330          (when source
    31123331            (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
    3113        string))
     3332                   string))
    31143333          (unless inherit
    31153334            (push :ignore-inherited-configuration directives))
    31293348    #+sbcl ,(let ((h (getenv "SBCL_HOME")))
    31303349                 (when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ())))
    3131     #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system
    3132     #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ; not needed: no precompiled ASDF system
     3350    ;; The below two are not needed: no precompiled ASDF system there
     3351    ;; #+ecl (,(translate-logical-pathname "SYS:**;*.*") ())
     3352    ;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ()))
    31333353    ;; All-import, here is where we want user stuff to be:
    31343354    :inherit-configuration
    31443364(defun* user-output-translations-pathname ()
    3145   (in-user-configuration-directory *output-translations-file* ))
     3365  (in-user-configuration-directory *output-translations-file*))
    31463366(defun* system-output-translations-pathname ()
    31473367  (in-system-configuration-directory *output-translations-file*))
    32173437                   (funcall collect (list trusrc t)))
    32183438                  (t
    3219                    (let* ((trudst (make-pathname
    3220                                    :defaults (if dst (resolve-location dst :directory t :wilden t) trusrc)))
     3439                   (let* ((trudst (if dst
     3440                                      (resolve-location dst :directory t :wilden t)
     3441                                      trusrc))
    32213442                          (wilddst (merge-pathnames* *wild-file* trudst)))
    32223443                     (funcall collect (list wilddst t))
    32723493(defun* apply-output-translations (path)
    32733494  (etypecase path
     3495    #+cormanlisp (t (truenamize path))
    32743496    (logical-pathname
    32753497     path)
    33023524(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
    3303   (or output-file
     3525  (if (absolute-pathname-p output-file)
     3526      (apply 'compile-file-pathname (lispize-pathname input-file) keys)
    33043527      (apply-output-translations
    33053528       (apply 'compile-file-pathname
    33183541(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys)
    3319   (let* ((output-file (or output-file (apply 'compile-file-pathname* input-file keys)))
     3542  (let* ((output-file (apply 'compile-file-pathname* input-file :output-file output-file keys))
    33203543         (tmp-file (tmpize-pathname output-file))
    33213544         (status :error))
    33843607  (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
    33853608         (mapped-files (if map-all-source-files *wild-file*
    3386                            (make-pathname :name :wild :version :wild :type fasl-type)))
     3609                           (make-pathname :type fasl-type :defaults *wild-file*)))
    33873610         (destination-directory
    33883611          (if centralize-lisp-binaries
    34193642(defun* read-little-endian (s &optional (bytes 4))
    3420   (loop
    3421     :for i :from 0 :below bytes
     3643  (loop :for i :from 0 :below bytes
    34223644    :sum (ash (read-byte s) (* 8 i))))
    34863708    ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
    34873709    "_sgbak" "autom4te.cache" "cover_db" "_build"
    3488     "debian")) ;; debian often build stuff under the debian directory... BAD.
     3710    "debian")) ;; debian often builds stuff under the debian directory... BAD.
    34903712(defvar *source-registry-exclusions* *default-source-registry-exclusions*)
    3492 (defvar *source-registry* ()
    3493   "Either NIL (for uninitialized), or a list of one element,
    3494 said element itself being a list of directory pathnames where to look for .asd files")
    3496 (defun* source-registry ()
    3497   (car *source-registry*))
    3499 (defun* (setf source-registry) (new-value)
    3500   (setf *source-registry* (list new-value))
    3501   new-value)
     3714(defvar *source-registry* nil
     3715  "Either NIL (for uninitialized), or an equal hash-table, mapping
     3716system names to pathnames of .asd files")
    35033718(defun* source-registry-initialized-p ()
    3504   (and *source-registry* t))
     3719  (typep *source-registry* 'hash-table))
    35063721(defun* clear-source-registry ()
    35083723You might want to call that before you dump an image that would be resumed
    35093724with a different configuration, so the configuration would be re-read then."
    3510   (setf *source-registry* '())
     3725  (setf *source-registry* nil)
    35113726  (values))
    35133728(defparameter *wild-asd*
    3514   (make-pathname :directory nil :name :wild :type "asd" :version :newest))
    3516 (defun directory-has-asd-files-p (directory)
     3729  (make-pathname :directory nil :name *wild* :type "asd" :version :newest))
     3731(defun directory-asd-files (directory)
    35173732  (ignore-errors
    3518     (and (directory* (merge-pathnames* *wild-asd* directory)) t)))
     3733    (directory* (merge-pathnames* *wild-asd* directory))))
    35203735(defun subdirectories (directory)
    35213736  (let* ((directory (ensure-directory-pathname directory))
    3522          #-(or cormanlisp genera)
     3737         #-(or abcl cormanlisp genera xcl)
    35233738         (wild (merge-pathnames*
    3524                 #-(or abcl allegro lispworks scl)
     3739                #-(or abcl allegro cmu lispworks scl xcl)
    35253740                *wild-directory*
    3526                 #+(or abcl allegro lispworks scl) "*.*"
     3741                #+(or abcl allegro cmu lispworks scl xcl) "*.*"
    35273742                directory))
    35283743         (dirs
    3529           #-(or cormanlisp genera)
     3744          #-(or abcl cormanlisp genera xcl)
    35303745          (ignore-errors
    35313746            (directory* wild . #.(or #+clozure '(:directories t :files nil)
    35323747                                     #+mcl '(:directories t))))
     3748          #+(or abcl xcl) (system:list-directory directory)
    35333749          #+cormanlisp (cl::directory-subdirs directory)
    35343750          #+genera (fs:directory-list directory))
    3535          #+(or abcl allegro genera lispworks scl)
    3536          (dirs (remove-if-not #+abcl #'extensions:probe-directory
    3537                               #+allegro #'excl:probe-directory
    3538                               #+lispworks #'lw:file-directory-p
    3539                               #+genera #'(lambda (x) (getf (cdr x) :directory))
    3540                               #-(or abcl allegro genera lispworks) #'directory-pathname-p
    3541                               dirs))
    3542          #+genera
    3543          (dirs (mapcar #'(lambda (x) (ensure-directory-pathname (first x))) dirs)))
     3751         #+(or abcl allegro cmu genera lispworks scl xcl)
     3752         (dirs (loop :for x :in dirs
     3753                 :for d = #+(or abcl xcl) (extensions:probe-directory x)
     3754                          #+allegro (excl:probe-directory x)
     3755                          #+(or cmu scl) (directory-pathname-p x)
     3756                          #+genera (getf (cdr x) :directory)
     3757                          #+lispworks (lw:file-directory-p x)
     3758                 :when d :collect #+(or abcl allegro xcl) d
     3759                                  #+genera (ensure-directory-pathname (first x))
     3760                                  #+(or cmu lispworks scl) x)))
    35443761    dirs))
     3763(defun collect-asds-in-directory (directory collect)
     3764  (map () collect (directory-asd-files directory)))
    35463766(defun collect-sub*directories (directory collectp recursep collector)
    35513771      (collect-sub*directories subdir collectp recursep collector))))
    3553 (defun collect-sub*directories-with-asd
     3773(defun collect-sub*directories-asd-files
    35543774    (directory &key
    35553775     (exclude *default-source-registry-exclusions*)
    35573777  (collect-sub*directories
    35583778   directory
    3559    #'directory-has-asd-files-p
     3779   (constantly t)
    35603780   #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal)))
    3561    collect))
     3781   #'(lambda (dir) (collect-asds-in-directory dir collect))))
    35633783(defun* validate-source-registry-directive (directive)
    36043824      :for pos = (position *inter-directory-separator* string :start start) :do
    36053825      (let ((s (subseq string start (or pos end))))
    3606         (cond
    3607          ((equal "" s) ; empty element: inherit
    3608           (when inherit
    3609             (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
    3610        string))
    3611           (setf inherit t)
    3612           (push ':inherit-configuration directives))
    3613          ((ends-with s "//")
    3614           (push `(:tree ,(subseq s 0 (1- (length s)))) directives))
    3615          (t
    3616           (push `(:directory ,s) directives)))
     3826        (flet ((check (dir)
     3827                 (unless (absolute-pathname-p dir)
     3828                   (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
     3829                 dir))
     3830          (cond
     3831            ((equal "" s) ; empty element: inherit
     3832             (when inherit
     3833               (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
     3834                      string))
     3835             (setf inherit t)
     3836             (push ':inherit-configuration directives))
     3837            ((ends-with s "//") ;; TODO: allow for doubling of separator even outside Unix?
     3838             (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
     3839            (t
     3840             (push `(:directory ,(check s)) directives))))
    36173841        (cond
    36183842          (pos
    36253849(defun* register-asd-directory (directory &key recurse exclude collect)
    36263850  (if (not recurse)
    3627       (funcall collect directory)
    3628       (collect-sub*directories-with-asd
     3851      (collect-asds-in-directory directory collect)
     3852      (collect-sub*directories-asd-files
    36293853       directory :exclude exclude :collect collect)))
    36463870    #+cmu (:tree #p"modules:")))
    36473871(defun* default-source-registry ()
    3648   (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
     3872  (flet ((try (x sub) (try-directory-subpath x sub)))
    36493873    `(:source-registry
    3650       #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir)))
     3874      #+sbcl (:directory ,(try (user-homedir) ".sbcl/systems/"))
    36513875      (:directory ,(default-directory))
    3652       ,@(let*
    3653          #+asdf-unix
    3654          ((datahome
    3655            (or (getenv "XDG_DATA_HOME")
    3656                (try (user-homedir) ".local/share/")))
    3657           (datadirs
    3658            (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share"))
    3659           (dirs (cons datahome (split-string datadirs :separator ":"))))
    3660          #+asdf-windows
    3661          ((datahome (getenv "APPDATA"))
    3662           (datadir
    3663            #+lispworks (sys:get-folder-path :local-appdata)
    3664            #-lispworks (try (getenv "ALLUSERSPROFILE")
    3665                             "Application Data"))
    3666           (dirs (list datahome datadir)))
    3667          #-(or asdf-unix asdf-windows)
    3668          ((dirs ()))
    3669          (loop :for dir :in dirs
    3670            :collect `(:directory ,(try dir "common-lisp/systems/"))
    3671            :collect `(:tree ,(try dir "common-lisp/source/"))))
     3876      ,@(loop :for dir :in
     3877          `(#+asdf-unix
     3878            ,@`(,(or (getenv "XDG_DATA_HOME")
     3879                     (try (user-homedir) ".local/share/"))
     3880                ,@(split-string (or (getenv "XDG_DATA_DIRS")
     3881                                    "/usr/local/share:/usr/share")
     3882                                :separator ":"))
     3883            #+asdf-windows
     3884            ,@`(,(or #+lispworks (sys:get-folder-path :local-appdata)
     3885                     (getenv "LOCALAPPDATA"))
     3886                ,(or #+lispworks (sys:get-folder-path :appdata)
     3887                     (getenv "APPDATA"))
     3888                ,(or #+lispworks (sys:get-folder-path :common-appdata)
     3889                     (getenv "ALLUSERSAPPDATA")
     3890                     (try (getenv "ALLUSERSPROFILE") "Application Data/"))))
     3891          :collect `(:directory ,(try dir "common-lisp/systems/"))
     3892          :collect `(:tree ,(try dir "common-lisp/source/")))
    36723893      :inherit-configuration)))
    36733894(defun* user-source-registry ()
    37583979;; Will read the configuration and initialize all internal variables,
    37593980;; and return the new configuration.
    3760 (defun* compute-source-registry (&optional parameter)
    3761   (while-collecting (collect)
    3762     (dolist (entry (flatten-source-registry parameter))
    3763       (destructuring-bind (directory &key recurse exclude) entry
     3981(defun* compute-source-registry (&optional parameter (registry *source-registry*))
     3982  (dolist (entry (flatten-source-registry parameter))
     3983    (destructuring-bind (directory &key recurse exclude) entry
     3984      (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
    37643985        (register-asd-directory
    3765          directory
    3766          :recurse recurse :exclude exclude :collect #'collect)))))
     3986         directory :recurse recurse :exclude exclude :collect
     3987         #'(lambda (asd)
     3988             (let ((name (pathname-name asd)))
     3989               (cond
     3990                 ((gethash name registry) ; already shadowed by something else
     3991                  nil)
     3992                 ((gethash name h) ; conflict at current level
     3993                  (when *asdf-verbose*
     3994                    (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
     3995                                found several entries for ~A - picking ~S over ~S~:>")
     3996                          directory recurse name (gethash name h) asd)))
     3997                 (t
     3998                  (setf (gethash name registry) asd)
     3999                  (setf (gethash name h) asd))))))
     4000        h)))
     4001  (values))
    37684003(defvar *source-registry-parameter* nil)
    37704005(defun* initialize-source-registry (&optional (parameter *source-registry-parameter*))
    3771   (setf *source-registry-parameter* parameter
    3772         (source-registry) (compute-source-registry parameter)))
     4006  (setf *source-registry-parameter* parameter)
     4007  (setf *source-registry* (make-hash-table :test 'equal))
     4008  (compute-source-registry parameter))
    37744010;; Checks an initial variable to see whether the state is initialized
    37814017;; initialize-source-registry directly with your parameter.
    37824018(defun* ensure-source-registry (&optional parameter)
    3783   (if (source-registry-initialized-p)
    3784       (source-registry)
    3785       (initialize-source-registry parameter)))
     4019  (unless (source-registry-initialized-p)
     4020    (initialize-source-registry parameter))
     4021  (values))
    37874023(defun* sysdef-source-registry-search (system)
    37884024  (ensure-source-registry)
    3789   (loop :with name = (coerce-name system)
    3790     :for defaults :in (source-registry)
    3791     :for file = (probe-asd name defaults)
    3792     :when file :return file))
     4025  (values (gethash (coerce-name system) *source-registry*)))
    37944027(defun* clear-configuration ()
    37964029  (clear-output-translations))
     4032;;; ECL support for COMPILE-OP / LOAD-OP
     4034;;; In ECL, these operations produce both FASL files and the
     4035;;; object files that they are built from. Having both of them allows
     4036;;; us to later on reuse the object files for bundles, libraries,
     4037;;; standalone executables, etc.
     4039;;; This has to be in asdf.lisp and not asdf-ecl.lisp, or else it becomes
     4040;;; a problem for asdf on ECL to compile asdf-ecl.lisp after loading asdf.lisp.
     4044  (setf *compile-op-compile-file-function*
     4045        (lambda (input-file &rest keys &key output-file &allow-other-keys)
     4046          (declare (ignore output-file))
     4047          (multiple-value-bind (object-file flags1 flags2)
     4048              (apply 'compile-file* input-file :system-p t keys)
     4049            (values (and object-file
     4050                         (c::build-fasl (compile-file-pathname object-file :type :fasl)
     4051                                        :lisp-files (list object-file))
     4052                         object-file)
     4053                    flags1
     4054                    flags2))))
     4056  (defmethod output-files ((operation compile-op) (c cl-source-file))
     4057    (declare (ignorable operation))
     4058    (let ((p (lispize-pathname (component-pathname c))))
     4059      (list (compile-file-pathname p :type :object)
     4060            (compile-file-pathname p :type :fasl))))
     4062  (defmethod perform ((o load-op) (c cl-source-file))
     4063    (map () #'load
     4064         (loop :for i :in (input-files o c)
     4065           :unless (string= (pathname-type i) "fas")
     4066           :collect (compile-file-pathname (lispize-pathname i))))))
    37984068;;;; -----------------------------------------------------------------
    37994069;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL and SBCL
     4071(defvar *require-asdf-operator* 'load-op)
    38014073(defun* module-provide-asdf (name)
    38024074  (handler-bind
    38074079                          name e))))
    38084080    (let ((*verbose-out* (make-broadcast-stream))
    3809            (system (find-system (string-downcase name) nil)))
     4081          (system (find-system (string-downcase name) nil)))
    38104082      (when system
    3811         (load-system system)))))
     4083        (operate *require-asdf-operator* system :verbose nil)
     4084        t))))
    38134086#+(or abcl clisp clozure cmu ecl sbcl)
Note: See TracChangeset for help on using the changeset viewer.