Changeset 13681


Ignore:
Timestamp:
May 6, 2010, 2:36:10 AM (10 years ago)
Author:
rme
Message:

Beta test version of asdf from upstream.
http://common-lisp.net/project/asdf/

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/tools/asdf.lisp

    r13021 r13681  
    1 ;;; This is asdf: Another System Definition Facility.
    2 ;;; hash - $Format:%H$
     1;;; -*- mode: common-lisp; package: asdf; -*-
     2;;; This is ASDF: Another System Definition Facility.
    33;;;
    4 ;;; Local Variables:
    5 ;;; mode: lisp
    6 ;;; End:
    7 ;;;
    8 ;;; Feedback, bug reports, and patches are all welcome: please mail to
    9 ;;; <asdf-devel@common-lisp.net>.  But note first that the canonical
    10 ;;; source for asdf is presently on common-lisp.net at
    11 ;;; <URL:http://common-lisp.net/project/asdf/>
     4;;; Feedback, bug reports, and patches are all welcome:
     5;;; please mail to <asdf-devel@common-lisp.net>.
     6;;; Note first that the canonical source for ASDF is presently
     7;;; <URL:http://common-lisp.net/project/asdf/>.
    128;;;
    139;;; If you obtained this copy from anywhere else, and you experience
     
    2016
    2117;;; -- LICENSE START
    22 ;;; (This is the MIT / X Consortium license as taken from 
     18;;; (This is the MIT / X Consortium license as taken from
    2319;;;  http://www.opensource.org/licenses/mit-license.html on or about
    2420;;;  Monday; July 13, 2009)
    2521;;;
    26 ;;; Copyright (c) 2001-2009 Daniel Barlow and contributors
     22;;; Copyright (c) 2001-2010 Daniel Barlow and contributors
    2723;;;
    2824;;; Permission is hereby granted, free of charge, to any person obtaining
     
    4743;;; -- LICENSE END
    4844
    49 ;;; the problem with writing a defsystem replacement is bootstrapping:
    50 ;;; we can't use defsystem to compile it.  Hence, all in one file
     45;;; The problem with writing a defsystem replacement is bootstrapping:
     46;;; we can't use defsystem to compile it.  Hence, all in one file.
    5147
    5248#+xcvb (module ())
    5349
    54 (defpackage #:asdf
    55   (:documentation "Another System Definition Facility")
    56   (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command
    57            #:system-definition-pathname #:find-component ; miscellaneous
    58            #:compile-system #:load-system #:test-system
    59            #:compile-op #:load-op #:load-source-op
    60            #:test-op
    61            #:operation           ; operations
    62            #:feature             ; sort-of operation
    63            #:version             ; metaphorically sort-of an operation
    64 
    65            #:input-files #:output-files #:perform ; operation methods
    66            #:operation-done-p #:explain
    67 
    68            #:component #:source-file
    69            #:c-source-file #:cl-source-file #:java-source-file
    70            #:static-file
    71            #:doc-file
    72            #:html-file
    73            #:text-file
    74            #:source-file-type
    75            #:module                     ; components
    76            #:system
    77            #:unix-dso
    78 
    79            #:module-components          ; component accessors
    80            #:component-pathname
    81            #:component-relative-pathname
    82            #:component-name
    83            #:component-version
    84            #:component-parent
    85            #:component-property
    86            #:component-system
    87 
    88            #:component-depends-on
    89 
    90            #:system-description
    91            #:system-long-description
    92            #:system-author
    93            #:system-maintainer
    94            #:system-license
    95            #:system-licence
    96            #:system-source-file
    97            #:system-relative-pathname
    98            #:map-systems
    99 
    100            #:operation-on-warnings
    101            #:operation-on-failure
    102 
    103                                         ;#:*component-parent-pathname*
    104            #:*system-definition-search-functions*
    105            #:*central-registry*         ; variables
    106            #:*compile-file-warnings-behaviour*
    107            #:*compile-file-failure-behaviour*
    108            #:*asdf-revision*
    109            #:*resolve-symlinks*
    110 
    111            #:operation-error #:compile-failed #:compile-warned #:compile-error
    112            #:error-component #:error-operation
    113            #:system-definition-error
    114            #:missing-component
    115            #:missing-component-of-version
    116            #:missing-dependency
    117            #:missing-dependency-of-version
    118            #:circular-dependency        ; errors
    119            #:duplicate-names
    120 
    121            #:try-recompiling
    122            #:retry
    123            #:accept                     ; restarts
    124            #:coerce-entry-to-directory
    125            #:remove-entry-from-registry
    126 
    127            #:standard-asdf-method-combination
    128            #:around                     ; protocol assistants
    129            
    130            #:*source-to-target-mappings*
    131            #:*default-toplevel-directory*
    132            #:*centralize-lisp-binaries*
    133            #:*include-per-user-information*
    134            #:*map-all-source-files*
    135            #:output-files-for-system-and-operation
    136            #:*enable-asdf-binary-locations*
    137            #:implementation-specific-directory-name)
    138   (:use :cl))
    139 
    140 
    141 #+nil
    142 (error "The author of this file habitually uses #+nil to comment out ~
    143         forms. But don't worry, it was unlikely to work in the New ~
    144         Implementation of Lisp anyway")
    145 
    146 (in-package #:asdf)
    147 
    148 (defvar *asdf-revision*
    149   ;; the 1+ hair is to ensure that we don't do an inadvertant find and replace
    150   (subseq "REVISION:1.366" (1+ (length "REVISION"))))
    151  
     50(cl:in-package :cl-user)
     51
     52(declaim (optimize (speed 2) (debug 2) (safety 3))
     53         #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
     54
     55#+ecl (require :cmp)
     56
     57;;;; Create packages in a way that is compatible with hot-upgrade.
     58;;;; See https://bugs.launchpad.net/asdf/+bug/485687
     59;;;; See more at the end of the file.
     60
     61#+gcl
     62(eval-when (:compile-toplevel :load-toplevel)
     63  (defpackage :asdf-utilities (:use :cl))
     64  (defpackage :asdf (:use :cl :asdf-utilities)))
     65
     66(eval-when (:load-toplevel :compile-toplevel :execute)
     67  #+allegro
     68  (setf excl::*autoload-package-name-alist*
     69        (remove "asdf" excl::*autoload-package-name-alist*
     70                :test 'equalp :key 'car))
     71  (let* ((asdf-version
     72          ;; the 1+ helps the version bumping script discriminate
     73          (subseq "VERSION:1.717" (1+ (length "VERSION"))))
     74         (existing-asdf (find-package :asdf))
     75         (vername '#:*asdf-version*)
     76         (versym (and existing-asdf
     77                      (find-symbol (string vername) existing-asdf)))
     78         (existing-version (and versym (boundp versym) (symbol-value versym)))
     79         (already-there (equal asdf-version existing-version)))
     80    (unless (and existing-asdf already-there)
     81      #-gcl
     82      (when existing-asdf
     83        (format *error-output*
     84                "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
     85                existing-version asdf-version))
     86      (labels
     87          ((rename-away (package)
     88             (loop :with name = (package-name package)
     89               :for i :from 1 :for new = (format nil "~A.~D" name i)
     90               :unless (find-package new) :do
     91               (rename-package-name package name new)))
     92           (rename-package-name (package old new)
     93             (let* ((old-names (cons (package-name package)
     94                                     (package-nicknames package)))
     95                    (new-names (subst new old old-names :test 'equal))
     96                    (new-name (car new-names))
     97                    (new-nicknames (cdr new-names)))
     98               (rename-package package new-name new-nicknames)))
     99           (ensure-exists (name nicknames use)
     100             (let* ((previous
     101                     (remove-duplicates
     102                      (remove-if
     103                       #'null
     104                       (mapcar #'find-package (cons name nicknames)))
     105                      :from-end t)))
     106               (cond
     107                 (previous
     108                  ;; do away with packages with conflicting (nick)names
     109                  (map () #'rename-away (cdr previous))
     110                  ;; reuse previous package with same name
     111                  (let ((p (car previous)))
     112                    (rename-package p name nicknames)
     113                    (ensure-use p use)
     114                    p))
     115                 (t
     116                  (make-package name :nicknames nicknames :use use)))))
     117           (find-sym (symbol package)
     118             (find-symbol (string symbol) package))
     119           (intern* (symbol package)
     120             (intern (string symbol) package))
     121           (remove-symbol (symbol package)
     122             (let ((sym (find-sym symbol package)))
     123               (when sym
     124                 (unexport sym package)
     125                 (unintern sym package))))
     126           (ensure-unintern (package symbols)
     127             (dolist (sym symbols) (remove-symbol sym package)))
     128           (ensure-shadow (package symbols)
     129             (shadow symbols package))
     130           (ensure-use (package use)
     131             (dolist (used (reverse use))
     132               (do-external-symbols (sym used)
     133                 (unless (eq sym (find-sym sym package))
     134                   (remove-symbol sym package)))
     135               (use-package used package)))
     136           (ensure-fmakunbound (package symbols)
     137             (loop :for name :in symbols
     138               :for sym = (find-sym name package)
     139               :when sym :do (fmakunbound sym)))
     140           (ensure-export (package export)
     141             (let ((syms (loop :for x :in export :collect
     142                           (intern* x package))))
     143               (do-external-symbols (sym package)
     144                 (unless (member sym syms)
     145                   (remove-symbol sym package)))
     146               (dolist (sym syms)
     147                 (export sym package))))
     148           (ensure-package (name &key nicknames use unintern fmakunbound shadow export)
     149             (let ((p (ensure-exists name nicknames use)))
     150               (ensure-unintern p unintern)
     151               (ensure-shadow p shadow)
     152               (ensure-export p export)
     153               (ensure-fmakunbound p fmakunbound)
     154               p)))
     155        (macrolet
     156            ((pkgdcl (name &key nicknames use export
     157                           redefined-functions unintern fmakunbound shadow)
     158               `(ensure-package
     159                 ',name :nicknames ',nicknames :use ',use :export ',export
     160                 :shadow ',shadow
     161                 :unintern ',(append #-(or gcl ecl) redefined-functions
     162                                     unintern)
     163                 :fmakunbound ',(append #+(or gcl ecl) redefined-functions
     164                                        fmakunbound))))
     165          (pkgdcl
     166           :asdf-utilities
     167           :nicknames (#:asdf-extensions)
     168           :use (#:common-lisp)
     169           :unintern (#:split #:make-collector)
     170           :export
     171           (#:absolute-pathname-p
     172            #:aif
     173            #:appendf
     174            #:asdf-message
     175            #:coerce-name
     176            #:directory-pathname-p
     177            #:ends-with
     178            #:ensure-directory-pathname
     179            #:getenv
     180            #:get-uid
     181            #:length=n-p
     182            #:merge-pathnames*
     183            #:pathname-directory-pathname
     184            #:read-file-forms
     185            #:remove-keys
     186            #:remove-keyword
     187            #:resolve-symlinks
     188            #:split-string
     189            #:component-name-to-pathname-components
     190            #:split-name-type
     191            #:system-registered-p
     192            #:truenamize
     193            #:while-collecting))
     194          (pkgdcl
     195           :asdf
     196           :use (:common-lisp :asdf-utilities)
     197           :redefined-functions
     198           (#:perform #:explain #:output-files #:operation-done-p
     199            #:perform-with-restarts #:component-relative-pathname
     200            #:system-source-file #:operate #:find-component)
     201           :unintern
     202           (#:*asdf-revision* #:around #:asdf-method-combination
     203            #:split #:make-collector)
     204           :fmakunbound
     205           (#:system-source-file
     206            #:component-relative-pathname #:system-relative-pathname
     207            #:process-source-registry
     208            #:inherit-source-registry #:process-source-registry-directive)
     209           :export
     210           (#:defsystem #:oos #:operate #:find-system #:run-shell-command
     211            #:system-definition-pathname #:find-component ; miscellaneous
     212            #:compile-system #:load-system #:test-system
     213            #:compile-op #:load-op #:load-source-op
     214            #:test-op
     215            #:operation               ; operations
     216            #:feature                 ; sort-of operation
     217            #:version                 ; metaphorically sort-of an operation
     218            #:version-satisfies
     219
     220            #:input-files #:output-files #:perform ; operation methods
     221            #:operation-done-p #:explain
     222
     223            #:component #:source-file
     224            #:c-source-file #:cl-source-file #:java-source-file
     225            #:static-file
     226            #:doc-file
     227            #:html-file
     228            #:text-file
     229            #:source-file-type
     230            #:module                     ; components
     231            #:system
     232            #:unix-dso
     233
     234            #:module-components          ; component accessors
     235            #:module-components-by-name  ; component accessors
     236            #:component-pathname
     237            #:component-relative-pathname
     238            #:component-name
     239            #:component-version
     240            #:component-parent
     241            #:component-property
     242            #:component-system
     243
     244            #:component-depends-on
     245
     246            #:system-description
     247            #:system-long-description
     248            #:system-author
     249            #:system-maintainer
     250            #:system-license
     251            #:system-licence
     252            #:system-source-file
     253            #:system-source-directory
     254            #:system-relative-pathname
     255            #:map-systems
     256
     257            #:operation-on-warnings
     258            #:operation-on-failure
     259            ;;#:*component-parent-pathname*
     260            #:*system-definition-search-functions*
     261            #:*central-registry*         ; variables
     262            #:*compile-file-warnings-behaviour*
     263            #:*compile-file-failure-behaviour*
     264            #:*resolve-symlinks*
     265            #:*asdf-verbose*
     266
     267            #:asdf-version
     268
     269            #:operation-error #:compile-failed #:compile-warned #:compile-error
     270            #:error-name
     271            #:error-pathname
     272            #:load-system-definition-error
     273            #:error-component #:error-operation
     274            #:system-definition-error
     275            #:missing-component
     276            #:missing-component-of-version
     277            #:missing-dependency
     278            #:missing-dependency-of-version
     279            #:circular-dependency        ; errors
     280            #:duplicate-names
     281
     282            #:try-recompiling
     283            #:retry
     284            #:accept                     ; restarts
     285            #:coerce-entry-to-directory
     286            #:remove-entry-from-registry
     287
     288            #:initialize-output-translations
     289            #:disable-output-translations
     290            #:clear-output-translations
     291            #:ensure-output-translations
     292            #:apply-output-translations
     293            #:compile-file-pathname*
     294            #:enable-asdf-binary-locations-compatibility
     295
     296            #:*default-source-registries*
     297            #:initialize-source-registry
     298            #:compute-source-registry
     299            #:clear-source-registry
     300            #:ensure-source-registry
     301            #:process-source-registry)))
     302        (let* ((version (intern* vername :asdf))
     303               (upvar (intern* '#:*upgraded-p* :asdf))
     304               (upval0 (and (boundp upvar) (symbol-value upvar)))
     305               (upval1 (if existing-version (cons existing-version upval0) upval0)))
     306          (eval `(progn
     307                   (defparameter ,version ,asdf-version)
     308                   (defparameter ,upvar ',upval1))))))))
     309
     310(in-package :asdf)
     311
     312;; More cleanups in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
     313#+gcl
     314(eval-when (:compile-toplevel :load-toplevel)
     315  (defvar *asdf-version* nil)
     316  (defvar *upgraded-p* nil))
     317(when *upgraded-p*
     318   #+ecl
     319   (when (find-class 'compile-op nil)
     320     (defmethod update-instance-for-redefined-class :after
     321         ((c compile-op) added deleted plist &key)
     322       (declare (ignore added deleted))
     323       (let ((system-p (getf plist 'system-p)))
     324         (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p)))))
     325   (when (find-class 'module nil)
     326     (eval
     327      '(defmethod update-instance-for-redefined-class :after
     328           ((m module) added deleted plist &key)
     329         (declare (ignorable deleted plist))
     330         (when (member 'components-by-name added)
     331           (compute-module-components-by-name m))))))
     332
     333;;;; -------------------------------------------------------------------------
     334;;;; User-visible parameters
     335;;;;
     336(defun asdf-version ()
     337  "Exported interface to the version of ASDF currently installed. A string.
     338You can compare this string with e.g.:
     339(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"1.704\")."
     340  *asdf-version*)
    152341
    153342(defvar *resolve-symlinks* t
     
    162351(defvar *verbose-out* nil)
    163352
     353(defvar *asdf-verbose* t)
     354
    164355(defparameter +asdf-methods+
    165   '(perform explain output-files operation-done-p))
    166 
    167 (define-method-combination standard-asdf-method-combination ()
    168   ((around-asdf (around))
    169    (around (:around))
    170    (before (:before))
    171    (primary () :required t)
    172    (after (:after)))
    173   (flet ((call-methods (methods)
    174            (mapcar #'(lambda (method)
    175                        `(call-method ,method))
    176                    methods)))
    177     (let* ((form (if (or before after (rest primary))
    178                      `(multiple-value-prog1
    179                           (progn ,@(call-methods before)
    180                                  (call-method ,(first primary)
    181                                               ,(rest primary)))
    182                         ,@(call-methods (reverse after)))
    183                      `(call-method ,(first primary))))
    184            (standard-form (if around
    185                               `(call-method ,(first around)
    186                                             (,@(rest around)
    187                                                (make-method ,form)))
    188                               form)))
    189       (if around-asdf
    190           `(call-method ,(first around-asdf)
    191                         (,@(rest around-asdf) (make-method ,standard-form)))
    192           standard-form))))
    193 
    194 (setf (documentation 'standard-asdf-method-combination
    195                      'method-combination)
    196       "This method combination is based on the standard method combination,
    197 but defines a new method-qualifier, `asdf:around`.  `asdf:around`
    198 methods will be run *around* any `:around` methods, so that the core
    199 protocol may employ around methods and those around methods will not
    200 be overridden by around methods added by a system developer.")
    201 
    202 (defgeneric perform (operation component)
    203   (:method-combination standard-asdf-method-combination))
    204 (defgeneric operation-done-p (operation component)
    205   (:method-combination standard-asdf-method-combination))
    206 (defgeneric explain (operation component)
    207   (:method-combination standard-asdf-method-combination))
    208 (defgeneric output-files (operation component)
    209   (:method-combination standard-asdf-method-combination))
    210 (defgeneric input-files (operation component)
    211   (:method-combination standard-asdf-method-combination))
     356  '(perform-with-restarts perform explain output-files operation-done-p))
     357
     358#+allegro
     359(eval-when (:compile-toplevel :execute)
     360  (defparameter *acl-warn-save*
     361                (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
     362                  excl:*warn-on-nested-reader-conditionals*))
     363  (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
     364    (setf excl:*warn-on-nested-reader-conditionals* nil)))
     365
     366;;;; -------------------------------------------------------------------------
     367;;;; ASDF Interface, in terms of generic functions.
     368
     369(defgeneric perform-with-restarts (operation component))
     370(defgeneric perform (operation component))
     371(defgeneric operation-done-p (operation component))
     372(defgeneric explain (operation component))
     373(defgeneric output-files (operation component))
     374(defgeneric input-files (operation component))
     375(defgeneric component-operation-time (operation component))
    212376
    213377(defgeneric system-source-file (system)
     
    221385
    222386(defgeneric component-relative-pathname (component)
    223   (:documentation "Extracts the relative pathname applicable for a particular component."))
     387  (:documentation "Returns a pathname for the component argument intended to be
     388interpreted relative to the pathname of that component's parent.
     389Despite the function's name, the return value may be an absolute
     390pathname, because an absolute pathname may be interpreted relative to
     391another pathname in a degenerate way."))
    224392
    225393(defgeneric component-property (component property))
     
    229397(defgeneric version-satisfies (component version))
    230398
    231 (defgeneric find-component (module name &optional version)
    232   (:documentation "Finds the component with name NAME present in the
    233 MODULE module; if MODULE is nil, then the component is assumed to be a
    234 system."))
     399(defgeneric find-component (base path)
     400  (:documentation "Finds the component with PATH starting from BASE module;
     401if BASE is nil, then the component is assumed to be a system."))
    235402
    236403(defgeneric source-file-type (component system))
     
    241408the head of the tree"))
    242409
    243 (defgeneric component-visited-p (operation component))
    244 
    245 (defgeneric visit-component (operation component data))
     410(defgeneric component-visited-p (operation component)
     411  (:documentation "Returns the value stored by a call to
     412VISIT-COMPONENT, if that has been called, otherwise NIL.
     413This value stored will be a cons cell, the first element
     414of which is a computed key, so not interesting.  The
     415CDR wil be the DATA value stored by VISIT-COMPONENT; recover
     416it as (cdr (component-visited-p op c)).
     417  In the current form of ASDF, the DATA value retrieved is
     418effectively a boolean, indicating whether some operations are
     419to be performed in order to do OPERATION X COMPONENT.  If the
     420data value is NIL, the combination had been explored, but no
     421operations needed to be performed."))
     422
     423(defgeneric visit-component (operation component data)
     424  (:documentation "Record DATA as being associated with OPERATION
     425and COMPONENT.  This is a side-effecting function:  the association
     426will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the
     427OPERATION\).
     428  No evidence that DATA is ever interesting, beyond just being
     429non-NIL.  Using the data field is probably very risky; if there is
     430already a record for OPERATION X COMPONENT, DATA will be quietly
     431discarded instead of recorded."))
    246432
    247433(defgeneric (setf visiting-component) (new-value operation component))
     
    269455
    270456(defgeneric traverse (operation component)
    271   (:documentation 
     457  (:documentation
    272458"Generate and return a plan for performing `operation` on `component`.
    273459
    274460The plan returned is a list of dotted-pairs. Each pair is the `cons`
    275 of ASDF operation object and a `component` object. The pairs will be 
     461of ASDF operation object and a `component` object. The pairs will be
    276462processed in order by `operate`."))
    277463
    278 (defgeneric output-files-using-mappings (source possible-paths path-mappings)
    279   (:documentation
    280 "Use the variable \\*source-to-target-mappings\\* to find
    281 an output path for the source. The algorithm transforms each
    282 entry in possible-paths as follows: If there is a mapping
    283 whose source starts with the path of possible-path, then
    284 replace possible-path with a pathname that starts with the
    285 target of the mapping and continues with the rest of
    286 possible-path. If no such mapping is found, then use the
    287 default mapping.
    288 
    289 If \\*centralize-lisp-binaries\\* is false, then the default
    290 mapping is to place the output in a subdirectory of the
    291 source. The subdirectory is named using the Lisp
    292 implementation \(see
    293 implementation-specific-directory-name\). If
    294 \\*centralize-lisp-binaries\\* is true, then the default
    295 mapping is to place the output in subdirectories of
    296 \\*default-toplevel-directory\\* where the subdirectory
    297 structure will mirror that of the source."))
    298 
    299 
    300 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    301 ;; utility stuff
     464
     465;;;; -------------------------------------------------------------------------
     466;;;; General Purpose Utilities
     467
     468(defmacro while-collecting ((&rest collectors) &body body)
     469  (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))
     470        (initial-values (mapcar (constantly nil) collectors)))
     471    `(let ,(mapcar #'list vars initial-values)
     472       (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars)
     473         ,@body
     474         (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))
    302475
    303476(defmacro aif (test then &optional else)
    304477  `(let ((it ,test)) (if it ,then ,else)))
    305478
    306 (defun pathname-sans-name+type (pathname)
     479(defun pathname-directory-pathname (pathname)
    307480  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
    308 and NIL NAME and TYPE components"
    309   (make-pathname :name nil :type nil :defaults pathname))
     481and NIL NAME, TYPE and VERSION components"
     482  (make-pathname :name nil :type nil :version nil :defaults pathname))
     483
     484(defun current-directory ()
     485  (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
     486
     487(defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
     488  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname
     489does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS.
     490Also, if either argument is NIL, then the other argument is returned unmodified."
     491  (when (null specified) (return-from merge-pathnames* defaults))
     492  (when (null defaults) (return-from merge-pathnames* specified))
     493  (let* ((specified (pathname specified))
     494         (defaults (pathname defaults))
     495         (directory (pathname-directory specified))
     496         (directory (if (stringp directory) `(:absolute ,directory) directory))
     497         (name (or (pathname-name specified) (pathname-name defaults)))
     498         (type (or (pathname-type specified) (pathname-type defaults)))
     499         (version (or (pathname-version specified) (pathname-version defaults))))
     500    (labels ((ununspecific (x)
     501               (if (eq x :unspecific) nil x))
     502             (unspecific-handler (p)
     503               (if (typep p 'logical-pathname) #'ununspecific #'identity)))
     504      (multiple-value-bind (host device directory unspecific-handler)
     505          (#-gcl ecase #+gcl case (first directory)
     506            ((nil)
     507             (values (pathname-host defaults)
     508                     (pathname-device defaults)
     509                     (pathname-directory defaults)
     510                     (unspecific-handler defaults)))
     511            ((:absolute)
     512             (values (pathname-host specified)
     513                     (pathname-device specified)
     514                     directory
     515                     (unspecific-handler specified)))
     516            ((:relative)
     517             (values (pathname-host defaults)
     518                     (pathname-device defaults)
     519                     (append (pathname-directory defaults) (cdr directory))
     520                     (unspecific-handler defaults)))
     521            #+gcl
     522            (t
     523             (assert (stringp (first directory)))
     524             (values (pathname-host defaults)
     525                     (pathname-device defaults)
     526                     (append (pathname-directory defaults) directory)
     527                     (unspecific-handler defaults))))
     528        (make-pathname :host host :device device :directory directory
     529                       :name (funcall unspecific-handler name)
     530                       :type (funcall unspecific-handler type)
     531                       :version (funcall unspecific-handler version))))))
    310532
    311533(define-modify-macro appendf (&rest args)
    312   append "Append onto list")
     534  append "Append onto list") ;; only to be used on short lists.
     535
     536(define-modify-macro orf (&rest args)
     537  or "or a flag")
    313538
    314539(defun asdf-message (format-string &rest format-args)
     
    316541  (apply #'format *verbose-out* format-string format-args))
    317542
    318 (defun split-path-string (s &optional force-directory)
     543(defun split-string (string &key max (separator '(#\Space #\Tab)))
     544  "Split STRING in components separater by any of the characters in the sequence SEPARATOR,
     545return a list.
     546If MAX is specified, then no more than max(1,MAX) components will be returned,
     547starting the separation from the end, e.g. when called with arguments
     548 \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
     549  (block nil
     550    (let ((list nil) (words 0) (end (length string)))
     551      (flet ((separatorp (char) (find char separator))
     552             (done () (return (cons (subseq string 0 end) list))))
     553        (loop
     554          :for start = (if (and max (>= words (1- max)))
     555                           (done)
     556                           (position-if #'separatorp string :end end :from-end t)) :do
     557          (when (null start)
     558            (done))
     559          (push (subseq string (1+ start) end) list)
     560          (incf words)
     561          (setf end start))))))
     562
     563(defun split-name-type (filename)
     564  (let ((unspecific
     565         ;; Giving :unspecific as argument to make-pathname is not portable.
     566         ;; See CLHS make-pathname and 19.2.2.2.3.
     567         ;; We only use it on implementations that support it.
     568         (or #+(or ccl ecl gcl lispworks sbcl) :unspecific)))
     569    (destructuring-bind (name &optional (type unspecific))
     570        (split-string filename :max 2 :separator ".")
     571      (if (equal name "")
     572          (values filename unspecific)
     573          (values name type)))))
     574
     575(defun component-name-to-pathname-components (s &optional force-directory)
     576  "Splits the path string S, returning three values:
     577A flag that is either :absolute or :relative, indicating
     578   how the rest of the values are to be interpreted.
     579A directory path --- a list of strings, suitable for
     580   use with MAKE-PATHNAME when prepended with the flag
     581   value.
     582A filename with type extension, possibly NIL in the
     583   case of a directory pathname.
     584FORCE-DIRECTORY forces S to be interpreted as a directory
     585pathname \(third return value will be NIL, final component
     586of S will be treated as part of the directory path.
     587
     588The intention of this function is to support structured component names,
     589e.g., \(:file \"foo/bar\"\), which will be unpacked to relative
     590pathnames."
    319591  (check-type s string)
    320   (let* ((components (split s nil "/"))
     592  (let* ((components (split-string s :separator "/"))
    321593         (last-comp (car (last components))))
    322594    (multiple-value-bind (relative components)
    323595        (if (equal (first components) "")
    324           (values :absolute (cdr components))
     596            (if (and (plusp (length s)) (eql (char s 0) #\/))
     597                (values :absolute (cdr components))
     598                (values :relative nil))
    325599          (values :relative components))
    326600      (cond
     
    332606         (values relative (butlast components) last-comp))))))
    333607
    334 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    335 ;; classes, condiitons
     608(defun remove-keys (key-names args)
     609  (loop :for (name val) :on args :by #'cddr
     610    :unless (member (symbol-name name) key-names
     611                    :key #'symbol-name :test 'equal)
     612    :append (list name val)))
     613
     614(defun remove-keyword (key args)
     615  (loop :for (k v) :on args :by #'cddr
     616    :unless (eq k key)
     617    :append (list k v)))
     618
     619(defun resolve-symlinks (path)
     620  #-allegro (truenamize path)
     621  #+allegro (excl:pathname-resolve-symbolic-links path))
     622
     623(defun getenv (x)
     624  #+abcl
     625  (ext:getenv x)
     626  #+sbcl
     627  (sb-ext:posix-getenv x)
     628  #+clozure
     629  (ccl::getenv x)
     630  #+clisp
     631  (ext:getenv x)
     632  #+cmu
     633  (cdr (assoc (intern x :keyword) ext:*environment-list*))
     634  #+lispworks
     635  (lispworks:environment-variable x)
     636  #+allegro
     637  (sys:getenv x)
     638  #+gcl
     639  (system:getenv x)
     640  #+ecl
     641  (si:getenv x))
     642
     643(defun directory-pathname-p (pathname)
     644  "Does `pathname` represent a directory?
     645
     646A directory-pathname is a pathname _without_ a filename. The three
     647ways that the filename components can be missing are for it to be `nil`,
     648`:unspecific` or the empty string.
     649
     650Note that this does _not_ check to see that `pathname` points to an
     651actually-existing directory."
     652  (flet ((check-one (x)
     653           (member x '(nil :unspecific "") :test 'equal)))
     654    (and (check-one (pathname-name pathname))
     655         (check-one (pathname-type pathname))
     656         t)))
     657
     658(defun ensure-directory-pathname (pathspec)
     659  "Converts the non-wild pathname designator PATHSPEC to directory form."
     660  (cond
     661   ((stringp pathspec)
     662    (ensure-directory-pathname (pathname pathspec)))
     663   ((not (pathnamep pathspec))
     664    (error "Invalid pathname designator ~S" pathspec))
     665   ((wild-pathname-p pathspec)
     666    (error "Can't reliably convert wild pathnames."))
     667   ((directory-pathname-p pathspec)
     668    pathspec)
     669   (t
     670    (make-pathname :directory (append (or (pathname-directory pathspec)
     671                                          (list :relative))
     672                                      (list (file-namestring pathspec)))
     673                   :name nil :type nil :version nil
     674                   :defaults pathspec))))
     675
     676(defun absolute-pathname-p (pathspec)
     677  (eq :absolute (car (pathname-directory (pathname pathspec)))))
     678
     679(defun length=n-p (x n) ;is it that (= (length x) n) ?
     680  (check-type n (integer 0 *))
     681  (loop
     682    :for l = x :then (cdr l)
     683    :for i :downfrom n :do
     684    (cond
     685      ((zerop i) (return (null l)))
     686      ((not (consp l)) (return nil)))))
     687
     688(defun ends-with (s suffix)
     689  (check-type s string)
     690  (check-type suffix string)
     691  (let ((start (- (length s) (length suffix))))
     692    (and (<= 0 start)
     693         (string-equal s suffix :start1 start))))
     694
     695(defun read-file-forms (file)
     696  (with-open-file (in file)
     697    (loop :with eof = (list nil)
     698     :for form = (read in nil eof)
     699     :until (eq form eof)
     700     :collect form)))
     701
     702#-(and (or win32 windows mswindows mingw32) (not cygwin))
     703(progn
     704#+clisp (defun get-uid () (posix:uid))
     705#+sbcl (defun get-uid () (sb-unix:unix-getuid))
     706#+cmu (defun get-uid () (unix:unix-getuid))
     707#+ecl (ffi:clines "#include <sys/types.h>" "#include <unistd.h>")
     708#+ecl (defun get-uid () (ffi:c-inline () () :int "getuid()" :one-liner t))
     709#+allegro (defun get-uid () (excl.osi:getuid))
     710#-(or cmu sbcl clisp allegro ecl)
     711(defun get-uid ()
     712  (let ((uid-string
     713         (with-output-to-string (*verbose-out*)
     714           (run-shell-command "id -ur"))))
     715    (with-input-from-string (stream uid-string)
     716      (read-line stream)
     717      (handler-case (parse-integer (read-line stream))
     718        (error () (error "Unable to find out user ID")))))))
     719
     720(defun pathname-root (pathname)
     721  (make-pathname :host (pathname-host pathname)
     722                 :device (pathname-device pathname)
     723                 :directory '(:absolute)
     724                 :name nil :type nil :version nil))
     725
     726(defun truenamize (p)
     727  "Resolve as much of a pathname as possible"
     728  (block nil
     729    (when (typep p 'logical-pathname) (return p))
     730    (let* ((p (merge-pathnames* p))
     731           (directory (pathname-directory p)))
     732      (when (typep p 'logical-pathname) (return p))
     733      (ignore-errors (return (truename p)))
     734      (when (stringp directory)
     735         (return p))
     736      (when (not (eq :absolute (car directory)))
     737        (return p))
     738      (let ((sofar (ignore-errors (truename (pathname-root p)))))
     739        (unless sofar (return p))
     740        (flet ((solution (directories)
     741                 (merge-pathnames*
     742                  (make-pathname :host nil :device nil
     743                                 :directory `(:relative ,@directories)
     744                                 :name (pathname-name p)
     745                                 :type (pathname-type p)
     746                                 :version (pathname-version p))
     747                  sofar)))
     748          (loop :for component :in (cdr directory)
     749            :for rest :on (cdr directory)
     750            :for more = (ignore-errors
     751                          (truename
     752                           (merge-pathnames*
     753                            (make-pathname :directory `(:relative ,component))
     754                            sofar))) :do
     755            (if more
     756                (setf sofar more)
     757                (return (solution rest)))
     758            :finally
     759            (return (solution nil))))))))
     760
     761(defun lispize-pathname (input-file)
     762  (make-pathname :type "lisp" :defaults input-file))
     763
     764;;;; -------------------------------------------------------------------------
     765;;;; Classes, Conditions
    336766
    337767(define-condition system-definition-error (error) ()
     
    350780             (apply #'format s (format-control c) (format-arguments c)))))
    351781
     782(define-condition load-system-definition-error (system-definition-error)
     783  ((name :initarg :name :reader error-name)
     784   (pathname :initarg :pathname :reader error-pathname)
     785   (condition :initarg :condition :reader error-condition))
     786  (:report (lambda (c s)
     787             (format s "~@<Error while trying to load definition for system ~A from pathname ~A: ~A~@:>"
     788                     (error-name c) (error-pathname c) (error-condition c)))))
     789
    352790(define-condition circular-dependency (system-definition-error)
    353791  ((components :initarg :components :reader circular-dependency-components)))
    354792
    355793(define-condition duplicate-names (system-definition-error)
    356   ((name :initarg :name :reader duplicate-names-name)))
     794  ((name :initarg :name :reader duplicate-names-name))
     795  (:report (lambda (c s)
     796             (format s "~@<Error while defining system: multiple components are given same name ~A~@:>"
     797                     (duplicate-names-name c)))))
    357798
    358799(define-condition missing-component (system-definition-error)
     
    367808
    368809(define-condition missing-dependency-of-version (missing-dependency
    369                                                 missing-component-of-version)
     810                                                missing-component-of-version)
    370811  ())
    371812
     
    384825         "Component name: designator for a string composed of portable pathname characters")
    385826   (version :accessor component-version :initarg :version)
    386    (in-order-to :initform nil :initarg :in-order-to)
    387    ;; XXX crap name
    388    (do-first :initform nil :initarg :do-first)
     827   (in-order-to :initform nil :initarg :in-order-to
     828                :accessor component-in-order-to)
     829   ;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to?
     830   (load-dependencies :accessor component-load-dependencies :initform nil)
     831   ;; XXX crap name, but it's an official API name!
     832   (do-first :initform nil :initarg :do-first
     833             :accessor component-do-first)
    389834   ;; methods defined using the "inline" style inside a defsystem form:
    390835   ;; need to store them somewhere so we can delete them when the system
     
    395840   ;; it to default in funky ways if not supplied
    396841   (relative-pathname :initarg :pathname)
    397    (operation-times :initform (make-hash-table )
     842   (absolute-pathname)
     843   (operation-times :initform (make-hash-table)
    398844                    :accessor component-operation-times)
    399845   ;; XXX we should provide some atomic interface for updating the
     
    402848               :initform nil)))
    403849
     850(defun component-find-path (component)
     851  (reverse
     852   (loop :for c = component :then (component-parent c)
     853     :while c :collect (component-name c))))
     854
     855(defmethod print-object ((c component) stream)
     856  (print-unreadable-object (c stream :type t :identity nil)
     857    (format stream "~@<~{~S~^ ~}~@:>" (component-find-path c))))
     858
     859
    404860;;;; methods: conditions
    405861
     
    409865
    410866(defun sysdef-error (format &rest arguments)
    411   (error 'formatted-system-definition-error :format-control 
    412         format :format-arguments arguments))
     867  (error 'formatted-system-definition-error :format-control
     868        format :format-arguments arguments))
    413869
    414870;;;; methods: components
     
    426882           (missing-requires c)
    427883           (missing-version c)
    428            (when (missing-parent c)
    429              (component-name (missing-parent c)))))
     884           (when (missing-parent c)
     885             (component-name (missing-parent c)))))
    430886
    431887(defmethod component-system ((component component))
     
    434890       component))
    435891
    436 (defmethod print-object ((c component) stream)
    437   (print-unreadable-object (c stream :type t :identity t)
    438     (ignore-errors
    439       (prin1 (component-name c) stream))))
     892(defvar *default-component-class* 'cl-source-file)
     893
     894(defun compute-module-components-by-name (module)
     895  (let ((hash (module-components-by-name module)))
     896    (clrhash hash)
     897    (loop :for c :in (module-components module)
     898      :for name = (component-name c)
     899      :for previous = (gethash name (module-components-by-name module))
     900      :do
     901      (when previous
     902        (error 'duplicate-names :name name))
     903      :do (setf (gethash name (module-components-by-name module)) c))
     904    hash))
    440905
    441906(defclass module (component)
    442   ((components :initform nil :accessor module-components :initarg :components)
    443    ;; what to do if we can't satisfy a dependency of one of this module's
    444    ;; components.  This allows a limited form of conditional processing
    445    (if-component-dep-fails :initform :fail
    446                            :accessor module-if-component-dep-fails
    447                            :initarg :if-component-dep-fails)
    448    (default-component-class :accessor module-default-component-class
    449      :initform 'cl-source-file :initarg :default-component-class)))
     907  ((components
     908    :initform nil
     909    :initarg :components
     910    :accessor module-components)
     911   (components-by-name
     912    :initform (make-hash-table :test 'equal)
     913    :accessor module-components-by-name)
     914   ;; What to do if we can't satisfy a dependency of one of this module's
     915   ;; components.  This allows a limited form of conditional processing.
     916   (if-component-dep-fails
     917    :initform :fail
     918    :initarg :if-component-dep-fails
     919    :accessor module-if-component-dep-fails)
     920   (default-component-class
     921    :initform *default-component-class*
     922    :initarg :default-component-class
     923    :accessor module-default-component-class)))
    450924
    451925(defun component-parent-pathname (component)
    452   (aif (component-parent component)
    453        (component-pathname it)
    454        *default-pathname-defaults*))
    455 
    456 (defmethod component-relative-pathname ((component module))
    457   (or (slot-value component 'relative-pathname)
    458       (multiple-value-bind (relative path)
    459           (split-path-string (component-name component) t)
    460         (make-pathname
    461          :directory `(,relative ,@path)
    462          :host (pathname-host (component-parent-pathname component))))))
     926  ;; No default anymore (in particular, no *default-pathname-defaults*).
     927  ;; If you force component to have a NULL pathname, you better arrange
     928  ;; for any of its children to explicitly provide a proper absolute pathname
     929  ;; wherever a pathname is actually wanted.
     930  (let ((parent (component-parent component)))
     931    (when parent
     932      (component-pathname parent))))
    463933
    464934(defmethod component-pathname ((component component))
    465   (let ((*default-pathname-defaults* (component-parent-pathname component)))
    466     (merge-pathnames (component-relative-pathname component))))
     935  (if (slot-boundp component 'absolute-pathname)
     936      (slot-value component 'absolute-pathname)
     937      (let ((pathname
     938             (merge-pathnames*
     939             (component-relative-pathname component)
     940             (component-parent-pathname component))))
     941        (unless (or (null pathname) (absolute-pathname-p pathname))
     942          (error "Invalid relative pathname ~S for component ~S" pathname component))
     943        (setf (slot-value component 'absolute-pathname) pathname)
     944        pathname)))
    467945
    468946(defmethod component-property ((c component) property)
     
    474952        (setf (cdr a) new-value)
    475953        (setf (slot-value c 'properties)
    476               (acons property new-value (slot-value c 'properties))))))
     954              (acons property new-value (slot-value c 'properties)))))
     955  new-value)
    477956
    478957(defclass system (module)
     
    485964            :accessor system-license :initarg :license)
    486965   (source-file :reader system-source-file :initarg :source-file
    487                 :writer %set-system-source-file)))
    488 
    489 ;;; version-satisfies
    490 
    491 ;;; with apologies to christophe rhodes ...
    492 (defun split (string &optional max (ws '(#\Space #\Tab)))
    493   (flet ((is-ws (char) (find char ws)))
    494     (nreverse
    495      (let ((list nil) (start 0) (words 0) end)
    496        (loop
    497          (when (and max (>= words (1- max)))
    498            (return (cons (subseq string start) list)))
    499          (setf end (position-if #'is-ws string :start start))
    500          (push (subseq string start end) list)
    501          (incf words)
    502          (unless end (return list))
    503          (setf start (1+ end)))))))
     966                :writer %set-system-source-file)))
     967
     968;;;; -------------------------------------------------------------------------
     969;;;; version-satisfies
    504970
    505971(defmethod version-satisfies ((c component) version)
    506972  (unless (and version (slot-boundp c 'version))
    507973    (return-from version-satisfies t))
     974  (version-satisfies (component-version c) version))
     975
     976(defmethod version-satisfies ((cver string) version)
    508977  (let ((x (mapcar #'parse-integer
    509                    (split (component-version c) nil '(#\.))))
     978                   (split-string cver :separator ".")))
    510979        (y (mapcar #'parse-integer
    511                    (split version nil '(#\.)))))
     980                   (split-string version :separator "."))))
    512981    (labels ((bigger (x y)
    513982               (cond ((not y) t)
     
    519988           (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
    520989
    521 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    522 ;;; finding systems
     990;;;; -------------------------------------------------------------------------
     991;;;; Finding systems
    523992
    524993(defun make-defined-systems-table ()
    525994  (make-hash-table :test 'equal))
    526995
    527 (defvar *defined-systems* (make-defined-systems-table))
     996(defvar *defined-systems* (make-defined-systems-table)
     997  "This is a hash table whose keys are strings, being the
     998names of the systems, and whose values are pairs, the first
     999element of which is a universal-time indicating when the
     1000system definition was last updated, and the second element
     1001of which is a system object.")
    5281002
    5291003(defun coerce-name (name)
     
    5431017called with an object of type asdf:system."
    5441018  (maphash (lambda (_ datum)
    545              (declare (ignore _))
    546              (destructuring-bind (_ . def) datum
    547                (declare (ignore _))
    548                (funcall fn def)))
    549            *defined-systems*))
     1019             (declare (ignore _))
     1020             (destructuring-bind (_ . def) datum
     1021               (declare (ignore _))
     1022               (funcall fn def)))
     1023           *defined-systems*))
    5501024
    5511025;;; for the sake of keeping things reasonably neat, we adopt a
    5521026;;; convention that functions in this list are prefixed SYSDEF-
    5531027
    554 (defvar *system-definition-search-functions*
    555   '(sysdef-central-registry-search))
     1028(defparameter *system-definition-search-functions*
     1029  '(sysdef-central-registry-search sysdef-source-registry-search))
    5561030
    5571031(defun system-definition-pathname (system)
     
    5591033    (or
    5601034     (some (lambda (x) (funcall x system-name))
    561            *system-definition-search-functions*)
     1035           *system-definition-search-functions*)
    5621036     (let ((system-pair (system-registered-p system-name)))
    5631037       (and system-pair
    564             (system-source-file (cdr system-pair)))))))
    565 
    566 (defvar *central-registry*
    567   `((directory-namestring *default-pathname-defaults*))
     1038            (system-source-file (cdr system-pair)))))))
     1039
     1040(defvar *central-registry* nil
    5681041"A list of 'system directory designators' ASDF uses to find systems.
    5691042
    570 A 'system directory designator' is a pathname or a function
     1043A 'system directory designator' is a pathname or an expression
    5711044which evaluates to a pathname. For example:
    5721045
     
    5751048                #p\"/home/me/cl/systems/\"
    5761049                #p\"/usr/share/common-lisp/systems/\"))
     1050
     1051This is for backward compatibilily.
     1052Going forward, we recommend new users should be using the source-registry.
    5771053")
    578 
    579 (defun directory-pathname-p (pathname)
    580   "Does `pathname` represent a directory?
    581 
    582 A directory-pathname is a pathname _without_ a filename. The three
    583 ways that the filename components can be missing are for it to be `nil`,
    584 `:unspecific` or the empty string.
    585 
    586 Note that this does _not_ check to see that `pathname` points to an
    587 actually-existing directory."
    588   (flet ((check-one (x)
    589            (not (null (member x '(nil :unspecific "")
    590                               :test 'equal)))))
    591     (and (check-one (pathname-name pathname))
    592          (check-one (pathname-type pathname)))))
    593 
    594 #+(or)
    595 ;;test
    596 ;;?? move into testsuite sometime soon
    597 (every (lambda (p)
    598           (directory-pathname-p p))
    599         (list
    600          (make-pathname :name "." :type nil :directory '(:absolute "tmp"))
    601          (make-pathname :name "." :type "" :directory '(:absolute "tmp"))
    602          (make-pathname :name nil :type "" :directory '(:absolute "tmp"))
    603          (make-pathname :name "" :directory '(:absolute "tmp"))
    604          (make-pathname :type :unspecific :directory '(:absolute "tmp"))
    605          (make-pathname :name :unspecific :directory '(:absolute "tmp"))
    606          (make-pathname :name :unspecific :directory '(:absolute "tmp"))
    607          (make-pathname :type "" :directory '(:absolute "tmp"))
    608          ))
    609 
    610 (defun ensure-directory-pathname (pathname)
    611   (if (directory-pathname-p pathname)
    612       pathname
    613       (make-pathname :defaults pathname
    614                      :directory (append
    615                                  (pathname-directory pathname)
    616                                  (list (file-namestring pathname)))
    617                      :name nil :type nil :version nil)))
    6181054
    6191055(defun sysdef-central-registry-search (system)
    6201056  (let ((name (coerce-name system))
    621         (to-remove nil)
    622         (to-replace nil))
     1057        (to-remove nil)
     1058        (to-replace nil))
    6231059    (block nil
    6241060      (unwind-protect
    625            (dolist (dir *central-registry*)
    626              (let ((defaults (eval dir)))
    627                (when defaults
    628                  (cond ((directory-pathname-p defaults)
    629                         (let ((file (and defaults
    630                                          (make-pathname
    631                                           :defaults defaults :version :newest
    632                                           :name name :type "asd" :case :local)))
    633                                #+(and (or win32 windows) (not :clisp))
    634                                (shortcut (make-pathname
    635                                           :defaults defaults :version :newest
    636                                           :name name :type "asd.lnk" :case :local)))
    637                           (if (and file (probe-file file))
    638                               (return file))
    639                           #+(and (or win32 windows) (not :clisp))
    640                           (when (probe-file shortcut)
    641                             (let ((target (parse-windows-shortcut shortcut)))
    642                               (when target
    643                                 (return (pathname target)))))))
    644                        (t
    645                         (restart-case
    646                             (let* ((*print-circle* nil)
    647                                    (message
    648                                     (format nil
    649                                             "~@<While searching for system `~a`: `~a` evaluated ~
    650 to `~a` which is not a directory.~@:>"
    651                                             system dir defaults)))
    652                               (error message))
    653                           (remove-entry-from-registry ()
    654                             :report "Remove entry from *central-registry* and continue"
    655                             (push dir to-remove))
    656                           (coerce-entry-to-directory ()
    657                             :report (lambda (s)
    658                                       (format s "Coerce entry to ~a, replace ~a and continue."
    659                                               (ensure-directory-pathname defaults) dir))
    660                             (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
    661         ;; cleanup
    662         (dolist (dir to-remove)
    663           (setf *central-registry* (remove dir *central-registry*)))
    664         (dolist (pair to-replace)
    665           (let* ((current (car pair))
    666                  (new (cdr pair))
    667                  (position (position current *central-registry*)))
    668             (setf *central-registry*
    669                   (append (subseq *central-registry* 0 position)
    670                           (list new)
    671                           (subseq *central-registry* (1+ position))))))))))
     1061           (dolist (dir *central-registry*)
     1062             (let ((defaults (eval dir)))
     1063               (when defaults
     1064                 (cond ((directory-pathname-p defaults)
     1065                        (let ((file (probe-asd name defaults)))
     1066                          (when file
     1067                            (return file))))
     1068                       (t
     1069                        (restart-case
     1070                            (let* ((*print-circle* nil)
     1071                                   (message
     1072                                    (format nil
     1073                                            "~@<While searching for system `~a`: `~a` evaluated ~
     1074to `~a` which is not a directory.~@:>"
     1075                                            system dir defaults)))
     1076                              (error message))
     1077                          (remove-entry-from-registry ()
     1078                            :report "Remove entry from *central-registry* and continue"
     1079                            (push dir to-remove))
     1080                          (coerce-entry-to-directory ()
     1081                            :report (lambda (s)
     1082                                      (format s "Coerce entry to ~a, replace ~a and continue."
     1083                                              (ensure-directory-pathname defaults) dir))
     1084                            (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
     1085        ;; cleanup
     1086        (dolist (dir to-remove)
     1087          (setf *central-registry* (remove dir *central-registry*)))
     1088        (dolist (pair to-replace)
     1089          (let* ((current (car pair))
     1090                 (new (cdr pair))
     1091                 (position (position current *central-registry*)))
     1092            (setf *central-registry*
     1093                  (append (subseq *central-registry* 0 position)
     1094                          (list new)
     1095                          (subseq *central-registry* (1+ position))))))))))
    6721096
    6731097(defun make-temporary-package ()
    6741098  (flet ((try (counter)
    6751099           (ignore-errors
    676              (make-package (format nil "~a~D" 'asdf counter)
     1100             (make-package (format nil "~A~D" :asdf counter)
    6771101                           :use '(:cl :asdf)))))
    6781102    (do* ((counter 0 (+ counter 1))
    6791103          (package (try counter) (try counter)))
    6801104         (package package))))
     1105
     1106(defun safe-file-write-date (pathname)
     1107  ;; If FILE-WRITE-DATE returns NIL, it's possible that
     1108  ;; the user or some other agent has deleted an input file.
     1109  ;; Also, generated files will not exist at the time planning is done
     1110  ;; and calls operation-done-p which calls safe-file-write-date.
     1111  ;; So it is very possible that we can't get a valid file-write-date,
     1112  ;; and we can survive and we will continue the planning
     1113  ;; as if the file were very old.
     1114  ;; (or should we treat the case in a different, special way?)
     1115  (or (and pathname (probe-file pathname) (file-write-date pathname))
     1116      (progn
     1117        (when pathname
     1118          (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero."
     1119                pathname))
     1120        0)))
    6811121
    6821122(defun find-system (name &optional (error-p t))
     
    6861126    (when (and on-disk
    6871127               (or (not in-memory)
    688                    (< (car in-memory) (file-write-date on-disk))))
     1128                   (< (car in-memory) (safe-file-write-date on-disk))))
    6891129      (let ((package (make-temporary-package)))
    6901130        (unwind-protect
    691              (let ((*package* package))
    692                (asdf-message
    693                 "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
    694                 ;; FIXME: This wants to be (ENOUGH-NAMESTRING
    695                 ;; ON-DISK), but CMUCL barfs on that.
    696                 on-disk
    697                 *package*)
    698                (load on-disk))
     1131             (handler-bind
     1132                 ((error (lambda (condition)
     1133                           (error 'load-system-definition-error
     1134                                  :name name :pathname on-disk
     1135                                  :condition condition))))
     1136               (let ((*package* package))
     1137                 (asdf-message
     1138                  "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
     1139                  on-disk *package*)
     1140                 (load on-disk)))
    6991141          (delete-package package))))
    7001142    (let ((in-memory (system-registered-p name)))
    7011143      (if in-memory
    702           (progn (if on-disk (setf (car in-memory) (file-write-date on-disk)))
     1144          (progn (when on-disk (setf (car in-memory)
     1145                                     (safe-file-write-date on-disk)))
    7031146                 (cdr in-memory))
    704           (if error-p (error 'missing-component :requires name))))))
     1147          (when error-p (error 'missing-component :requires name))))))
    7051148
    7061149(defun register-system (name system)
     
    7101153
    7111154
    712 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    713 ;;; finding components
    714 
    715 (defmethod find-component ((module module) name &optional version)
    716   (if (slot-boundp module 'components)
    717       (let ((m (find name (module-components module)
    718                      :test #'equal :key #'component-name)))
    719         (if (and m (version-satisfies m version)) m))))
    720 
    721 
    722 ;;; a component with no parent is a system
    723 (defmethod find-component ((module (eql nil)) name &optional version)
    724   (let ((m (find-system name nil)))
    725     (if (and m (version-satisfies m version)) m)))
     1155;;;; -------------------------------------------------------------------------
     1156;;;; Finding components
     1157
     1158(defmethod find-component ((base string) path)
     1159  (let ((s (find-system base nil)))
     1160    (and s (find-component s path))))
     1161
     1162(defmethod find-component ((base symbol) path)
     1163  (cond
     1164    (base (find-component (coerce-name base) path))
     1165    (path (find-component path nil))
     1166    (t    nil)))
     1167
     1168(defmethod find-component ((base cons) path)
     1169  (find-component (car base) (cons (cdr base) path)))
     1170
     1171(defmethod find-component ((module module) (name string))
     1172  (when (slot-boundp module 'components-by-name)
     1173    (values (gethash name (module-components-by-name module)))))
     1174
     1175(defmethod find-component ((component component) (name symbol))
     1176  (if name
     1177      (find-component component (string name))
     1178      component))
     1179
     1180(defmethod find-component ((module module) (name cons))
     1181  (find-component (find-component module (car name)) (cdr name)))
     1182
    7261183
    7271184;;; component subclasses
    7281185
    729 (defclass source-file (component) ())
    730 
    731 (defclass cl-source-file (source-file) ())
    732 (defclass c-source-file (source-file) ())
    733 (defclass java-source-file (source-file) ())
     1186(defclass source-file (component)
     1187  ((type :accessor source-file-explicit-type :initarg :type :initform nil)))
     1188
     1189(defclass cl-source-file (source-file)
     1190  ((type :initform "lisp")))
     1191(defclass c-source-file (source-file)
     1192  ((type :initform "c")))
     1193(defclass java-source-file (source-file)
     1194  ((type :initform "java")))
    7341195(defclass static-file (source-file) ())
    7351196(defclass doc-file (static-file) ())
    736 (defclass html-file (doc-file) ())
    737 
    738 (defmethod source-file-type ((c cl-source-file) (s module)) "lisp")
    739 (defmethod source-file-type ((c c-source-file) (s module)) "c")
    740 (defmethod source-file-type ((c java-source-file) (s module)) "java")
    741 (defmethod source-file-type ((c html-file) (s module)) "html")
    742 (defmethod source-file-type ((c static-file) (s module)) nil)
    743 
    744 (defmethod component-relative-pathname ((component source-file))
    745   (multiple-value-bind (relative path name)
    746       (split-path-string (component-name component))
    747     (let ((type (source-file-type component (component-system component)))
    748           (relative-pathname (slot-value component 'relative-pathname))
    749           (*default-pathname-defaults* (component-parent-pathname component)))
    750       (if relative-pathname
    751         (merge-pathnames
    752          relative-pathname
    753          (if type
    754            (make-pathname :name name :type type)
    755            name))
    756         (make-pathname :directory `(,relative ,@path) :name name :type type)))))
    757 
    758 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    759 ;;; operations
    760 
    761 ;;; one of these is instantiated whenever (operate ) is called
     1197(defclass html-file (doc-file)
     1198  ((type :initform "html")))
     1199
     1200(defmethod source-file-type ((component module) (s module))
     1201  (declare (ignorable component s))
     1202  :directory)
     1203(defmethod source-file-type ((component source-file) (s module))
     1204  (declare (ignorable s))
     1205  (source-file-explicit-type component))
     1206
     1207(defun merge-component-name-type (name &key type defaults)
     1208  ;; The defaults are required notably because they provide the default host
     1209  ;; to the below make-pathname, which may crucially matter to people using
     1210  ;; merge-pathnames with non-default hosts,  e.g. for logical-pathnames.
     1211  ;; NOTE that the host and device slots will be taken from the defaults,
     1212  ;; but that should only matter if you either (a) use absolute pathnames, or
     1213  ;; (b) later merge relative pathnames with CL:MERGE-PATHNAMES instead of
     1214  ;; ASDF-UTILITIES:MERGE-PATHNAMES*
     1215  (etypecase name
     1216    (pathname
     1217     name)
     1218    (symbol
     1219     (merge-component-name-type (string-downcase name) :type type :defaults defaults))
     1220    (string
     1221     (multiple-value-bind (relative path filename)
     1222         (component-name-to-pathname-components name (eq type :directory))
     1223       (multiple-value-bind (name type)
     1224           (cond
     1225             ((or (eq type :directory) (null filename))
     1226              (values nil nil))
     1227             (type
     1228              (values filename type))
     1229             (t
     1230              (split-name-type filename)))
     1231         (let* ((defaults (pathname (or defaults *default-pathname-defaults*)))
     1232                (host (pathname-host defaults))
     1233                (device (pathname-device defaults)))
     1234           (make-pathname :directory `(,relative ,@path)
     1235                          :name name :type type
     1236                          :host host :device device)))))))
     1237
     1238(defmethod component-relative-pathname ((component component))
     1239  (merge-component-name-type
     1240   (or (slot-value component 'relative-pathname)
     1241       (component-name component))
     1242   :type (source-file-type component (component-system component))
     1243   :defaults (component-parent-pathname component)))
     1244
     1245;;;; -------------------------------------------------------------------------
     1246;;;; Operations
     1247
     1248;;; one of these is instantiated whenever #'operate is called
    7621249
    7631250(defclass operation ()
    764   ((forced :initform nil :initarg :force :accessor operation-forced)
     1251  (
     1252   ;; as of danb's 2003-03-16 commit e0d02781, :force can be:
     1253   ;; T to force the inside of existing system,
     1254   ;;   but not recurse to other systems we depend on.
     1255   ;; :ALL (or any other atom) to force all systems
     1256   ;;   including other systems we depend on.
     1257   ;; (SYSTEM1 SYSTEM2 ... SYSTEMN)
     1258   ;;   to force systems named in a given list
     1259   ;;   (but this feature never worked before ASDF 1.700 and is cerror'ed out.)
     1260   (forced :initform nil :initarg :force :accessor operation-forced)
    7651261   (original-initargs :initform nil :initarg :original-initargs
    7661262                      :accessor operation-original-initargs)
    767    (visited-nodes :initform nil :accessor operation-visited-nodes)
    768    (visiting-nodes :initform nil :accessor operation-visiting-nodes)
     1263   (visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes)
     1264   (visiting-nodes :initform (make-hash-table :test 'equal) :accessor operation-visiting-nodes)
    7691265   (parent :initform nil :initarg :parent :accessor operation-parent)))
    7701266
     
    7771273                                     &key force
    7781274                                     &allow-other-keys)
    779   (declare (ignore slot-names force))
     1275  (declare (ignorable operation slot-names force))
    7801276  ;; empty method to disable initarg validity checking
    781   )
     1277  (values))
    7821278
    7831279(defun node-for (o c)
     
    7911287
    7921288(defun make-sub-operation (c o dep-c dep-o)
     1289  "C is a component, O is an operation, DEP-C is another
     1290component, and DEP-O, confusingly enough, is an operation
     1291class specifier, not an operation."
    7931292  (let* ((args (copy-list (operation-original-initargs o)))
    7941293         (force-p (getf args :force)))
     
    8121311(defmethod visit-component ((o operation) (c component) data)
    8131312  (unless (component-visited-p o c)
    814     (push (cons (node-for o c) data)
    815           (operation-visited-nodes (operation-ancestor o)))))
     1313    (setf (gethash (node-for o c)
     1314                   (operation-visited-nodes (operation-ancestor o)))
     1315          (cons t data))))
    8161316
    8171317(defmethod component-visited-p ((o operation) (c component))
    818   (assoc (node-for o c)
    819          (operation-visited-nodes (operation-ancestor o))
    820          :test 'equal))
     1318  (gethash (node-for o c)
     1319           (operation-visited-nodes (operation-ancestor o))))
    8211320
    8221321(defmethod (setf visiting-component) (new-value operation component)
    8231322  ;; MCL complains about unused lexical variables
    824   (declare (ignorable new-value operation component)))
     1323  (declare (ignorable operation component))
     1324  new-value)
    8251325
    8261326(defmethod (setf visiting-component) (new-value (o operation) (c component))
     
    8281328        (a (operation-ancestor o)))
    8291329    (if new-value
    830         (pushnew node (operation-visiting-nodes a) :test 'equal)
    831         (setf (operation-visiting-nodes a)
    832               (remove node  (operation-visiting-nodes a) :test 'equal)))))
     1330        (setf (gethash node (operation-visiting-nodes a)) t)
     1331        (remhash node (operation-visiting-nodes a)))
     1332    new-value))
    8331333
    8341334(defmethod component-visiting-p ((o operation) (c component))
    8351335  (let ((node (node-for o c)))
    836     (member node (operation-visiting-nodes (operation-ancestor o))
    837             :test 'equal)))
     1336    (gethash node (operation-visiting-nodes (operation-ancestor o)))))
    8381337
    8391338(defmethod component-depends-on ((op-spec symbol) (c component))
     
    8421341(defmethod component-depends-on ((o operation) (c component))
    8431342  (cdr (assoc (class-name (class-of o))
    844               (slot-value c 'in-order-to))))
     1343              (component-in-order-to c))))
    8451344
    8461345(defmethod component-self-dependencies ((o operation) (c component))
     
    8631362        (list (component-pathname c)))))
    8641363
    865 (defmethod input-files ((operation operation) (c module)) nil)
     1364(defmethod input-files ((operation operation) (c module))
     1365  (declare (ignorable operation c))
     1366  nil)
     1367
     1368(defmethod component-operation-time (o c)
     1369  (gethash (type-of o) (component-operation-times c)))
    8661370
    8671371(defmethod operation-done-p ((o operation) (c component))
    868   (flet ((fwd-or-return-t (file)
    869            ;; if FILE-WRITE-DATE returns NIL, it's possible that the
    870            ;; user or some other agent has deleted an input file.  If
    871            ;; that's the case, well, that's not good, but as long as
    872            ;; the operation is otherwise considered to be done we
    873            ;; could continue and survive.
    874            (let ((date (file-write-date file)))
    875              (cond
    876                (date)
    877                (t
    878                 (warn "~@<Missing FILE-WRITE-DATE for ~S: treating ~
    879                        operation ~S on component ~S as done.~@:>"
    880                       file o c)
    881                 (return-from operation-done-p t))))))
    882     (let ((out-files (output-files o c))
    883           (in-files (input-files o c)))
    884       (cond ((and (not in-files) (not out-files))
    885              ;; arbitrary decision: an operation that uses nothing to
    886              ;; produce nothing probably isn't doing much
    887              t)
    888             ((not out-files)
    889              (let ((op-done
    890                     (gethash (type-of o)
    891                              (component-operation-times c))))
    892                (and op-done
    893                     (>= op-done
    894                         (apply #'max
    895                                (mapcar #'fwd-or-return-t in-files))))))
    896             ((not in-files) nil)
    897             (t
    898              (and
    899               (every #'probe-file out-files)
    900               (> (apply #'min (mapcar #'file-write-date out-files))
    901                  (apply #'max (mapcar #'fwd-or-return-t in-files)))))))))
    902 
    903 ;;; So you look at this code and think "why isn't it a bunch of
    904 ;;; methods".  And the answer is, because standard method combination
    905 ;;; runs :before methods most->least-specific, which is back to front
    906 ;;; for our purposes. 
    907 
    908 (defmethod traverse ((operation operation) (c component))
    909   (let ((forced nil))
    910     (labels ((%do-one-dep (required-op required-c required-v)
    911                (let* ((dep-c (or (find-component
    912                                   (component-parent c)
    913                                   ;; XXX tacky.  really we should build the
    914                                   ;; in-order-to slot with canonicalized
    915                                   ;; names instead of coercing this late
    916                                   (coerce-name required-c) required-v)
    917                                  (if required-v
    918                                      (error 'missing-dependency-of-version
    919                                             :required-by c
    920                                             :version required-v
    921                                             :requires required-c)
    922                                      (error 'missing-dependency
    923                                             :required-by c
    924                                             :requires required-c))))
    925                       (op (make-sub-operation c operation dep-c required-op)))
    926                  (traverse op dep-c)))
    927              (do-one-dep (required-op required-c required-v)
    928                (loop
    929                   (restart-case
    930                       (return (%do-one-dep required-op required-c required-v))
    931                     (retry ()
    932                       :report (lambda (s)
    933                                 (format s "~@<Retry loading component ~S.~@:>"
    934                                         required-c))
    935                       :test
    936                       (lambda (c)
    937 #|
    938                         (print (list :c1 c (typep c 'missing-dependency)))
    939                         (when (typep c 'missing-dependency)
    940                           (print (list :c2 (missing-requires c) required-c
    941                                        (equalp (missing-requires c)
    942                                                required-c))))
    943 |#
    944                         (and (typep c 'missing-dependency)
    945                              (equalp (missing-requires c)
    946                                      required-c)))))))
    947              (do-dep (op dep)
    948                (cond ((eq op 'feature)
    949                       (or (member (car dep) *features*)
    950                           (error 'missing-dependency
    951                                  :required-by c
    952                                  :requires (car dep))))
    953                      (t
    954                       (dolist (d dep)
    955                         (cond ((consp d)
    956                                (cond ((string-equal
    957                                        (symbol-name (first d))
    958                                        "VERSION")
    959                                       (appendf
    960                                        forced
    961                                        (do-one-dep op (second d) (third d))))
    962                                      ((and (string-equal
    963                                             (symbol-name (first d))
    964                                             "FEATURE")
    965                                            (find (second d) *features*
    966                                                  :test 'string-equal))
    967                                       (appendf
    968                                        forced
    969                                        (do-one-dep op (second d) (third d))))
    970                                      (t
    971                                       (error "Bad dependency ~a.  Dependencies must be (:version <version>), (:feature <feature>), or a name" d))))
    972                               (t
    973                                (appendf forced (do-one-dep op d nil)))))))))
     1372  (let ((out-files (output-files o c))
     1373        (in-files (input-files o c))
     1374        (op-time (component-operation-time o c)))
     1375    (flet ((earliest-out ()
     1376             (reduce #'min (mapcar #'safe-file-write-date out-files)))
     1377           (latest-in ()
     1378             (reduce #'max (mapcar #'safe-file-write-date in-files))))
     1379      (cond
     1380        ((and (not in-files) (not out-files))
     1381         ;; arbitrary decision: an operation that uses nothing to
     1382         ;; produce nothing probably isn't doing much.
     1383         ;; e.g. operations on systems, modules that have no immediate action,
     1384         ;; but are only meaningful through traversed dependencies
     1385         t)
     1386        ((not out-files)
     1387         ;; an operation without output-files is probably meant
     1388         ;; for its side-effects in the current image,
     1389         ;; assumed to be idem-potent,
     1390         ;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE.
     1391         (and op-time (>= op-time (latest-in))))
     1392        ((not in-files)
     1393         ;; an operation without output-files and no input-files
     1394         ;; is probably meant for its side-effects on the file-system,
     1395         ;; assumed to have to be done everytime.
     1396         ;; (I don't think there is any such case in ASDF unless extended)
     1397         nil)
     1398        (t
     1399         ;; an operation with both input and output files is assumed
     1400         ;; as computing the latter from the former,
     1401         ;; assumed to have been done if the latter are all older
     1402         ;; than the former.
     1403         ;; e.g. COMPILE-OP of some CL-SOURCE-FILE.
     1404         ;; We use >= instead of > to play nice with generated files.
     1405         ;; This opens a race condition if an input file is changed
     1406         ;; after the output is created but within the same second
     1407         ;; of filesystem time; but the same race condition exists
     1408         ;; whenever the computation from input to output takes more
     1409         ;; than one second of filesystem time (or just crosses the
     1410         ;; second). So that's cool.
     1411         (and
     1412          (every #'probe-file in-files)
     1413          (every #'probe-file out-files)
     1414          (>= (earliest-out) (latest-in))))))))
     1415
     1416
     1417
     1418;;; For 1.700 I've done my best to refactor TRAVERSE
     1419;;; by splitting it up in a bunch of functions,
     1420;;; so as to improve the collection and use-detection algorithm. --fare
     1421;;; The protocol is as follows: we pass around operation, dependency,
     1422;;; bunch of other stuff, and a force argument. Return a force flag.
     1423;;; The returned flag is T if anything has changed that requires a rebuild.
     1424;;; The force argument is a list of components that will require a rebuild
     1425;;; if the flag is T, at which point whoever returns the flag has to
     1426;;; mark them all as forced, and whoever recurses again can use a NIL list
     1427;;; as a further argument.
     1428
     1429(defvar *forcing* nil
     1430  "This dynamically-bound variable is used to force operations in
     1431recursive calls to traverse.")
     1432
     1433(defgeneric do-traverse (operation component collect))
     1434
     1435(defun %do-one-dep (operation c collect required-op required-c required-v)
     1436  ;; collects a partial plan that results from performing required-op
     1437  ;; on required-c, possibly with a required-vERSION
     1438  (let* ((dep-c (or (let ((d (find-component (component-parent c) required-c)))
     1439                      (and d (version-satisfies d required-v) d))
     1440                    (if required-v
     1441                        (error 'missing-dependency-of-version
     1442                               :required-by c
     1443                               :version required-v
     1444                               :requires required-c)
     1445                        (error 'missing-dependency
     1446                               :required-by c
     1447                               :requires required-c))))
     1448         (op (make-sub-operation c operation dep-c required-op)))
     1449    (do-traverse op dep-c collect)))
     1450
     1451(defun do-one-dep (operation c collect required-op required-c required-v)
     1452  ;; this function is a thin, error-handling wrapper around
     1453  ;; %do-one-dep.  Returns a partial plan per that function.
     1454  (loop
     1455    (restart-case
     1456        (return (%do-one-dep operation c collect
     1457                             required-op required-c required-v))
     1458      (retry ()
     1459        :report (lambda (s)
     1460                  (format s "~@<Retry loading component ~S.~@:>"
     1461                          required-c))
     1462        :test
     1463        (lambda (c)
     1464          #|
     1465          (print (list :c1 c (typep c 'missing-dependency)))
     1466          (when (typep c 'missing-dependency)
     1467          (print (list :c2 (missing-requires c) required-c
     1468          (equalp (missing-requires c)
     1469          required-c))))
     1470          |#
     1471          (or (null c)
     1472              (and (typep c 'missing-dependency)
     1473                   (equalp (missing-requires c)
     1474                           required-c))))))))
     1475
     1476(defun do-dep (operation c collect op dep)
     1477  ;; type of arguments uncertain:
     1478  ;; op seems to at least potentially be a symbol, rather than an operation
     1479  ;; dep is a list of component names
     1480  (cond ((eq op 'feature)
     1481         (if (member (car dep) *features*)
     1482             nil
     1483             (error 'missing-dependency
     1484                    :required-by c
     1485                    :requires (car dep))))
     1486        (t
     1487         (let ((flag nil))
     1488           (flet ((dep (op comp ver)
     1489                    (when (do-one-dep operation c collect
     1490                                      op comp ver)
     1491                      (setf flag t))))
     1492             (dolist (d dep)
     1493               (if (atom d)
     1494                   (dep op d nil)
     1495                   ;; structured dependencies --- this parses keywords
     1496                   ;; the keywords could be broken out and cleanly (extensibly)
     1497                   ;; processed by EQL methods
     1498                   (cond ((eq :version (first d))
     1499                          ;; https://bugs.launchpad.net/asdf/+bug/527788
     1500                          (dep op (second d) (third d)))
     1501                         ;; This particular subform is not documented and
     1502                         ;; has always been broken in the past.
     1503                         ;; Therefore no one uses it, and I'm cerroring it out,
     1504                         ;; after fixing it
     1505                         ;; See https://bugs.launchpad.net/asdf/+bug/518467
     1506                         ((eq :feature (first d))
     1507                          (cerror "Continue nonetheless."
     1508                                  "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.")
     1509                          (when (find (second d) *features* :test 'string-equal)
     1510                            (dep op (third d) nil)))
     1511                         (t
     1512                          (error "Bad dependency ~a.  Dependencies must be (:version <version>), (:feature <feature> [version]), or a name" d))))))
     1513           flag))))
     1514
     1515(defun do-collect (collect x)
     1516  (funcall collect x))
     1517
     1518(defmethod do-traverse ((operation operation) (c component) collect)
     1519  (let ((flag nil)) ;; return value: must we rebuild this and its dependencies?
     1520    (labels
     1521        ((update-flag (x)
     1522           (when x
     1523             (setf flag t)))
     1524         (dep (op comp)
     1525           (update-flag (do-dep operation c collect op comp))))
     1526      ;; Have we been visited yet? If so, just process the result.
    9741527      (aif (component-visited-p operation c)
    975            (return-from traverse
    976              (if (cdr it) (list (cons 'pruned-op c)) nil)))
     1528           (progn
     1529             (update-flag (cdr it))
     1530             (return-from do-traverse flag)))
    9771531      ;; dependencies
    978       (if (component-visiting-p operation c)
    979           (error 'circular-dependency :components (list c)))
     1532      (when (component-visiting-p operation c)
     1533        (error 'circular-dependency :components (list c)))
    9801534      (setf (visiting-component operation c) t)
    9811535      (unwind-protect
    982            (progn
    983              (loop for (required-op . deps) in
    984                   (component-depends-on operation c)
    985                   do (do-dep required-op deps))
    986              ;; constituent bits
    987              (let ((module-ops
    988                     (when (typep c 'module)
    989                       (let ((at-least-one nil)
    990                             (forced nil)
    991                             (error nil))
    992                         (loop for kid in (module-components c)
    993                            do (handler-case
    994                                   (appendf forced (traverse operation kid ))
    995                                 (missing-dependency (condition)
    996                                   (if (eq (module-if-component-dep-fails c)
    997                                           :fail)
    998                                       (error condition))
    999                                   (setf error condition))
    1000                                 (:no-error (c)
    1001                                   (declare (ignore c))
    1002                                   (setf at-least-one t))))
    1003                         (when (and (eq (module-if-component-dep-fails c)
    1004                                        :try-next)
    1005                                    (not at-least-one))
    1006                           (error error))
    1007                         forced))))
    1008                ;; now the thing itself
    1009                (when (or forced module-ops
    1010                          (not (operation-done-p operation c))
    1011                          (let ((f (operation-forced
    1012                                    (operation-ancestor operation))))
    1013                            (and f (or (not (consp f))
    1014                                       (member (component-name
    1015                                                (operation-ancestor operation))
    1016                                               (mapcar #'coerce-name f)
    1017                                               :test #'string=)))))
    1018                  (let ((do-first (cdr (assoc (class-name (class-of operation))
    1019                                              (slot-value c 'do-first)))))
    1020                    (loop for (required-op . deps) in do-first
    1021                       do (do-dep required-op deps)))
    1022                  (setf forced (append (delete 'pruned-op forced :key #'car)
    1023                                       (delete 'pruned-op module-ops :key #'car)
    1024                                       (list (cons operation c)))))))
    1025         (setf (visiting-component operation c) nil))
    1026       (visit-component operation c (and forced t))
    1027       forced)))
    1028 
     1536           (progn
     1537             ;; first we check and do all the dependencies for the module.
     1538             ;; Operations planned in this loop will show up
     1539             ;; in the results, and are consumed below.
     1540             (let ((*forcing* nil))
     1541               ;; upstream dependencies are never forced to happen just because
     1542               ;; the things that depend on them are....
     1543               (loop
     1544                 :for (required-op . deps) :in (component-depends-on operation c)
     1545                 :do (dep required-op deps)))
     1546             ;; constituent bits
     1547             (let ((module-ops
     1548                    (when (typep c 'module)
     1549                      (let ((at-least-one nil)
     1550                            ;; This is set based on the results of the
     1551                            ;; dependencies and whether we are in the
     1552                            ;; context of a *forcing* call...
     1553                            ;; inter-system dependencies do NOT trigger
     1554                            ;; building components
     1555                            (*forcing*
     1556                             (or *forcing*
     1557                                 (and flag (not (typep c 'system)))))
     1558                            (error nil))
     1559                        (while-collecting (internal-collect)
     1560                          (dolist (kid (module-components c))
     1561                            (handler-case
     1562                                (update-flag
     1563                                 (do-traverse operation kid #'internal-collect))
     1564                              (missing-dependency (condition)
     1565                                (when (eq (module-if-component-dep-fails c)
     1566                                          :fail)
     1567                                  (error condition))
     1568                                (setf error condition))
     1569                              (:no-error (c)
     1570                                (declare (ignore c))
     1571                                (setf at-least-one t))))
     1572                          (when (and (eq (module-if-component-dep-fails c)
     1573                                         :try-next)
     1574                                     (not at-least-one))
     1575                            (error error)))))))
     1576               (update-flag
     1577                (or
     1578                 *forcing*
     1579                 (not (operation-done-p operation c))
     1580                 ;; For sub-operations, check whether
     1581                 ;; the original ancestor operation was forced,
     1582                 ;; or names us amongst an explicit list of things to force...
     1583                 ;; except that this check doesn't distinguish
     1584                 ;; between all the things with a given name. Sigh.
     1585                 ;; BROKEN!
     1586                 (let ((f (operation-forced
     1587                           (operation-ancestor operation))))
     1588                   (and f (or (not (consp f)) ;; T or :ALL
     1589                              (and (typep c 'system) ;; list of names of systems to force
     1590                                   (member (component-name c) f
     1591                                           :test #'string=)))))))
     1592               (when flag
     1593                 (let ((do-first (cdr (assoc (class-name (class-of operation))
     1594                                             (component-do-first c)))))
     1595                   (loop :for (required-op . deps) :in do-first
     1596                     :do (do-dep operation c collect required-op deps)))
     1597                 (do-collect collect (vector module-ops))
     1598                 (do-collect collect (cons operation c)))))
     1599             (setf (visiting-component operation c) nil)))
     1600      (visit-component operation c flag)
     1601      flag))
     1602
     1603(defmethod traverse ((operation operation) (c component))
     1604  ;; cerror'ing a feature that seems to have NEVER EVER worked
     1605  ;; ever since danb created it in his 2003-03-16 commit e0d02781.
     1606  ;; It was both fixed and disabled in the 1.700 rewrite.
     1607  (when (consp (operation-forced operation))
     1608    (cerror "Continue nonetheless."
     1609            "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.")
     1610    (setf (operation-forced operation)
     1611          (mapcar #'coerce-name (operation-forced operation))))
     1612  (flatten-tree
     1613   (while-collecting (collect)
     1614     (do-traverse operation c #'collect))))
     1615
     1616(defun flatten-tree (l)
     1617  ;; You collected things into a list.
     1618  ;; Most elements are just things to collect again.
     1619  ;; A (simple-vector 1) indicate that you should recurse into its contents.
     1620  ;; This way, in two passes (rather than N being the depth of the tree),
     1621  ;; you can collect things with marginally constant-time append,
     1622  ;; achieving linear time collection instead of quadratic time.
     1623  (while-collecting (c)
     1624    (labels ((r (x)
     1625               (if (typep x '(simple-vector 1))
     1626                   (r* (svref x 0))
     1627                   (c x)))
     1628             (r* (l)
     1629               (dolist (x l) (r x))))
     1630      (r* l))))
    10291631
    10301632(defmethod perform ((operation operation) (c source-file))
     
    10351637
    10361638(defmethod perform ((operation operation) (c module))
     1639  (declare (ignorable operation c))
    10371640  nil)
    10381641
     
    10401643  (asdf-message "~&;;; ~A on ~A~%" operation component))
    10411644
    1042 ;;; compile-op
     1645;;;; -------------------------------------------------------------------------
     1646;;;; compile-op
    10431647
    10441648(defclass compile-op (operation)
     
    10471651                :initform *compile-file-warnings-behaviour*)
    10481652   (on-failure :initarg :on-failure :accessor operation-on-failure
    1049                :initform *compile-file-failure-behaviour*)))
     1653               :initform *compile-file-failure-behaviour*)
     1654   (flags :initarg :flags :accessor compile-op-flags
     1655          :initform #-ecl nil #+ecl '(:system-p t))))
    10501656
    10511657(defmethod perform :before ((operation compile-op) (c source-file))
    10521658  (map nil #'ensure-directories-exist (output-files operation c)))
     1659
     1660#+ecl
     1661(defmethod perform :after ((o compile-op) (c cl-source-file))
     1662  ;; Note how we use OUTPUT-FILES to find the binary locations
     1663  ;; This allows the user to override the names.
     1664  (let* ((input (output-files o c))
     1665         (output (compile-file-pathname (lispize-pathname (first input)) :type :fasl)))
     1666    (c:build-fasl output :lisp-files (remove "fas" input :key #'pathname-type :test #'string=))))
    10531667
    10541668(defmethod perform :after ((operation operation) (c component))
     
    10631677        (output-file (car (output-files operation c))))
    10641678    (multiple-value-bind (output warnings-p failure-p)
    1065         (compile-file source-file :output-file output-file)
     1679        (apply #'compile-file source-file :output-file output-file
     1680               (compile-op-flags operation))
    10661681      (when warnings-p
    10671682        (case (operation-on-warnings operation)
     
    10821697
    10831698(defmethod output-files ((operation compile-op) (c cl-source-file))
    1084   #-:broken-fasl-loader (list (compile-file-pathname (component-pathname c)))
    1085   #+:broken-fasl-loader (list (component-pathname c)))
     1699  (declare (ignorable operation))
     1700  (let ((p (lispize-pathname (component-pathname c))))
     1701    #-:broken-fasl-loader
     1702    (list #-ecl (compile-file-pathname p)
     1703          #+ecl (compile-file-pathname p :type :object)
     1704          #+ecl (compile-file-pathname p :type :fasl))
     1705    #+:broken-fasl-loader (list p)))
    10861706
    10871707(defmethod perform ((operation compile-op) (c static-file))
     1708  (declare (ignorable operation c))
    10881709  nil)
    10891710
    10901711(defmethod output-files ((operation compile-op) (c static-file))
     1712  (declare (ignorable operation c))
    10911713  nil)
    10921714
    1093 (defmethod input-files ((op compile-op) (c static-file))
     1715(defmethod input-files ((operation compile-op) (c static-file))
     1716  (declare (ignorable operation c))
    10941717  nil)
    10951718
    10961719
    1097 ;;; load-op
     1720;;;; -------------------------------------------------------------------------
     1721;;;; load-op
    10981722
    10991723(defclass basic-load-op (operation) ())
     
    11021726
    11031727(defmethod perform ((o load-op) (c cl-source-file))
    1104   (mapcar #'load (input-files o c)))
    1105 
    1106 (defmethod perform around ((o load-op) (c cl-source-file))
    1107   (let ((state :initial))
    1108     (loop until (or (eq state :success)
    1109                     (eq state :failure)) do
    1110          (case state
    1111            (:recompiled
    1112             (setf state :failure)
    1113             (call-next-method)
    1114             (setf state :success))
    1115            (:failed-load
    1116             (setf state :recompiled)
    1117             (perform (make-instance 'asdf:compile-op) c))
    1118            (t
    1119             (with-simple-restart
    1120                 (try-recompiling "Recompile ~a and try loading it again"
    1121                                   (component-name c))
    1122               (setf state :failed-load)
    1123               (call-next-method)
    1124               (setf state :success)))))))
    1125 
    1126 (defmethod perform around ((o compile-op) (c cl-source-file))
    1127   (let ((state :initial))
    1128     (loop until (or (eq state :success)
    1129                     (eq state :failure)) do
    1130          (case state
    1131            (:recompiled
    1132             (setf state :failure)
    1133             (call-next-method)
    1134             (setf state :success))
    1135            (:failed-compile
    1136             (setf state :recompiled)
    1137             (perform (make-instance 'asdf:compile-op) c))
    1138            (t
    1139             (with-simple-restart
    1140                 (try-recompiling "Try recompiling ~a"
    1141                                   (component-name c))
    1142               (setf state :failed-compile)
    1143               (call-next-method)
    1144               (setf state :success)))))))
     1728  #-ecl (mapcar #'load (input-files o c))
     1729  #+ecl (loop :for i :in (input-files o c)
     1730          :unless (string= (pathname-type i) "fas")
     1731          :collect (let ((output (compile-file-pathname (lispize-pathname i))))
     1732                     (load output))))
     1733
     1734(defmethod perform-with-restarts (operation component)
     1735  (perform operation component))
     1736
     1737(defmethod perform-with-restarts ((o load-op) (c cl-source-file))
     1738  (declare (ignorable o))
     1739  (loop :with state = :initial
     1740    :until (or (eq state :success)
     1741               (eq state :failure)) :do
     1742    (case state
     1743      (:recompiled
     1744       (setf state :failure)
     1745       (call-next-method)
     1746       (setf state :success))
     1747      (:failed-load
     1748       (setf state :recompiled)
     1749       (perform (make-instance 'compile-op) c))
     1750      (t
     1751       (with-simple-restart
     1752           (try-recompiling "Recompile ~a and try loading it again"
     1753                            (component-name c))
     1754         (setf state :failed-load)
     1755         (call-next-method)
     1756         (setf state :success))))))
     1757
     1758(defmethod perform-with-restarts ((o compile-op) (c cl-source-file))
     1759  (loop :with state = :initial
     1760    :until (or (eq state :success)
     1761               (eq state :failure)) :do
     1762    (case state
     1763      (:recompiled
     1764       (setf state :failure)
     1765       (call-next-method)
     1766       (setf state :success))
     1767      (:failed-compile
     1768       (setf state :recompiled)
     1769       (perform-with-restarts o c))
     1770      (t
     1771       (with-simple-restart
     1772           (try-recompiling "Try recompiling ~a"
     1773                            (component-name c))
     1774         (setf state :failed-compile)
     1775         (call-next-method)
     1776         (setf state :success))))))
    11451777
    11461778(defmethod perform ((operation load-op) (c static-file))
     1779  (declare (ignorable operation c))
    11471780  nil)
    11481781
    11491782(defmethod operation-done-p ((operation load-op) (c static-file))
     1783  (declare (ignorable operation c))
    11501784  t)
    11511785
    1152 (defmethod output-files ((o operation) (c component))
     1786(defmethod output-files ((operation operation) (c component))
     1787  (declare (ignorable operation c))
    11531788  nil)
    11541789
    11551790(defmethod component-depends-on ((operation load-op) (c component))
     1791  (declare (ignorable operation))
    11561792  (cons (list 'compile-op (component-name c))
    11571793        (call-next-method)))
    11581794
    1159 ;;; load-source-op
     1795;;;; -------------------------------------------------------------------------
     1796;;;; load-source-op
    11601797
    11611798(defclass load-source-op (basic-load-op) ())
    11621799
    11631800(defmethod perform ((o load-source-op) (c cl-source-file))
     1801  (declare (ignorable o))
    11641802  (let ((source (component-pathname c)))
    11651803    (setf (component-property c 'last-loaded-as-source)
     
    11681806
    11691807(defmethod perform ((operation load-source-op) (c static-file))
     1808  (declare (ignorable operation c))
    11701809  nil)
    11711810
    11721811(defmethod output-files ((operation load-source-op) (c component))
     1812  (declare (ignorable operation c))
    11731813  nil)
    11741814
    11751815;;; FIXME: we simply copy load-op's dependencies.  this is Just Not Right.
    11761816(defmethod component-depends-on ((o load-source-op) (c component))
     1817  (declare (ignorable o))
    11771818  (let ((what-would-load-op-do (cdr (assoc 'load-op
    1178                                            (slot-value c 'in-order-to)))))
     1819                                           (component-in-order-to c)))))
    11791820    (mapcar (lambda (dep)
    11801821              (if (eq (car dep) 'load-op)
     
    11841825
    11851826(defmethod operation-done-p ((o load-source-op) (c source-file))
     1827  (declare (ignorable o))
    11861828  (if (or (not (component-property c 'last-loaded-as-source))
    1187           (> (file-write-date (component-pathname c))
     1829          (> (safe-file-write-date (component-pathname c))
    11881830             (component-property c 'last-loaded-as-source)))
    11891831      nil t))
    11901832
     1833
     1834;;;; -------------------------------------------------------------------------
     1835;;;; test-op
     1836
    11911837(defclass test-op (operation) ())
    11921838
    11931839(defmethod perform ((operation test-op) (c component))
     1840  (declare (ignorable operation c))
    11941841  nil)
    11951842
    11961843(defmethod operation-done-p ((operation test-op) (c system))
    11971844  "Testing a system is _never_ done."
     1845  (declare (ignorable operation c))
    11981846  nil)
    11991847
    12001848(defmethod component-depends-on :around ((o test-op) (c system))
     1849  (declare (ignorable o))
    12011850  (cons `(load-op ,(component-name c)) (call-next-method)))
    12021851
    12031852
    1204 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1205 ;;; invoking operations
    1206 
    1207 (defun operate (operation-class system &rest args &key (verbose t) version force
    1208                 &allow-other-keys)
     1853;;;; -------------------------------------------------------------------------
     1854;;;; Invoking Operations
     1855
     1856(defgeneric operate (operation-class system &key &allow-other-keys))
     1857
     1858(defmethod operate (operation-class system &rest args
     1859                    &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force
     1860                    &allow-other-keys)
    12091861  (declare (ignore force))
    12101862  (let* ((*package* *package*)
     
    12131865                    :original-initargs args
    12141866                    args))
    1215          (*verbose-out* (if verbose *standard-output* (make-broadcast-stream)))
     1867         (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
    12161868         (system (if (typep system 'component) system (find-system system))))
    12171869    (unless (version-satisfies system version)
     
    12191871    (let ((steps (traverse op system)))
    12201872      (with-compilation-unit ()
    1221         (loop for (op . component) in steps do
    1222                  (loop
    1223                    (restart-case
    1224                        (progn (perform op component)
    1225                               (return))
    1226                      (retry ()
    1227                        :report
    1228                        (lambda (s)
    1229                          (format s "~@<Retry performing ~S on ~S.~@:>"
    1230                                  op component)))
    1231                      (accept ()
    1232                        :report
    1233                        (lambda (s)
    1234                          (format s "~@<Continue, treating ~S on ~S as ~
     1873        (loop :for (op . component) :in steps :do
     1874          (loop
     1875            (restart-case
     1876                (progn
     1877                  (perform-with-restarts op component)
     1878                  (return))
     1879              (retry ()
     1880                :report
     1881                (lambda (s)
     1882                  (format s "~@<Retry performing ~S on ~S.~@:>"
     1883                          op component)))
     1884              (accept ()
     1885                :report
     1886                (lambda (s)
     1887                  (format s "~@<Continue, treating ~S on ~S as ~
    12351888                                   having been successful.~@:>"
    1236                                  op component))
    1237                        (setf (gethash (type-of op)
    1238                                       (component-operation-times component))
    1239                              (get-universal-time))
    1240                        (return)))))))
     1889                          op component))
     1890                (setf (gethash (type-of op)
     1891                               (component-operation-times component))
     1892                      (get-universal-time))
     1893                (return)))))))
    12411894    op))
    12421895
    1243 (defun oos (operation-class system &rest args &key force (verbose t) version
    1244             &allow-other-keys)
     1896(defun oos (operation-class system &rest args &key force verbose version
     1897            &allow-other-keys)
    12451898  (declare (ignore force verbose version))
    12461899  (apply #'operate operation-class system args))
     
    12651918"))
    12661919  (setf (documentation 'oos 'function)
    1267         (format nil
    1268                 "Short for _operate on system_ and an alias for the [operate][] function. ~&~&~a"
    1269                 operate-docstring))
     1920        (format nil
     1921                "Short for _operate on system_ and an alias for the OPERATE function. ~&~&~a"
     1922                operate-docstring))
    12701923  (setf (documentation 'operate 'function)
    1271         operate-docstring))
    1272 
    1273 (defun load-system (system &rest args &key force (verbose t) version)
    1274   "Shorthand for `(operate 'asdf:load-op system)`. See [operate][] for details."
     1924        operate-docstring))
     1925
     1926(defun load-system (system &rest args &key force verbose version
     1927                    &allow-other-keys)
     1928  "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for
     1929details."
    12751930  (declare (ignore force verbose version))
    12761931  (apply #'operate 'load-op system args))
    12771932
    1278 (defun compile-system (system &rest args &key force (verbose t) version)
    1279   "Shorthand for `(operate 'asdf:compile-op system)`. See [operate][] for details."
     1933(defun compile-system (system &rest args &key force verbose version
     1934                       &allow-other-keys)
     1935  "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE
     1936for details."
    12801937  (declare (ignore force verbose version))
    12811938  (apply #'operate 'compile-op system args))
    12821939
    1283 (defun test-system (system &rest args &key force (verbose t) version)
    1284   "Shorthand for `(operate 'asdf:test-op system)`. See [operate][] for details."
     1940(defun test-system (system &rest args &key force verbose version
     1941                    &allow-other-keys)
     1942  "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for
     1943details."
    12851944  (declare (ignore force verbose version))
    12861945  (apply #'operate 'test-op system args))
    12871946
    1288 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1289 ;;; syntax
    1290 
    1291 (defun remove-keyword (key arglist)
    1292   (labels ((aux (key arglist)
    1293              (cond ((null arglist) nil)
    1294                    ((eq key (car arglist)) (cddr arglist))
    1295                    (t (cons (car arglist) (cons (cadr arglist)
    1296                                                 (remove-keyword
    1297                                                  key (cddr arglist))))))))
    1298     (aux key arglist)))
    1299 
    1300 (defun resolve-symlinks (path)
    1301   #-allegro (truename path)
    1302   #+allegro (excl:pathname-resolve-symbolic-links path)
    1303   )
     1947;;;; -------------------------------------------------------------------------
     1948;;;; Defsystem
    13041949
    13051950(defun determine-system-pathname (pathname pathname-supplied-p)
    13061951  ;; called from the defsystem macro.
    13071952  ;; the pathname of a system is either
    1308   ;; 1. the one supplied, 
     1953  ;; 1. the one supplied,
    13091954  ;; 2. derived from the *load-truename* (see below), or
    13101955  ;; 3. taken from *default-pathname-defaults*
     
    13141959  ;; *load-pathname* instead of *load-truename* since in some
    13151960  ;; implementations, the latter has *already resolved it.
    1316   (or (and pathname-supplied-p pathname)
    1317       (when *load-truename*
    1318         (pathname-sans-name+type
    1319          (if *resolve-symlinks*
    1320              (resolve-symlinks *load-truename*)
    1321              *load-pathname*)))
    1322       *default-pathname-defaults*))
     1961  (let ((file-pathname
     1962         (when (or *load-pathname* *compile-file-pathname*)
     1963           (pathname-directory-pathname
     1964            (if *resolve-symlinks*
     1965                (resolve-symlinks (or *load-truename* *compile-file-truename*))
     1966                *load-pathname*)))))
     1967    (or (and pathname-supplied-p (merge-pathnames* pathname file-pathname))
     1968        file-pathname
     1969        (current-directory))))
    13231970
    13241971(defmacro defsystem (name &body options)
    13251972  (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
    1326                             &allow-other-keys)
     1973                            defsystem-depends-on &allow-other-keys)
    13271974      options
    1328     (let ((component-options (remove-keyword :class options)))
     1975    (let ((component-options (remove-keys '(:defsystem-depends-on :class) options)))
    13291976      `(progn
    13301977         ;; system must be registered before we parse the body, otherwise
    13311978         ;; we recur when trying to find an existing system of the same name
    13321979         ;; to reuse options (e.g. pathname) from
     1980         ,@(loop :for system :in defsystem-depends-on
     1981             :collect `(load-system ,system))
    13331982         (let ((s (system-registered-p ',name)))
    13341983           (cond ((and s (eq (type-of (cdr s)) ',class))
     
    13391988                  (register-system (quote ,name)
    13401989                                   (make-instance ',class :name ',name))))
    1341            (%set-system-source-file *load-truename*
    1342                                     (cdr (system-registered-p ',name))))
    1343          (parse-component-form
    1344           nil (apply
    1345                #'list
    1346                :module (coerce-name ',name)
    1347                :pathname
    1348                ,(determine-system-pathname pathname pathname-arg-p)
    1349                ',component-options))))))
     1990           (%set-system-source-file *load-truename*
     1991                                    (cdr (system-registered-p ',name))))
     1992         (parse-component-form
     1993          nil (list*
     1994               :module (coerce-name ',name)
     1995               :pathname
     1996               ,(determine-system-pathname pathname pathname-arg-p)
     1997               ',component-options))))))
    13501998
    13511999
     
    13942042
    13952043
    1396 (defun remove-keys (key-names args)
    1397   (loop for ( name val ) on args by #'cddr
    1398         unless (member (symbol-name name) key-names
    1399                        :key #'symbol-name :test 'equal)
    1400         append (list name val)))
    1401 
    1402 (defvar *serial-depends-on*)
     2044(defvar *serial-depends-on* nil)
    14032045
    14042046(defun sysdef-error-component (msg type name value)
    14052047  (sysdef-error (concatenate 'string msg
    1406                              "~&The value specified for ~(~A~) ~A is ~W")
     2048                             "~&The value specified for ~(~A~) ~A is ~S")
    14072049                type name value))
    14082050
    1409 (defun check-component-input (type name weakly-depends-on 
    1410                               depends-on components in-order-to)
     2051(defun check-component-input (type name weakly-depends-on
     2052                              depends-on components in-order-to)
    14112053  "A partial test of the values of a component."
    14122054  (unless (listp depends-on)
     
    14242066
    14252067(defun %remove-component-inline-methods (component)
    1426   (loop for name in +asdf-methods+
    1427         do (map 'nil
    1428                 ;; this is inefficient as most of the stored
    1429                 ;; methods will not be for this particular gf n
    1430                 ;; But this is hardly performance-critical
    1431                 (lambda (m)
    1432                   (remove-method (symbol-function name) m))
    1433                 (component-inline-methods component)))
     2068  (dolist (name +asdf-methods+)
     2069    (map ()
     2070         ;; this is inefficient as most of the stored
     2071         ;; methods will not be for this particular gf
     2072         ;; But this is hardly performance-critical
     2073         (lambda (m)
     2074           (remove-method (symbol-function name) m))
     2075         (component-inline-methods component)))
    14342076  ;; clear methods, then add the new ones
    14352077  (setf (component-inline-methods component) nil))
    14362078
    14372079(defun %define-component-inline-methods (ret rest)
    1438   (loop for name in +asdf-methods+ do
    1439        (let ((keyword (intern (symbol-name name) :keyword)))
    1440          (loop for data = rest then (cddr data)
    1441               for key = (first data)
    1442               for value = (second data)
    1443               while data
    1444               when (eq key keyword) do
    1445               (destructuring-bind (op qual (o c) &body body) value
    1446               (pushnew
    1447                 (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
    1448                                    ,@body))
    1449                 (component-inline-methods ret)))))))
     2080  (dolist (name +asdf-methods+)
     2081    (let ((keyword (intern (symbol-name name) :keyword)))
     2082      (loop :for data = rest :then (cddr data)
     2083        :for key = (first data)
     2084        :for value = (second data)
     2085        :while data
     2086        :when (eq key keyword) :do
     2087        (destructuring-bind (op qual (o c) &body body) value
     2088          (pushnew
     2089          (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
     2090                             ,@body))
     2091          (component-inline-methods ret)))))))
    14502092
    14512093(defun %refresh-component-inline-methods (component rest)
    14522094  (%remove-component-inline-methods component)
    14532095  (%define-component-inline-methods component rest))
    1454  
     2096
    14552097(defun parse-component-form (parent options)
    1456 
    14572098  (destructuring-bind
    14582099        (type name &rest rest &key
     
    14862127                (make-instance (class-for-type parent type)))))
    14872128      (when weakly-depends-on
    1488         (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on))))
    1489       (when (boundp '*serial-depends-on*)
    1490         (setf depends-on
    1491               (concatenate 'list *serial-depends-on* depends-on)))
     2129        (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on)))
     2130      (when *serial-depends-on*
     2131        (push *serial-depends-on* depends-on))
    14922132      (apply #'reinitialize-instance ret
    14932133             :name (coerce-name name)
     
    14952135             :parent parent
    14962136             other-args)
     2137      (component-pathname ret) ; eagerly compute the absolute pathname
    14972138      (when (typep ret 'module)
    14982139        (setf (module-default-component-class ret)
     
    15022143        (let ((*serial-depends-on* nil))
    15032144          (setf (module-components ret)
    1504                 (loop for c-form in components
    1505                       for c = (parse-component-form ret c-form)
    1506                       collect c
    1507                       if serial
    1508                       do (push (component-name c) *serial-depends-on*))))
    1509 
    1510         ;; check for duplicate names
    1511         (let ((name-hash (make-hash-table :test #'equal)))
    1512           (loop for c in (module-components ret)
    1513                 do
    1514                 (if (gethash (component-name c)
    1515                              name-hash)
    1516                     (error 'duplicate-names
    1517                            :name (component-name c))
    1518                     (setf (gethash (component-name c)
    1519                                    name-hash)
    1520                           t)))))
    1521 
    1522       (setf (slot-value ret 'in-order-to)
     2145                (loop
     2146                  :for c-form :in components
     2147                  :for c = (parse-component-form ret c-form)
     2148                  :for name = (component-name c)
     2149                  :collect c
     2150                  :when serial :do (setf *serial-depends-on* name))))
     2151        (compute-module-components-by-name ret))
     2152
     2153      (setf (component-load-dependencies ret) depends-on) ;; Used by POIU
     2154
     2155      (setf (component-in-order-to ret)
    15232156            (union-of-dependencies
    15242157             in-order-to
    15252158             `((compile-op (compile-op ,@depends-on))
    1526                (load-op (load-op ,@depends-on))))
    1527             (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on))))
     2159               (load-op (load-op ,@depends-on)))))
     2160      (setf (component-do-first ret) `((compile-op (load-op ,@depends-on))))
    15282161
    15292162      (%refresh-component-inline-methods ret rest)
    1530 
    15312163      ret)))
    15322164
    1533 ;;; optional extras
    1534 
    1535 ;;; run-shell-command functions for other lisp implementations will be
    1536 ;;; gratefully accepted, if they do the same thing.  If the docstring
    1537 ;;; is ambiguous, send a bug report
     2165;;;; ---------------------------------------------------------------------------
     2166;;;; run-shell-command
     2167;;;;
     2168;;;; run-shell-command functions for other lisp implementations will be
     2169;;;; gratefully accepted, if they do the same thing.
     2170;;;; If the docstring is ambiguous, send a bug report.
     2171;;;;
     2172;;;; We probably should move this functionality to its own system and deprecate
     2173;;;; use of it from the asdf package. However, this would break unspecified
     2174;;;; existing software, so until a clear alternative exists, we can't deprecate
     2175;;;; it, and even after it's been deprecated, we will support it for a few
     2176;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01
    15382177
    15392178(defun run-shell-command (control-string &rest args)
     
    15432182  (let ((command (apply #'format nil control-string args)))
    15442183    (asdf-message "; $ ~A~%" command)
     2184
     2185    #+abcl
     2186    (ext:run-shell-command command :output *verbose-out*)
     2187
     2188    #+allegro
     2189    ;; will this fail if command has embedded quotes - it seems to work
     2190    (multiple-value-bind (stdout stderr exit-code)
     2191        (excl.osi:command-output
     2192         (format nil "~a -c \"~a\""
     2193                 #+mswindows "sh" #-mswindows "/bin/sh" command)
     2194         :input nil :whole nil
     2195         #+mswindows :show-window #+mswindows :hide)
     2196      (format *verbose-out* "~{~&; ~a~%~}~%" stderr)
     2197      (format *verbose-out* "~{~&; ~a~%~}~%" stdout)
     2198      exit-code)
     2199
     2200    #+clisp                     ;XXX not exactly *verbose-out*, I know
     2201    (ext:run-shell-command  command :output :terminal :wait t)
     2202
     2203    #+clozure
     2204    (nth-value 1
     2205               (ccl:external-process-status
     2206                (ccl:run-program "/bin/sh" (list "-c" command)
     2207                                 :input nil :output *verbose-out*
     2208                                 :wait t)))
     2209
     2210    #+ecl ;; courtesy of Juan Jose Garcia Ripoll
     2211    (si:system command)
     2212
     2213    #+gcl
     2214    (lisp:system command)
     2215
     2216    #+lispworks
     2217    (system:call-system-showing-output
     2218     command
     2219     :shell-type "/bin/sh"
     2220     :show-cmd nil
     2221     :prefix ""
     2222     :output-stream *verbose-out*)
     2223
    15452224    #+sbcl
    15462225    (sb-ext:process-exit-code
    15472226     (apply #'sb-ext:run-program
    1548             #+win32 "sh" #-win32 "/bin/sh"
    1549             (list  "-c" command)
    1550             :input nil :output *verbose-out*
    1551             #+win32 '(:search t) #-win32 nil))
     2227            #+win32 "sh" #-win32 "/bin/sh"
     2228            (list  "-c" command)
     2229            :input nil :output *verbose-out*
     2230            #+win32 '(:search t) #-win32 nil))
    15522231
    15532232    #+(or cmu scl)
     
    15582237      :input nil :output *verbose-out*))
    15592238
    1560     #+allegro
    1561     ;; will this fail if command has embedded quotes - it seems to work
    1562     (multiple-value-bind (stdout stderr exit-code)
    1563         (excl.osi:command-output
    1564          (format nil "~a -c \"~a\""
    1565                  #+mswindows "sh" #-mswindows "/bin/sh" command)
    1566          :input nil :whole nil
    1567          #+mswindows :show-window #+mswindows :hide)
    1568       (format *verbose-out* "~{~&; ~a~%~}~%" stderr)
    1569       (format *verbose-out* "~{~&; ~a~%~}~%" stdout)
    1570       exit-code)
    1571 
    1572     #+lispworks
    1573     (system:call-system-showing-output
    1574      command
    1575      :shell-type "/bin/sh"
    1576      :output-stream *verbose-out*)
    1577 
    1578     #+clisp                     ;XXX not exactly *verbose-out*, I know
    1579     (ext:run-shell-command  command :output :terminal :wait t)
    1580 
    1581     #+openmcl
    1582     (nth-value 1
    1583                (ccl:external-process-status
    1584                 (ccl:run-program "/bin/sh" (list "-c" command)
    1585                                  :input nil :output *verbose-out*
    1586                                  :wait t)))
    1587 
    1588     #+ecl ;; courtesy of Juan Jose Garcia Ripoll
    1589     (si:system command)
    1590 
    1591     #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl)
    1592     (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
    1593     ))
    1594 
    1595 (defmethod system-source-file ((system-name t))
     2239    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl)
     2240    (error "RUN-SHELL-COMMAND not implemented for this Lisp")))
     2241
     2242;;;; ---------------------------------------------------------------------------
     2243;;;; system-relative-pathname
     2244
     2245(defmethod system-source-file ((system-name string))
    15962246  (system-source-file (find-system system-name)))
    1597 
    1598 (defun system-source-directory (system-name)
    1599   (make-pathname :name nil
     2247(defmethod system-source-file ((system-name symbol))
     2248  (system-source-file (find-system system-name)))
     2249
     2250(defun system-source-directory (system-designator)
     2251  "Return a pathname object corresponding to the
     2252directory in which the system specification (.asd file) is
     2253located."
     2254     (make-pathname :name nil
    16002255                 :type nil
    1601                  :defaults (system-source-file system-name)))
    1602 
    1603 (defun system-relative-pathname (system pathname &key name type)
    1604   ;; you're not allowed to muck with the return value of pathname-X
    1605   (let ((directory (copy-list (pathname-directory pathname))))
    1606     (when (eq (car directory) :absolute)
    1607       (setf (car directory) :relative))
    1608     (merge-pathnames
    1609      (make-pathname :name (or name (pathname-name pathname))
    1610                     :type (or type (pathname-type pathname))
    1611                     :directory directory)
    1612      (system-source-directory system))))
     2256                 :defaults (system-source-file system-designator)))
     2257
     2258(defun relativize-directory (directory)
     2259  (cond
     2260    ((stringp directory)
     2261     (list :relative directory))
     2262    ((eq (car directory) :absolute)
     2263     (cons :relative (cdr directory)))
     2264    (t
     2265     directory)))
     2266
     2267(defun relativize-pathname-directory (pathspec)
     2268  (let ((p (pathname pathspec)))
     2269    (make-pathname
     2270     :directory (relativize-directory (pathname-directory p))
     2271     :defaults p)))
     2272
     2273(defun system-relative-pathname (system name &key type)
     2274  (merge-pathnames*
     2275   (merge-component-name-type name :type type)
     2276   (system-source-directory system)))
     2277
    16132278
    16142279;;; ---------------------------------------------------------------------------
    1615 ;;; asdf-binary-locations
     2280;;; implementation-identifier
    16162281;;;
    1617 ;;; this bit of code was stolen from Bjorn Lindberg and then it grew!
    1618 ;;; see http://www.cliki.net/asdf%20binary%20locations
    1619 ;;; and http://groups.google.com/group/comp.lang.lisp/msg/bd5ea9d2008ab9fd
    1620 ;;; ---------------------------------------------------------------------------
    1621 ;;; Portions of this code were once from SWANK / SLIME
    1622 
    1623 (defparameter *centralize-lisp-binaries*
    1624   nil "
    1625 If true, compiled lisp files without an explicit mapping (see
    1626 \\*source-to-target-mappings\\*) will be placed in subdirectories of
    1627 \\*default-toplevel-directory\\*. If false, then compiled lisp files
    1628 without an explicitly mapping will be placed in subdirectories of
    1629 their sources.")
    1630 
    1631 (defparameter *enable-asdf-binary-locations* nil
    1632   "
    1633 If true, then compiled lisp files will be placed into a directory
    1634 computed from the Lisp version, Operating System and computer archetecture.
    1635 See [implementation-specific-directory-name][] for details.")
    1636 
    1637 
    1638 (defparameter *default-toplevel-directory*
    1639   (merge-pathnames
    1640    (make-pathname :directory '(:relative ".fasls"))
    1641    (truename (user-homedir-pathname)))
    1642   "If \\*centralize-lisp-binaries\\* is true, then compiled lisp files without an explicit mapping \(see \\*source-to-target-mappings\\*\) will be placed in subdirectories of \\*default-toplevel-directory\\*.")
    1643 
    1644 (defparameter *include-per-user-information*
    1645   nil
    1646   "When \\*centralize-lisp-binaries\\* is true this variable controls whether or not to customize the output directory based on the current user. It can be nil, t or a string. If it is nil \(the default\), then no additional information will be added to the output directory. If it is t, then the user's name \(as taken from the return value of #'user-homedir-pathname\) will be included into the centralized path (just before the lisp-implementation directory). Finally, if \\*include-per-user-information\\* is a string, then this string will be included in the output-directory.")
    1647 
    1648 (defparameter *map-all-source-files*
    1649   nil
    1650   "If true, then all subclasses of source-file will have their output locations mapped by ASDF-Binary-Locations. If nil (the default), then only subclasses of cl-source-file will be mapped.")
    1651 
    1652 (defvar *source-to-target-mappings*
    1653   #-sbcl
    1654   nil
    1655   #+sbcl
    1656   (list (list (princ-to-string (sb-ext:posix-getenv "SBCL_HOME")) nil))
    1657   "The \\*source-to-target-mappings\\* variable specifies mappings from source to target. If the target is nil, then it means to not map the source to anything. I.e., to leave it as is. This has the effect of turning off ASDF-Binary-Locations for the given source directory. Examples:
    1658 
    1659     ;; compile everything in .../src and below into .../cmucl
    1660     '((\"/nfs/home/compbio/d95-bli/share/common-lisp/src/\"
    1661        \"/nfs/home/compbio/d95-bli/lib/common-lisp/cmucl/\"))
    1662 
    1663     ;; leave SBCL innards alone (SBCL specific)
    1664     (list (list (princ-to-string (sb-ext:posix-getenv \"SBCL_HOME\")) nil))
    1665 ")
     2282;;; produce a string to identify current implementation.
     2283;;; Initially stolen from SLIME's SWANK, hacked since.
    16662284
    16672285(defparameter *implementation-features*
    1668   '(:allegro :lispworks :sbcl :ccl :openmcl :cmu :clisp
     2286  '(:allegro :lispworks :sbcl :clozure :digitool :cmu :clisp
    16692287    :corman :cormanlisp :armedbear :gcl :ecl :scl))
    16702288
    16712289(defparameter *os-features*
    1672   '(:windows :mswindows :win32 :mingw32
    1673     :solaris :sunos
     2290  '((:windows :mswindows :win32 :mingw32)
     2291    (:solaris :sunos)
     2292    :linux ;; for GCL at least, must appear before :bsd.
    16742293    :macosx :darwin :apple
    16752294    :freebsd :netbsd :openbsd :bsd
    1676     :linux :unix))
     2295    :unix))
    16772296
    16782297(defparameter *architecture-features*
    1679   '(:amd64 (:x86-64 :x86_64 :x8664-target) :i686 :i586 :pentium3
    1680     :i486 (:i386 :pc386 :iapx386) (:x86 :x8632-target) :pentium4
    1681     :hppa64 :hppa :ppc64 :ppc32 :powerpc :ppc :sparc64 :sparc))
    1682 
    1683 ;; note to gwking: this is in slime, system-check, and system-check-server too
     2298  '((:x86-64 :amd64 :x86_64 :x8664-target)
     2299    (:x86 :i686 :i586 :pentium3 :i486 :i386 :pc386 :iapx386 :x8632-target :pentium4)
     2300    :hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc))
     2301
    16842302(defun lisp-version-string ()
    1685   #+cmu       (substitute #\- #\/
    1686                           (substitute #\_ #\Space
    1687                                       (lisp-implementation-version)))
    1688   #+scl       (lisp-implementation-version)
    1689   #+sbcl      (lisp-implementation-version)
    1690   #+ecl       (reduce (lambda (x str) (substitute #\_ str x))
    1691                       '(#\Space #\: #\( #\))
    1692                       :initial-value (lisp-implementation-version))
    1693   #+gcl       (let ((s (lisp-implementation-version))) (subseq s 4))
    1694   #+openmcl   (format nil "~d.~d~@[-~d~]"
    1695                       ccl::*openmcl-major-version*
    1696                       ccl::*openmcl-minor-version*
    1697                       #+ppc64-target 64
    1698                       #-ppc64-target nil)
    1699   #+lispworks (format nil "~A~@[~A~]"
    1700                       (lisp-implementation-version)
    1701                       (when (member :lispworks-64bit *features*) "-64bit"))
    1702   #+allegro   (format nil
     2303  (let ((s (lisp-implementation-version)))
     2304    (declare (ignorable s))
     2305    #+allegro (format nil
    17032306                      "~A~A~A~A"
    17042307                      excl::*common-lisp-version-number*
    1705                                         ; ANSI vs MoDeRn
    1706                       ;; thanks to Robert Goldman and Charley Cox for
    1707                       ;; an improvement to my hack
    1708                       (if (eq excl:*current-case-mode*
    1709                               :case-sensitive-lower) "M" "A")
    1710                       ;; Note if not using International ACL
    1711                       ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
    1712                       (excl:ics-target-case
    1713                         (:-ics "8")
    1714                         (:+ics ""))
     2308                      ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
     2309                      (if (eq excl:*current-case-mode*
     2310                              :case-sensitive-lower) "M" "A")
     2311                      ;; Note if not using International ACL
     2312                      ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
     2313                      (excl:ics-target-case
     2314                       (:-ics "8")
     2315                       (:+ics ""))
    17152316                      (if (member :64bit *features*) "-64bit" ""))
    1716   #+clisp     (let ((s (lisp-implementation-version)))
    1717                 (subseq s 0 (position #\space s)))
    1718   #+armedbear (lisp-implementation-version)
    1719   #+cormanlisp (lisp-implementation-version)
    1720   #+digitool   (subseq (lisp-implementation-version) 8))
    1721 
    1722 
    1723 (defparameter *implementation-specific-directory-name* nil)
    1724 
    1725 (defun implementation-specific-directory-name ()
    1726   "Return a name that can be used as a directory name that is
    1727 unique to a Lisp implementation, Lisp implementation version,
    1728 operating system, and hardware architecture."
    1729   (and *enable-asdf-binary-locations*
    1730        (list
    1731         (or *implementation-specific-directory-name*
    1732             (setf *implementation-specific-directory-name*
    1733                   (labels
    1734                       ((fp (thing)
    1735                          (etypecase thing
    1736                            (symbol
    1737                             (let ((feature (find thing *features*)))
    1738                               (when feature (return-from fp feature))))
    1739                            ;; allows features to be lists of which the first
    1740                            ;; member is the "main name", the rest being aliases
    1741                            (cons
    1742                             (dolist (subf thing)
    1743                               (let ((feature (find subf *features*)))
    1744                                 (when feature (return-from fp (first thing))))))))
    1745                        (first-of (features)
    1746                          (loop for f in features
    1747                             when (fp f) return it))
    1748                        (maybe-warn (value fstring &rest args)
    1749                          (cond (value)
    1750                                (t (apply #'warn fstring args)
    1751                                   "unknown"))))
    1752                     (let ((lisp (maybe-warn (first-of *implementation-features*)
    1753                                             "No implementation feature found in ~a."
    1754                                             *implementation-features*))
    1755                           (os   (maybe-warn (first-of *os-features*)
    1756                                             "No os feature found in ~a." *os-features*))
    1757                           (arch (maybe-warn (first-of *architecture-features*)
    1758                                             "No architecture feature found in ~a."
    1759                                             *architecture-features*))
    1760                           (version (maybe-warn (lisp-version-string)
    1761                                                "Don't know how to get Lisp ~
     2317    #+clisp (subseq s 0 (position #\space s))
     2318    #+clozure (format nil "~d.~d-fasl~d"
     2319                      ccl::*openmcl-major-version*
     2320                      ccl::*openmcl-minor-version*
     2321                      (logand ccl::fasl-version #xFF))
     2322    #+cmu (substitute #\- #\/ s)
     2323    #+digitool (subseq s 8)
     2324    #+ecl (format nil "~A~@[-~A~]" s
     2325                  (let ((vcs-id (ext:lisp-implementation-vcs-id)))
     2326                    (when (>= (length vcs-id) 8)
     2327                      (subseq vcs-id 0 8))))
     2328    #+gcl (subseq s (1+ (position #\space s)))
     2329    #+lispworks (format nil "~A~@[~A~]" s
     2330                        (when (member :lispworks-64bit *features*) "-64bit"))
     2331    ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; fasl-f-v is redundant
     2332    #+(or armedbear cormanlisp mcl sbcl scl) s
     2333    #-(or allegro armedbear clisp clozure cmu cormanlisp digitool
     2334          ecl gcl lispworks mcl sbcl scl) s))
     2335
     2336(defun first-feature (features)
     2337  (labels
     2338      ((fp (thing)
     2339         (etypecase thing
     2340           (symbol
     2341            (let ((feature (find thing *features*)))
     2342              (when feature (return-from fp feature))))
     2343           ;; allows features to be lists of which the first
     2344           ;; member is the "main name", the rest being aliases
     2345           (cons
     2346            (dolist (subf thing)
     2347              (when (find subf *features*) (return-from fp (first thing))))))
     2348         nil))
     2349    (loop :for f :in features
     2350      :when (fp f) :return :it)))
     2351
     2352(defun implementation-type ()
     2353  (first-feature *implementation-features*))
     2354
     2355(defun implementation-identifier ()
     2356  (labels
     2357      ((maybe-warn (value fstring &rest args)
     2358         (cond (value)
     2359               (t (apply #'warn fstring args)
     2360                  "unknown"))))
     2361    (let ((lisp (maybe-warn (implementation-type)
     2362                            "No implementation feature found in ~a."
     2363                            *implementation-features*))
     2364          (os   (maybe-warn (first-feature *os-features*)
     2365                            "No os feature found in ~a." *os-features*))
     2366          (arch (maybe-warn (first-feature *architecture-features*)
     2367                            "No architecture feature found in ~a."
     2368                            *architecture-features*))
     2369          (version (maybe-warn (lisp-version-string)
     2370                               "Don't know how to get Lisp ~
    17622371                                          implementation version.")))
    1763                       (format nil "~(~@{~a~^-~}~)" lisp version os arch))))))))
    1764 
    1765 (defun pathname-prefix-p (prefix pathname)
    1766   (let ((prefix-ns (namestring prefix))
    1767         (pathname-ns (namestring pathname)))
    1768     (= (length prefix-ns)
    1769        (mismatch prefix-ns pathname-ns))))
    1770 
    1771 (defgeneric output-files-for-system-and-operation
    1772   (system operation component source possible-paths)
    1773   (:documentation "Returns the directory where the componets output files should be placed. This may depends on the system, the operation and the component. The ASDF default input and outputs are provided in the source and possible-paths parameters."))
    1774 
    1775 (defun source-to-target-resolved-mappings ()
    1776   "Answer `*source-to-target-mappings*` with additional entries made
    1777 by resolving sources that are symlinks.
    1778 
    1779 As ASDF sometimes resolves symlinks to compute source paths, we must
    1780 follow that.  For example, if SBCL is installed under a symlink, and
    1781 SBCL_HOME is set through that symlink, the default rule above
    1782 preventing SBCL contribs from being mapped elsewhere will not be
    1783 applied by the plain `*source-to-target-mappings*`."
    1784   (loop for mapping in asdf:*source-to-target-mappings*
    1785         for (source target) = mapping
    1786         for true-source = (and source (resolve-symlinks source))
    1787         if (equal source true-source)
    1788           collect mapping
    1789         else append (list mapping (list true-source target))))
    1790 
    1791 (defmethod output-files-for-system-and-operation
    1792            ((system system) operation component source possible-paths)
    1793   (declare (ignore operation component))
    1794   (output-files-using-mappings
    1795    source possible-paths (source-to-target-resolved-mappings)))
    1796 
    1797 (defmethod output-files-using-mappings (source possible-paths path-mappings)
    1798   (mapcar
    1799    (lambda (path)
    1800      (loop for (from to) in path-mappings
    1801         when (pathname-prefix-p from source)
    1802         do (return
    1803              (if to
    1804                  (merge-pathnames
    1805                   (make-pathname :type (pathname-type path))
    1806                   (merge-pathnames (enough-namestring source from)
    1807                                    to))
    1808                  path))
    1809                  
    1810         finally
    1811           (return
    1812             ;; Instead of just returning the path when we
    1813             ;; don't find a mapping, we stick stuff into
    1814             ;; the appropriate binary directory based on
    1815             ;; the implementation
    1816             (if *centralize-lisp-binaries*
    1817                 (merge-pathnames
    1818                  (make-pathname
    1819                   :type (pathname-type path)
    1820                   :directory `(:relative
    1821                                ,@(cond ((eq *include-per-user-information* t)
    1822                                         (cdr (pathname-directory
    1823                                               (user-homedir-pathname))))
    1824                                        ((not (null *include-per-user-information*))
    1825                                         (list *include-per-user-information*)))
    1826                                ,@(implementation-specific-directory-name)
    1827                                ,@(rest (pathname-directory path)))
    1828                   :defaults path)
    1829                  *default-toplevel-directory*)
    1830                 (make-pathname
    1831                  :type (pathname-type path)
    1832                  :directory (append
    1833                              (pathname-directory path)
    1834                              (implementation-specific-directory-name))
    1835                  :defaults path)))))
    1836           possible-paths))
    1837 
    1838 (defmethod output-files
    1839     :around ((operation compile-op) (component source-file))
    1840   (if (or *map-all-source-files*
    1841             (typecase component
    1842               (cl-source-file t)
    1843               (t nil)))
    1844     (let ((source (component-pathname component ))
    1845           (paths (call-next-method)))
    1846       (output-files-for-system-and-operation
    1847        (component-system component) operation component source paths))
    1848     (call-next-method)))
     2372      (substitute-if
     2373       #\_ (lambda (x) (find x " /:\\(){}[]$#`'\""))
     2374       (format nil "~(~@{~a~^-~}~)" lisp version os arch)))))
     2375
     2376
     2377
     2378;;; ---------------------------------------------------------------------------
     2379;;; Generic support for configuration files
     2380
     2381(defparameter *inter-directory-separator*
     2382  #+(or unix cygwin) #\:
     2383  #-(or unix cygwin) #\;)
     2384
     2385(defun user-homedir ()
     2386  (truename (user-homedir-pathname)))
     2387
     2388(defun try-directory-subpath (x sub &key type)
     2389  (let* ((p (and x (ensure-directory-pathname x)))
     2390         (tp (and p (ignore-errors (truename p))))
     2391         (sp (and tp (merge-pathnames* (merge-component-name-type sub :type type) p)))
     2392         (ts (and sp (ignore-errors (truename sp)))))
     2393    (and ts (values sp ts))))
     2394(defun user-configuration-directories ()
     2395  (remove-if
     2396   #'null
     2397   (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
     2398     `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/")
     2399       ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")
     2400           :for dir :in (split-string dirs :separator ":")
     2401           :collect (try dir "common-lisp/"))
     2402       #+(and (or win32 windows mswindows mingw32) (not cygwin))
     2403        ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/")
     2404            ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
     2405           #+(not cygwin)
     2406           ,(try (or (getenv "USERPROFILE") (user-homedir))
     2407                 "Application Data/common-lisp/config/"))
     2408       ,(try (user-homedir) ".config/common-lisp/")))))
     2409(defun system-configuration-directories ()
     2410  (remove-if
     2411   #'null
     2412   (append
     2413    #+(and (or win32 windows mswindows mingw32) (not cygwin))
     2414    (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
     2415      `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")
     2416           ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
     2417        ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
     2418    (list #p"/etc/"))))
     2419(defun in-first-directory (dirs x)
     2420  (loop :for dir :in dirs
     2421    :thereis (and dir (ignore-errors
     2422                        (truename (merge-pathnames* x (ensure-directory-pathname dir)))))))
     2423(defun in-user-configuration-directory (x)
     2424  (in-first-directory (user-configuration-directories) x))
     2425(defun in-system-configuration-directory (x)
     2426  (in-first-directory (system-configuration-directories) x))
     2427
     2428(defun configuration-inheritance-directive-p (x)
     2429  (let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
     2430    (or (member x kw)
     2431        (and (length=n-p x 1) (member (car x) kw)))))
     2432
     2433(defun validate-configuration-form (form tag directive-validator
     2434                                    &optional (description tag))
     2435  (unless (and (consp form) (eq (car form) tag))
     2436    (error "Error: Form doesn't specify ~A ~S~%" description form))
     2437  (loop :with inherit = 0
     2438    :for directive :in (cdr form) :do
     2439    (if (configuration-inheritance-directive-p directive)
     2440        (incf inherit)
     2441        (funcall directive-validator directive))
     2442    :finally
     2443    (unless (= inherit 1)
     2444      (error "One and only one of ~S or ~S is required"
     2445             :inherit-configuration :ignore-inherited-configuration)))
     2446  form)
     2447
     2448(defun validate-configuration-file (file validator description)
     2449  (let ((forms (read-file-forms file)))
     2450    (unless (length=n-p forms 1)
     2451      (error "One and only one form allowed for ~A. Got: ~S~%" description forms))
     2452    (funcall validator (car forms))))
     2453
     2454(defun validate-configuration-directory (directory tag validator)
     2455  (let ((files (sort (ignore-errors
     2456                       (directory (make-pathname :name :wild :type :wild :defaults directory)
     2457                                  #+sbcl :resolve-symlinks #+sbcl nil))
     2458                     #'string< :key #'namestring)))
     2459    `(,tag
     2460      ,@(loop :for file :in files :append
     2461          (mapcar validator (read-file-forms file)))
     2462      :inherit-configuration)))
     2463
     2464
     2465;;; ---------------------------------------------------------------------------
     2466;;; asdf-output-translations
     2467;;;
     2468;;; this code is heavily inspired from
     2469;;; asdf-binary-translations, common-lisp-controller and cl-launch.
     2470;;; ---------------------------------------------------------------------------
     2471
     2472(defvar *output-translations* ()
     2473  "Either NIL (for uninitialized), or a list of one element,
     2474said element itself being a sorted list of mappings.
     2475Each mapping is a pair of a source pathname and destination pathname,
     2476and the order is by decreasing length of namestring of the source pathname.")
     2477
     2478(defvar *user-cache*
     2479  (or
     2480   (let ((h (getenv "XDG_CACHE_HOME")))
     2481     (and h `(,h "common-lisp" :implementation)))
     2482   #+(and windows lispworks)
     2483   (let ((h (sys:get-folder-path :common-appdata))) ;; no :common-caches in Windows???
     2484     (and h `(,h "common-lisp" "cache")))
     2485   #+(and (or win32 windows mswindows mingw32) (not cygwin))
     2486   ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Cache
     2487   (let ((h (or (getenv "USERPROFILE") (user-homedir))))
     2488     (and h `(,h "Local Settings" "Temporary Internet Files" "common-lisp")))
     2489   '(:home ".cache" "common-lisp" :implementation)))
     2490(defvar *system-cache*
     2491  (or
     2492   #+(and windows lispworks)
     2493   (let ((h (sys:get-folder-path :common-appdata))) ;; no :common-caches in Windows???
     2494     (and h `(,h "common-lisp" "cache")))
     2495   #+(and (or win32 windows mswindows mingw32) (not cygwin))
     2496   (let ((h (or (getenv "USERPROFILE") (user-homedir))))
     2497     (and h `(,h "Local Settings" "Temporary Internet Files" "common-lisp")))
     2498   #+(or unix cygwin)
     2499   '("/var/cache/common-lisp" :uid :implementation)))
     2500
     2501(defun output-translations ()
     2502  (car *output-translations*))
     2503
     2504(defun (setf output-translations) (new-value)
     2505  (setf *output-translations*
     2506        (list
     2507         (stable-sort (copy-list new-value) #'>
     2508                      :key (lambda (x)
     2509                             (etypecase (car x)
     2510                               ((eql t) -1)
     2511                               (pathname
     2512                                (length (pathname-directory (car x)))))))))
     2513  new-value)
     2514
     2515(defun output-translations-initialized-p ()
     2516  (and *output-translations* t))
     2517
     2518(defun clear-output-translations ()
     2519  "Undoes any initialization of the output translations.
     2520You might want to call that before you dump an image that would be resumed
     2521with a different configuration, so the configuration would be re-read then."
     2522  (setf *output-translations* '())
     2523  (values))
     2524
     2525(defparameter *wild-path*
     2526  (make-pathname :directory '(:relative :wild-inferiors)
     2527                 :name :wild :type :wild :version :wild))
     2528
     2529(defparameter *wild-asd*
     2530  (make-pathname :directory '(:relative :wild-inferiors)
     2531                 :name :wild :type "asd" :version :newest))
     2532
     2533(defun wilden (path)
     2534  (merge-pathnames* *wild-path* path))
     2535
     2536(defun resolve-absolute-location-component (x wildenp)
     2537  (let* ((r
     2538          (etypecase x
     2539            (pathname x)
     2540            (string (ensure-directory-pathname x))
     2541            (cons
     2542             (let ((car (resolve-absolute-location-component (car x) nil)))
     2543               (if (null (cdr x))
     2544                   car
     2545                   (let ((cdr (resolve-relative-location-component
     2546                               car (cdr x) wildenp)))
     2547                     (merge-pathnames* cdr car)))))
     2548            ((eql :root)
     2549             ;; special magic! we encode such paths as relative pathnames,
     2550             ;; but it means "relative to the root of the source pathname's host and device".
     2551             (return-from resolve-absolute-location-component
     2552               (make-pathname :directory '(:relative))))
     2553            ((eql :home) (user-homedir))
     2554            ((eql :user-cache) (resolve-location *user-cache* nil))
     2555            ((eql :system-cache) (resolve-location *system-cache* nil))
     2556            ((eql :current-directory) (current-directory))))
     2557         (s (if (and wildenp (not (pathnamep x)))
     2558                (wilden r)
     2559                r)))
     2560    (unless (absolute-pathname-p s)
     2561      (error "Not an absolute pathname ~S" s))
     2562    s))
     2563
     2564(defun resolve-relative-location-component (super x &optional wildenp)
     2565  (let* ((r (etypecase x
     2566              (pathname x)
     2567              (string x)
     2568              (cons
     2569               (let ((car (resolve-relative-location-component super (car x) nil)))
     2570                 (if (null (cdr x))
     2571                     car
     2572                     (let ((cdr (resolve-relative-location-component
     2573                                 (merge-pathnames* car super) (cdr x) wildenp)))
     2574                       (merge-pathnames* cdr car)))))
     2575              ((eql :current-directory)
     2576               (relativize-pathname-directory (current-directory)))
     2577              ((eql :implementation) (implementation-identifier))
     2578              ((eql :implementation-type) (string-downcase (implementation-type)))
     2579              ((eql :uid) (princ-to-string (get-uid)))))
     2580         (d (if (pathnamep x) r (ensure-directory-pathname r)))
     2581         (s (if (and wildenp (not (pathnamep x)))
     2582                (wilden d)
     2583                d)))
     2584    (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
     2585      (error "pathname ~S is not relative to ~S" s super))
     2586    (merge-pathnames* s super)))
     2587
     2588(defun resolve-location (x &optional wildenp)
     2589  (if (atom x)
     2590      (resolve-absolute-location-component x wildenp)
     2591      (loop :with path = (resolve-absolute-location-component (car x) nil)
     2592        :for (component . morep) :on (cdr x)
     2593        :do (setf path (resolve-relative-location-component
     2594                        path component (and wildenp (not morep))))
     2595        :finally (return path))))
     2596
     2597(defun location-designator-p (x)
     2598  (flet ((componentp (c) (typep c '(or string pathname keyword))))
     2599    (or (typep x 'boolean) (componentp x) (and (consp x) (every #'componentp x)))))
     2600
     2601(defun location-function-p (x)
     2602  (and
     2603   (consp x)
     2604   (length=n-p x 2)
     2605   (or (and (equal (first x) :function)
     2606            (typep (second x) 'symbol))
     2607       (and (equal (first x) 'lambda)
     2608            (cddr x)
     2609            (length=n-p (second x) 2)))))
     2610
     2611(defun validate-output-translations-directive (directive)
     2612  (unless
     2613      (or (member directive '(:inherit-configuration
     2614                              :ignore-inherited-configuration
     2615                              :enable-user-cache :disable-cache))
     2616          (and (consp directive)
     2617               (or (and (length=n-p directive 2)
     2618                        (or (and (eq (first directive) :include)
     2619                                 (typep (second directive) '(or string pathname null)))
     2620                            (and (location-designator-p (first directive))
     2621                                 (or (location-designator-p (second directive))
     2622                                     (location-function-p (second directive))))))
     2623                   (and (length=n-p directive 1)
     2624                        (location-designator-p (first directive))))))
     2625    (error "Invalid directive ~S~%" directive))
     2626  directive)
     2627
     2628(defun validate-output-translations-form (form)
     2629  (validate-configuration-form
     2630   form
     2631   :output-translations
     2632   'validate-output-translations-directive
     2633   "output translations"))
     2634
     2635(defun validate-output-translations-file (file)
     2636  (validate-configuration-file
     2637   file 'validate-output-translations-form "output translations"))
     2638
     2639(defun validate-output-translations-directory (directory)
     2640  (validate-configuration-directory
     2641   directory :output-translations 'validate-output-translations-directive))
     2642
     2643(defun parse-output-translations-string (string)
     2644  (cond
     2645    ((or (null string) (equal string ""))
     2646     '(:output-translations :inherit-configuration))
     2647    ((not (stringp string))
     2648     (error "environment string isn't: ~S" string))
     2649    ((eql (char string 0) #\")
     2650     (parse-output-translations-string (read-from-string string)))
     2651    ((eql (char string 0) #\()
     2652     (validate-output-translations-form (read-from-string string)))
     2653    (t
     2654     (loop
     2655      :with inherit = nil
     2656      :with directives = ()
     2657      :with start = 0
     2658      :with end = (length string)
     2659      :with source = nil
     2660      :for i = (or (position *inter-directory-separator* string :start start) end) :do
     2661      (let ((s (subseq string start i)))
     2662        (cond
     2663          (source
     2664           (push (list source (if (equal "" s) nil s)) directives)
     2665           (setf source nil))
     2666          ((equal "" s)
     2667           (when inherit
     2668             (error "only one inherited configuration allowed: ~S" string))
     2669           (setf inherit t)
     2670           (push :inherit-configuration directives))
     2671          (t
     2672           (setf source s)))
     2673        (setf start (1+ i))
     2674        (when (> start end)
     2675          (when source
     2676            (error "Uneven number of components in source to destination mapping ~S" string))
     2677          (unless inherit
     2678            (push :ignore-inherited-configuration directives))
     2679          (return `(:output-translations ,@(nreverse directives)))))))))
     2680
     2681(defparameter *default-output-translations*
     2682  '(environment-output-translations
     2683    user-output-translations-pathname
     2684    user-output-translations-directory-pathname
     2685    system-output-translations-pathname
     2686    system-output-translations-directory-pathname))
     2687
     2688(defun wrapping-output-translations ()
     2689  `(:output-translations
     2690    ;; Some implementations have precompiled ASDF systems,
     2691    ;; so we must disable translations for implementation paths.
     2692    #+sbcl (,(getenv "SBCL_HOME") ())
     2693    #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; only needed if LPNs are resolved manually.
     2694    #+clozure (,(wilden (ccl::ccl-directory)) ()) ; not needed: no precompiled ASDF system
     2695    ;; All-import, here is where we want user stuff to be:
     2696    :inherit-configuration
     2697    ;; These are for convenience, and can be overridden by the user:
     2698    #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
     2699    #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
     2700    ;; If we want to enable the user cache by default, here would be the place:
     2701    :enable-user-cache))
     2702
     2703(defparameter *output-translations-file* #p"asdf-output-translations.conf")
     2704(defparameter *output-translations-directory* #p"asdf-output-translations.conf.d/")
     2705
     2706(defun user-output-translations-pathname ()
     2707  (in-user-configuration-directory *output-translations-file* ))
     2708(defun system-output-translations-pathname ()
     2709  (in-system-configuration-directory *output-translations-file*))
     2710(defun user-output-translations-directory-pathname ()
     2711  (in-user-configuration-directory *output-translations-directory*))
     2712(defun system-output-translations-directory-pathname ()
     2713  (in-system-configuration-directory *output-translations-directory*))
     2714(defun environment-output-translations ()
     2715  (getenv "ASDF_OUTPUT_TRANSLATIONS"))
     2716
     2717(defgeneric process-output-translations (spec &key inherit collect))
     2718(defmethod process-output-translations ((x symbol) &key
     2719                                        (inherit *default-output-translations*)
     2720                                        collect)
     2721  (process-output-translations (funcall x) :inherit inherit :collect collect))
     2722(defmethod process-output-translations ((pathname pathname) &key inherit collect)
     2723  (cond
     2724    ((directory-pathname-p pathname)
     2725     (process-output-translations (validate-output-translations-directory pathname)
     2726                                  :inherit inherit :collect collect))
     2727    ((probe-file pathname)
     2728     (process-output-translations (validate-output-translations-file pathname)
     2729                                  :inherit inherit :collect collect))
     2730    (t
     2731     (inherit-output-translations inherit :collect collect))))
     2732(defmethod process-output-translations ((string string) &key inherit collect)
     2733  (process-output-translations (parse-output-translations-string string)
     2734                               :inherit inherit :collect collect))
     2735(defmethod process-output-translations ((x null) &key inherit collect)
     2736  (declare (ignorable x))
     2737  (inherit-output-translations inherit :collect collect))
     2738(defmethod process-output-translations ((form cons) &key inherit collect)
     2739  (dolist (directive (cdr (validate-output-translations-form form)))
     2740    (process-output-translations-directive directive :inherit inherit :collect collect)))
     2741
     2742(defun inherit-output-translations (inherit &key collect)
     2743  (when inherit
     2744    (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
     2745
     2746(defun process-output-translations-directive (directive &key inherit collect)
     2747  (if (atom directive)
     2748      (ecase directive
     2749        ((:enable-user-cache)
     2750         (process-output-translations-directive '(t :user-cache) :collect collect))
     2751        ((:disable-cache)
     2752         (process-output-translations-directive '(t t) :collect collect))
     2753        ((:inherit-configuration)
     2754         (inherit-output-translations inherit :collect collect))
     2755        ((:ignore-inherited-configuration)
     2756         nil))
     2757      (let ((src (first directive))
     2758            (dst (second directive)))
     2759        (if (eq src :include)
     2760            (when dst
     2761              (process-output-translations (pathname dst) :inherit nil :collect collect))
     2762            (when src
     2763              (let ((trusrc (or (eql src t)
     2764                                (let ((loc (resolve-location src t)))
     2765                                  (if (absolute-pathname-p loc) (truenamize loc) loc)))))
     2766                (cond
     2767                  ((location-function-p dst)
     2768                   (funcall collect
     2769                            (list trusrc
     2770                                  (if (symbolp (second dst))
     2771                                      (fdefinition (second dst))
     2772                                      (eval (second dst))))))
     2773                  ((eq dst t)
     2774                   (funcall collect (list trusrc t)))
     2775                  (t
     2776                   (let* ((trudst (make-pathname
     2777                                   :defaults (if dst (resolve-location dst t) trusrc)))
     2778                          (wilddst (make-pathname
     2779                                    :name :wild :type :wild :version :wild
     2780                                    :defaults trudst)))
     2781                     (funcall collect (list wilddst t))
     2782                     (funcall collect (list trusrc trudst)))))))))))
     2783
     2784(defun compute-output-translations (&optional parameter)
     2785  "read the configuration, return it"
     2786  (remove-duplicates
     2787   (while-collecting (c)
     2788     (inherit-output-translations
     2789      `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
     2790   :test 'equal :from-end t))
     2791
     2792(defun initialize-output-translations (&optional parameter)
     2793  "read the configuration, initialize the internal configuration variable,
     2794return the configuration"
     2795  (setf (output-translations) (compute-output-translations parameter)))
     2796
     2797(defun disable-output-translations ()
     2798  "Initialize output translations in a way that maps every file to itself,
     2799effectively disabling the output translation facility."
     2800  (initialize-output-translations
     2801   '(:output-translations :disable-cache :ignore-inherited-configuration)))
     2802
     2803;; checks an initial variable to see whether the state is initialized
     2804;; or cleared. In the former case, return current configuration; in
     2805;; the latter, initialize.  ASDF will call this function at the start
     2806;; of (asdf:find-system).
     2807(defun ensure-output-translations ()
     2808  (if (output-translations-initialized-p)
     2809      (output-translations)
     2810      (initialize-output-translations)))
     2811
     2812(defun apply-output-translations (path)
     2813  (etypecase path
     2814    (logical-pathname
     2815     path)
     2816    ((or pathname string)
     2817     (ensure-output-translations)
     2818     (loop :with p = (truenamize path)
     2819       :for (source destination) :in (car *output-translations*)
     2820       :for root = (when (or (eq source t)
     2821                             (and (pathnamep source)
     2822                                  (not (absolute-pathname-p source))))
     2823                     (pathname-root p))
     2824       :for absolute-source = (cond
     2825                                ((eq source t) (wilden root))
     2826                                (root (merge-pathnames* source root))
     2827                                (t source))
     2828       :when (or (eq source t) (pathname-match-p p absolute-source))
     2829       :return
     2830       (cond
     2831         ((functionp destination)
     2832          (funcall destination p absolute-source))
     2833         ((eq destination t)
     2834          p)
     2835         ((not (pathnamep destination))
     2836          (error "invalid destination"))
     2837         ((not (absolute-pathname-p destination))
     2838          (translate-pathname p absolute-source (merge-pathnames* destination root)))
     2839         (root
     2840          (translate-pathname (directorize-pathname-host-device p) absolute-source destination))
     2841         (t
     2842          (translate-pathname p absolute-source destination)))
     2843       :finally (return p)))))
     2844
     2845(defun last-char (s)
     2846  (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
     2847
     2848(defun directorize-pathname-host-device (pathname)
     2849  (let* ((root (pathname-root pathname))
     2850         (wild-root (wilden root))
     2851         (absolute-pathname (merge-pathnames* pathname root))
     2852         (foo (make-pathname :directory '(:absolute "FOO") :defaults root))
     2853         (separator (last-char (namestring foo)))
     2854         (root-namestring (namestring root))
     2855         (root-string
     2856          (substitute-if #\/
     2857                         (lambda (x) (or (eql x #\:)
     2858                                         (eql x separator)))
     2859                         root-namestring)))
     2860    (multiple-value-bind (relative path filename)
     2861        (component-name-to-pathname-components root-string t)
     2862      (declare (ignore relative filename))
     2863      (let ((new-base
     2864             (make-pathname :defaults root
     2865                            :directory `(:absolute ,@path))))
     2866        (translate-pathname absolute-pathname wild-root (wilden new-base))))))
     2867
     2868(defmethod output-files :around (operation component)
     2869  "Translate output files, unless asked not to"
     2870  (declare (ignorable operation component))
     2871  (values
     2872   (multiple-value-bind (files fixedp) (call-next-method)
     2873     (if fixedp
     2874         files
     2875         (mapcar #'apply-output-translations files)))
     2876   t))
     2877
     2878(defun compile-file-pathname* (input-file &rest keys)
     2879  (apply-output-translations
     2880   (apply #'compile-file-pathname
     2881          (truenamize (lispize-pathname input-file))
     2882          keys)))
     2883
     2884#+abcl
     2885(defun translate-jar-pathname (source wildcard)
     2886  (declare (ignore wildcard))
     2887  (let* ((p (pathname (first (pathname-device source))))
     2888         (root (format nil "/___jar___file___root___/~@[~A/~]"
     2889                       (and (find :windows *features*)
     2890                            (pathname-device p)))))
     2891    (apply-output-translations
     2892     (merge-pathnames*
     2893      (relativize-pathname-directory source)
     2894      (merge-pathnames*
     2895       (relativize-pathname-directory (ensure-directory-pathname p))
     2896       root)))))
     2897
     2898;;;; -----------------------------------------------------------------
     2899;;;; Compatibility mode for ASDF-Binary-Locations
     2900
     2901(defun enable-asdf-binary-locations-compatibility
     2902    (&key
     2903     (centralize-lisp-binaries nil)
     2904     (default-toplevel-directory
     2905         ;; Use ".cache/common-lisp" instead ???
     2906         (merge-pathnames* (make-pathname :directory '(:relative ".fasls"))
     2907                           (user-homedir)))
     2908     (include-per-user-information nil)
     2909     (map-all-source-files nil)
     2910     (source-to-target-mappings nil))
     2911  (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
     2912         (wild-inferiors (make-pathname :directory '(:relative :wild-inferiors)))
     2913         (mapped-files (make-pathname
     2914                        :name :wild :version :wild
     2915                        :type (if map-all-source-files :wild fasl-type)))
     2916         (destination-directory
     2917          (if centralize-lisp-binaries
     2918              `(,default-toplevel-directory
     2919                ,@(when include-per-user-information
     2920                        (cdr (pathname-directory (user-homedir))))
     2921                :implementation ,wild-inferiors)
     2922              `(:root ,wild-inferiors :implementation))))
     2923    (initialize-output-translations
     2924     `(:output-translations
     2925       ,@source-to-target-mappings
     2926       ((:root ,wild-inferiors ,mapped-files)
     2927        (,@destination-directory ,mapped-files))
     2928       (t t)
     2929       :ignore-inherited-configuration))))
    18492930
    18502931;;;; -----------------------------------------------------------------
     
    18532934;;;; Jesse Hager: The Windows Shortcut File Format.
    18542935;;;; http://www.wotsit.org/list.asp?fc=13
    1855 ;;;; -----------------------------------------------------------------
    18562936
    18572937(defparameter *link-initial-dword* 76)
     
    18602940(defun read-null-terminated-string (s)
    18612941  (with-output-to-string (out)
    1862     (loop
    1863         for code = (read-byte s)
    1864         until (zerop code)
    1865         do (write-char (code-char code) out))))
     2942    (loop :for code = (read-byte s)
     2943      :until (zerop code)
     2944      :do (write-char (code-char code) out))))
    18662945
    18672946(defun read-little-endian (s &optional (bytes 4))
    1868   (let ((result 0))
    1869     (loop
    1870         for i from 0 below bytes
    1871         do
    1872           (setf result (logior result (ash (read-byte s) (* 8 i)))))
    1873     result))
     2947  (loop
     2948    :for i :from 0 :below bytes
     2949    :sum (ash (read-byte s) (* 8 i))))
     2950
     2951(defun parse-file-location-info (s)
     2952  (let ((start (file-position s))
     2953        (total-length (read-little-endian s))
     2954        (end-of-header (read-little-endian s))
     2955        (fli-flags (read-little-endian s))
     2956        (local-volume-offset (read-little-endian s))
     2957        (local-offset (read-little-endian s))
     2958        (network-volume-offset (read-little-endian s))
     2959        (remaining-offset (read-little-endian s)))
     2960    (declare (ignore total-length end-of-header local-volume-offset))
     2961    (unless (zerop fli-flags)
     2962      (cond
     2963        ((logbitp 0 fli-flags)
     2964          (file-position s (+ start local-offset)))
     2965        ((logbitp 1 fli-flags)
     2966          (file-position s (+ start
     2967                              network-volume-offset
     2968                              #x14))))
     2969      (concatenate 'string
     2970        (read-null-terminated-string s)
     2971        (progn
     2972          (file-position s (+ start remaining-offset))
     2973          (read-null-terminated-string s))))))
    18742974
    18752975(defun parse-windows-shortcut (pathname)
    18762976  (with-open-file (s pathname :element-type '(unsigned-byte 8))
    18772977    (handler-case
    1878         (when (and (= (read-little-endian s) *link-initial-dword*)
    1879                    (let ((header (make-array (length *link-guid*))))
    1880                      (read-sequence header s)
    1881                      (equalp header *link-guid*)))
    1882           (let ((flags (read-little-endian s)))
    1883             (file-position s 76)        ;skip rest of header
    1884             (when (logbitp 0 flags)
    1885               ;; skip shell item id list
    1886               (let ((length (read-little-endian s 2)))
    1887                 (file-position s (+ length (file-position s)))))
    1888             (cond
    1889               ((logbitp 1 flags)
    1890                 (parse-file-location-info s))
    1891               (t
    1892                 (when (logbitp 2 flags)
    1893                   ;; skip description string
    1894                   (let ((length (read-little-endian s 2)))
    1895                     (file-position s (+ length (file-position s)))))
    1896                 (when (logbitp 3 flags)
    1897                   ;; finally, our pathname
    1898                   (let* ((length (read-little-endian s 2))
    1899                         (buffer (make-array length)))
    1900                     (read-sequence buffer s)
    1901                     (map 'string #'code-char buffer)))))))
     2978        (when (and (= (read-little-endian s) *link-initial-dword*)
     2979                   (let ((header (make-array (length *link-guid*))))
     2980                     (read-sequence header s)
     2981                     (equalp header *link-guid*)))
     2982          (let ((flags (read-little-endian s)))
     2983            (file-position s 76)        ;skip rest of header
     2984            (when (logbitp 0 flags)
     2985              ;; skip shell item id list
     2986              (let ((length (read-little-endian s 2)))
     2987                (file-position s (+ length (file-position s)))))
     2988            (cond
     2989              ((logbitp 1 flags)
     2990                (parse-file-location-info s))
     2991              (t
     2992                (when (logbitp 2 flags)
     2993                  ;; skip description string
     2994                  (let ((length (read-little-endian s 2)))
     2995                    (file-position s (+ length (file-position s)))))
     2996                (when (logbitp 3 flags)
     2997                  ;; finally, our pathname
     2998                  (let* ((length (read-little-endian s 2))
     2999                        (buffer (make-array length)))
     3000                    (read-sequence buffer s)
     3001                    (map 'string #'code-char buffer)))))))
    19023002      (end-of-file ()
    1903         nil))))
    1904 
    1905 (defun parse-file-location-info (s)
    1906   (let ((start (file-position s))
    1907         (total-length (read-little-endian s))
    1908         (end-of-header (read-little-endian s))
    1909         (fli-flags (read-little-endian s))
    1910         (local-volume-offset (read-little-endian s))
    1911         (local-offset (read-little-endian s))
    1912         (network-volume-offset (read-little-endian s))
    1913         (remaining-offset (read-little-endian s)))
    1914     (declare (ignore total-length end-of-header local-volume-offset))
    1915     (unless (zerop fli-flags)
    1916       (cond
    1917         ((logbitp 0 fli-flags)
    1918           (file-position s (+ start local-offset)))
    1919         ((logbitp 1 fli-flags)
    1920           (file-position s (+ start
    1921                               network-volume-offset
    1922                               #x14))))
    1923       (concatenate 'string
    1924         (read-null-terminated-string s)
    1925         (progn
    1926           (file-position s (+ start remaining-offset))
    1927           (read-null-terminated-string s))))))
    1928 
    1929 
    1930 (pushnew :asdf *features*)
    1931 
    1932 #+sbcl
    1933 (eval-when (:compile-toplevel :load-toplevel :execute)
    1934   (when (sb-ext:posix-getenv "SBCL_BUILDING_CONTRIB")
    1935     (pushnew :sbcl-hooks-require *features*)))
    1936 
    1937 #+(and sbcl sbcl-hooks-require)
     3003        nil))))
     3004
     3005;;;; -----------------------------------------------------------------
     3006;;;; Source Registry Configuration, by Francois-Rene Rideau
     3007;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
     3008
     3009;; Using ack 1.2 exclusions
     3010(defvar *default-exclusions*
     3011  '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst"
     3012    ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
     3013    "_sgbak" "autom4te.cache" "cover_db" "_build"))
     3014
     3015(defvar *source-registry* ()
     3016  "Either NIL (for uninitialized), or a list of one element,
     3017said element itself being a list of directory pathnames where to look for .asd files")
     3018
     3019(defun source-registry ()
     3020  (car *source-registry*))
     3021
     3022(defun (setf source-registry) (new-value)
     3023  (setf *source-registry* (list new-value))
     3024  new-value)
     3025
     3026(defun source-registry-initialized-p ()
     3027  (and *source-registry* t))
     3028
     3029(defun clear-source-registry ()
     3030  "Undoes any initialization of the source registry.
     3031You might want to call that before you dump an image that would be resumed
     3032with a different configuration, so the configuration would be re-read then."
     3033  (setf *source-registry* '())
     3034  (values))
     3035
     3036(defun probe-asd (name defaults)
     3037  (block nil
     3038    (when (directory-pathname-p defaults)
     3039      (let ((file
     3040             (make-pathname
     3041              :defaults defaults :version :newest :case :local
     3042              :name name
     3043              :type "asd")))
     3044        (when (probe-file file)
     3045          (return file)))
     3046      #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
     3047      (let ((shortcut
     3048             (make-pathname
     3049              :defaults defaults :version :newest :case :local
     3050              :name (concatenate 'string name ".asd")
     3051              :type "lnk")))
     3052        (when (probe-file shortcut)
     3053          (let ((target (parse-windows-shortcut shortcut)))
     3054            (when target
     3055              (return (pathname target)))))))))
     3056
     3057(defun sysdef-source-registry-search (system)
     3058  (ensure-source-registry)
     3059  (loop :with name = (coerce-name system)
     3060    :for defaults :in (source-registry)
     3061    :for file = (probe-asd name defaults)
     3062    :when file :return file))
     3063
     3064(defun validate-source-registry-directive (directive)
     3065  (unless
     3066      (or (member directive '(:default-registry (:default-registry)) :test 'equal)
     3067          (destructuring-bind (kw &rest rest) directive
     3068            (case kw
     3069              ((:include :directory :tree)
     3070               (and (length=n-p rest 1)
     3071                    (typep (car rest) '(or pathname string null))))
     3072              ((:exclude)
     3073               (every #'stringp rest))
     3074              (null rest))))
     3075    (error "Invalid directive ~S~%" directive))
     3076  directive)
     3077
     3078(defun validate-source-registry-form (form)
     3079  (validate-configuration-form
     3080   form :source-registry 'validate-source-registry-directive "a source registry"))
     3081
     3082(defun validate-source-registry-file (file)
     3083  (validate-configuration-file
     3084   file 'validate-source-registry-form "a source registry"))
     3085
     3086(defun validate-source-registry-directory (directory)
     3087  (validate-configuration-directory
     3088   directory :source-registry 'validate-source-registry-directive))
     3089
     3090(defun parse-source-registry-string (string)
     3091  (cond
     3092    ((or (null string) (equal string ""))
     3093     '(:source-registry :inherit-configuration))
     3094    ((not (stringp string))
     3095     (error "environment string isn't: ~S" string))
     3096    ((find (char string 0) "\"(")
     3097     (validate-source-registry-form (read-from-string string)))
     3098    (t
     3099     (loop
     3100      :with inherit = nil
     3101      :with directives = ()
     3102      :with start = 0
     3103      :with end = (length string)
     3104      :for pos = (position *inter-directory-separator* string :start start) :do
     3105      (let ((s (subseq string start (or pos end))))
     3106        (cond
     3107         ((equal "" s) ; empty element: inherit
     3108          (when inherit
     3109            (error "only one inherited configuration allowed: ~S" string))
     3110          (setf inherit t)
     3111          (push ':inherit-configuration directives))
     3112         ((ends-with s "//")
     3113          (push `(:tree ,(subseq s 0 (1- (length s)))) directives))
     3114         (t
     3115          (push `(:directory ,s) directives)))
     3116        (cond
     3117          (pos
     3118           (setf start (1+ pos)))
     3119          (t
     3120           (unless inherit
     3121             (push '(:ignore-inherited-configuration) directives))
     3122           (return `(:source-registry ,@(nreverse directives))))))))))
     3123
     3124(defun register-asd-directory (directory &key recurse exclude collect)
     3125  (if (not recurse)
     3126      (funcall collect directory)
     3127      (let* ((files
     3128              (handler-case
     3129                  (directory (merge-pathnames* *wild-asd* directory)
     3130                             #+sbcl #+sbcl :resolve-symlinks nil
     3131                             #+clisp #+clisp :circle t)
     3132                (error (c)
     3133                  (warn "Error while scanning system definitions under directory ~S:~%~A"
     3134                        directory c)
     3135                  nil)))
     3136             (dirs (remove-duplicates (mapcar #'pathname-directory-pathname files)
     3137                                      :test #'equal :from-end t)))
     3138        (loop
     3139          :for dir :in dirs
     3140          :unless (loop :for x :in exclude
     3141                    :thereis (find x (pathname-directory dir) :test #'equal))
     3142          :do (funcall collect dir)))))
     3143
     3144(defparameter *default-source-registries*
     3145  '(environment-source-registry
     3146    user-source-registry
     3147    user-source-registry-directory
     3148    system-source-registry
     3149    system-source-registry-directory
     3150    default-source-registry))
     3151
     3152(defparameter *source-registry-file* #p"source-registry.conf")
     3153(defparameter *source-registry-directory* #p"source-registry.conf.d/")
     3154
     3155(defun wrapping-source-registry ()
     3156  `(:source-registry
     3157    #+sbcl (:tree ,(getenv "SBCL_HOME"))
     3158   :inherit-configuration))
     3159(defun default-source-registry ()
     3160  (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
     3161    `(:source-registry
     3162      #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir)))
     3163      (:directory ,(truenamize (directory-namestring *default-pathname-defaults*)))
     3164      ,@(let*
     3165         #+(or unix cygwin)
     3166         ((datahome
     3167           (or (getenv "XDG_DATA_HOME")
     3168               (try (user-homedir) ".local/share/")))
     3169          (datadirs
     3170           (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share"))
     3171          (dirs (cons datahome (split-string datadirs :separator ":"))))
     3172         #+(and (or win32 windows mswindows mingw32) (not cygwin))
     3173         ((datahome
     3174           #+lispworks (sys:get-folder-path :common-appdata)
     3175           #-lispworks (try (or (getenv "USERPROFILE") (user-homedir))
     3176                            "Application Data"))
     3177          (datadir
     3178           #+lispworks (sys:get-folder-path :local-appdata)
     3179           #-lispworks (try (getenv "ALLUSERSPROFILE")
     3180                            "Application Data"))
     3181          (dirs (list datahome datadir)))
     3182         #-(or unix win32 windows mswindows mingw32 cygwin)
     3183         ((dirs ()))
     3184         (loop :for dir :in dirs
     3185           :collect `(:directory ,(try dir "common-lisp/systems/"))
     3186           :collect `(:tree ,(try dir "common-lisp/source/"))))
     3187      :inherit-configuration)))
     3188(defun user-source-registry ()
     3189  (in-user-configuration-directory *source-registry-file*))
     3190(defun system-source-registry ()
     3191  (in-system-configuration-directory *source-registry-file*))
     3192(defun user-source-registry-directory ()
     3193  (in-user-configuration-directory *source-registry-directory*))
     3194(defun system-source-registry-directory ()
     3195  (in-system-configuration-directory *source-registry-directory*))
     3196(defun environment-source-registry ()
     3197  (getenv "CL_SOURCE_REGISTRY"))
     3198
     3199(defgeneric process-source-registry (spec &key inherit register))
     3200(defmethod process-source-registry ((x symbol) &key inherit register)
     3201  (process-source-registry (funcall x) :inherit inherit :register register))
     3202(defmethod process-source-registry ((pathname pathname) &key inherit register)
     3203  (cond
     3204    ((directory-pathname-p pathname)
     3205     (process-source-registry (validate-source-registry-directory pathname)
     3206                              :inherit inherit :register register))
     3207    ((probe-file pathname)
     3208     (process-source-registry (validate-source-registry-file pathname)
     3209                              :inherit inherit :register register))
     3210    (t
     3211     (inherit-source-registry inherit :register register))))
     3212(defmethod process-source-registry ((string string) &key inherit register)
     3213  (process-source-registry (parse-source-registry-string string)
     3214                           :inherit inherit :register register))
     3215(defmethod process-source-registry ((x null) &key inherit register)
     3216  (declare (ignorable x))
     3217  (inherit-source-registry inherit :register register))
     3218(defmethod process-source-registry ((form cons) &key inherit register)
     3219  (let ((*default-exclusions* *default-exclusions*))
     3220    (dolist (directive (cdr (validate-source-registry-form form)))
     3221      (process-source-registry-directive directive :inherit inherit :register register))))
     3222
     3223(defun inherit-source-registry (inherit &key register)
     3224  (when inherit
     3225    (process-source-registry (first inherit) :register register :inherit (rest inherit))))
     3226
     3227(defun process-source-registry-directive (directive &key inherit register)
     3228  (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
     3229    (ecase kw
     3230      ((:include)
     3231       (destructuring-bind (pathname) rest
     3232         (process-source-registry (pathname pathname) :inherit nil :register register)))
     3233      ((:directory)
     3234       (destructuring-bind (pathname) rest
     3235         (when pathname
     3236           (funcall register (ensure-directory-pathname pathname)))))
     3237      ((:tree)
     3238       (destructuring-bind (pathname) rest
     3239         (when pathname
     3240           (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *default-exclusions*))))
     3241      ((:exclude)
     3242       (setf *default-exclusions* rest))
     3243      ((:default-registry)
     3244       (inherit-source-registry '(default-source-registry) :register register))
     3245      ((:inherit-configuration)
     3246       (inherit-source-registry inherit :register register))
     3247      ((:ignore-inherited-configuration)
     3248       nil))))
     3249
     3250(defun flatten-source-registry (&optional parameter)
     3251  (remove-duplicates
     3252   (while-collecting (collect)
     3253     (inherit-source-registry
     3254      `(wrapping-source-registry
     3255        ,parameter
     3256        ,@*default-source-registries*)
     3257      :register (lambda (directory &key recurse exclude)
     3258                  (collect (list directory :recurse recurse :exclude exclude)))))
     3259   :test 'equal :from-end t))
     3260
     3261;; Will read the configuration and initialize all internal variables,
     3262;; and return the new configuration.
     3263(defun compute-source-registry (&optional parameter)
     3264  (while-collecting (collect)
     3265    (dolist (entry (flatten-source-registry parameter))
     3266      (destructuring-bind (directory &key recurse exclude) entry
     3267        (register-asd-directory
     3268         directory
     3269         :recurse recurse :exclude exclude :collect #'collect)))))
     3270
     3271(defun initialize-source-registry (&optional parameter)
     3272  (setf (source-registry) (compute-source-registry parameter)))
     3273
     3274;; checks an initial variable to see whether the state is initialized
     3275;; or cleared. In the former case, return current configuration; in
     3276;; the latter, initialize.  ASDF will call this function at the start
     3277;; of (asdf:find-system).
     3278(defun ensure-source-registry ()
     3279  (if (source-registry-initialized-p)
     3280      (source-registry)
     3281      (initialize-source-registry)))
     3282
     3283;;;; -----------------------------------------------------------------
     3284;;;; Hook into REQUIRE for SBCL, ClozureCL and ABCL
     3285;;;;
     3286#+(or sbcl clozure abcl)
    19383287(progn
    19393288  (defun module-provide-asdf (name)
    1940     (handler-bind ((style-warning #'muffle-warning))
     3289    (handler-bind
     3290        ((style-warning #'muffle-warning)
     3291         (missing-component (constantly nil))
     3292         (error (lambda (e)
     3293                  (format *error-output* "ASDF could not load ~A because ~A.~%"
     3294                          name e))))
    19413295      (let* ((*verbose-out* (make-broadcast-stream))
    1942              (system (asdf:find-system name nil)))
     3296             (system (find-system name nil)))
    19433297        (when system
    1944           (asdf:operate 'asdf:load-op name)
     3298          (load-system name)
    19453299          t))))
    1946 
    1947   (defun contrib-sysdef-search (system)
    1948     (let ((home (sb-ext:posix-getenv "SBCL_HOME")))
    1949       (when (and home (not (string= home "")))
    1950         (let* ((name (coerce-name system))
    1951                (home (truename home))
    1952                (contrib (merge-pathnames
    1953                          (make-pathname :directory `(:relative ,name)
    1954                                         :name name
    1955                                         :type "asd"
    1956                                         :case :local
    1957                                         :version :newest)
    1958                          home)))
    1959           (probe-file contrib)))))
    1960 
    1961   (pushnew
    1962    '(let ((home (sb-ext:posix-getenv "SBCL_HOME")))
    1963       (when (and home (not (string= home "")))
    1964         (merge-pathnames "site-systems/" (truename home))))
    1965    *central-registry*)
    1966 
    1967   (pushnew
    1968    '(merge-pathnames ".sbcl/systems/"
    1969      (user-homedir-pathname))
    1970    *central-registry*)
    1971 
    1972   (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)
    1973   (pushnew 'contrib-sysdef-search *system-definition-search-functions*))
    1974 
    1975 (if *asdf-revision*
    1976     (asdf-message ";; ASDF, revision ~a" *asdf-revision*)
    1977     (asdf-message ";; ASDF, revision unknown; possibly a development version"))
    1978 
    1979 (provide 'asdf)
    1980 
    1981 
    1982 #+(or)
    1983 ;;?? ignore -- so how will ABL get "installed"
    1984 ;; should be unnecessary with newer versions of ASDF
    1985 ;; load customizations
    1986 (eval-when (:load-toplevel :execute)
    1987   (let* ((*package* (find-package :common-lisp)))
    1988     (load
    1989      (merge-pathnames
    1990       (make-pathname :name "asdf-binary-locations"
    1991                      :type "lisp"
    1992                      :directory '(:relative ".asdf"))
    1993       (truename (user-homedir-pathname)))
    1994      :if-does-not-exist nil)))
     3300  (pushnew 'module-provide-asdf
     3301           #+sbcl sb-ext:*module-provider-functions*
     3302           #+clozure ccl::*module-provider-functions*
     3303           #+abcl sys::*module-provider-functions*))
     3304
     3305;;;; -------------------------------------------------------------------------
     3306;;;; Cleanups after hot-upgrade.
     3307;;;; Things to do in case we're upgrading from a previous version of ASDF.
     3308;;;; See https://bugs.launchpad.net/asdf/+bug/485687
     3309;;;;
     3310;;;; TODO: debug why it's not enough to upgrade from ECL <= 9.11.1
     3311(eval-when (:compile-toplevel :load-toplevel :execute)
     3312  #+ecl ;; Support upgrade from before ECL went to 1.369
     3313  (when (fboundp 'compile-op-system-p)
     3314    (defmethod compile-op-system-p ((op compile-op))
     3315      (getf :system-p (compile-op-flags op)))
     3316    (defmethod initialize-instance :after ((op compile-op)
     3317                                           &rest initargs
     3318                                           &key system-p &allow-other-keys)
     3319      (declare (ignorable initargs))
     3320      (when system-p (appendf (compile-op-flags op) (list :system-p system-p))))))
     3321
     3322;;;; -----------------------------------------------------------------
     3323;;;; Done!
     3324(when *load-verbose*
     3325  (asdf-message ";; ASDF, version ~a" (asdf-version)))
     3326
     3327#+allegro
     3328(eval-when (:compile-toplevel :execute)
     3329  (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
     3330    (setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*)))
     3331
     3332(pushnew :asdf *features*)
     3333;; this is a release candidate for ASDF 2.0
     3334(pushnew :asdf2 *features*)
     3335
     3336(provide :asdf)
     3337
     3338;;; Local Variables:
     3339;;; mode: lisp
     3340;;; End:
Note: See TracChangeset for help on using the changeset viewer.