Changeset 13311


Ignore:
Timestamp:
06/08/11 05:23:25 (10 years ago)
Author:
Mark Evenson
Message:

Update to asdf-2.016.

Location:
trunk/abcl
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • 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}.
     184
     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.
    177192
    178193
     
    200215
    201216@lisp
    202 (require :asdf)
     217(require "asdf")
    203218@end lisp
    204219
    205 Consult your Lisp implementation's documentation for details.
    206 
    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.
     227
     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.
     233
     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")}.
     237
    213238
    214239@section Checking whether ASDF is loaded
     
    243268If it returns @code{NIL} then ASDF is not installed.
    244269
    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.
    247274
    248275
     
    257284
    258285@lisp
    259 (require :asdf)
     286(require "asdf")
    260287(asdf:load-system :asdf)
    261288@end lisp
     
    265292
    266293@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.
    282312
    283313Finally, note that there are some limitations to upgrading ASDF:
    284314@itemize
    285315@item
    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.
     321@item
     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.
     326@item
     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:
     337@example
     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
    292343
     
    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.
    342393
     
    345396is to create the directory
    346397@file{~/.config/common-lisp/source-registry.conf.d/}
    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:
    409461
     
    613665@item
    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")}.
    617669
     
    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.
     
    9841036
    9851037
    986 @subsection Warning about logical pathnames
     1038@subsection Using logical pathnames
    9871039@cindex logical pathnames
    9881040
    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.
    9921045
    9931046To use logical pathnames,
     
    9961049@code{#p"LOGICAL-HOST:absolute;path;to;component.lisp"}.
    9971050
    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
     
    10051059
    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.
    10131068
     
    10161071ASDF currently provides no specific support
    10171072for defining logical pathname translations.
     1073
     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.
    10181091
    10191092
     
    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:
    13681443
    13691444@itemize
    13701445@item
    13711446there is no system of that name in memory
     1447@item
     1448the pathname is different from that which was previously loaded
    13721449@item
    13731450the file's @code{last-modified} time exceeds the @code{last-modified} time
     
    16861763@end lisp
    16871764
    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
     
    16931770@lisp
    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
    17011776
     
    27052780@defun coerce-pathname name @&key type defaults
    27062781
    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.
    30093085
     
    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.
    31103187
    31113188@item
    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.
    31293207
     
    31613239@itemize
    31623240@item
    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?
    34013479
    3402 First, create a new @code{cl-source-file} subclass that provides an
    3403 initform for the @code{type} slot:
    3404 
    3405 @lisp
    3406 (defclass my-cl-source-file (cl-source-file)
    3407    ((type :initform "cl")))
    3408 @end lisp
    3409 
    3410 To support both ASDF 1 and ASDF 2,
    3411 you may omit the above @code{type} slot definition and instead define:
    3412 
    3413 @lisp
    3414 (defmethod source-file-type ((f my-cl-source-file) (m module))
    3415   (declare (ignorable f m))
    3416   "cl")
    3417 @end lisp
    3418 
    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{cl-source-file.cl} as
     3482the @code{:default-component-class} argument to @code{defsystem}:
    34213483
    34223484@lisp
    34233485(defsystem my-cl-system
    3424   :default-component-class my-cl-source-file
    3425    ....
    3426 )
     3486  :default-component-class cl-source-file.cl
     3487  ...)
    34273488@end lisp
    34283489
    3429 We assume that these definitions are loaded into a package that uses
    3430 @code{ASDF}.
    3431 
     3490Another builtin class @code{cl-source-file.lsp} is offered
     3491for files ending in @file{.lsp}.
     3492
     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:
     3498
     3499@lisp
     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)
     3505
     3506(defclass cl-source-file.lis (cl-source-file)
     3507   ((type :initform "lis")))
     3508@end lisp
     3509
     3510Then you can use it as follows:
     3511@lisp
     3512(defsystem my-cl-system
     3513  :default-component-class my-asdf-extension:cl-source-file.lis
     3514  ...)
     3515@end lisp
     3516
     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:
     3522
     3523@lisp
     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
     3531
     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:
     3539
     3540@lisp
     3541(defmethod source-file-type ((f cl-source-file.lis) (m module))
     3542  (declare (ignorable f m))
     3543  "lis")
     3544@end lisp
    34323545
    34333546
  • 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.
    33;;;
    44;;; Feedback, bug reports, and patches are all welcome:
     
    2020;;;  Monday; July 13, 2009)
    2121;;;
    22 ;;; Copyright (c) 2001-2010 Daniel Barlow and contributors
     22;;; Copyright (c) 2001-2011 Daniel Barlow and contributors
    2323;;;
    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)
    5151
     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.")
     54
    5255#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this
    5356
    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))))
    6871
    6972(in-package :asdf)
    70 
    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))
    8673
    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
    236244
    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.cl #: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.:
    364 (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.013\")."
     373(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")."
    365374  *asdf-version*)
    366375
     
    382391
    383392(defvar *verbose-out* nil)
    384 
    385 (defvar *asdf-verbose* t)
    386393
    387394(defparameter +asdf-methods+
     
    397404
    398405;;;; -------------------------------------------------------------------------
     406;;;; Resolve forward references
     407
     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)))
     420
     421;;;; -------------------------------------------------------------------------
     422;;;; Compatibility with Corman Lisp
     423#+cormanlisp
     424(progn
     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)))
     433#+cormanlisp
     434(defun maybe-break ()
     435  (decf *count*)
     436  (unless (plusp *count*)
     437    (setf *count* 3)
     438    (break)))
     439
     440;;;; -------------------------------------------------------------------------
    399441;;;; General Purpose Utilities
    400442
     
    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)))
    517561
     
    529573  (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
    530574
    531    
     575
    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))
    535579
    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))
    640694
    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))))
    737 
    738 (defun* find-symbol* (s p)
    739   (find-symbol (string s) p))
    740793
    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)))))))
    751805
    752806(defun* truenamize (p)
     
    789843                (excl:pathname-resolve-symbolic-links path)))
    790844
     845(defun* resolve-symlinks* (path)
     846  (if *resolve-symlinks*
     847      (and path (resolve-symlinks path))
     848      path))
     849
     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))))
     858
    791859(defun* default-directory ()
    792860  (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
     
    795863  (make-pathname :type "lisp" :defaults input-file))
    796864
     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)))))
    858928
    859929;;;; -------------------------------------------------------------------------
     
    892962(defgeneric* (setf component-property) (new-value component property))
    893963
     964(eval-when (:compile-toplevel :load-toplevel :execute)
     965  (defgeneric* (setf module-components-by-name) (new-value module)))
     966
    894967(defgeneric* version-satisfies (component version))
    895968
     
    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))
    9961069
    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)))
    1008 
    1009 
    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)))))
    10151075
    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)))))
    10231083
    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)))))
    10291089
    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)))))
    10351095
    10361096(define-condition missing-component (system-definition-error)
     
    10741134
    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)))))
    11581221
    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))
    12491314
     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 "."))))
     1334
    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)))))))
    12631346
     
    12851368  (gethash (coerce-name name) *defined-systems*))
    12861369
     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)))))
     1378
    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*))
    12941386
     
    13091401
    13101402(defparameter *system-definition-search-functions*
    1311   '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf))
    1312 
    1313 (defun* system-definition-pathname (system)
     1403  '(sysdef-central-registry-search
     1404    sysdef-source-registry-search
     1405    sysdef-find-asdf))
     1406
     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*))))
    13211411
    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)))
    14231513
     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~@:>"))))
     1517
    14241518(defmethod find-system (name &optional (error-p t))
    14251519  (find-system (coerce-name name) error-p))
    14261520
    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")
     1523
     1524(defun* find-system-if-being-defined (name)
     1525  (when *systems-being-defined*
     1526    (gethash (coerce-name name) *systems-being-defined*)))
     1527
     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))))
     1533
     1534(defmacro with-system-definitions (() &body body)
     1535  `(call-with-system-definitions #'(lambda () ,@body)))
     1536
     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)))))
    14411552
    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)))))))
    14611590
    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)))
    1467 
    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)))))
    14831599
    14841600(defun* sysdef-find-asdf (name)
     
    15241640(defclass cl-source-file (source-file)
    15251641  ((type :initform "lisp")))
     1642(defclass cl-source-file.cl (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))))))))
    15771697
    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))
    15821703
     
    15941715
    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)))))
    16541774
     
    16821802
    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))
    16851808
    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))))
    16891811
    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))))))))
    18121934
    18131935(defun* do-dep (operation c collect op dep)
     
    18561978
    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))
     
    19572077
    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))))
     
    19802095
    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)))
    19832099
    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))
    19872103
    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))))))
    20492165
    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))
     2187
     2188(defmethod operation-description ((operation compile-op) (component module))
     2189  (declare (ignorable operation))
     2190  (format nil (compatfmt "~@<compiled ~3i~_~A~@:>") component))
     2191
    20712192
    20722193;;;; -------------------------------------------------------------------------
     
    20812202
    20822203(defmethod perform-with-restarts (operation component)
     2204  ;;(when *asdf-verbose* (explain operation component)) ; TOO verbose, especially as the default.
    20832205  (perform operation component))
    20842206
     
    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)))
    2147 
     2267  (format nil (compatfmt "~@<loading ~3i~_~A~@:>")
     2268          component))
     2269
     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))
     2274
     2275(defmethod operation-description ((operation load-op) (component module))
     2276  (declare (ignorable operation))
     2277  (format nil (compatfmt "~@<loaded ~3i~_~A~@:>")
     2278          component))
    21482279
    21492280;;;; -------------------------------------------------------------------------
     
    21672298  nil)
    21682299
    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)))
    21792306
    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))
     2318
     2319(defmethod operation-description ((operation load-source-op) (component module))
     2320  (declare (ignorable operation))
     2321  (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") component))
    21912322
    21922323
     
    22142345
    22152346(defgeneric* operate (operation-class system &key &allow-other-keys))
     2347(defgeneric* perform-plan (plan &key))
     2348
     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)))))
     2374
     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))))))))
    22162399
    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)))))
    22532429
    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))
    22582434
    22592435(let ((operate-docstring
     
    22822458        operate-docstring))
    22832459
    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)
    22912466
     
    22952470for details."
    22962471  (declare (ignore force verbose version))
    2297   (apply #'operate 'compile-op system args)
     2472  (apply 'operate 'compile-op system args)
    22982473  t)
    22992474
     
    23032478details."
    23042479  (declare (ignore force verbose version))
    2305   (apply #'operate 'test-op system args)
     2480  (apply 'operate 'test-op system args)
    23062481  t)
    23072482
     
    23102485
    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*)))
    23162488
    23172489(defun* determine-system-pathname (pathname pathname-supplied-p)
     
    23292501        (default-directory))))
    23302502
    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))))))
    2359 
    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))
     2619
     2620    (when versionp
     2621      (unless (parse-version version nil)
     2622        (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>")
     2623              version name parent)))
    24732624
    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)))
    25192670
     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)))))
     2701
     2702(defmacro defsystem (name &body options)
     2703  `(apply 'do-defsystem ',name ',options))
     2704
    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)
    25392724
     
    25532738      exit-code)
    25542739
    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)
    25572742
    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*))
    25932778
    2594     #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl)
     2779    #+xcl
     2780    (ext:run-shell-command command)
     2781
     2782    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl xcl)
    25952783    (error "RUN-SHELL-COMMAND not implemented for this Lisp")))
    25962784
    25972785;;;; ---------------------------------------------------------------------------
    25982786;;;; system-relative-pathname
     2787
     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,
     2797or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
     2798if that's whay you mean." ;;)
     2799  (system-source-file x))
    25992800
    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))
    26482849
    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.
     
    26572858
    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))
    26702870
    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 http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
    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 http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
     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)))
    27072902
    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 #\;)
    27552950
     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 http://code.google.com/p/mcl/wiki/Portability
     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))")))
     2958
    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))))
    27582964
    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/")))
     2999
    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)))
    28503061
     
    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))))))
    28613073
    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
     
    31433363
    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)
     
    33013523
    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
     
    33173540
    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
     
    34183641
    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))))
    34233645
     
    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.
    34893711
    34903712(defvar *source-registry-exclusions* *default-source-registry-exclusions*)
    34913713
    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")
    3495 
    3496 (defun* source-registry ()
    3497   (car *source-registry*))
    3498 
    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")
    35023717
    35033718(defun* source-registry-initialized-p ()
    3504   (and *source-registry* t))
     3719  (typep *source-registry* 'hash-table))
    35053720
    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))
    35123727
    35133728(defparameter *wild-asd*
    3514   (make-pathname :directory nil :name :wild :type "asd" :version :newest))
    3515 
    3516 (defun directory-has-asd-files-p (directory)
     3729  (make-pathname :directory nil :name *wild* :type "asd" :version :newest))
     3730
     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))))
    35193734
    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))
     3762
     3763(defun collect-asds-in-directory (directory collect)
     3764  (map () collect (directory-asd-files directory)))
    35453765
    35463766(defun collect-sub*directories (directory collectp recursep collector)
     
    35513771      (collect-sub*directories subdir collectp recursep collector))))
    35523772
    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))))
    35623782
    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)))
    36303854
     
    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))
    37674002
    37684003(defvar *source-registry-parameter* nil)
    37694004
    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))
    37734009
    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))
    37864022
    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*)))
    37934026
    37944027(defun* clear-configuration ()
     
    37964029  (clear-output-translations))
    37974030
     4031
     4032;;; ECL support for COMPILE-OP / LOAD-OP
     4033;;;
     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.
     4038;;;
     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.
     4041;;;
     4042#+ecl
     4043(progn
     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))))
     4055
     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))))
     4061
     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))))))
     4067
    37984068;;;; -----------------------------------------------------------------
    37994069;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL and SBCL
    38004070;;;;
     4071(defvar *require-asdf-operator* 'load-op)
     4072
    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))))
    38124085
    38134086#+(or abcl clisp clozure cmu ecl sbcl)
Note: See TracChangeset for help on using the changeset viewer.