Changeset 12618


Ignore:
Timestamp:
04/15/10 20:23:44 (5 years ago)
Author:
mevenson
Message:

Incorporate an ASDF2 snapshot as the base ASDF.

Location:
trunk/abcl
Files:
2 added
1 deleted
7 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/asdf.lisp

    r12422 r12618  
    1 ;;; This is asdf: Another System Definition Facility.  $Revision: 1.3 $
     1;;; -*- mode: common-lisp; package: asdf; -*-
     2;;; This is ASDF: Another System Definition Facility.
    23;;;
    3 ;;; Feedback, bug reports, and patches are all welcome: please mail to
    4 ;;; <cclan-list@lists.sf.net>.  But note first that the canonical
    5 ;;; source for asdf is presently the cCLan CVS repository at
    6 ;;; <URL:http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/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/>.
    78;;;
    89;;; If you obtained this copy from anywhere else, and you experience
     
    1011;;; location above for a more recent version (and for documentation
    1112;;; and test files, if your copy came without them) before reporting
    12 ;;; bugs.  There are usually two "supported" revisions - the CVS HEAD
     13;;; bugs.  There are usually two "supported" revisions - the git HEAD
    1314;;; is the latest development version, whereas the revision tagged
    1415;;; RELEASE may be slightly older but is considered `stable'
    1516
    16 ;;; Copyright (c) 2001-2003 Daniel Barlow and contributors
     17;;; -- LICENSE START
     18;;; (This is the MIT / X Consortium license as taken from
     19;;;  http://www.opensource.org/licenses/mit-license.html on or about
     20;;;  Monday; July 13, 2009)
     21;;;
     22;;; Copyright (c) 2001-2010 Daniel Barlow and contributors
    1723;;;
    1824;;; Permission is hereby granted, free of charge, to any person obtaining
     
    3440;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
    3541;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
    36 
    37 ;;; the problem with writing a defsystem replacement is bootstrapping:
    38 ;;; we can't use defsystem to compile it.  Hence, all in one file
    39 
    40 (defpackage #:asdf
    41   (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command
    42      #:system-definition-pathname #:find-component ; miscellaneous
    43      #:hyperdocumentation #:hyperdoc
    44      
    45      #:compile-op #:load-op #:load-source-op #:test-system-version
    46      #:test-op
    47      #:operation      ; operations
    48      #:feature      ; sort-of operation
    49      #:version      ; metaphorically sort-of an operation
    50      
    51      #:input-files #:output-files #:perform ; operation methods
    52      #:operation-done-p #:explain
    53      
    54      #:component #:source-file
    55      #:c-source-file #:cl-source-file #:java-source-file
    56      #:static-file
    57      #:doc-file
    58      #:html-file
    59      #:text-file
    60      #:source-file-type
    61      #:module     ; components
    62      #:system
    63      #:unix-dso
    64      
    65      #:module-components    ; component accessors
    66      #:component-pathname
    67      #:component-relative-pathname
    68      #:component-name
    69      #:component-version
    70      #:component-parent
    71      #:component-property
    72      #:component-system
    73      
    74      #:component-depends-on
    75 
    76      #:system-description
    77      #:system-long-description
    78      #:system-author
    79      #:system-maintainer
    80      #:system-license
    81      
    82      #:operation-on-warnings
    83      #:operation-on-failure
    84      
    85      ;#:*component-parent-pathname*
    86      #:*system-definition-search-functions*
    87      #:*central-registry*   ; variables
    88      #:*compile-file-warnings-behaviour*
    89      #:*compile-file-failure-behaviour*
    90      #:*asdf-revision*
    91      
    92      #:operation-error #:compile-failed #:compile-warned #:compile-error
    93      #:error-component #:error-operation
    94      #:system-definition-error
    95      #:missing-component
    96      #:missing-dependency
    97      #:circular-dependency  ; errors
    98      #:duplicate-names
    99      
    100      #:retry
    101      #:accept                     ; restarts
    102      
    103      )
    104   (:use :cl))
    105 
    106 #+nil
    107 (error "The author of this file habitually uses #+nil to comment out forms.  But don't worry, it was unlikely to work in the New Implementation of Lisp anyway")
    108 
     42;;;
     43;;; -- LICENSE END
     44
     45;;; The problem with writing a defsystem replacement is bootstrapping:
     46;;; we can't use defsystem to compile it.  Hence, all in one file.
     47
     48#+xcvb (module ())
     49
     50(cl:in-package :cl-user)
     51
     52(declaim (optimize (speed 2) (debug 2) (safety 3)))
     53
     54#+ecl (require 'cmp)
     55
     56;;;; Create packages in a way that is compatible with hot-upgrade.
     57;;;; See https://bugs.launchpad.net/asdf/+bug/485687
     58;;;; See more at the end of the file.
     59
     60(eval-when (:load-toplevel :compile-toplevel :execute)
     61  (let* ((asdf-version
     62          ;; the 1+ hair is to ensure that we don't do an inadvertent find and replace
     63          (subseq "VERSION:1.679" (1+ (length "VERSION"))))
     64         #+allegro (excl::*autoload-package-name-alist* nil)
     65         (existing-asdf (find-package :asdf))
     66         (versym '#:*asdf-version*)
     67         (existing-version (and existing-asdf (find-symbol (string versym) existing-asdf)))
     68         (redefined-functions
     69          '(#:perform #:explain #:output-files #:operation-done-p
     70            #:perform-with-restarts #:component-relative-pathname
     71            #:system-source-file)))
     72    (unless (equal asdf-version existing-version)
     73      (labels ((rename-away (package)
     74                 (loop :with name = (package-name package)
     75                   :for i :from 1 :for new = (format nil "~A.~D" name i)
     76                   :unless (find-package new) :do
     77                   (rename-package-name package name new)))
     78               (rename-package-name (package old new)
     79                 (let* ((old-names (cons (package-name package) (package-nicknames package)))
     80                        (new-names (subst new old old-names :test 'equal))
     81                        (new-name (car new-names))
     82                        (new-nicknames (cdr new-names)))
     83                   (rename-package package new-name new-nicknames)))
     84               (ensure-exists (name nicknames use)
     85                 (let* ((previous
     86                         (remove-duplicates
     87                          (remove-if
     88                           #'null
     89                           (mapcar #'find-package (cons name nicknames)))
     90                          :from-end t)))
     91                   (cond
     92                     (previous
     93                      (map () #'rename-away (cdr previous)) ;; packages with conflicting (nick)names
     94                      (let ((p (car previous))) ;; previous package with same name
     95                        (rename-package p name nicknames)
     96                        (ensure-use p use)
     97                        p))
     98                     (t
     99                      (make-package name :nicknames nicknames :use use)))))
     100               (find-sym (symbol package)
     101                 (find-symbol (string symbol) package))
     102               (remove-symbol (symbol package)
     103                 (let ((sym (find-sym symbol package)))
     104                   (when sym
     105                     (unexport sym package)
     106                     (unintern sym package))))
     107               (ensure-unintern (package symbols)
     108                 (dolist (sym symbols) (remove-symbol sym package)))
     109               (ensure-shadow (package symbols)
     110                 (shadow symbols package))
     111               (ensure-use (package use)
     112                 (dolist (used (reverse use))
     113                   (do-external-symbols (sym used)
     114                     (unless (eq sym (find-sym sym package))
     115                       (remove-symbol sym package)))
     116                   (use-package used package)))
     117               (ensure-fmakunbound (package symbols)
     118                 (loop :for name :in symbols
     119                   :for sym = (find-sym name package)
     120                   :when sym :do (fmakunbound sym)))
     121               (ensure-export (package export)
     122                 (let ((syms (loop :for x :in export :collect
     123                               (intern (string x) package))))
     124                   (do-external-symbols (sym package)
     125                     (unless (member sym syms)
     126                       (remove-symbol sym package)))
     127                   (dolist (sym syms)
     128                     (export sym package))))
     129               (ensure-package (name &key nicknames use unintern fmakunbound shadow export)
     130                 (let ((p (ensure-exists name nicknames use)))
     131                   (ensure-unintern p unintern)
     132                   (ensure-shadow p shadow)
     133                   (ensure-export p export)
     134                   (ensure-fmakunbound p fmakunbound)
     135                   p)))
     136        (ensure-package
     137         ':asdf-utilities
     138         :nicknames '(#:asdf-extensions)
     139         :use '(#:common-lisp)
     140         :unintern '(#:split #:make-collector)
     141         :export
     142         '(#:absolute-pathname-p
     143           #:aif
     144           #:appendf
     145           #:asdf-message
     146           #:coerce-name
     147           #:directory-pathname-p
     148           #:ends-with
     149           #:ensure-directory-pathname
     150           #:getenv
     151           #:get-uid
     152           #:length=n-p
     153           #:merge-pathnames*
     154           #:pathname-directory-pathname
     155           #:pathname-sans-name+type ;; deprecated. Use pathname-directory-pathname
     156           #:read-file-forms
     157           #:remove-keys
     158           #:remove-keyword
     159           #:resolve-symlinks
     160           #:split-string
     161           #:component-name-to-pathname-components
     162           #:split-name-type
     163           #:system-registered-p
     164           #:truenamize
     165           #:while-collecting))
     166        (ensure-package
     167         ':asdf
     168         :use '(:common-lisp :asdf-utilities)
     169         :unintern `(#-ecl ,@redefined-functions
     170                           #:*asdf-revision* #:around #:asdf-method-combination
     171                           #:split #:make-collector)
     172         :fmakunbound `(#+ecl ,@redefined-functions
     173                              #:system-source-file
     174                              #:component-relative-pathname #:system-relative-pathname
     175                              #:process-source-registry
     176                              #:inherit-source-registry #:process-source-registry-directive)
     177         :export
     178         '(#:defsystem #:oos #:operate #:find-system #:run-shell-command
     179           #:system-definition-pathname #:find-component ; miscellaneous
     180           #:compile-system #:load-system #:test-system
     181           #:compile-op #:load-op #:load-source-op
     182           #:test-op
     183           #:operation               ; operations
     184           #:feature                 ; sort-of operation
     185           #:version                 ; metaphorically sort-of an operation
     186           #:version-satisfies
     187
     188           #:input-files #:output-files #:perform ; operation methods
     189           #:operation-done-p #:explain
     190
     191           #:component #:source-file
     192           #:c-source-file #:cl-source-file #:java-source-file
     193           #:static-file
     194           #:doc-file
     195           #:html-file
     196           #:text-file
     197           #:source-file-type
     198           #:module                     ; components
     199           #:system
     200           #:unix-dso
     201
     202           #:module-components          ; component accessors
     203           #:component-pathname
     204           #:component-relative-pathname
     205           #:component-name
     206           #:component-version
     207           #:component-parent
     208           #:component-property
     209           #:component-system
     210
     211           #:component-depends-on
     212
     213           #:system-description
     214           #:system-long-description
     215           #:system-author
     216           #:system-maintainer
     217           #:system-license
     218           #:system-licence
     219           #:system-source-file
     220           #:system-source-directory
     221           #:system-relative-pathname
     222           #:map-systems
     223
     224           #:operation-on-warnings
     225           #:operation-on-failure
     226                                        ;#:*component-parent-pathname*
     227           #:*system-definition-search-functions*
     228           #:*central-registry*         ; variables
     229           #:*compile-file-warnings-behaviour*
     230           #:*compile-file-failure-behaviour*
     231           #:*resolve-symlinks*
     232
     233           #:asdf-version
     234
     235           #:operation-error #:compile-failed #:compile-warned #:compile-error
     236           #:error-name
     237           #:error-pathname
     238           #:load-system-definition-error
     239           #:error-component #:error-operation
     240           #:system-definition-error
     241           #:missing-component
     242           #:missing-component-of-version
     243           #:missing-dependency
     244           #:missing-dependency-of-version
     245           #:circular-dependency        ; errors
     246           #:duplicate-names
     247
     248           #:try-recompiling
     249           #:retry
     250           #:accept                     ; restarts
     251           #:coerce-entry-to-directory
     252           #:remove-entry-from-registry
     253
     254           #:initialize-output-translations
     255           #:disable-output-translations
     256           #:clear-output-translations
     257           #:ensure-output-translations
     258           #:apply-output-translations
     259           #:compile-file-pathname*
     260           #:enable-asdf-binary-locations-compatibility
     261
     262           #:*default-source-registries*
     263           #:initialize-source-registry
     264           #:compute-source-registry
     265           #:clear-source-registry
     266           #:ensure-source-registry
     267           #:process-source-registry))
     268        (eval `(defparameter ,(intern (string versym) (find-package :asdf)) ,asdf-version))))))
    109269
    110270(in-package #:asdf)
    111271
    112 (defvar *asdf-revision* (let* ((v "$Revision: 1.3 $")
    113              (colon (or (position #\: v) -1))
    114              (dot (position #\. v)))
    115         (and v colon dot
    116              (list (parse-integer v :start (1+ colon)
    117                 :junk-allowed t)
    118              (parse-integer v :start (1+ dot)
    119                 :junk-allowed t)))))
     272;;;; -------------------------------------------------------------------------
     273;;;; User-visible parameters
     274;;;;
     275(defun asdf-version ()
     276  "Exported interface to the version of ASDF currently installed. A string.
     277You can compare this string with e.g.:
     278(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"1.661\")."
     279  *asdf-version*)
     280
     281(defvar *resolve-symlinks* t
     282  "Determine whether or not ASDF resolves symlinks when defining systems.
     283
     284Defaults to `t`.")
    120285
    121286(defvar *compile-file-warnings-behaviour* :warn)
     287
    122288(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn)
    123289
    124290(defvar *verbose-out* nil)
    125291
    126 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    127 ;; utility stuff
     292(defparameter +asdf-methods+
     293  '(perform-with-restarts perform explain output-files operation-done-p))
     294
     295#+allegro
     296(eval-when (:compile-toplevel :execute)
     297  (defparameter *acl-warn-save*
     298                (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
     299                  excl:*warn-on-nested-reader-conditionals*))
     300  (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
     301    (setf excl:*warn-on-nested-reader-conditionals* nil)))
     302
     303;;;; -------------------------------------------------------------------------
     304;;;; Cleanups before hot-upgrade.
     305;;;; Things to do in case we're upgrading from a previous version of ASDF.
     306;;;; See https://bugs.launchpad.net/asdf/+bug/485687
     307;;;; * define methods on UPDATE-INSTANCE-FOR-REDEFINED-CLASS
     308;;;;   for each of the classes we define that has changed incompatibly.
     309(eval-when (:compile-toplevel :load-toplevel :execute)
     310  #+ecl
     311  (when (find-class 'compile-op nil)
     312    (defmethod update-instance-for-redefined-class :after
     313        ((c compile-op) added deleted plist &key)
     314      (format *trace-output* "~&UI4RC:a ~S~%" (list c added deleted plist))
     315      (let ((system-p (getf plist 'system-p)))
     316        (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p))))))
     317
     318;;;; -------------------------------------------------------------------------
     319;;;; ASDF Interface, in terms of generic functions.
     320
     321(defgeneric perform-with-restarts (operation component))
     322(defgeneric perform (operation component))
     323(defgeneric operation-done-p (operation component))
     324(defgeneric explain (operation component))
     325(defgeneric output-files (operation component))
     326(defgeneric input-files (operation component))
     327
     328(defgeneric system-source-file (system)
     329  (:documentation "Return the source file in which system is defined."))
     330
     331(defgeneric component-system (component)
     332  (:documentation "Find the top-level system containing COMPONENT"))
     333
     334(defgeneric component-pathname (component)
     335  (:documentation "Extracts the pathname applicable for a particular component."))
     336
     337(defgeneric component-relative-pathname (component)
     338  (:documentation "Returns a pathname for the component argument intended to be
     339interpreted relative to the pathname of that component's parent.
     340Despite the function's name, the return value may be an absolute
     341pathname, because an absolute pathname may be interpreted relative to
     342another pathname in a degenerate way."))
     343
     344(defgeneric component-property (component property))
     345
     346(defgeneric (setf component-property) (new-value component property))
     347
     348(defgeneric version-satisfies (component version))
     349
     350(defgeneric find-component (module name &optional version)
     351  (:documentation "Finds the component with name NAME present in the
     352MODULE module; if MODULE is nil, then the component is assumed to be a
     353system."))
     354
     355(defgeneric source-file-type (component system))
     356
     357(defgeneric operation-ancestor (operation)
     358  (:documentation
     359   "Recursively chase the operation's parent pointer until we get to
     360the head of the tree"))
     361
     362(defgeneric component-visited-p (operation component)
     363  (:documentation "Returns the value stored by a call to
     364VISIT-COMPONENT, if that has been called, otherwise NIL.
     365This value stored will be a cons cell, the first element
     366of which is a computed key, so not interesting.  The
     367CDR wil be the DATA value stored by VISIT-COMPONENT; recover
     368it as \(cdr \(component-visited-p op c\)\).
     369  In the current form of ASDF, the DATA value retrieved is
     370effectively a boolean, indicating whether some operations are
     371to be performed in order to do OPERATION X COMPONENT.  If the
     372data value is NIL, the combination had been explored, but no
     373operations needed to be performed."))
     374
     375(defgeneric visit-component (operation component data)
     376  (:documentation "Record DATA as being associated with OPERATION
     377and COMPONENT.  This is a side-effecting function:  the association
     378will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the
     379OPERATION\).
     380  No evidence that DATA is ever interesting, beyond just being
     381non-NIL.  Using the data field is probably very risky; if there is
     382already a record for OPERATION X COMPONENT, DATA will be quietly
     383discarded instead of recorded."))
     384
     385(defgeneric (setf visiting-component) (new-value operation component))
     386
     387(defgeneric component-visiting-p (operation component))
     388
     389(defgeneric component-depends-on (operation component)
     390  (:documentation
     391   "Returns a list of dependencies needed by the component to perform
     392    the operation.  A dependency has one of the following forms:
     393
     394      (<operation> <component>*), where <operation> is a class
     395        designator and each <component> is a component
     396        designator, which means that the component depends on
     397        <operation> having been performed on each <component>; or
     398
     399      (FEATURE <feature>), which means that the component depends
     400        on <feature>'s presence in *FEATURES*.
     401
     402    Methods specialized on subclasses of existing component types
     403    should usually append the results of CALL-NEXT-METHOD to the
     404    list."))
     405
     406(defgeneric component-self-dependencies (operation component))
     407
     408(defgeneric traverse (operation component)
     409  (:documentation
     410"Generate and return a plan for performing `operation` on `component`.
     411
     412The plan returned is a list of dotted-pairs. Each pair is the `cons`
     413of ASDF operation object and a `component` object. The pairs will be
     414processed in order by `operate`."))
     415
     416
     417;;;; -------------------------------------------------------------------------
     418;;;; General Purpose Utilities
     419
     420(defmacro while-collecting ((&rest collectors) &body body)
     421  (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))
     422        (initial-values (mapcar (constantly nil) collectors)))
     423    `(let ,(mapcar #'list vars initial-values)
     424       (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v))) collectors vars)
     425         ,@body
     426         (values ,@(mapcar #'(lambda (v) `(nreverse ,v)) vars))))))
    128427
    129428(defmacro aif (test then &optional else)
     
    132431(defun pathname-sans-name+type (pathname)
    133432  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
    134 and NIL NAME and TYPE components"
     433and NIL NAME and TYPE components.
     434Issue: doesn't override the VERSION component.
     435
     436Deprecated. Use PATHNAME-DIRECTORY-PATHNAME instead."
    135437  (make-pathname :name nil :type nil :defaults pathname))
    136438
    137 (define-modify-macro appendf (&rest args)
    138          append "Append onto list")
    139 
    140 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    141 ;; classes, condiitons
     439(defun pathname-directory-pathname (pathname)
     440  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
     441and NIL NAME, TYPE and VERSION components"
     442  (make-pathname :name nil :type nil :version nil :defaults pathname))
     443
     444(defun current-directory ()
     445  (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
     446
     447(defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
     448  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname
     449does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS.
     450Also, if either argument is NIL, then the other argument is returned unmodified."
     451  (when (null specified) (return-from merge-pathnames* defaults))
     452  (when (null defaults) (return-from merge-pathnames* specified))
     453  (let* ((specified (pathname specified))
     454         (defaults (pathname defaults))
     455         (directory (pathname-directory specified))
     456         (directory (if (stringp directory) `(:absolute ,directory) directory))
     457         (name (or (pathname-name specified) (pathname-name defaults)))
     458         (type (or (pathname-type specified) (pathname-type defaults)))
     459         (version (or (pathname-version specified) (pathname-version defaults))))
     460    (labels ((ununspecific (x)
     461               (if (eq x :unspecific) nil x))
     462             (unspecific-handler (p)
     463               (if (typep p 'logical-pathname) #'ununspecific #'identity)))
     464      (multiple-value-bind (host device directory unspecific-handler)
     465          (ecase (first directory)
     466            ((nil)
     467             (values (pathname-host defaults)
     468                     (pathname-device defaults)
     469                     (pathname-directory defaults)
     470                     (unspecific-handler defaults)))
     471            ((:absolute)
     472             (values (pathname-host specified)
     473                     (pathname-device specified)
     474                     directory
     475                     (unspecific-handler specified)))
     476            ((:relative)
     477             (values (pathname-host defaults)
     478                     (pathname-device defaults)
     479                     (append (pathname-directory defaults) (cdr directory))
     480                     (unspecific-handler defaults))))
     481        (make-pathname :host host :device device :directory directory
     482                       :name (funcall unspecific-handler name)
     483                       :type (funcall unspecific-handler type)
     484                       :version (funcall unspecific-handler version))))))
     485
     486(define-modify-macro appendf (&rest args)
     487  append "Append onto list")
     488
     489(defun asdf-message (format-string &rest format-args)
     490  (declare (dynamic-extent format-args))
     491  (apply #'format *verbose-out* format-string format-args))
     492
     493(defun split-string (string &key max (separator '(#\Space #\Tab)))
     494  "Split STRING in components separater by any of the characters in the sequence SEPARATOR,
     495return a list.
     496If MAX is specified, then no more than max(1,MAX) components will be returned,
     497starting the separation from the end, e.g. when called with arguments
     498 \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
     499  (block nil
     500    (let ((list nil) (words 0) (end (length string)))
     501      (flet ((separatorp (char) (find char separator))
     502             (done () (return (cons (subseq string 0 end) list))))
     503        (loop
     504          :for start = (if (and max (>= words (1- max)))
     505                           (done)
     506                           (position-if #'separatorp string :end end :from-end t)) :do
     507          (when (null start)
     508            (done))
     509          (push (subseq string (1+ start) end) list)
     510          (incf words)
     511          (setf end start))))))
     512
     513(defun split-name-type (filename)
     514  (let ((unspecific
     515         ;; Giving :unspecific as argument to make-pathname is not portable.
     516         ;; See CLHS make-pathname and 19.2.2.2.3.
     517         ;; We only use it on implementations that support it.
     518         (or #+(or sbcl ccl ecl lispworks) :unspecific)))
     519    (destructuring-bind (name &optional (type unspecific))
     520        (split-string filename :max 2 :separator ".")
     521      (if (equal name "")
     522          (values filename unspecific)
     523          (values name type)))))
     524
     525(defun component-name-to-pathname-components (s &optional force-directory)
     526  "Splits the path string S, returning three values:
     527A flag that is either :absolute or :relative, indicating
     528   how the rest of the values are to be interpreted.
     529A directory path --- a list of strings, suitable for
     530   use with MAKE-PATHNAME when prepended with the flag
     531   value.
     532A filename with type extension, possibly NIL in the
     533   case of a directory pathname.
     534FORCE-DIRECTORY forces S to be interpreted as a directory
     535pathname \(third return value will be NIL, final component
     536of S will be treated as part of the directory path.
     537
     538The intention of this function is to support structured component names,
     539e.g., \(:file \"foo/bar\"\), which will be unpacked to relative
     540pathnames."
     541  (check-type s string)
     542  (let* ((components (split-string s :separator "/"))
     543         (last-comp (car (last components))))
     544    (multiple-value-bind (relative components)
     545        (if (equal (first components) "")
     546            (if (and (plusp (length s)) (eql (char s 0) #\/))
     547                (values :absolute (cdr components))
     548                (values :relative nil))
     549          (values :relative components))
     550      (cond
     551        ((equal last-comp "")
     552         (values relative (butlast components) nil))
     553        (force-directory
     554         (values relative components nil))
     555        (t
     556         (values relative (butlast components) last-comp))))))
     557
     558(defun remove-keys (key-names args)
     559  (loop :for (name val) :on args :by #'cddr
     560    :unless (member (symbol-name name) key-names
     561                    :key #'symbol-name :test 'equal)
     562    :append (list name val)))
     563
     564(defun remove-keyword (key args)
     565  (loop :for (k v) :on args :by #'cddr
     566    :unless (eq k key)
     567    :append (list k v)))
     568
     569(defun resolve-symlinks (path)
     570  #-allegro (truenamize path)
     571  #+allegro (excl:pathname-resolve-symbolic-links path))
     572
     573(defun getenv (x)
     574  #+abcl
     575  (ext:getenv x)
     576  #+sbcl
     577  (sb-ext:posix-getenv x)
     578  #+clozure
     579  (ccl::getenv x)
     580  #+clisp
     581  (ext:getenv x)
     582  #+cmu
     583  (cdr (assoc (intern x :keyword) ext:*environment-list*))
     584  #+lispworks
     585  (lispworks:environment-variable x)
     586  #+allegro
     587  (sys:getenv x)
     588  #+gcl
     589  (system:getenv x)
     590  #+ecl
     591  (si:getenv x))
     592
     593(defun directory-pathname-p (pathname)
     594  "Does `pathname` represent a directory?
     595
     596A directory-pathname is a pathname _without_ a filename. The three
     597ways that the filename components can be missing are for it to be `nil`,
     598`:unspecific` or the empty string.
     599
     600Note that this does _not_ check to see that `pathname` points to an
     601actually-existing directory."
     602  (flet ((check-one (x)
     603           (member x '(nil :unspecific "") :test 'equal)))
     604    (and (check-one (pathname-name pathname))
     605         (check-one (pathname-type pathname))
     606         t)))
     607
     608(defun ensure-directory-pathname (pathspec)
     609  "Converts the non-wild pathname designator PATHSPEC to directory form."
     610  (cond
     611   ((stringp pathspec)
     612    (ensure-directory-pathname (pathname pathspec)))
     613   ((not (pathnamep pathspec))
     614    (error "Invalid pathname designator ~S" pathspec))
     615   ((wild-pathname-p pathspec)
     616    (error "Can't reliably convert wild pathnames."))
     617   ((directory-pathname-p pathspec)
     618    pathspec)
     619   (t
     620    (make-pathname :directory (append (or (pathname-directory pathspec)
     621                                          (list :relative))
     622                                      (list (file-namestring pathspec)))
     623                   :name nil :type nil :version nil
     624                   :defaults pathspec))))
     625
     626(defun absolute-pathname-p (pathspec)
     627  (eq :absolute (car (pathname-directory (pathname pathspec)))))
     628
     629(defun length=n-p (x n) ;is it that (= (length x) n) ?
     630  (check-type n (integer 0 *))
     631  (loop
     632    :for l = x :then (cdr l)
     633    :for i :downfrom n :do
     634    (cond
     635      ((zerop i) (return (null l)))
     636      ((not (consp l)) (return nil)))))
     637
     638(defun ends-with (s suffix)
     639  (check-type s string)
     640  (check-type suffix string)
     641  (let ((start (- (length s) (length suffix))))
     642    (and (<= 0 start)
     643         (string-equal s suffix :start1 start))))
     644
     645(defun read-file-forms (file)
     646  (with-open-file (in file)
     647    (loop :with eof = (list nil)
     648     :for form = (read in nil eof)
     649     :until (eq form eof)
     650     :collect form)))
     651
     652#-windows
     653(progn
     654#+clisp (defun get-uid () (posix:uid))
     655#+sbcl (defun get-uid () (sb-unix:unix-getuid))
     656#+cmu (defun get-uid () (unix:unix-getuid))
     657#+ecl (ffi:clines "#include <sys/types.h>" "#include <unistd.h>")
     658#+ecl (defun get-uid () (ffi:c-inline () () :int "getuid()" :one-liner t))
     659#+allegro (defun get-uid () (excl.osi:getuid))
     660#-(or cmu sbcl clisp allegro ecl)
     661(defun get-uid ()
     662  (let ((uid-string
     663         (with-output-to-string (asdf::*VERBOSE-OUT*)
     664           (asdf:run-shell-command "id -ur"))))
     665    (with-input-from-string (stream uid-string)
     666      (read-line stream)
     667      (handler-case (parse-integer (read-line stream))
     668        (error () (error "Unable to find out user ID")))))))
     669
     670(defun pathname-root (pathname)
     671  (make-pathname :host (pathname-host pathname)
     672                 :device (pathname-device pathname)
     673                 :directory '(:absolute)
     674                 :name nil :type nil :version nil))
     675
     676(defun truenamize (p)
     677  "Resolve as much of a pathname as possible"
     678  (block nil
     679    (when (typep p 'logical-pathname) (return p))
     680    (let* ((p (merge-pathnames* p))
     681           (directory (pathname-directory p)))
     682      (when (typep p 'logical-pathname) (return p))
     683      (ignore-errors (return (truename p)))
     684      (when (stringp directory)
     685         (return p))
     686      (when (not (eq :absolute (car directory)))
     687        (return p))
     688      (let ((sofar (ignore-errors (truename (pathname-root p)))))
     689        (unless sofar (return p))
     690        (loop :for component :in (cdr directory)
     691          :for rest :on (cdr directory)
     692          :for more = (ignore-errors
     693                        (truename
     694                         (merge-pathnames*
     695                          (make-pathname :directory `(:relative ,component))
     696                          sofar))) :do
     697          (if more
     698              (setf sofar more)
     699              (return
     700                (merge-pathnames*
     701                 (make-pathname :host nil :device nil
     702                                :directory `(:relative ,@rest)
     703                                :defaults p)
     704                 sofar)))
     705          :finally
     706          (return
     707            (merge-pathnames*
     708             (make-pathname :host nil :device nil
     709                            :directory nil
     710                            :defaults p)
     711             sofar)))))))
     712
     713(defun lispize-pathname (input-file)
     714  (make-pathname :type "lisp" :defaults input-file))
     715
     716;;;; -------------------------------------------------------------------------
     717;;;; Classes, Conditions
    142718
    143719(define-condition system-definition-error (error) ()
     
    154730   (format-arguments :initarg :format-arguments :reader format-arguments))
    155731  (:report (lambda (c s)
    156        (apply #'format s (format-control c) (format-arguments c)))))
     732             (apply #'format s (format-control c) (format-arguments c)))))
     733
     734(define-condition load-system-definition-error (system-definition-error)
     735  ((name :initarg :name :reader error-name)
     736   (pathname :initarg :pathname :reader error-pathname)
     737   (condition :initarg :condition :reader error-condition))
     738  (:report (lambda (c s)
     739             (format s "~@<Error while trying to load definition for system ~A from pathname ~A: ~A~@:>"
     740                     (error-name c) (error-pathname c) (error-condition c)))))
    157741
    158742(define-condition circular-dependency (system-definition-error)
     
    160744
    161745(define-condition duplicate-names (system-definition-error)
    162   ((name :initarg :name :reader duplicate-names-name)))
     746  ((name :initarg :name :reader duplicate-names-name))
     747  (:report (lambda (c s)
     748             (format s "~@<Error while defining system: multiple components are given same name ~A~@:>"
     749                     (duplicate-names-name c)))))
    163750
    164751(define-condition missing-component (system-definition-error)
    165752  ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
    166    (version :initform nil :reader missing-version :initarg :version)
    167753   (parent :initform nil :reader missing-parent :initarg :parent)))
     754
     755(define-condition missing-component-of-version (missing-component)
     756  ((version :initform nil :reader missing-version :initarg :version)))
    168757
    169758(define-condition missing-dependency (missing-component)
    170759  ((required-by :initarg :required-by :reader missing-required-by)))
     760
     761(define-condition missing-dependency-of-version (missing-dependency
     762                                                 missing-component-of-version)
     763  ())
    171764
    172765(define-condition operation-error (error)
     
    174767   (operation :reader error-operation :initarg :operation))
    175768  (:report (lambda (c s)
    176        (format s "~@<erred while invoking ~A on ~A~@:>"
    177          (error-operation c) (error-component c)))))
     769             (format s "~@<erred while invoking ~A on ~A~@:>"
     770                     (error-operation c) (error-component c)))))
    178771(define-condition compile-error (operation-error) ())
    179772(define-condition compile-failed (compile-error) ())
     
    182775(defclass component ()
    183776  ((name :accessor component-name :initarg :name :documentation
    184   "Component name: designator for a string composed of portable pathname characters")
     777        "Component name: designator for a string composed of portable pathname characters")
    185778   (version :accessor component-version :initarg :version)
    186    (in-order-to :initform nil :initarg :in-order-to)
    187    ;;; XXX crap name
    188    (do-first :initform nil :initarg :do-first)
     779   (in-order-to :initform nil :initarg :in-order-to
     780                :accessor component-in-order-to)
     781   ;; XXX crap name
     782   (do-first :initform nil :initarg :do-first
     783             :accessor component-do-first)
    189784   ;; methods defined using the "inline" style inside a defsystem form:
    190785   ;; need to store them somewhere so we can delete them when the system
     
    195790   ;; it to default in funky ways if not supplied
    196791   (relative-pathname :initarg :pathname)
    197    (operation-times :initform (make-hash-table )
    198         :accessor component-operation-times)
     792   (absolute-pathname)
     793   (operation-times :initform (make-hash-table)
     794                    :accessor component-operation-times)
    199795   ;; XXX we should provide some atomic interface for updating the
    200796   ;; component properties
    201797   (properties :accessor component-properties :initarg :properties
    202          :initform nil)))
     798               :initform nil)))
    203799
    204800;;;; methods: conditions
     
    206802(defmethod print-object ((c missing-dependency) s)
    207803  (format s "~@<~A, required by ~A~@:>"
    208     (call-next-method c nil) (missing-required-by c)))
     804          (call-next-method c nil) (missing-required-by c)))
    209805
    210806(defun sysdef-error (format &rest arguments)
    211   (error 'formatted-system-definition-error :format-control format :format-arguments arguments))
     807  (error 'formatted-system-definition-error :format-control
     808         format :format-arguments arguments))
    212809
    213810;;;; methods: components
    214811
    215812(defmethod print-object ((c missing-component) s)
    216   (format s "~@<component ~S not found~
    217              ~@[ or does not match version ~A~]~
     813   (format s "~@<component ~S not found~
    218814             ~@[ in ~A~]~@:>"
    219     (missing-requires c)
    220     (missing-version c)
    221     (when (missing-parent c)
    222       (component-name (missing-parent c)))))
    223 
    224 (defgeneric component-system (component)
    225   (:documentation "Find the top-level system containing COMPONENT"))
    226  
     815          (missing-requires c)
     816          (when (missing-parent c)
     817            (component-name (missing-parent c)))))
     818
     819(defmethod print-object ((c missing-component-of-version) s)
     820  (format s "~@<component ~S does not match version ~A~
     821              ~@[ in ~A~]~@:>"
     822           (missing-requires c)
     823           (missing-version c)
     824           (when (missing-parent c)
     825             (component-name (missing-parent c)))))
     826
    227827(defmethod component-system ((component component))
    228828  (aif (component-parent component)
     
    240840   ;; components.  This allows a limited form of conditional processing
    241841   (if-component-dep-fails :initform :fail
    242          :accessor module-if-component-dep-fails
    243          :initarg :if-component-dep-fails)
     842                           :accessor module-if-component-dep-fails
     843                           :initarg :if-component-dep-fails)
    244844   (default-component-class :accessor module-default-component-class
    245845     :initform 'cl-source-file :initarg :default-component-class)))
    246846
    247 (defgeneric component-pathname (component)
    248   (:documentation "Extracts the pathname applicable for a particular component."))
    249 
    250847(defun component-parent-pathname (component)
    251   (aif (component-parent component)
    252        (component-pathname it)
    253        *default-pathname-defaults*))
    254 
    255 (defgeneric component-relative-pathname (component)
    256   (:documentation "Extracts the relative pathname applicable for a particular component."))
    257    
    258 (defmethod component-relative-pathname ((component module))
    259   (or (slot-value component 'relative-pathname)
    260       (make-pathname
    261        :directory `(:relative ,(component-name component))
    262        :host (pathname-host (component-parent-pathname component)))))
     848  ;; No default anymore (in particular, no *default-pathname-defaults*).
     849  ;; If you force component to have a NULL pathname, you better arrange
     850  ;; for any of its children to explicitly provide a proper absolute pathname
     851  ;; wherever a pathname is actually wanted.
     852  (let ((parent (component-parent component)))
     853    (when parent
     854      (component-pathname parent))))
    263855
    264856(defmethod component-pathname ((component component))
    265   (let ((*default-pathname-defaults* (component-parent-pathname component)))
    266     (merge-pathnames (component-relative-pathname component))))
    267 
    268 (defgeneric component-property (component property))
     857  (if (slot-boundp component 'absolute-pathname)
     858      (slot-value component 'absolute-pathname)
     859      (let ((pathname
     860             (merge-pathnames*
     861             (component-relative-pathname component)
     862             (component-parent-pathname component))))
     863        (unless (or (null pathname) (absolute-pathname-p pathname))
     864          (error "Invalid relative pathname ~S for component ~S" pathname component))
     865        (setf (slot-value component 'absolute-pathname) pathname)
     866        pathname)))
    269867
    270868(defmethod component-property ((c component) property)
    271869  (cdr (assoc property (slot-value c 'properties) :test #'equal)))
    272 
    273 (defgeneric (setf component-property) (new-value component property))
    274870
    275871(defmethod (setf component-property) (new-value (c component) property)
    276872  (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
    277873    (if a
    278   (setf (cdr a) new-value)
    279   (setf (slot-value c 'properties)
    280         (acons property new-value (slot-value c 'properties))))))
     874        (setf (cdr a) new-value)
     875        (setf (slot-value c 'properties)
     876              (acons property new-value (slot-value c 'properties)))))
     877  new-value)
    281878
    282879(defclass system (module)
     
    286883   (author :accessor system-author :initarg :author)
    287884   (maintainer :accessor system-maintainer :initarg :maintainer)
    288    (licence :accessor system-licence :initarg :licence)))
    289 
    290 ;;; version-satisfies
    291 
    292 ;;; with apologies to christophe rhodes ...
    293 (defun split (string &optional max (ws '(#\Space #\Tab)))
    294   (flet ((is-ws (char) (find char ws)))
    295     (nreverse
    296      (let ((list nil) (start 0) (words 0) end)
    297        (loop
    298   (when (and max (>= words (1- max)))
    299     (return (cons (subseq string start) list)))
    300   (setf end (position-if #'is-ws string :start start))
    301   (push (subseq string start end) list)
    302   (incf words)
    303   (unless end (return list))
    304   (setf start (1+ end)))))))
    305 
    306 (defgeneric version-satisfies (component version))
     885   (licence :accessor system-licence :initarg :licence
     886            :accessor system-license :initarg :license)
     887   (source-file :reader system-source-file :initarg :source-file
     888                :writer %set-system-source-file)))
     889
     890;;;; -------------------------------------------------------------------------
     891;;;; version-satisfies
    307892
    308893(defmethod version-satisfies ((c component) version)
    309894  (unless (and version (slot-boundp c 'version))
    310895    (return-from version-satisfies t))
     896  (version-satisfies (component-version c) version))
     897
     898(defmethod version-satisfies ((cver string) version)
    311899  (let ((x (mapcar #'parse-integer
    312        (split (component-version c) nil '(#\.))))
    313   (y (mapcar #'parse-integer
    314        (split version nil '(#\.)))))
     900                   (split-string cver :separator ".")))
     901        (y (mapcar #'parse-integer
     902                   (split-string version :separator "."))))
    315903    (labels ((bigger (x y)
    316          (cond ((not y) t)
    317          ((not x) nil)
    318          ((> (car x) (car y)) t)
    319          ((= (car x) (car y))
    320           (bigger (cdr x) (cdr y))))))
     904               (cond ((not y) t)
     905                     ((not x) nil)
     906                     ((> (car x) (car y)) t)
     907                     ((= (car x) (car y))
     908                      (bigger (cdr x) (cdr y))))))
    321909      (and (= (car x) (car y))
    322      (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
    323 
    324 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    325 ;;; finding systems
    326 
    327 (defvar *defined-systems* (make-hash-table :test 'equal))
     910           (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
     911
     912;;;; -------------------------------------------------------------------------
     913;;;; Finding systems
     914
     915(defun make-defined-systems-table ()
     916  (make-hash-table :test 'equal))
     917
     918(defvar *defined-systems* (make-defined-systems-table)
     919  "This is a hash table whose keys are strings, being the
     920names of the systems, and whose values are pairs, the first
     921element of which is a universal-time indicating when the
     922system definition was last updated, and the second element
     923of which is a system object.")
     924
    328925(defun coerce-name (name)
    329    (typecase name
    330      (component (component-name name))
    331      (symbol (string-downcase (symbol-name name)))
    332      (string name)
    333      (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
     926  (typecase name
     927    (component (component-name name))
     928    (symbol (string-downcase (symbol-name name)))
     929    (string name)
     930    (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
     931
     932(defun system-registered-p (name)
     933  (gethash (coerce-name name) *defined-systems*))
     934
     935(defun map-systems (fn)
     936  "Apply `fn` to each defined system.
     937
     938`fn` should be a function of one argument. It will be
     939called with an object of type asdf:system."
     940  (maphash (lambda (_ datum)
     941             (declare (ignore _))
     942             (destructuring-bind (_ . def) datum
     943               (declare (ignore _))
     944               (funcall fn def)))
     945           *defined-systems*))
    334946
    335947;;; for the sake of keeping things reasonably neat, we adopt a
    336948;;; convention that functions in this list are prefixed SYSDEF-
    337949
    338 (defvar *system-definition-search-functions*
    339   '(sysdef-central-registry-search))
     950(defparameter *system-definition-search-functions*
     951  '(sysdef-central-registry-search sysdef-source-registry-search))
    340952
    341953(defun system-definition-pathname (system)
    342   (some (lambda (x) (funcall x system))
    343   *system-definition-search-functions*))
    344  
    345 (defvar *central-registry*
    346   '(*default-pathname-defaults*
    347     #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/"
    348     #+nil "telent:asdf;systems;"))
     954  (let ((system-name (coerce-name system)))
     955    (or
     956     (some (lambda (x) (funcall x system-name))
     957           *system-definition-search-functions*)
     958     (let ((system-pair (system-registered-p system-name)))
     959       (and system-pair
     960            (system-source-file (cdr system-pair)))))))
     961
     962(defvar *central-registry* nil
     963"A list of 'system directory designators' ASDF uses to find systems.
     964
     965A 'system directory designator' is a pathname or an expression
     966which evaluates to a pathname. For example:
     967
     968    (setf asdf:*central-registry*
     969          (list '*default-pathname-defaults*
     970                #p\"/home/me/cl/systems/\"
     971                #p\"/usr/share/common-lisp/systems/\"))
     972
     973This is for backward compatibilily.
     974Going forward, we recommend new users should be using the source-registry.
     975")
    349976
    350977(defun sysdef-central-registry-search (system)
    351   (let ((name (coerce-name system)))
     978  (let ((name (coerce-name system))
     979        (to-remove nil)
     980        (to-replace nil))
    352981    (block nil
    353       (dolist (dir *central-registry*)
    354   (let* ((defaults (eval dir))
    355          (file (and defaults
    356         (make-pathname
    357          :defaults defaults :version :newest
    358          :name name :type "asd" :case :local))))
    359     (if (and file (probe-file file))
    360         (return file)))))))
     982      (unwind-protect
     983           (dolist (dir *central-registry*)
     984             (let ((defaults (eval dir)))
     985               (when defaults
     986                 (cond ((directory-pathname-p defaults)
     987                        (let ((file (and defaults
     988                                         (make-pathname
     989                                          :defaults defaults :version :newest
     990                                          :name name :type "asd" :case :local)))
     991                               #+(and (or win32 windows) (not :clisp))
     992                               (shortcut (make-pathname
     993                                          :defaults defaults :version :newest
     994                                          :name name :type "asd.lnk" :case :local)))
     995                          (if (and file (probe-file file))
     996                              (return file))
     997                          #+(and (or win32 windows) (not :clisp))
     998                          (when (probe-file shortcut)
     999                            (let ((target (parse-windows-shortcut shortcut)))
     1000                              (when target
     1001                                (return (pathname target)))))))
     1002                       (t
     1003                        (restart-case
     1004                            (let* ((*print-circle* nil)
     1005                                   (message
     1006                                    (format nil
     1007                                            "~@<While searching for system `~a`: `~a` evaluated ~
     1008to `~a` which is not a directory.~@:>"
     1009                                            system dir defaults)))
     1010                              (error message))
     1011                          (remove-entry-from-registry ()
     1012                            :report "Remove entry from *central-registry* and continue"
     1013                            (push dir to-remove))
     1014                          (coerce-entry-to-directory ()
     1015                            :report (lambda (s)
     1016                                      (format s "Coerce entry to ~a, replace ~a and continue."
     1017                                              (ensure-directory-pathname defaults) dir))
     1018                            (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
     1019        ;; cleanup
     1020        (dolist (dir to-remove)
     1021          (setf *central-registry* (remove dir *central-registry*)))
     1022        (dolist (pair to-replace)
     1023          (let* ((current (car pair))
     1024                 (new (cdr pair))
     1025                 (position (position current *central-registry*)))
     1026            (setf *central-registry*
     1027                  (append (subseq *central-registry* 0 position)
     1028                          (list new)
     1029                          (subseq *central-registry* (1+ position))))))))))
    3611030
    3621031(defun make-temporary-package ()
    3631032  (flet ((try (counter)
    3641033           (ignore-errors
    365                    (make-package (format nil "ASDF~D" counter)
    366                                  :use '(:cl :asdf)))))
     1034             (make-package (format nil "~a~D" 'asdf counter)
     1035                           :use '(:cl :asdf)))))
    3671036    (do* ((counter 0 (+ counter 1))
    3681037          (package (try counter) (try counter)))
    3691038         (package package))))
    3701039
    371 (defun find-system (name &optional (error-p t))
    372   (let* ((name (coerce-name name))
    373    (in-memory (gethash name *defined-systems*))
    374    (on-disk (system-definition-pathname name))) 
    375     (when (and on-disk
    376          (or (not in-memory)
    377        (< (car in-memory) (file-write-date on-disk))))
    378       (let ((package (make-temporary-package)))
    379         (unwind-protect
    380              (let ((*package* package))
    381                (format
    382                 *verbose-out*
    383                 "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
    384                 ;; FIXME: This wants to be (ENOUGH-NAMESTRING
    385                 ;; ON-DISK), but CMUCL barfs on that.
    386     on-disk
    387     *package*)
    388                (load on-disk))
    389           (delete-package package))))
    390     (let ((in-memory (gethash name *defined-systems*)))
    391       (if in-memory
    392     (progn (if on-disk (setf (car in-memory) (file-write-date on-disk)))
    393      (cdr in-memory))
    394     (if error-p (error 'missing-component :requires name))))))
    395 
    396 (defun register-system (name system)
    397   (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
    398   (setf (gethash (coerce-name  name) *defined-systems*)
    399   (cons (get-universal-time) system)))
    400 
    401 (defun system-registered-p (name)
    402   (gethash (coerce-name name) *defined-systems*))
    403 
    404 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    405 ;;; finding components
    406 
    407 (defgeneric find-component (module name &optional version)
    408   (:documentation "Finds the component with name NAME present in the
    409 MODULE module; if MODULE is nil, then the component is assumed to be a
    410 system."))
    411 
    412 (defmethod find-component ((module module) name &optional version)
    413   (if (slot-boundp module 'components)
    414       (let ((m (find name (module-components module)
    415          :test #'equal :key #'component-name)))
    416   (if (and m (version-satisfies m version)) m))))
    417      
    418 
    419 ;;; a component with no parent is a system
    420 (defmethod find-component ((module (eql nil)) name &optional version)
    421   (let ((m (find-system name nil)))
    422     (if (and m (version-satisfies m version)) m)))
    423 
    424 ;;; component subclasses
    425 
    426 (defclass source-file (component) ())
    427 
    428 (defclass cl-source-file (source-file) ())
    429 (defclass c-source-file (source-file) ())
    430 (defclass java-source-file (source-file) ())
    431 (defclass static-file (source-file) ())
    432 (defclass doc-file (static-file) ())
    433 (defclass html-file (doc-file) ())
    434 
    435 (defgeneric source-file-type (component system))
    436 (defmethod source-file-type ((c cl-source-file) (s module)) "lisp")
    437 (defmethod source-file-type ((c c-source-file) (s module)) "c")
    438 (defmethod source-file-type ((c java-source-file) (s module)) "java")
    439 (defmethod source-file-type ((c html-file) (s module)) "html")
    440 (defmethod source-file-type ((c static-file) (s module)) nil)
    441 
    442 (defmethod component-relative-pathname ((component source-file))
    443   (let ((relative-pathname (slot-value component 'relative-pathname)))
    444     (if relative-pathname
    445         (merge-pathnames
    446          relative-pathname
    447          (make-pathname
    448           :type (source-file-type component (component-system component))))
    449         (let* ((*default-pathname-defaults*
    450                 (component-parent-pathname component))
    451                (name-type
    452                 (make-pathname
    453                  :name (component-name component)
    454                  :type (source-file-type component
    455                                          (component-system component)))))
    456           name-type))))
    457 
    458 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    459 ;;; operations
    460 
    461 ;;; one of these is instantiated whenever (operate ) is called
    462 
    463 (defclass operation ()
    464   ((forced :initform nil :initarg :force :accessor operation-forced)
    465    (original-initargs :initform nil :initarg :original-initargs
    466           :accessor operation-original-initargs)
    467    (visited-nodes :initform nil :accessor operation-visited-nodes)
    468    (visiting-nodes :initform nil :accessor operation-visiting-nodes)
    469    (parent :initform nil :initarg :parent :accessor operation-parent)))
    470 
    471 (defmethod print-object ((o operation) stream)
    472   (print-unreadable-object (o stream :type t :identity t)
    473     (ignore-errors
    474       (prin1 (operation-original-initargs o) stream))))
    475 
    476 (defmethod shared-initialize :after ((operation operation) slot-names
    477              &key force
    478              &allow-other-keys)
    479   (declare (ignore slot-names force))
    480   ;; empty method to disable initarg validity checking
    481   )
    482 
    483 (defgeneric perform (operation component))
    484 (defgeneric operation-done-p (operation component))
    485 (defgeneric explain (operation component))
    486 (defgeneric output-files (operation component))
    487 (defgeneric input-files (operation component))
    488 
    489 (defun node-for (o c)
    490   (cons (class-name (class-of o)) c))
    491 
    492 (defgeneric operation-ancestor (operation)
    493   (:documentation   "Recursively chase the operation's parent pointer until we get to the head of the tree"))
    494 
    495 (defmethod operation-ancestor ((operation operation))
    496   (aif (operation-parent operation)
    497        (operation-ancestor it)
    498        operation))
    499 
    500 
    501 (defun make-sub-operation (c o dep-c dep-o)
    502   (let* ((args (copy-list (operation-original-initargs o)))
    503    (force-p (getf args :force)))
    504     ;; note explicit comparison with T: any other non-NIL force value
    505     ;; (e.g. :recursive) will pass through
    506     (cond ((and (null (component-parent c))
    507     (null (component-parent dep-c))
    508     (not (eql c dep-c)))
    509      (when (eql force-p t)
    510        (setf (getf args :force) nil))
    511      (apply #'make-instance dep-o
    512       :parent o
    513       :original-initargs args args))
    514     ((subtypep (type-of o) dep-o)
    515      o)
    516     (t
    517      (apply #'make-instance dep-o
    518       :parent o :original-initargs args args)))))
    519 
    520 
    521 (defgeneric visit-component (operation component data))
    522 
    523 (defmethod visit-component ((o operation) (c component) data)
    524   (unless (component-visited-p o c)
    525     (push (cons (node-for o c) data)
    526     (operation-visited-nodes (operation-ancestor o)))))
    527 
    528 (defgeneric component-visited-p (operation component))
    529 
    530 (defmethod component-visited-p ((o operation) (c component))
    531   (assoc (node-for o c)
    532    (operation-visited-nodes (operation-ancestor o))
    533    :test 'equal))
    534 
    535 (defgeneric (setf visiting-component) (new-value operation component))
    536 
    537 (defmethod (setf visiting-component) (new-value operation component)
    538   ;; MCL complains about unused lexical variables
    539   (declare (ignorable new-value operation component)))
    540 
    541 (defmethod (setf visiting-component) (new-value (o operation) (c component))
    542   (let ((node (node-for o c))
    543   (a (operation-ancestor o)))
    544     (if new-value
    545   (pushnew node (operation-visiting-nodes a) :test 'equal)
    546   (setf (operation-visiting-nodes a)
    547         (remove node  (operation-visiting-nodes a) :test 'equal)))))
    548 
    549 (defgeneric component-visiting-p (operation component))
    550 
    551 (defmethod component-visiting-p ((o operation) (c component))
    552   (let ((node (cons o c)))
    553     (member node (operation-visiting-nodes (operation-ancestor o))
    554       :test 'equal)))
    555 
    556 (defgeneric component-depends-on (operation component))
    557 
    558 (defmethod component-depends-on ((o operation) (c component))
    559   (cdr (assoc (class-name (class-of o))
    560         (slot-value c 'in-order-to))))
    561 
    562 (defgeneric component-self-dependencies (operation component))
    563 
    564 (defmethod component-self-dependencies ((o operation) (c component))
    565   (let ((all-deps (component-depends-on o c)))
    566     (remove-if-not (lambda (x)
    567          (member (component-name c) (cdr x) :test #'string=))
    568        all-deps)))
    569    
    570 (defmethod input-files ((operation operation) (c component))
    571   (let ((parent (component-parent c))
    572   (self-deps (component-self-dependencies operation c)))
    573     (if self-deps
    574   (mapcan (lambda (dep)
    575       (destructuring-bind (op name) dep
    576         (output-files (make-instance op)
    577           (find-component parent name))))
    578     self-deps)
    579   ;; no previous operations needed?  I guess we work with the
    580   ;; original source file, then
    581   (list (component-pathname c)))))
    582 
    583 (defmethod input-files ((operation operation) (c module)) nil)
    584 
    585 (defmethod operation-done-p ((o operation) (c component))
    586   (flet ((fwd-or-return-t (file)
     1040(defun safe-file-write-date (pathname)
    5871041           ;; if FILE-WRITE-DATE returns NIL, it's possible that the
    5881042           ;; user or some other agent has deleted an input file.  If
     
    5901044           ;; the operation is otherwise considered to be done we
    5911045           ;; could continue and survive.
    592            (let ((date (file-write-date file)))
    593              (cond
    594                (date)
    595                (t
    596                 (warn "~@<Missing FILE-WRITE-DATE for ~S: treating ~
    597                        operation ~S on component ~S as done.~@:>"
    598                       file o c)
    599                 (return-from operation-done-p t))))))
    600     (let ((out-files (output-files o c))
    601           (in-files (input-files o c)))
    602       (cond ((and (not in-files) (not out-files))
    603              ;; arbitrary decision: an operation that uses nothing to
    604              ;; produce nothing probably isn't doing much
    605              t)
    606             ((not out-files)
    607              (let ((op-done
    608                     (gethash (type-of o)
    609                              (component-operation-times c))))
    610                (and op-done
    611                     (>= op-done
    612                         (apply #'max
    613                                (mapcar #'fwd-or-return-t in-files))))))
    614             ((not in-files) nil)
    615             (t
    616              (and
    617               (every #'probe-file out-files)
    618               (> (apply #'min (mapcar #'file-write-date out-files))
    619                  (apply #'max (mapcar #'fwd-or-return-t in-files)))))))))
     1046  (or (and pathname (file-write-date pathname))
     1047      (progn
     1048        (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero."
     1049              pathname)
     1050        0)))
     1051
     1052(defun find-system (name &optional (error-p t))
     1053  (let* ((name (coerce-name name))
     1054         (in-memory (system-registered-p name))
     1055         (on-disk (system-definition-pathname name)))
     1056    (when (and on-disk
     1057               (or (not in-memory)
     1058                   (< (car in-memory) (safe-file-write-date on-disk))))
     1059      (let ((package (make-temporary-package)))
     1060        (unwind-protect
     1061             (handler-bind
     1062                 ((error (lambda (condition)
     1063                           (error 'load-system-definition-error
     1064                                  :name name :pathname on-disk
     1065                                  :condition condition))))
     1066               (let ((*package* package))
     1067                 (asdf-message
     1068                  "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
     1069                  ;; FIXME: This wants to be (ENOUGH-NAMESTRING
     1070                  ;; ON-DISK), but CMUCL barfs on that.
     1071                  on-disk
     1072                  *package*)
     1073                 (load on-disk)))
     1074          (delete-package package))))
     1075    (let ((in-memory (system-registered-p name)))
     1076      (if in-memory
     1077          (progn (when on-disk (setf (car in-memory)
     1078                                     (safe-file-write-date on-disk)))
     1079                 (cdr in-memory))
     1080          (when error-p (error 'missing-component :requires name))))))
     1081
     1082(defun register-system (name system)
     1083  (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
     1084  (setf (gethash (coerce-name name) *defined-systems*)
     1085        (cons (get-universal-time) system)))
     1086
     1087
     1088;;;; -------------------------------------------------------------------------
     1089;;;; Finding components
     1090
     1091(defmethod find-component ((module module) name &optional version)
     1092  (if (slot-boundp module 'components)
     1093      (let ((m (find name (module-components module)
     1094                     :test #'equal :key #'component-name)))
     1095        (if (and m (version-satisfies m version)) m))))
     1096
     1097
     1098;;; a component with no parent is a system
     1099(defmethod find-component ((module (eql nil)) name &optional version)
     1100  (declare (ignorable module))
     1101  (let ((m (find-system name nil)))
     1102    (if (and m (version-satisfies m version)) m)))
     1103
     1104;;; component subclasses
     1105
     1106(defclass source-file (component)
     1107  ((type :accessor source-file-explicit-type :initarg :type :initform nil)))
     1108
     1109(defclass cl-source-file (source-file)
     1110  ((type :initform "lisp")))
     1111(defclass c-source-file (source-file)
     1112  ((type :initform "c")))
     1113(defclass java-source-file (source-file)
     1114  ((type :initform "java")))
     1115(defclass static-file (source-file) ())
     1116(defclass doc-file (static-file) ())
     1117(defclass html-file (doc-file)
     1118  ((type :initform "html")))
     1119
     1120(defmethod source-file-type ((component module) (s module)) :directory)
     1121(defmethod source-file-type ((component source-file) (s module))
     1122  (source-file-explicit-type component))
     1123
     1124(defun merge-component-name-type (name &key type defaults)
     1125  ;; The defaults are required notably because they provide the default host
     1126  ;; to the below make-pathname, which may crucially matter to people using
     1127  ;; merge-pathnames with non-default hosts,  e.g. for logical-pathnames.
     1128  ;; NOTE that the host and device slots will be taken from the defaults,
     1129  ;; but that should only matter if you either (a) use absolute pathnames, or
     1130  ;; (b) later merge relative pathnames with CL:MERGE-PATHNAMES instead of
     1131  ;; ASDF-UTILITIES:MERGE-PATHNAMES*
     1132  (etypecase name
     1133    (pathname
     1134     name)
     1135    (symbol
     1136     (merge-component-name-type (string-downcase name) :type type :defaults defaults))
     1137    (string
     1138     (multiple-value-bind (relative path filename)
     1139         (component-name-to-pathname-components name (eq type :directory))
     1140       (multiple-value-bind (name type)
     1141           (cond
     1142             ((or (eq type :directory) (null filename))
     1143              (values nil nil))
     1144             (type
     1145              (values filename type))
     1146             (t
     1147              (split-name-type filename)))
     1148         (let* ((defaults (pathname (or defaults *default-pathname-defaults*)))
     1149                (host (pathname-host defaults))
     1150                (device (pathname-device defaults)))
     1151           (make-pathname :directory `(,relative ,@path)
     1152                          :name name :type type
     1153                          :host host :device device)))))))
     1154
     1155(defmethod component-relative-pathname ((component component))
     1156  (merge-component-name-type
     1157   (or (slot-value component 'relative-pathname)
     1158       (component-name component))
     1159   :type (source-file-type component (component-system component))
     1160   :defaults (component-parent-pathname component)))
     1161
     1162;;;; -------------------------------------------------------------------------
     1163;;;; Operations
     1164
     1165;;; one of these is instantiated whenever #'operate is called
     1166
     1167(defclass operation ()
     1168  (
     1169   ;; what is the TYPE of this slot?  seems like it should be boolean,
     1170   ;; but TRAVERSE checks to see if it's a list of component names...
     1171   ;; [2010/02/07:rpg]
     1172   (forced :initform nil :initarg :force :accessor operation-forced)
     1173   (original-initargs :initform nil :initarg :original-initargs
     1174                      :accessor operation-original-initargs)
     1175   (visited-nodes :initform nil :accessor operation-visited-nodes)
     1176   (visiting-nodes :initform nil :accessor operation-visiting-nodes)
     1177   (parent :initform nil :initarg :parent :accessor operation-parent)))
     1178
     1179(defmethod print-object ((o operation) stream)
     1180  (print-unreadable-object (o stream :type t :identity t)
     1181    (ignore-errors
     1182      (prin1 (operation-original-initargs o) stream))))
     1183
     1184(defmethod shared-initialize :after ((operation operation) slot-names
     1185                                     &key force
     1186                                     &allow-other-keys)
     1187  (declare (ignorable operation slot-names force))
     1188  ;; empty method to disable initarg validity checking
     1189  (values))
     1190
     1191(defun node-for (o c)
     1192  (cons (class-name (class-of o)) c))
     1193
     1194(defmethod operation-ancestor ((operation operation))
     1195  (aif (operation-parent operation)
     1196       (operation-ancestor it)
     1197       operation))
     1198
     1199
     1200(defun make-sub-operation (c o dep-c dep-o)
     1201  "C is a component, O is an operation, DEP-C is another
     1202component, and DEP-O, confusingly enough, is an operation
     1203class specifier, not an operation."
     1204  (let* ((args (copy-list (operation-original-initargs o)))
     1205         (force-p (getf args :force)))
     1206    ;; note explicit comparison with T: any other non-NIL force value
     1207    ;; (e.g. :recursive) will pass through
     1208    (cond ((and (null (component-parent c))
     1209                (null (component-parent dep-c))
     1210                (not (eql c dep-c)))
     1211           (when (eql force-p t)
     1212             (setf (getf args :force) nil))
     1213           (apply #'make-instance dep-o
     1214                  :parent o
     1215                  :original-initargs args args))
     1216          ((subtypep (type-of o) dep-o)
     1217           o)
     1218          (t
     1219           (apply #'make-instance dep-o
     1220                  :parent o :original-initargs args args)))))
     1221
     1222
     1223(defmethod visit-component ((o operation) (c component) data)
     1224  (unless (component-visited-p o c)
     1225    (push (cons (node-for o c) data)
     1226          (operation-visited-nodes (operation-ancestor o)))))
     1227
     1228(defmethod component-visited-p ((o operation) (c component))
     1229  (assoc (node-for o c)
     1230         (operation-visited-nodes (operation-ancestor o))
     1231         :test 'equal))
     1232
     1233(defmethod (setf visiting-component) (new-value operation component)
     1234  ;; MCL complains about unused lexical variables
     1235  (declare (ignorable operation component))
     1236  new-value)
     1237
     1238(defmethod (setf visiting-component) (new-value (o operation) (c component))
     1239  (let ((node (node-for o c))
     1240        (a (operation-ancestor o)))
     1241    (if new-value
     1242        (pushnew node (operation-visiting-nodes a) :test 'equal)
     1243        (setf (operation-visiting-nodes a)
     1244              (remove node  (operation-visiting-nodes a) :test 'equal))))
     1245  new-value)
     1246
     1247(defmethod component-visiting-p ((o operation) (c component))
     1248  (let ((node (node-for o c)))
     1249    (member node (operation-visiting-nodes (operation-ancestor o))
     1250            :test 'equal)))
     1251
     1252(defmethod component-depends-on ((op-spec symbol) (c component))
     1253  (component-depends-on (make-instance op-spec) c))
     1254
     1255(defmethod component-depends-on ((o operation) (c component))
     1256  (cdr (assoc (class-name (class-of o))
     1257              (component-in-order-to c))))
     1258
     1259(defmethod component-self-dependencies ((o operation) (c component))
     1260  (let ((all-deps (component-depends-on o c)))
     1261    (remove-if-not (lambda (x)
     1262                     (member (component-name c) (cdr x) :test #'string=))
     1263                   all-deps)))
     1264
     1265(defmethod input-files ((operation operation) (c component))
     1266  (let ((parent (component-parent c))
     1267        (self-deps (component-self-dependencies operation c)))
     1268    (if self-deps
     1269        (mapcan (lambda (dep)
     1270                  (destructuring-bind (op name) dep
     1271                    (output-files (make-instance op)
     1272                                  (find-component parent name))))
     1273                self-deps)
     1274        ;; no previous operations needed?  I guess we work with the
     1275        ;; original source file, then
     1276        (list (component-pathname c)))))
     1277
     1278(defmethod input-files ((operation operation) (c module)) nil)
     1279
     1280(defmethod operation-done-p ((o operation) (c component))
     1281  (let ((out-files (output-files o c))
     1282        (in-files (input-files o c))
     1283        (op-time (gethash (type-of o) (component-operation-times c))))
     1284    (flet ((earliest-out ()
     1285             (reduce #'min (mapcar #'safe-file-write-date out-files)))
     1286           (latest-in ()
     1287             (reduce #'max (mapcar #'safe-file-write-date in-files))))
     1288      (cond
     1289        ((and (not in-files) (not out-files))
     1290         ;; arbitrary decision: an operation that uses nothing to
     1291         ;; produce nothing probably isn't doing much.
     1292         ;; e.g. operations on systems, modules that have no immediate action,
     1293         ;; but are only meaningful through traversed dependencies
     1294         t)
     1295        ((not out-files)
     1296         ;; an operation without output-files is probably meant
     1297         ;; for its side-effects in the current image,
     1298         ;; assumed to be idem-potent,
     1299         ;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE.
     1300         (and op-time (>= op-time (latest-in))))
     1301        ((not in-files)
     1302         ;; an operation without output-files and no input-files
     1303         ;; is probably meant for its side-effects on the file-system,
     1304         ;; assumed to have to be done everytime.
     1305         ;; (I don't think there is any such case in ASDF unless extended)
     1306         nil)
     1307        (t
     1308         ;; an operation with both input and output files is assumed
     1309         ;; as computing the latter from the former,
     1310         ;; assumed to have been done if the latter are all older
     1311         ;; than the former.
     1312         ;; e.g. COMPILE-OP of some CL-SOURCE-FILE.
     1313         ;; We use >= instead of > to play nice with generated files.
     1314         ;; This opens a race condition if an input file is changed
     1315         ;; after the output is created but within the same second
     1316         ;; of filesystem time; but the same race condition exists
     1317         ;; whenever the computation from input to output takes more
     1318         ;; than one second of filesystem time (or just crosses the
     1319         ;; second). So that's cool.
     1320         (and
     1321          (every #'probe-file in-files)
     1322          (every #'probe-file out-files)
     1323          (>= (earliest-out) (latest-in))))))))
     1324
    6201325
    6211326;;; So you look at this code and think "why isn't it a bunch of
    6221327;;; methods".  And the answer is, because standard method combination
    6231328;;; runs :before methods most->least-specific, which is back to front
    624 ;;; for our purposes.  And CLISP doesn't have non-standard method
    625 ;;; combinations, so let's keep it simple and aspire to portability
    626 
    627 (defgeneric traverse (operation component))
     1329;;; for our purposes.
     1330
     1331(defvar *forcing* nil
     1332  "This dynamically-bound variable is used to force operations in
     1333recursive calls to traverse.")
     1334
    6281335(defmethod traverse ((operation operation) (c component))
    629   (let ((forced nil))
    630     (labels ((do-one-dep (required-op required-c required-v)
    631          (let* ((dep-c (or (find-component
    632           (component-parent c)
    633           ;; XXX tacky.  really we should build the
    634           ;; in-order-to slot with canonicalized
    635           ;; names instead of coercing this late
    636           (coerce-name required-c) required-v)
    637          (error 'missing-dependency :required-by c
    638           :version required-v
    639           :requires required-c)))
    640           (op (make-sub-operation c operation dep-c required-op)))
    641      (traverse op dep-c)))         
    642        (do-dep (op dep)
    643          (cond ((eq op 'feature)
    644           (or (member (car dep) *features*)
    645         (error 'missing-dependency :required-by c
    646          :requires (car dep) :version nil)))
    647          (t
    648           (dolist (d dep)
     1336  (let ((forced nil))                   ;return value -- everyone side-effects onto this
     1337    (labels ((%do-one-dep (required-op required-c required-v)
     1338               ;; returns a partial plan that results from performing required-op
     1339               ;; on required-c, possibly with a required-vERSION
     1340               (let* ((dep-c (or (find-component
     1341                                  (component-parent c)
     1342                                  ;; XXX tacky.  really we should build the
     1343                                  ;; in-order-to slot with canonicalized
     1344                                  ;; names instead of coercing this late
     1345                                  (coerce-name required-c) required-v)
     1346                                 (if required-v
     1347                                     (error 'missing-dependency-of-version
     1348                                            :required-by c
     1349                                            :version required-v
     1350                                            :requires required-c)
     1351                                     (error 'missing-dependency
     1352                                            :required-by c
     1353                                            :requires required-c))))
     1354                      (op (make-sub-operation c operation dep-c required-op)))
     1355                 (traverse op dep-c)))
     1356             (do-one-dep (required-op required-c required-v)
     1357               ;; this function is a thin, error-handling wrapper around
     1358               ;; %do-one-dep.  Returns a partial plan per that function.
     1359               (loop
     1360                 (restart-case
     1361                     (return (%do-one-dep required-op required-c required-v))
     1362                   (retry ()
     1363                     :report (lambda (s)
     1364                               (format s "~@<Retry loading component ~S.~@:>"
     1365                                       required-c))
     1366                     :test
     1367                     (lambda (c)
     1368#|
     1369                        (print (list :c1 c (typep c 'missing-dependency)))
     1370                        (when (typep c 'missing-dependency)
     1371                          (print (list :c2 (missing-requires c) required-c
     1372                                       (equalp (missing-requires c)
     1373                                               required-c))))
     1374|#
     1375                       (or (null c)
     1376                           (and (typep c 'missing-dependency)
     1377                                (equalp (missing-requires c)
     1378                                        required-c))))))))
     1379             (do-dep (op dep)
     1380               ;; type of arguments uncertain:  op seems to at least potentially be a
     1381               ;; symbol, rather than an operation
     1382               ;; dep is either a list of component names (?) or (we hope) a single
     1383               ;; component name.
     1384               ;; handle a single dependency, returns nothing of interest --- side-
     1385               ;; effects onto the FORCED variable, which is scoped over TRAVERSE
     1386               (cond ((eq op 'feature)
     1387                      (or (member (car dep) *features*)
     1388                          (error 'missing-dependency
     1389                                 :required-by c
     1390                                 :requires (car dep))))
     1391                     (t
     1392                      (dolist (d dep)
     1393                        ;; structured dependencies --- this parses keywords
     1394                        ;; the keywords could be broken out and cleanly (extensibly)
     1395                        ;; processed by EQL methods, but for the pervasive side-effecting
     1396                        ;; onto FORCED
    6491397                        (cond ((consp d)
    650                                (assert (string-equal
    651                                         (symbol-name (first d))
    652                                         "VERSION"))
    653                                (appendf forced
    654           (do-one-dep op (second d) (third d))))
     1398                               (cond ((string-equal
     1399                                       (symbol-name (first d))
     1400                                       "VERSION")
     1401                                      ;; https://bugs.launchpad.net/asdf/+bug/527788
     1402                                      (appendf
     1403                                       forced
     1404                                       (do-one-dep op (second d) (third d))))
     1405                                     ;; this particular subform is not documented, indeed
     1406                                     ;; clashes with the documentation, since it assumes a
     1407                                     ;; third component.
     1408                                     ;; See https://bugs.launchpad.net/asdf/+bug/518467
     1409                                     ((and (string-equal
     1410                                            (symbol-name (first d))
     1411                                            "FEATURE")
     1412                                           (find (second d) *features*
     1413                                                 :test 'string-equal))
     1414                                      (appendf
     1415                                       forced
     1416                                       (do-one-dep op (third d) nil)))
     1417                                     (t
     1418                                      (error "Bad dependency ~a.  Dependencies must be (:version <version>), (:feature <feature> [version]), or a name" d))))
    6551419                              (t
    6561420                               (appendf forced (do-one-dep op d nil)))))))))
    6571421      (aif (component-visited-p operation c)
    658      (return-from traverse
    659        (if (cdr it) (list (cons 'pruned-op c)) nil)))
     1422           (return-from traverse
     1423             (if (cdr it) (list (cons 'pruned-op c)) nil)))
    6601424      ;; dependencies
    6611425      (if (component-visiting-p operation c)
    662     (error 'circular-dependency :components (list c)))
     1426          (error 'circular-dependency :components (list c)))
    6631427      (setf (visiting-component operation c) t)
    664       (loop for (required-op . deps) in (component-depends-on operation c)
    665       do (do-dep required-op deps))
    666       ;; constituent bits
    667       (let ((module-ops
    668        (when (typep c 'module)
    669          (let ((at-least-one nil)
    670          (forced nil)
    671          (error nil))
    672      (loop for kid in (module-components c)
    673            do (handler-case
    674             (appendf forced (traverse operation kid ))
    675           (missing-dependency (condition)
    676             (if (eq (module-if-component-dep-fails c) :fail)
    677           (error condition))
    678             (setf error condition))
    679           (:no-error (c)
    680             (declare (ignore c))
    681             (setf at-least-one t))))
    682      (when (and (eq (module-if-component-dep-fails c) :try-next)
    683           (not at-least-one))
    684        (error error))
    685      forced))))
    686   ;; now the thing itself
    687   (when (or forced module-ops
    688       (not (operation-done-p operation c))
    689       (let ((f (operation-forced (operation-ancestor operation))))
    690         (and f (or (not (consp f))
    691              (member (component-name
    692           (operation-ancestor operation))
    693                (mapcar #'coerce-name f)
    694                :test #'string=)))))
    695     (let ((do-first (cdr (assoc (class-name (class-of operation))
    696               (slot-value c 'do-first)))))
    697       (loop for (required-op . deps) in do-first
    698       do (do-dep required-op deps)))
    699     (setf forced (append (delete 'pruned-op forced :key #'car)
    700              (delete 'pruned-op module-ops :key #'car)
    701              (list (cons operation c))))))
    702       (setf (visiting-component operation c) nil)
     1428      (unwind-protect
     1429          (progn
     1430            ;; first we check and do all the dependencies for the
     1431            ;; module.  Operations planned in this loop will show up
     1432            ;; in the contents of the FORCED variable, and are consumed
     1433            ;; downstream (watch out for the shadowing FORCED variable
     1434            ;; around the DOLIST below!)
     1435            (let ((*forcing* nil))
     1436              ;; upstream dependencies are never forced to happen just because
     1437              ;; the things that depend on them are....
     1438              (loop :for (required-op . deps) :in
     1439                                              (component-depends-on operation c)
     1440                    :do (do-dep required-op deps)))
     1441            ;; constituent bits
     1442            (let ((module-ops
     1443                   (when (typep c 'module)
     1444                     (let ((at-least-one nil)
     1445                           (forced nil)
     1446                           ;; this is set based on the results of the
     1447                           ;; dependencies and whether we are in the
     1448                           ;; context of a *forcing* call...
     1449                           (must-operate (or *forcing*
     1450                                             ;; inter-system dependencies do NOT trigger
     1451                                             ;; building components
     1452                                             (and
     1453                                              (not (typep c 'system))
     1454                                              forced)))
     1455                           (error nil))
     1456                       (dolist (kid (module-components c))
     1457                           (handler-case
     1458                               (let ((*forcing* must-operate))
     1459                                 (appendf forced (traverse operation kid)))
     1460                             (missing-dependency (condition)
     1461                               (when (eq (module-if-component-dep-fails c)
     1462                                       :fail)
     1463                                   (error condition))
     1464                               (setf error condition))
     1465                             (:no-error (c)
     1466                               (declare (ignore c))
     1467                               (setf at-least-one t))))
     1468                       (when (and (eq (module-if-component-dep-fails c)
     1469                                      :try-next)
     1470                                  (not at-least-one))
     1471                         (error error))
     1472                       forced))))
     1473              ;; now the thing itself
     1474              ;; the test here is a bit oddly written.  FORCED here doesn't
     1475              ;; mean that this operation is forced on this component, but that
     1476              ;; something upstream of this component has been forced.
     1477              (when (or forced module-ops
     1478                        *forcing*
     1479                        (not (operation-done-p operation c))
     1480                        (let ((f (operation-forced
     1481                                  (operation-ancestor operation))))
     1482                          ;; does anyone fully understand the following condition?
     1483                          ;; if so, please add a comment to explain it...
     1484                          (and f (or (not (consp f))
     1485                                     (member (component-name
     1486                                              (operation-ancestor operation))
     1487                                             (mapcar #'coerce-name f)
     1488                                             ;; this was string=, but for the benefit
     1489                                             ;; of mlisp, we use string-equal for this
     1490                                             ;; purpose.
     1491                                             :test #'string-equal)))))
     1492                (let ((do-first (cdr (assoc (class-name (class-of operation))
     1493                                            (component-do-first c)))))
     1494                  (loop :for (required-op . deps) :in do-first
     1495                        :do (do-dep required-op deps)))
     1496                (setf forced (append (delete 'pruned-op forced :key #'car)
     1497                                     (delete 'pruned-op module-ops :key #'car)
     1498                                     (list (cons operation c)))))))
     1499        (setf (visiting-component operation c) nil))
    7031500      (visit-component operation c (and forced t))
    7041501      forced)))
    705  
     1502
    7061503
    7071504(defmethod perform ((operation operation) (c source-file))
     
    7151512
    7161513(defmethod explain ((operation operation) (component component))
    717   (format *verbose-out* "~&;;; ~A on ~A~%" operation component))
    718 
    719 ;;; compile-op
     1514  (asdf-message "~&;;; ~A on ~A~%" operation component))
     1515
     1516;;;; -------------------------------------------------------------------------
     1517;;;; compile-op
    7201518
    7211519(defclass compile-op (operation)
    7221520  ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
    7231521   (on-warnings :initarg :on-warnings :accessor operation-on-warnings
    724     :initform *compile-file-warnings-behaviour*)
     1522                :initform *compile-file-warnings-behaviour*)
    7251523   (on-failure :initarg :on-failure :accessor operation-on-failure
    726          :initform *compile-file-failure-behaviour*)))
     1524               :initform *compile-file-failure-behaviour*)
     1525   (flags :initarg :flags :accessor compile-op-flags
     1526          :initform #-ecl nil #+ecl '(:system-p t))))
    7271527
    7281528(defmethod perform :before ((operation compile-op) (c source-file))
    7291529  (map nil #'ensure-directories-exist (output-files operation c)))
    7301530
     1531#+ecl
     1532(defmethod perform :after ((o compile-op) (c cl-source-file))
     1533  ;; Note how we use OUTPUT-FILES to find the binary locations
     1534  ;; This allows the user to override the names.
     1535  (let* ((input (output-files o c))
     1536         (output (compile-file-pathname (lispize-pathname (first input)) :type :fasl)))
     1537    (c:build-fasl output :lisp-files (remove "fas" input :key #'pathname-type :test #'string=))))
     1538
    7311539(defmethod perform :after ((operation operation) (c component))
    7321540  (setf (gethash (type-of operation) (component-operation-times c))
    733   (get-universal-time)))
     1541        (get-universal-time)))
    7341542
    7351543;;; perform is required to check output-files to find out where to put
     
    7381546  #-:broken-fasl-loader
    7391547  (let ((source-file (component-pathname c))
    740   (output-file (car (output-files operation c))))
     1548        (output-file (car (output-files operation c))))
    7411549    (multiple-value-bind (output warnings-p failure-p)
    742   (compile-file source-file
    743           :output-file output-file)
    744       ;(declare (ignore output))
     1550        (apply #'compile-file source-file :output-file output-file
     1551               (compile-op-flags operation))
    7451552      (when warnings-p
    746   (case (operation-on-warnings operation)
    747     (:warn (warn
    748       "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
    749       operation c))
    750     (:error (error 'compile-warned :component c :operation operation))
    751     (:ignore nil)))
     1553        (case (operation-on-warnings operation)
     1554          (:warn (warn
     1555                  "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
     1556                  operation c))
     1557          (:error (error 'compile-warned :component c :operation operation))
     1558          (:ignore nil)))
    7521559      (when failure-p
    753   (case (operation-on-failure operation)
    754     (:warn (warn
    755       "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
    756       operation c))
    757     (:error (error 'compile-failed :component c :operation operation))
    758     (:ignore nil)))
     1560        (case (operation-on-failure operation)
     1561          (:warn (warn
     1562                  "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
     1563                  operation c))
     1564          (:error (error 'compile-failed :component c :operation operation))
     1565          (:ignore nil)))
    7591566      (unless output
    760   (error 'compile-error :component c :operation operation)))))
     1567        (error 'compile-error :component c :operation operation)))))
    7611568
    7621569(defmethod output-files ((operation compile-op) (c cl-source-file))
    763   #-:broken-fasl-loader (list (compile-file-pathname (component-pathname c)))
    764   #+:broken-fasl-loader (list (component-pathname c)))
     1570  (let ((p (lispize-pathname (component-pathname c))))
     1571    #-:broken-fasl-loader
     1572    (list #-ecl (compile-file-pathname p)
     1573          #+ecl (compile-file-pathname p :type :object)
     1574          #+ecl (compile-file-pathname p :type :fasl))
     1575    #+:broken-fasl-loader (list p)))
    7651576
    7661577(defmethod perform ((operation compile-op) (c static-file))
     
    7701581  nil)
    7711582
    772 ;;; load-op
    773 
    774 (defclass load-op (operation) ())
     1583(defmethod input-files ((op compile-op) (c static-file))
     1584  nil)
     1585
     1586
     1587;;;; -------------------------------------------------------------------------
     1588;;;; load-op
     1589
     1590(defclass basic-load-op (operation) ())
     1591
     1592(defclass load-op (basic-load-op) ())
    7751593
    7761594(defmethod perform ((o load-op) (c cl-source-file))
    777   (mapcar #'load (input-files o c)))
     1595  #-ecl (mapcar #'load (input-files o c))
     1596  #+ecl (loop :for i :in (input-files o c)
     1597          :unless (string= (pathname-type i) "fas")
     1598          :collect (let ((output (compile-file-pathname (lispize-pathname i))))
     1599                     (load output))))
     1600
     1601(defmethod perform-with-restarts (operation component)
     1602  (perform operation component))
     1603
     1604(defmethod perform-with-restarts ((o load-op) (c cl-source-file))
     1605  (let ((state :initial))
     1606    (loop :until (or (eq state :success)
     1607                     (eq state :failure)) :do
     1608         (case state
     1609           (:recompiled
     1610            (setf state :failure)
     1611            (call-next-method)
     1612            (setf state :success))
     1613           (:failed-load
     1614            (setf state :recompiled)
     1615            (perform (make-instance 'compile-op) c))
     1616           (t
     1617            (with-simple-restart
     1618                (try-recompiling "Recompile ~a and try loading it again"
     1619                                  (component-name c))
     1620              (setf state :failed-load)
     1621              (call-next-method)
     1622              (setf state :success)))))))
    7781623
    7791624(defmethod perform ((operation load-op) (c static-file))
    7801625  nil)
     1626
    7811627(defmethod operation-done-p ((operation load-op) (c static-file))
    7821628  t)
     
    7891635        (call-next-method)))
    7901636
    791 ;;; load-source-op
    792 
    793 (defclass load-source-op (operation) ())
     1637;;;; -------------------------------------------------------------------------
     1638;;;; load-source-op
     1639
     1640(defclass load-source-op (basic-load-op) ())
    7941641
    7951642(defmethod perform ((o load-source-op) (c cl-source-file))
     
    8081655(defmethod component-depends-on ((o load-source-op) (c component))
    8091656  (let ((what-would-load-op-do (cdr (assoc 'load-op
    810                                            (slot-value c 'in-order-to)))))
     1657                                           (component-in-order-to c)))))
    8111658    (mapcar (lambda (dep)
    8121659              (if (eq (car dep) 'load-op)
     
    8171664(defmethod operation-done-p ((o load-source-op) (c source-file))
    8181665  (if (or (not (component-property c 'last-loaded-as-source))
    819     (> (file-write-date (component-pathname c))
    820        (component-property c 'last-loaded-as-source)))
     1666          (> (safe-file-write-date (component-pathname c))
     1667             (component-property c 'last-loaded-as-source)))
    8211668      nil t))
     1669
     1670
     1671;;;; -------------------------------------------------------------------------
     1672;;;; test-op
    8221673
    8231674(defclass test-op (operation) ())
     
    8261677  nil)
    8271678
    828 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    829 ;;; invoking operations
    830 
    831 (defun operate (operation-class system &rest args &key (verbose t) version
    832                                 &allow-other-keys)
    833   (let* ((op (apply #'make-instance operation-class
    834         :original-initargs args
    835         args))
    836    (*verbose-out* (if verbose *trace-output* (make-broadcast-stream)))
    837    (system (if (typep system 'component) system (find-system system))))
     1679(defmethod operation-done-p ((operation test-op) (c system))
     1680  "Testing a system is _never_ done."
     1681  nil)
     1682
     1683(defmethod component-depends-on :around ((o test-op) (c system))
     1684  (cons `(load-op ,(component-name c)) (call-next-method)))
     1685
     1686
     1687;;;; -------------------------------------------------------------------------
     1688;;;; Invoking Operations
     1689
     1690(defun operate (operation-class system &rest args &key (verbose t) version force
     1691                &allow-other-keys)
     1692  (declare (ignore force))
     1693  (let* ((*package* *package*)
     1694         (*readtable* *readtable*)
     1695         (op (apply #'make-instance operation-class
     1696                    :original-initargs args
     1697                    args))
     1698         (*verbose-out* (if verbose *standard-output* (make-broadcast-stream)))
     1699         (system (if (typep system 'component) system (find-system system))))
    8381700    (unless (version-satisfies system version)
    839       (error 'missing-component :requires system :version version))
     1701      (error 'missing-component-of-version :requires system :version version))
    8401702    (let ((steps (traverse op system)))
    8411703      (with-compilation-unit ()
    842   (loop for (op . component) in steps do
    843        (loop
    844     (restart-case
    845         (progn (perform op component)
    846          (return))
    847       (retry ()
    848         :report
    849         (lambda (s)
    850           (format s "~@<Retry performing ~S on ~S.~@:>"
    851             op component)))
    852       (accept ()
    853         :report
    854         (lambda (s)
    855           (format s
    856             "~@<Continue, treating ~S on ~S as ~
    857                                having been successful.~@:>"
    858             op component))
    859         (setf (gethash (type-of op)
    860            (component-operation-times component))
    861         (get-universal-time))
    862         (return)))))))))
    863 
    864 (defun oos (&rest args)
    865   "Alias of OPERATE function"
    866   (apply #'operate args))
    867 
    868 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    869 ;;; syntax
    870 
    871 (defun remove-keyword (key arglist)
    872   (labels ((aux (key arglist)
    873        (cond ((null arglist) nil)
    874        ((eq key (car arglist)) (cddr arglist))
    875        (t (cons (car arglist) (cons (cadr arglist)
    876             (remove-keyword
    877              key (cddr arglist))))))))
    878     (aux key arglist)))
     1704        (loop :for (op . component) :in steps :do
     1705          (loop
     1706            (restart-case
     1707                (progn (perform-with-restarts op component)
     1708                       (return))
     1709              (retry ()
     1710                :report
     1711                (lambda (s)
     1712                  (format s "~@<Retry performing ~S on ~S.~@:>"
     1713                          op component)))
     1714              (accept ()
     1715                :report
     1716                (lambda (s)
     1717                  (format s "~@<Continue, treating ~S on ~S as ~
     1718                                   having been successful.~@:>"
     1719                          op component))
     1720                (setf (gethash (type-of op)
     1721                               (component-operation-times component))
     1722                      (get-universal-time))
     1723                (return)))))))
     1724    op))
     1725
     1726(defun oos (operation-class system &rest args &key force (verbose t) version
     1727            &allow-other-keys)
     1728  (declare (ignore force verbose version))
     1729  (apply #'operate operation-class system args))
     1730
     1731(let ((operate-docstring
     1732  "Operate does three things:
     1733
     17341. It creates an instance of `operation-class` using any keyword parameters
     1735as initargs.
     17362. It finds the  asdf-system specified by `system` (possibly loading
     1737it from disk).
     17383. It then calls `traverse` with the operation and system as arguments
     1739
     1740The traverse operation is wrapped in `with-compilation-unit` and error
     1741handling code. If a `version` argument is supplied, then operate also
     1742ensures that the system found satisfies it using the `version-satisfies`
     1743method.
     1744
     1745Note that dependencies may cause the operation to invoke other
     1746operations on the system or its components: the new operations will be
     1747created with the same initargs as the original one.
     1748"))
     1749  (setf (documentation 'oos 'function)
     1750        (format nil
     1751                "Short for _operate on system_ and an alias for the OPERATE function. ~&~&~a"
     1752                operate-docstring))
     1753  (setf (documentation 'operate 'function)
     1754        operate-docstring))
     1755
     1756(defun load-system (system &rest args &key force (verbose t) version
     1757                    &allow-other-keys)
     1758  "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for
     1759details."
     1760  (declare (ignore force verbose version))
     1761  (apply #'operate 'load-op system args))
     1762
     1763(defun compile-system (system &rest args &key force (verbose t) version
     1764                       &allow-other-keys)
     1765  "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE
     1766for details."
     1767  (declare (ignore force verbose version))
     1768  (apply #'operate 'compile-op system args))
     1769
     1770(defun test-system (system &rest args &key force (verbose t) version
     1771                    &allow-other-keys)
     1772  "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for
     1773details."
     1774  (declare (ignore force verbose version))
     1775  (apply #'operate 'test-op system args))
     1776
     1777;;;; -------------------------------------------------------------------------
     1778;;;; Defsystem
     1779
     1780(defun determine-system-pathname (pathname pathname-supplied-p)
     1781  ;; called from the defsystem macro.
     1782  ;; the pathname of a system is either
     1783  ;; 1. the one supplied,
     1784  ;; 2. derived from the *load-truename* (see below), or
     1785  ;; 3. taken from *default-pathname-defaults*
     1786  ;;
     1787  ;; if using *load-truename*, then we also deal with whether or not
     1788  ;; to resolve symbolic links. If not resolving symlinks, then we use
     1789  ;; *load-pathname* instead of *load-truename* since in some
     1790  ;; implementations, the latter has *already resolved it.
     1791  (let ((file-pathname
     1792         (when (or *load-pathname* *compile-file-pathname*)
     1793           (pathname-directory-pathname
     1794            (if *resolve-symlinks*
     1795                (resolve-symlinks (or *load-truename* *compile-file-truename*))
     1796                *load-pathname*)))))
     1797    (or (and pathname-supplied-p (merge-pathnames* pathname file-pathname))
     1798        file-pathname
     1799        (current-directory))))
    8791800
    8801801(defmacro defsystem (name &body options)
    881   (destructuring-bind (&key pathname (class 'system) &allow-other-keys) options
     1802  (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
     1803                            &allow-other-keys)
     1804      options
    8821805    (let ((component-options (remove-keyword :class options)))
    8831806      `(progn
    884   ;; system must be registered before we parse the body, otherwise
    885   ;; we recur when trying to find an existing system of the same name
    886   ;; to reuse options (e.g. pathname) from
    887   (let ((s (system-registered-p ',name)))
    888     (cond ((and s (eq (type-of (cdr s)) ',class))
    889      (setf (car s) (get-universal-time)))
    890     (s
    891      #+clisp
    892      (sysdef-error "Cannot redefine the existing system ~A with a different class" s)
    893      #-clisp
    894      (change-class (cdr s) ',class))
    895     (t
    896      (register-system (quote ,name)
    897           (make-instance ',class :name ',name)))))
    898   (parse-component-form nil (apply
    899            #'list
    900            :module (coerce-name ',name)
    901            :pathname
    902            (or ,pathname
    903                (pathname-sans-name+type
    904           (resolve-symlinks  *load-truename*))
    905                *default-pathname-defaults*)
    906            ',component-options))))))
    907  
     1807         ;; system must be registered before we parse the body, otherwise
     1808         ;; we recur when trying to find an existing system of the same name
     1809         ;; to reuse options (e.g. pathname) from
     1810         (let ((s (system-registered-p ',name)))
     1811           (cond ((and s (eq (type-of (cdr s)) ',class))
     1812                  (setf (car s) (get-universal-time)))
     1813                 (s
     1814                  (change-class (cdr s) ',class))
     1815                 (t
     1816                  (register-system (quote ,name)
     1817                                   (make-instance ',class :name ',name))))
     1818           (%set-system-source-file *load-truename*
     1819                                    (cdr (system-registered-p ',name))))
     1820         (parse-component-form
     1821          nil (apply
     1822               #'list
     1823               :module (coerce-name ',name)
     1824               :pathname
     1825               ,(determine-system-pathname pathname pathname-arg-p)
     1826               ',component-options))))))
     1827
    9081828
    9091829(defun class-for-type (parent type)
    910   (let ((class
    911    (find-class
    912     (or (find-symbol (symbol-name type) *package*)
    913         (find-symbol (symbol-name type) #.(package-name *package*)))
    914     nil)))
     1830  (let* ((extra-symbols (list (find-symbol (symbol-name type) *package*)
     1831                              (find-symbol (symbol-name type)
     1832                                           (load-time-value
     1833                                            (package-name :asdf)))))
     1834         (class (dolist (symbol (if (keywordp type)
     1835                                    extra-symbols
     1836                                    (cons type extra-symbols)))
     1837                  (when (and symbol
     1838                             (find-class symbol nil)
     1839                             (subtypep symbol 'component))
     1840                    (return (find-class symbol))))))
    9151841    (or class
    916   (and (eq type :file)
    917        (or (module-default-component-class parent)
    918     (find-class 'cl-source-file)))
    919   (sysdef-error "~@<don't recognize component type ~A~@:>" type))))
     1842        (and (eq type :file)
     1843             (or (module-default-component-class parent)
     1844                (find-class 'cl-source-file)))
     1845        (sysdef-error "~@<don't recognize component type ~A~@:>" type))))
    9201846
    9211847(defun maybe-add-tree (tree op1 op2 c)
     
    9241850  (let ((first-op-tree (assoc op1 tree)))
    9251851    (if first-op-tree
    926   (progn
    927     (aif (assoc op2 (cdr first-op-tree))
    928          (if (find c (cdr it))
    929        nil
    930        (setf (cdr it) (cons c (cdr it))))
    931          (setf (cdr first-op-tree)
    932          (acons op2 (list c) (cdr first-op-tree))))
    933     tree)
    934   (acons op1 (list (list op2 c)) tree))))
    935    
     1852        (progn
     1853          (aif (assoc op2 (cdr first-op-tree))
     1854               (if (find c (cdr it))
     1855                   nil
     1856                   (setf (cdr it) (cons c (cdr it))))
     1857               (setf (cdr first-op-tree)
     1858                     (acons op2 (list c) (cdr first-op-tree))))
     1859          tree)
     1860        (acons op1 (list (list op2 c)) tree))))
     1861
    9361862(defun union-of-dependencies (&rest deps)
    9371863  (let ((new-tree nil))
    9381864    (dolist (dep deps)
    9391865      (dolist (op-tree dep)
    940   (dolist (op  (cdr op-tree))
    941     (dolist (c (cdr op))
    942       (setf new-tree
    943       (maybe-add-tree new-tree (car op-tree) (car op) c))))))
     1866        (dolist (op  (cdr op-tree))
     1867          (dolist (c (cdr op))
     1868            (setf new-tree
     1869                  (maybe-add-tree new-tree (car op-tree) (car op) c))))))
    9441870    new-tree))
    9451871
    9461872
    947 (defun remove-keys (key-names args)
    948   (loop for ( name val ) on args by #'cddr
    949   unless (member (symbol-name name) key-names
    950            :key #'symbol-name :test 'equal)
    951   append (list name val)))
    952 
    9531873(defvar *serial-depends-on*)
    9541874
    955 (defun parse-component-form (parent options)
    956   (destructuring-bind
    957   (type name &rest rest &key
    958         ;; the following list of keywords is reproduced below in the
    959         ;; remove-keys form.  important to keep them in sync
    960         components pathname default-component-class
    961         perform explain output-files operation-done-p
    962         weakly-depends-on
    963         depends-on serial in-order-to
    964         ;; list ends
    965         &allow-other-keys) options
    966     (check-component-input type name weakly-depends-on depends-on components in-order-to)
    967 
    968     (when (and parent
    969        (find-component parent name)
    970        ;; ignore the same object when rereading the defsystem
    971        (not
    972         (typep (find-component parent name)
    973          (class-for-type parent type))))       
    974       (error 'duplicate-names :name name))
    975    
    976     (let* ((other-args (remove-keys
    977       '(components pathname default-component-class
    978         perform explain output-files operation-done-p
    979         weakly-depends-on
    980         depends-on serial in-order-to)
    981       rest))
    982      (ret
    983       (or (find-component parent name)
    984     (make-instance (class-for-type parent type)))))
    985       (when weakly-depends-on
    986   (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on))))
    987       (when (boundp '*serial-depends-on*)
    988   (setf depends-on
    989         (concatenate 'list *serial-depends-on* depends-on)))     
    990       (apply #'reinitialize-instance
    991        ret
    992        :name (coerce-name name)
    993        :pathname pathname
    994        :parent parent
    995        other-args)
    996       (when (typep ret 'module)
    997   (setf (module-default-component-class ret)
    998         (or default-component-class
    999       (and (typep parent 'module)
    1000            (module-default-component-class parent))))
    1001   (let ((*serial-depends-on* nil))
    1002     (setf (module-components ret)
    1003     (loop for c-form in components
    1004           for c = (parse-component-form ret c-form)
    1005           collect c
    1006           if serial
    1007           do (push (component-name c) *serial-depends-on*))))
    1008 
    1009   ;; check for duplicate names
    1010   (let ((name-hash (make-hash-table :test #'equal)))
    1011     (loop for c in (module-components ret)
    1012     do
    1013     (if (gethash (component-name c)
    1014            name-hash)
    1015         (error 'duplicate-names
    1016          :name (component-name c))
    1017       (setf (gethash (component-name c)
    1018          name-hash)
    1019       t)))))
    1020      
    1021       (setf (slot-value ret 'in-order-to)
    1022       (union-of-dependencies
    1023        in-order-to
    1024        `((compile-op (compile-op ,@depends-on))
    1025          (load-op (load-op ,@depends-on))))
    1026       (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on))))
    1027      
    1028       (loop for (n v) in `((perform ,perform) (explain ,explain)
    1029          (output-files ,output-files)
    1030          (operation-done-p ,operation-done-p))
    1031       do (map 'nil
    1032         ;; this is inefficient as most of the stored
    1033         ;; methods will not be for this particular gf n
    1034         ;; But this is hardly performance-critical
    1035         (lambda (m) (remove-method (symbol-function n) m))
    1036         (component-inline-methods ret))
    1037       when v
    1038       do (destructuring-bind (op qual (o c) &body body) v
    1039      (pushnew
    1040       (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret)))
    1041         ,@body))
    1042       (component-inline-methods ret))))
    1043       ret)))
    1044 
    1045 (defun check-component-input (type name weakly-depends-on depends-on components in-order-to)
     1875(defun sysdef-error-component (msg type name value)
     1876  (sysdef-error (concatenate 'string msg
     1877                             "~&The value specified for ~(~A~) ~A is ~W")
     1878                type name value))
     1879
     1880(defun check-component-input (type name weakly-depends-on
     1881                              depends-on components in-order-to)
    10461882  "A partial test of the values of a component."
    1047   (when weakly-depends-on (warn "We got one! XXXXX"))
    10481883  (unless (listp depends-on)
    10491884    (sysdef-error-component ":depends-on must be a list."
    1050           type name depends-on))
     1885                            type name depends-on))
    10511886  (unless (listp weakly-depends-on)
    10521887    (sysdef-error-component ":weakly-depends-on must be a list."
    1053           type name weakly-depends-on))
     1888                            type name weakly-depends-on))
    10541889  (unless (listp components)
    10551890    (sysdef-error-component ":components must be NIL or a list of components."
    1056           type name components))
     1891                            type name components))
    10571892  (unless (and (listp in-order-to) (listp (car in-order-to)))
    10581893    (sysdef-error-component ":in-order-to must be NIL or a list of components."
    1059          type name in-order-to)))
    1060 
    1061 (defun sysdef-error-component (msg type name value)
    1062   (sysdef-error (concatenate 'string msg
    1063            "~&The value specified for ~(~A~) ~A is ~W")
    1064     type name value))
    1065 
    1066 (defun resolve-symlinks (path)
    1067   #-allegro (truename path)
    1068   #+allegro (excl:pathname-resolve-symbolic-links path)
    1069   )
    1070 
    1071 ;;; optional extras
    1072 
    1073 ;;; run-shell-command functions for other lisp implementations will be
    1074 ;;; gratefully accepted, if they do the same thing.  If the docstring
    1075 ;;; is ambiguous, send a bug report
     1894                            type name in-order-to)))
     1895
     1896(defun %remove-component-inline-methods (component)
     1897  (dolist (name +asdf-methods+)
     1898    (map ()
     1899         ;; this is inefficient as most of the stored
     1900         ;; methods will not be for this particular gf
     1901         ;; But this is hardly performance-critical
     1902         (lambda (m)
     1903           (remove-method (symbol-function name) m))
     1904         (component-inline-methods component)))
     1905  ;; clear methods, then add the new ones
     1906  (setf (component-inline-methods component) nil))
     1907
     1908(defun %define-component-inline-methods (ret rest)
     1909  (dolist (name +asdf-methods+)
     1910    (let ((keyword (intern (symbol-name name) :keyword)))
     1911      (loop :for data = rest :then (cddr data)
     1912        :for key = (first data)
     1913        :for value = (second data)
     1914        :while data
     1915        :when (eq key keyword) :do
     1916        (destructuring-bind (op qual (o c) &body body) value
     1917          (pushnew
     1918           (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
     1919                             ,@body))
     1920           (component-inline-methods ret)))))))
     1921
     1922(defun %refresh-component-inline-methods (component rest)
     1923  (%remove-component-inline-methods component)
     1924  (%define-component-inline-methods component rest))
     1925
     1926(defun parse-component-form (parent options)
     1927
     1928  (destructuring-bind
     1929        (type name &rest rest &key
     1930              ;; the following list of keywords is reproduced below in the
     1931              ;; remove-keys form.  important to keep them in sync
     1932              components pathname default-component-class
     1933              perform explain output-files operation-done-p
     1934              weakly-depends-on
     1935              depends-on serial in-order-to
     1936              ;; list ends
     1937              &allow-other-keys) options
     1938    (declare (ignorable perform explain output-files operation-done-p))
     1939    (check-component-input type name weakly-depends-on depends-on components in-order-to)
     1940
     1941    (when (and parent
     1942               (find-component parent name)
     1943               ;; ignore the same object when rereading the defsystem
     1944               (not
     1945                (typep (find-component parent name)
     1946                       (class-for-type parent type))))
     1947      (error 'duplicate-names :name name))
     1948
     1949    (let* ((other-args (remove-keys
     1950                        '(components pathname default-component-class
     1951                          perform explain output-files operation-done-p
     1952                          weakly-depends-on
     1953                          depends-on serial in-order-to)
     1954                        rest))
     1955           (ret
     1956            (or (find-component parent name)
     1957                (make-instance (class-for-type parent type)))))
     1958      (when weakly-depends-on
     1959        (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on))))
     1960      (when (boundp '*serial-depends-on*)
     1961        (setf depends-on
     1962              (concatenate 'list *serial-depends-on* depends-on)))
     1963      (apply #'reinitialize-instance ret
     1964             :name (coerce-name name)
     1965             :pathname pathname
     1966             :parent parent
     1967             other-args)
     1968      (component-pathname ret) ; eagerly compute the absolute pathname
     1969      (when (typep ret 'module)
     1970        (setf (module-default-component-class ret)
     1971              (or default-component-class
     1972                  (and (typep parent 'module)
     1973                       (module-default-component-class parent))))
     1974        (let ((*serial-depends-on* nil))
     1975          (setf (module-components ret)
     1976                (loop :for c-form :in components
     1977                  :for c = (parse-component-form ret c-form)
     1978                  :collect c
     1979                  :if serial
     1980                  :do (push (component-name c) *serial-depends-on*))))
     1981
     1982        ;; check for duplicate names
     1983        (let ((name-hash (make-hash-table :test #'equal)))
     1984          (loop :for c in (module-components ret) :do
     1985            (if (gethash (component-name c)
     1986                         name-hash)
     1987                (error 'duplicate-names :name (component-name c))
     1988                (setf (gethash (component-name c)
     1989                               name-hash)
     1990                      t)))))
     1991
     1992      (setf (component-in-order-to ret)
     1993            (union-of-dependencies
     1994             in-order-to
     1995             `((compile-op (compile-op ,@depends-on))
     1996               (load-op (load-op ,@depends-on))))
     1997            (component-do-first ret) `((compile-op (load-op ,@depends-on))))
     1998
     1999      (%refresh-component-inline-methods ret rest)
     2000      ret)))
     2001
     2002;;;; ---------------------------------------------------------------------------
     2003;;;; run-shell-command
     2004;;;;
     2005;;;; run-shell-command functions for other lisp implementations will be
     2006;;;; gratefully accepted, if they do the same thing.
     2007;;;; If the docstring is ambiguous, send a bug report.
     2008;;;;
     2009;;;; We probably should move this functionality to its own system and deprecate
     2010;;;; use of it from the asdf package. However, this would break unspecified
     2011;;;; existing software, so until a clear alternative exists, we can't deprecate
     2012;;;; it, and even after it's been deprecated, we will support it for a few
     2013;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01
    10762014
    10772015(defun run-shell-command (control-string &rest args)
    1078   "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
     2016  "Interpolate `args` into `control-string` as if by `format`, and
    10792017synchronously execute the result using a Bourne-compatible shell, with
    1080 output to *VERBOSE-OUT*.  Returns the shell's exit code."
     2018output to `*verbose-out*`.  Returns the shell's exit code."
    10812019  (let ((command (apply #'format nil control-string args)))
    1082     (format *verbose-out* "; $ ~A~%" command)
     2020    (asdf-message "; $ ~A~%" command)
    10832021    #+sbcl
    10842022    (sb-ext:process-exit-code
    1085      (sb-ext:run-program 
    1086       #+win32 "sh" #-win32 "/bin/sh"
    1087       (list  "-c" command)
    1088       #+win32 #+win32 :search t
    1089       :input nil :output *verbose-out*))
    1090    
     2023     (apply #'sb-ext:run-program
     2024            #+win32 "sh" #-win32 "/bin/sh"
     2025            (list  "-c" command)
     2026            :input nil :output *verbose-out*
     2027            #+win32 '(:search t) #-win32 nil))
     2028
    10912029    #+(or cmu scl)
    10922030    (ext:process-exit-code
    1093      (ext:run-program 
     2031     (ext:run-program
    10942032      "/bin/sh"
    10952033      (list  "-c" command)
     
    10972035
    10982036    #+allegro
    1099     (excl:run-shell-command command :input nil :output *verbose-out*)
    1100    
     2037    ;; will this fail if command has embedded quotes - it seems to work
     2038    (multiple-value-bind (stdout stderr exit-code)
     2039        (excl.osi:command-output
     2040         (format nil "~a -c \"~a\""
     2041                 #+mswindows "sh" #-mswindows "/bin/sh" command)
     2042         :input nil :whole nil
     2043         #+mswindows :show-window #+mswindows :hide)
     2044      (format *verbose-out* "~{~&; ~a~%~}~%" stderr)
     2045      (format *verbose-out* "~{~&; ~a~%~}~%" stdout)
     2046      exit-code)
     2047
    11012048    #+lispworks
    11022049    (system:call-system-showing-output
    11032050     command
    11042051     :shell-type "/bin/sh"
     2052     :show-cmd nil
     2053     :prefix ""
    11052054     :output-stream *verbose-out*)
    1106    
    1107     #+clisp       ;XXX not exactly *verbose-out*, I know
     2055
     2056    #+clisp                     ;XXX not exactly *verbose-out*, I know
    11082057    (ext:run-shell-command  command :output :terminal :wait t)
    11092058
    11102059    #+openmcl
    11112060    (nth-value 1
    1112          (ccl:external-process-status
    1113     (ccl:run-program "/bin/sh" (list "-c" command)
    1114          :input nil :output *verbose-out*
    1115          :wait t)))
     2061               (ccl:external-process-status
     2062                (ccl:run-program "/bin/sh" (list "-c" command)
     2063                                 :input nil :output *verbose-out*
     2064                                 :wait t)))
     2065
    11162066    #+ecl ;; courtesy of Juan Jose Garcia Ripoll
    11172067    (si:system command)
    1118    
     2068
    11192069    #+abcl
    11202070    (ext:run-shell-command command :output *verbose-out*)
     2071
    11212072    #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl abcl)
    1122     (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
     2073    (error "RUN-SHELL-COMMAND not implemented for this Lisp")
    11232074    ))
    11242075
    1125 
    1126 (defgeneric hyperdocumentation (package name doc-type))
    1127 (defmethod hyperdocumentation ((package symbol) name doc-type)
    1128   (hyperdocumentation (find-package package) name doc-type))
    1129 
    1130 (defun hyperdoc (name doc-type)
    1131   (hyperdocumentation (symbol-package name) name doc-type))
    1132 
    1133 
    1134 (pushnew :asdf *features*)
    1135 
    1136 #+sbcl
    1137 (eval-when (:compile-toplevel :load-toplevel :execute)
    1138   (when (sb-ext:posix-getenv "SBCL_BUILDING_CONTRIB")
    1139     (pushnew :sbcl-hooks-require *features*)))
    1140 
    1141 #+(and sbcl sbcl-hooks-require)
     2076;;;; ---------------------------------------------------------------------------
     2077;;;; system-relative-pathname
     2078
     2079(defmethod system-source-file ((system-name string))
     2080  (system-source-file (find-system system-name)))
     2081(defmethod system-source-file ((system-name symbol))
     2082  (system-source-file (find-system system-name)))
     2083
     2084(defun system-source-directory (system-designator)
     2085  "Return a pathname object corresponding to the
     2086directory in which the system specification (.asd file) is
     2087located."
     2088     (make-pathname :name nil
     2089                 :type nil
     2090                 :defaults (system-source-file system-designator)))
     2091
     2092(defun relativize-directory (directory)
     2093  (if (eq (car directory) :absolute)
     2094      (cons :relative (cdr directory))
     2095      directory))
     2096
     2097(defun relativize-pathname-directory (pathspec)
     2098  (let ((p (pathname pathspec)))
     2099    (make-pathname
     2100     :directory (relativize-directory (pathname-directory p))
     2101     :defaults p)))
     2102
     2103(defun system-relative-pathname (system name &key type)
     2104  (merge-pathnames*
     2105   (merge-component-name-type name :type type)
     2106   (system-source-directory system)))
     2107
     2108
     2109;;; ---------------------------------------------------------------------------
     2110;;; implementation-identifier
     2111;;;
     2112;;; produce a string to identify current implementation.
     2113;;; Initially stolen from SLIME's SWANK, hacked since.
     2114
     2115(defparameter *implementation-features*
     2116  '(:allegro :lispworks :sbcl :clozure :digitool :cmu :clisp
     2117    :corman :cormanlisp :armedbear :gcl :ecl :scl))
     2118
     2119(defparameter *os-features*
     2120  '((:windows :mswindows :win32 :mingw32)
     2121    (:solaris :sunos)
     2122    :macosx :darwin :apple
     2123    :freebsd :netbsd :openbsd :bsd
     2124    :linux :unix))
     2125
     2126(defparameter *architecture-features*
     2127  '((:x86-64 :amd64 :x86_64 :x8664-target)
     2128    (:x86 :i686 :i586 :pentium3 :i486 :i386 :pc386 :iapx386 :x8632-target :pentium4)
     2129    :hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc))
     2130
     2131(defun lisp-version-string ()
     2132  (let ((s (lisp-implementation-version)))
     2133    (declare (ignorable s))
     2134    #+(or scl sbcl ecl armedbear cormanlisp mcl) s
     2135    #+cmu (substitute #\- #\/ s)
     2136    #+clozure (format nil "~d.~d~@[-~d~]"
     2137                      ccl::*openmcl-major-version*
     2138                      ccl::*openmcl-minor-version*
     2139                      #+ppc64-target 64
     2140                      #-ppc64-target nil)
     2141    #+lispworks (format nil "~A~@[~A~]" s
     2142                        (when (member :lispworks-64bit *features*) "-64bit"))
     2143    #+allegro (format nil
     2144                      "~A~A~A~A"
     2145                      excl::*common-lisp-version-number*
     2146                      ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
     2147                      (if (eq excl:*current-case-mode*
     2148                              :case-sensitive-lower) "M" "A")
     2149                      ;; Note if not using International ACL
     2150                      ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
     2151                      (excl:ics-target-case
     2152                       (:-ics "8")
     2153                       (:+ics ""))
     2154                      (if (member :64bit *features*) "-64bit" ""))
     2155    #+(or clisp gcl) (subseq s 0 (position #\space s))
     2156    #+digitool (subseq s 8)))
     2157
     2158(defun first-feature (features)
     2159  (labels
     2160      ((fp (thing)
     2161         (etypecase thing
     2162           (symbol
     2163            (let ((feature (find thing *features*)))
     2164              (when feature (return-from fp feature))))
     2165           ;; allows features to be lists of which the first
     2166           ;; member is the "main name", the rest being aliases
     2167           (cons
     2168            (dolist (subf thing)
     2169              (when (find subf *features*) (return-from fp (first thing))))))
     2170         nil))
     2171    (loop :for f :in features
     2172      :when (fp f) :return :it)))
     2173
     2174(defun implementation-type ()
     2175  (first-feature *implementation-features*))
     2176
     2177(defun implementation-identifier ()
     2178  (labels
     2179      ((maybe-warn (value fstring &rest args)
     2180         (cond (value)
     2181               (t (apply #'warn fstring args)
     2182                  "unknown"))))
     2183    (let ((lisp (maybe-warn (implementation-type)
     2184                            "No implementation feature found in ~a."
     2185                            *implementation-features*))
     2186          (os   (maybe-warn (first-feature *os-features*)
     2187                            "No os feature found in ~a." *os-features*))
     2188          (arch (maybe-warn (first-feature *architecture-features*)
     2189                            "No architecture feature found in ~a."
     2190                            *architecture-features*))
     2191          (version (maybe-warn (lisp-version-string)
     2192                               "Don't know how to get Lisp ~
     2193                                          implementation version.")))
     2194      (substitute-if
     2195       #\_ (lambda (x) (find x " /:\\(){}[]$#`'\""))
     2196       (format nil "~(~@{~a~^-~}~)" lisp version os arch)))))
     2197
     2198
     2199
     2200;;; ---------------------------------------------------------------------------
     2201;;; Generic support for configuration files
     2202
     2203(defparameter *inter-directory-separator*
     2204  #+(or unix cygwin) #\:
     2205  #-(or unix cygwin) #\;)
     2206
     2207(defun user-homedir ()
     2208  (truename (user-homedir-pathname)))
     2209
     2210(defun try-directory-subpath (x sub &key type)
     2211  (let* ((p (and x (ensure-directory-pathname x)))
     2212         (tp (and p (ignore-errors (truename p))))
     2213         (sp (and tp (merge-pathnames* (merge-component-name-type sub :type type) p)))
     2214         (ts (and sp (ignore-errors (truename sp)))))
     2215    (and ts (values sp ts))))
     2216(defun user-configuration-directories ()
     2217  (remove-if
     2218   #'null
     2219   (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
     2220     `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/")
     2221       ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")
     2222           :for dir :in (split-string dirs :separator ":")
     2223           :collect (try dir "common-lisp/"))
     2224       #+windows
     2225        ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/")
     2226            ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
     2227           #+(not cygwin)
     2228           ,(try (or (getenv "USERPROFILE") (user-homedir))
     2229                 "Application Data/common-lisp/config/"))
     2230       ,(try (user-homedir) ".config/common-lisp/")))))
     2231(defun system-configuration-directories ()
     2232  (remove-if
     2233   #'null
     2234   (append
     2235    #+windows
     2236    (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
     2237      `(
     2238       ,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")
     2239           ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
     2240           #+(not cygwin)
     2241           ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
     2242    (list #p"/etc/"))))
     2243(defun in-first-directory (dirs x)
     2244  (loop :for dir :in dirs
     2245    :thereis (and dir (ignore-errors (truename (merge-pathnames* x (ensure-directory-pathname dir)))))))
     2246(defun in-user-configuration-directory (x)
     2247  (in-first-directory (user-configuration-directories) x))
     2248(defun in-system-configuration-directory (x)
     2249  (in-first-directory (system-configuration-directories) x))
     2250
     2251(defun configuration-inheritance-directive-p (x)
     2252  (let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
     2253    (or (member x kw)
     2254        (and (length=n-p x 1) (member (car x) kw)))))
     2255
     2256(defun validate-configuration-form (form tag directive-validator
     2257                                    &optional (description tag))
     2258  (unless (and (consp form) (eq (car form) tag))
     2259    (error "Error: Form doesn't specify ~A ~S~%" description form))
     2260  (loop :with inherit = 0
     2261    :for directive :in (cdr form) :do
     2262    (if (configuration-inheritance-directive-p directive)
     2263        (incf inherit)
     2264        (funcall directive-validator directive))
     2265    :finally
     2266    (unless (= inherit 1)
     2267      (error "One and only one of ~S or ~S is required"
     2268             :inherit-configuration :ignore-inherited-configuration)))
     2269  form)
     2270
     2271(defun validate-configuration-file (file validator description)
     2272  (let ((forms (read-file-forms file)))
     2273    (unless (length=n-p forms 1)
     2274      (error "One and only one form allowed for ~A. Got: ~S~%" description forms))
     2275    (funcall validator (car forms))))
     2276
     2277(defun validate-configuration-directory (directory tag validator)
     2278  (let ((files (sort (ignore-errors
     2279                       (directory (make-pathname :name :wild :type :wild :defaults directory)
     2280                                  #+sbcl :resolve-symlinks #+sbcl nil))
     2281                     #'string< :key #'namestring)))
     2282    `(,tag
     2283      ,@(loop :for file :in files :append
     2284          (mapcar validator (read-file-forms file)))
     2285      :inherit-configuration)))
     2286
     2287
     2288;;; ---------------------------------------------------------------------------
     2289;;; asdf-output-translations
     2290;;;
     2291;;; this code is heavily inspired from
     2292;;; asdf-binary-translations, common-lisp-controller and cl-launch.
     2293;;; ---------------------------------------------------------------------------
     2294
     2295(defvar *output-translations* ()
     2296  "Either NIL (for uninitialized), or a list of one element,
     2297said element itself being a sorted list of mappings.
     2298Each mapping is a pair of a source pathname and destination pathname,
     2299and the order is by decreasing length of namestring of the source pathname.")
     2300
     2301(defvar *user-cache*
     2302  (or
     2303   (let ((h (getenv "XDG_CACHE_HOME")))
     2304     (and h `(,h "common-lisp" :implementation)))
     2305   #+(and windows lispworks)
     2306   (let ((h (sys:get-folder-path :common-appdata))) ;; no :common-caches in Windows???
     2307     (and h `(,h "common-lisp" "cache")))
     2308   #+(and windows (not cygwin))
     2309   ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Cache
     2310   (let ((h (or (getenv "USERPROFILE") (user-homedir))))
     2311     (and h `(,h "Local Settings" "Temporary Internet Files" "common-lisp")))
     2312   '(:home ".cache" "common-lisp" :implementation)))
     2313(defvar *system-cache*
     2314  (or
     2315   #+(and windows lispworks)
     2316   (let ((h (sys:get-folder-path :common-appdata))) ;; no :common-caches in Windows???
     2317     (and h `(,h "common-lisp" "cache")))
     2318   #+windows
     2319   (let ((h (or (getenv "USERPROFILE") (user-homedir))))
     2320     (and h `(,h "Local Settings" "Temporary Internet Files" "common-lisp")))
     2321   #+(or unix cygwin)
     2322   '("/var/cache/common-lisp" :uid :implementation)))
     2323
     2324(defun output-translations ()
     2325  (car *output-translations*))
     2326
     2327(defun (setf output-translations) (new-value)
     2328  (setf *output-translations*
     2329        (list
     2330         (stable-sort (copy-list new-value) #'>
     2331                      :key (lambda (x)
     2332                             (etypecase (car x)
     2333                               ((eql t) -1)
     2334                               (pathname
     2335                                (length (pathname-directory (car x)))))))))
     2336  new-value)
     2337
     2338(defun output-translations-initialized-p ()
     2339  (and *output-translations* t))
     2340
     2341(defun clear-output-translations ()
     2342  "Undoes any initialization of the output translations.
     2343You might want to call that before you dump an image that would be resumed
     2344with a different configuration, so the configuration would be re-read then."
     2345  (setf *output-translations* '())
     2346  (values))
     2347
     2348(defparameter *wild-path*
     2349  (make-pathname :directory '(:relative :wild-inferiors)
     2350                 :name :wild :type :wild :version :wild))
     2351
     2352(defparameter *wild-asd*
     2353  (make-pathname :directory '(:relative :wild-inferiors)
     2354                 :name :wild :type "asd" :version :newest))
     2355
     2356(defun wilden (path)
     2357  (merge-pathnames* *wild-path* path))
     2358
     2359(defun resolve-absolute-location-component (x wildenp)
     2360  (let* ((r
     2361          (etypecase x
     2362            (pathname x)
     2363            (string (ensure-directory-pathname x))
     2364            (cons
     2365             (let ((car (resolve-absolute-location-component (car x) nil)))
     2366               (if (null (cdr x))
     2367                   car
     2368                   (let ((cdr (resolve-relative-location-component
     2369                               car (cdr x) wildenp)))
     2370                     (merge-pathnames* cdr car)))))
     2371            ((eql :root)
     2372             ;; special magic! we encode such paths as relative pathnames,
     2373             ;; but it means "relative to the root of the source pathname's host and device".
     2374             (return-from resolve-absolute-location-component
     2375               (make-pathname :directory '(:relative))))
     2376            ((eql :home) (user-homedir))
     2377            ((eql :user-cache) (resolve-location *user-cache* nil))
     2378            ((eql :system-cache) (resolve-location *system-cache* nil))
     2379            ((eql :current-directory) (current-directory))))
     2380         (s (if (and wildenp (not (pathnamep x)))
     2381                (wilden r)
     2382                r)))
     2383    (unless (absolute-pathname-p s)
     2384      (error "Not an absolute pathname ~S" s))
     2385    s))
     2386
     2387(defun resolve-relative-location-component (super x &optional wildenp)
     2388  (let* ((r (etypecase x
     2389              (pathname x)
     2390              (string x)
     2391              (cons
     2392               (let ((car (resolve-relative-location-component super (car x) nil)))
     2393                 (if (null (cdr x))
     2394                     car
     2395                     (let ((cdr (resolve-relative-location-component
     2396                                 (merge-pathnames* car super) (cdr x) wildenp)))
     2397                       (merge-pathnames* cdr car)))))
     2398              ((eql :current-directory)
     2399               (relativize-pathname-directory (current-directory)))
     2400              ((eql :implementation) (implementation-identifier))
     2401              ((eql :implementation-type) (string-downcase (implementation-type)))
     2402              ((eql :uid) (princ-to-string (get-uid)))))
     2403         (d (if (pathnamep x) r (ensure-directory-pathname r)))
     2404         (s (if (and wildenp (not (pathnamep x)))
     2405                (wilden d)
     2406                d)))
     2407    (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
     2408      (error "pathname ~S is not relative to ~S" s super))
     2409    (merge-pathnames* s super)))
     2410
     2411(defun resolve-location (x &optional wildenp)
     2412  (if (atom x)
     2413      (resolve-absolute-location-component x wildenp)
     2414      (loop :with path = (resolve-absolute-location-component (car x) nil)
     2415        :for (component . morep) :on (cdr x)
     2416        :do (setf path (resolve-relative-location-component
     2417                        path component (and wildenp (not morep))))
     2418        :finally (return path))))
     2419
     2420(defun location-designator-p (x)
     2421  (flet ((componentp (c) (typep c '(or string pathname keyword))))
     2422    (or (typep x 'boolean) (componentp x) (and (consp x) (every #'componentp x)))))
     2423
     2424(defun location-function-p (x)
     2425  (and
     2426   (consp x)
     2427   (length=n-p x 2)
     2428   (or (and (equal (first x) :function)
     2429            (typep (second x) 'symbol))
     2430       (and (equal (first x) 'lambda)
     2431            (cddr x)
     2432            (length=n-p (second x) 2)))))
     2433
     2434(defun validate-output-translations-directive (directive)
     2435  (unless
     2436      (or (member directive '(:inherit-configuration
     2437                              :ignore-inherited-configuration
     2438                              :enable-user-cache :disable-cache))
     2439          (and (consp directive)
     2440               (or (and (length=n-p directive 2)
     2441                        (or (and (eq (first directive) :include)
     2442                                 (typep (second directive) '(or string pathname null)))
     2443                            (and (location-designator-p (first directive))
     2444                                 (or (location-designator-p (second directive))
     2445                                     (location-function-p (second directive))))))
     2446                   (and (length=n-p directive 1)
     2447                        (location-designator-p (first directive))))))
     2448    (error "Invalid directive ~S~%" directive))
     2449  directive)
     2450
     2451(defun validate-output-translations-form (form)
     2452  (validate-configuration-form
     2453   form
     2454   :output-translations
     2455   'validate-output-translations-directive
     2456   "output translations"))
     2457
     2458(defun validate-output-translations-file (file)
     2459  (validate-configuration-file
     2460   file 'validate-output-translations-form "output translations"))
     2461
     2462(defun validate-output-translations-directory (directory)
     2463  (validate-configuration-directory
     2464   directory :output-translations 'validate-output-translations-directive))
     2465
     2466(defun parse-output-translations-string (string)
     2467  (cond
     2468    ((or (null string) (equal string ""))
     2469     '(:output-translations :inherit-configuration))
     2470    ((not (stringp string))
     2471     (error "environment string isn't: ~S" string))
     2472    ((eql (char string 0) #\")
     2473     (parse-output-translations-string (read-from-string string)))
     2474    ((eql (char string 0) #\()
     2475     (validate-output-translations-form (read-from-string string)))
     2476    (t
     2477     (loop
     2478      :with inherit = nil
     2479      :with directives = ()
     2480      :with start = 0
     2481      :with end = (length string)
     2482      :with source = nil
     2483      :for i = (or (position *inter-directory-separator* string :start start) end) :do
     2484      (let ((s (subseq string start i)))
     2485        (cond
     2486          (source
     2487           (push (list source (if (equal "" s) nil s)) directives)
     2488           (setf source nil))
     2489          ((equal "" s)
     2490           (when inherit
     2491             (error "only one inherited configuration allowed: ~S" string))
     2492           (setf inherit t)
     2493           (push :inherit-configuration directives))
     2494          (t
     2495           (setf source s)))
     2496        (setf start (1+ i))
     2497        (when (> start end)
     2498          (when source
     2499            (error "Uneven number of components in source to destination mapping ~S" string))
     2500          (unless inherit
     2501            (push :ignore-inherited-configuration directives))
     2502          (return `(:output-translations ,@(nreverse directives)))))))))
     2503
     2504(defparameter *default-output-translations*
     2505  '(environment-output-translations
     2506    user-output-translations-pathname
     2507    user-output-translations-directory-pathname
     2508    system-output-translations-pathname
     2509    system-output-translations-directory-pathname))
     2510
     2511(defun wrapping-output-translations ()
     2512  `(:output-translations
     2513    ;; Some implementations have precompiled ASDF systems,
     2514    ;; so we must disable translations for implementation paths.
     2515    #+sbcl (,(getenv "SBCL_HOME") ())
     2516    #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; only needed if LPNs are resolved manually.
     2517    #+clozure (,(wilden (ccl::ccl-directory)) ()) ; not needed: no precompiled ASDF system
     2518    #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
     2519    #+abcl (#p"/:jar:file/**/*.*" (:user-cache #p"**/*.*"))
     2520    ;; All-import, here is where we want user stuff to be:
     2521    :inherit-configuration
     2522    ;; If we want to enable the user cache by default, here would be the place:
     2523    :enable-user-cache))
     2524
     2525(defparameter *output-translations-file* #p"asdf-output-translations.conf")
     2526(defparameter *output-translations-directory* #p"asdf-output-translations.conf.d/")
     2527
     2528(defun user-output-translations-pathname ()
     2529  (in-user-configuration-directory *output-translations-file* ))
     2530(defun system-output-translations-pathname ()
     2531  (in-system-configuration-directory *output-translations-file*))
     2532(defun user-output-translations-directory-pathname ()
     2533  (in-user-configuration-directory *output-translations-directory*))
     2534(defun system-output-translations-directory-pathname ()
     2535  (in-system-configuration-directory *output-translations-directory*))
     2536(defun environment-output-translations ()
     2537  (getenv "ASDF_OUTPUT_TRANSLATIONS"))
     2538
     2539(defgeneric process-output-translations (spec &key inherit collect))
     2540(defmethod process-output-translations ((x symbol) &key
     2541                                        (inherit *default-output-translations*)
     2542                                        collect)
     2543  (process-output-translations (funcall x) :inherit inherit :collect collect))
     2544(defmethod process-output-translations ((pathname pathname) &key inherit collect)
     2545  (cond
     2546    ((directory-pathname-p pathname)
     2547     (process-output-translations (validate-output-translations-directory pathname)
     2548                                  :inherit inherit :collect collect))
     2549    ((probe-file pathname)
     2550     (process-output-translations (validate-output-translations-file pathname)
     2551                                  :inherit inherit :collect collect))
     2552    (t
     2553     (inherit-output-translations inherit :collect collect))))
     2554(defmethod process-output-translations ((string string) &key inherit collect)
     2555  (process-output-translations (parse-output-translations-string string)
     2556                               :inherit inherit :collect collect))
     2557(defmethod process-output-translations ((x null) &key inherit collect)
     2558  (declare (ignorable x))
     2559  (inherit-output-translations inherit :collect collect))
     2560(defmethod process-output-translations ((form cons) &key inherit collect)
     2561  (dolist (directive (cdr (validate-output-translations-form form)))
     2562    (process-output-translations-directive directive :inherit inherit :collect collect)))
     2563
     2564(defun inherit-output-translations (inherit &key collect)
     2565  (when inherit
     2566    (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
     2567
     2568(defun process-output-translations-directive (directive &key inherit collect)
     2569  (if (atom directive)
     2570      (ecase directive
     2571        ((:enable-user-cache)
     2572         (process-output-translations-directive '(t :user-cache) :collect collect))
     2573        ((:disable-cache)
     2574         (process-output-translations-directive '(t t) :collect collect))
     2575        ((:inherit-configuration)
     2576         (inherit-output-translations inherit :collect collect))
     2577        ((:ignore-inherited-configuration)
     2578         nil))
     2579      (let ((src (first directive))
     2580            (dst (second directive)))
     2581        (if (eq src :include)
     2582            (when dst
     2583              (process-output-translations (pathname dst) :inherit nil :collect collect))
     2584            (when src
     2585              (let ((trusrc (or (eql src t)
     2586                                (let ((loc (resolve-location src t)))
     2587                                  (if (absolute-pathname-p loc) (truenamize loc) loc)))))
     2588                (cond
     2589                  ((location-function-p dst)
     2590                   (funcall collect
     2591                            (list trusrc
     2592                                  (if (symbolp (second dst))
     2593                                      (fdefinition (second dst))
     2594                                      (eval (second dst))))))
     2595                  ((eq dst t)
     2596                   (funcall collect (list trusrc t)))
     2597                  (t
     2598                   (let* ((trudst (make-pathname
     2599                                   :defaults (if dst (resolve-location dst t) trusrc)))
     2600                          (wilddst (make-pathname
     2601                                    :name :wild :type :wild :version :wild
     2602                                    :defaults trudst)))
     2603                     (funcall collect (list wilddst t))
     2604                     (funcall collect (list trusrc trudst)))))))))))
     2605
     2606(defun compute-output-translations (&optional parameter)
     2607  "read the configuration, return it"
     2608  (remove-duplicates
     2609   (while-collecting (c)
     2610     (inherit-output-translations
     2611      `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
     2612   :test 'equal :from-end t))
     2613
     2614(defun initialize-output-translations (&optional parameter)
     2615  "read the configuration, initialize the internal configuration variable,
     2616return the configuration"
     2617  (setf (output-translations) (compute-output-translations parameter)))
     2618
     2619(defun disable-output-translations ()
     2620  "Initialize output translations in a way that maps every file to itself,
     2621effectively disabling the output translation facility."
     2622  (initialize-output-translations
     2623   '(:output-translations :disable-cache :ignore-inherited-configuration)))
     2624
     2625;; checks an initial variable to see whether the state is initialized
     2626;; or cleared. In the former case, return current configuration; in
     2627;; the latter, initialize.  ASDF will call this function at the start
     2628;; of (asdf:find-system).
     2629(defun ensure-output-translations ()
     2630  (if (output-translations-initialized-p)
     2631      (output-translations)
     2632      (initialize-output-translations)))
     2633
     2634(defun apply-output-translations (path)
     2635  (etypecase path
     2636    (logical-pathname
     2637     path)
     2638    ((or pathname string)
     2639     (ensure-output-translations)
     2640     (loop :with p = (truenamize path)
     2641       :for (source destination) :in (car *output-translations*)
     2642       :for root = (when (or (eq source t)
     2643                             (and (pathnamep source)
     2644                                  (not (absolute-pathname-p source))))
     2645                     (pathname-root p))
     2646       :for absolute-source = (cond
     2647                                ((eq source t) (wilden root))
     2648                                (root (merge-pathnames* source root))
     2649                                (t source))
     2650       :when (or (eq source t) (pathname-match-p p absolute-source))
     2651       :return
     2652       (cond
     2653         ((functionp destination)
     2654          (funcall destination p absolute-source))
     2655         ((eq destination t)
     2656          p)
     2657         ((not (pathnamep destination))
     2658          (error "invalid destination"))
     2659         ((not (absolute-pathname-p destination))
     2660          (translate-pathname p absolute-source (merge-pathnames* destination root)))
     2661         (root
     2662          (translate-pathname (directorize-pathname-host-device p) absolute-source destination))
     2663         (t
     2664          (translate-pathname p absolute-source destination)))
     2665       :finally (return p)))))
     2666
     2667(defun last-char (s)
     2668  (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
     2669
     2670(defun directorize-pathname-host-device (pathname)
     2671  (let* ((root (pathname-root pathname))
     2672         (wild-root (wilden root))
     2673         (absolute-pathname (merge-pathnames* pathname root))
     2674         (foo (make-pathname :directory '(:absolute "FOO") :defaults root))
     2675         (separator (last-char (namestring foo)))
     2676         (root-namestring (namestring root))
     2677         (root-string
     2678          (substitute-if #\/
     2679                         (lambda (x) (or (eql x #\:)
     2680                                         (eql x separator)))
     2681                         root-namestring)))
     2682    (multiple-value-bind (relative path filename)
     2683        (component-name-to-pathname-components root-string t)
     2684      (declare (ignore relative filename))
     2685      (let ((new-base
     2686             (make-pathname :defaults root
     2687                            :directory `(:absolute ,@path))))
     2688        (translate-pathname absolute-pathname wild-root (wilden new-base))))))
     2689
     2690(defmethod output-files :around (operation component)
     2691  "Translate output files, unless asked not to"
     2692  (declare (ignorable operation component))
     2693  (values
     2694   (multiple-value-bind (files fixedp) (call-next-method)
     2695     (if fixedp
     2696         files
     2697         (mapcar #'apply-output-translations files)))
     2698   t))
     2699
     2700(defun compile-file-pathname* (input-file &rest keys)
     2701  (apply-output-translations
     2702   (apply #'compile-file-pathname
     2703          (truenamize (lispize-pathname input-file))
     2704          keys)))
     2705
     2706#+abcl
     2707(defun translate-jar-pathname (source wildcard)
     2708  (declare (ignore wildcard))
     2709  (let ((root (apply-output-translations
     2710               (concatenate 'string
     2711                            "/:jar:file/"
     2712                            (namestring (first (pathname-device
     2713                                                source))))))
     2714        (entry (make-pathname :directory (pathname-directory source)
     2715                              :name (pathname-name source)
     2716                              :type (pathname-type source))))
     2717    (concatenate 'string (namestring root) (namestring entry))))
     2718
     2719;;;; -----------------------------------------------------------------
     2720;;;; Compatibility mode for ASDF-Binary-Locations
     2721
     2722(defun enable-asdf-binary-locations-compatibility
     2723    (&key
     2724     (centralize-lisp-binaries nil)
     2725     (default-toplevel-directory
     2726         ;; Use ".cache/common-lisp" instead ???
     2727         (merge-pathnames* (make-pathname :directory '(:relative ".fasls"))
     2728                           (user-homedir)))
     2729     (include-per-user-information nil)
     2730     (map-all-source-files nil)
     2731     (source-to-target-mappings nil))
     2732  (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
     2733         (wild-inferiors (make-pathname :directory '(:relative :wild-inferiors)))
     2734         (mapped-files (make-pathname
     2735                        :name :wild :version :wild
     2736                        :type (if map-all-source-files :wild fasl-type)))
     2737         (destination-directory
     2738          (if centralize-lisp-binaries
     2739              `(,default-toplevel-directory
     2740                ,@(when include-per-user-information
     2741                        (cdr (pathname-directory (user-homedir))))
     2742                :implementation ,wild-inferiors)
     2743              `(:root ,wild-inferiors :implementation))))
     2744    (initialize-output-translations
     2745     `(:output-translations
     2746       ,@source-to-target-mappings
     2747       ((:root ,wild-inferiors ,mapped-files)
     2748        (,@destination-directory ,mapped-files))
     2749       (t t)
     2750       :ignore-inherited-configuration))))
     2751
     2752;;;; -----------------------------------------------------------------
     2753;;;; Windows shortcut support.  Based on:
     2754;;;;
     2755;;;; Jesse Hager: The Windows Shortcut File Format.
     2756;;;; http://www.wotsit.org/list.asp?fc=13
     2757
     2758(defparameter *link-initial-dword* 76)
     2759(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
     2760
     2761(defun read-null-terminated-string (s)
     2762  (with-output-to-string (out)
     2763    (loop :for code = (read-byte s)
     2764      :until (zerop code)
     2765      :do (write-char (code-char code) out))))
     2766
     2767(defun read-little-endian (s &optional (bytes 4))
     2768  (loop
     2769    :for i :from 0 :below bytes
     2770    :sum (ash (read-byte s) (* 8 i))))
     2771
     2772(defun parse-file-location-info (s)
     2773  (let ((start (file-position s))
     2774        (total-length (read-little-endian s))
     2775        (end-of-header (read-little-endian s))
     2776        (fli-flags (read-little-endian s))
     2777        (local-volume-offset (read-little-endian s))
     2778        (local-offset (read-little-endian s))
     2779        (network-volume-offset (read-little-endian s))
     2780        (remaining-offset (read-little-endian s)))
     2781    (declare (ignore total-length end-of-header local-volume-offset))
     2782    (unless (zerop fli-flags)
     2783      (cond
     2784        ((logbitp 0 fli-flags)
     2785          (file-position s (+ start local-offset)))
     2786        ((logbitp 1 fli-flags)
     2787          (file-position s (+ start
     2788                              network-volume-offset
     2789                              #x14))))
     2790      (concatenate 'string
     2791        (read-null-terminated-string s)
     2792        (progn
     2793          (file-position s (+ start remaining-offset))
     2794          (read-null-terminated-string s))))))
     2795
     2796(defun parse-windows-shortcut (pathname)
     2797  (with-open-file (s pathname :element-type '(unsigned-byte 8))
     2798    (handler-case
     2799        (when (and (= (read-little-endian s) *link-initial-dword*)
     2800                   (let ((header (make-array (length *link-guid*))))
     2801                     (read-sequence header s)
     2802                     (equalp header *link-guid*)))
     2803          (let ((flags (read-little-endian s)))
     2804            (file-position s 76)        ;skip rest of header
     2805            (when (logbitp 0 flags)
     2806              ;; skip shell item id list
     2807              (let ((length (read-little-endian s 2)))
     2808                (file-position s (+ length (file-position s)))))
     2809            (cond
     2810              ((logbitp 1 flags)
     2811                (parse-file-location-info s))
     2812              (t
     2813                (when (logbitp 2 flags)
     2814                  ;; skip description string
     2815                  (let ((length (read-little-endian s 2)))
     2816                    (file-position s (+ length (file-position s)))))
     2817                (when (logbitp 3 flags)
     2818                  ;; finally, our pathname
     2819                  (let* ((length (read-little-endian s 2))
     2820                         (buffer (make-array length)))
     2821                    (read-sequence buffer s)
     2822                    (map 'string #'code-char buffer)))))))
     2823      (end-of-file ()
     2824        nil))))
     2825
     2826;;;; -----------------------------------------------------------------
     2827;;;; Source Registry Configuration, by Francois-Rene Rideau
     2828;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
     2829
     2830;; Using ack 1.2 exclusions
     2831(defvar *default-exclusions*
     2832  '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst"
     2833    ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
     2834    "_sgbak" "autom4te.cache" "cover_db" "_build"))
     2835
     2836(defvar *source-registry* ()
     2837  "Either NIL (for uninitialized), or a list of one element,
     2838said element itself being a list of directory pathnames where to look for .asd files")
     2839
     2840(defun source-registry ()
     2841  (car *source-registry*))
     2842
     2843(defun (setf source-registry) (new-value)
     2844  (setf *source-registry* (list new-value))
     2845  new-value)
     2846
     2847(defun source-registry-initialized-p ()
     2848  (and *source-registry* t))
     2849
     2850(defun clear-source-registry ()
     2851  "Undoes any initialization of the source registry.
     2852You might want to call that before you dump an image that would be resumed
     2853with a different configuration, so the configuration would be re-read then."
     2854  (setf *source-registry* '())
     2855  (values))
     2856
     2857(defun sysdef-source-registry-search (system)
     2858  (ensure-source-registry)
     2859  (let ((name (coerce-name system)))
     2860    (block nil
     2861      (dolist (dir (source-registry))
     2862        (let ((defaults (eval dir)))
     2863          (when defaults
     2864            (cond ((directory-pathname-p defaults)
     2865                   (let ((file (and defaults
     2866                                    (make-pathname
     2867                                     :defaults defaults :version :newest
     2868                                     :name name :type "asd" :case :local)))
     2869                         #+(and (or win32 windows) (not :clisp))
     2870                         (shortcut (make-pathname
     2871                                    :defaults defaults :version :newest
     2872                                    :name name :type "asd.lnk" :case :local)))
     2873                     (when (and file (probe-file file))
     2874                       (return file))
     2875                     #+(and (or win32 windows) (not :clisp))
     2876                     (when (probe-file shortcut)
     2877                       (let ((target (parse-windows-shortcut shortcut)))
     2878                         (when target
     2879                           (return (pathname target))))))))))))))
     2880
     2881(defun validate-source-registry-directive (directive)
     2882  (unless
     2883      (or (member directive '(:default-registry (:default-registry)) :test 'equal)
     2884          (destructuring-bind (kw &rest rest) directive
     2885            (case kw
     2886              ((:include :directory :tree)
     2887               (and (length=n-p rest 1)
     2888                    (typep (car rest) '(or pathname string null))))
     2889              ((:exclude)
     2890               (every #'stringp rest))
     2891              (null rest))))
     2892    (error "Invalid directive ~S~%" directive))
     2893  directive)
     2894
     2895(defun validate-source-registry-form (form)
     2896  (validate-configuration-form
     2897   form :source-registry 'validate-source-registry-directive "a source registry"))
     2898
     2899(defun validate-source-registry-file (file)
     2900  (validate-configuration-file
     2901   file 'validate-source-registry-form "a source registry"))
     2902
     2903(defun validate-source-registry-directory (directory)
     2904  (validate-configuration-directory
     2905   directory :source-registry 'validate-source-registry-directive))
     2906
     2907(defun parse-source-registry-string (string)
     2908  (cond
     2909    ((or (null string) (equal string ""))
     2910     '(:source-registry :inherit-configuration))
     2911    ((not (stringp string))
     2912     (error "environment string isn't: ~S" string))
     2913    ((find (char string 0) "\"(")
     2914     (validate-source-registry-form (read-from-string string)))
     2915    (t
     2916     (loop
     2917      :with inherit = nil
     2918      :with directives = ()
     2919      :with start = 0
     2920      :with end = (length string)
     2921      :for pos = (position *inter-directory-separator* string :start start) :do
     2922      (let ((s (subseq string start (or pos end))))
     2923        (cond
     2924         ((equal "" s) ; empty element: inherit
     2925          (when inherit
     2926            (error "only one inherited configuration allowed: ~S" string))
     2927          (setf inherit t)
     2928          (push ':inherit-configuration directives))
     2929         ((ends-with s "//")
     2930          (push `(:tree ,(subseq s 0 (1- (length s)))) directives))
     2931         (t
     2932          (push `(:directory ,s) directives)))
     2933        (cond
     2934          (pos
     2935           (setf start (1+ pos)))
     2936          (t
     2937           (unless inherit
     2938             (push '(:ignore-inherited-configuration) directives))
     2939           (return `(:source-registry ,@(nreverse directives))))))))))
     2940
     2941(defun register-asd-directory (directory &key recurse exclude collect)
     2942  (if (not recurse)
     2943      (funcall collect directory)
     2944      (let* ((files (ignore-errors
     2945                      (directory (merge-pathnames* *wild-asd* directory)
     2946                                 #+sbcl #+sbcl :resolve-symlinks nil
     2947                                 #+clisp #+clisp :circle t)))
     2948             (dirs (remove-duplicates (mapcar #'pathname-directory-pathname files)
     2949                                      :test #'equal :from-end t)))
     2950        (loop
     2951          :for dir :in dirs
     2952          :unless (loop :for x :in exclude
     2953                    :thereis (find x (pathname-directory dir) :test #'equal))
     2954          :do (funcall collect dir)))))
     2955
     2956(defparameter *default-source-registries*
     2957  '(environment-source-registry
     2958    user-source-registry
     2959    user-source-registry-directory
     2960    system-source-registry
     2961    system-source-registry-directory
     2962    default-source-registry))
     2963
     2964(defparameter *source-registry-file* #p"source-registry.conf")
     2965(defparameter *source-registry-directory* #p"source-registry.conf.d/")
     2966
     2967(defun wrapping-source-registry ()
     2968  `(:source-registry
     2969    #+sbcl (:tree ,(getenv "SBCL_HOME"))
     2970   :inherit-configuration))
     2971(defun default-source-registry ()
     2972  (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
     2973    `(:source-registry
     2974      #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir)))
     2975      (:directory ,(truenamize (directory-namestring *default-pathname-defaults*)))
     2976      ,@(let*
     2977         #+(or unix cygwin)
     2978         ((datahome
     2979           (or (getenv "XDG_DATA_HOME")
     2980               (try (user-homedir) ".local/share/")))
     2981          (datadirs
     2982           (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share"))
     2983          (dirs (cons datahome (split-string datadirs :separator ":"))))
     2984         #+(and windows (not cygwin))
     2985         ((datahome
     2986           #+lispworks (sys:get-folder-path :common-appdata)
     2987           #-lispworks (try (or (getenv "USERPROFILE") (user-homedir))
     2988                            "Application Data"))
     2989          (datadir
     2990           #+lispworks (sys:get-folder-path :local-appdata)
     2991           #-lispworks (try (getenv "ALLUSERSPROFILE")
     2992                            "Application Data"))
     2993          (dirs (list datahome datadir)))
     2994         #+(and (not unix) (not windows) (not cygwin))
     2995         ((dirs ()))
     2996         (loop :for dir :in dirs
     2997           :collect `(:directory ,(try dir "common-lisp/systems/"))
     2998           :collect `(:tree ,(try dir "common-lisp/source/"))))
     2999      :inherit-configuration)))
     3000(defun user-source-registry ()
     3001  (in-user-configuration-directory *source-registry-file*))
     3002(defun system-source-registry ()
     3003  (in-system-configuration-directory *source-registry-file*))
     3004(defun user-source-registry-directory ()
     3005  (in-user-configuration-directory *source-registry-directory*))
     3006(defun system-source-registry-directory ()
     3007  (in-system-configuration-directory *source-registry-directory*))
     3008(defun environment-source-registry ()
     3009  (getenv "CL_SOURCE_REGISTRY"))
     3010
     3011(defgeneric process-source-registry (spec &key inherit register))
     3012(defmethod process-source-registry ((x symbol) &key inherit register)
     3013  (process-source-registry (funcall x) :inherit inherit :register register))
     3014(defmethod process-source-registry ((pathname pathname) &key inherit register)
     3015  (cond
     3016    ((directory-pathname-p pathname)
     3017     (process-source-registry (validate-source-registry-directory pathname)
     3018                              :inherit inherit :register register))
     3019    ((probe-file pathname)
     3020     (process-source-registry (validate-source-registry-file pathname)
     3021                              :inherit inherit :register register))
     3022    (t
     3023     (inherit-source-registry inherit :register register))))
     3024(defmethod process-source-registry ((string string) &key inherit register)
     3025  (process-source-registry (parse-source-registry-string string)
     3026                           :inherit inherit :register register))
     3027(defmethod process-source-registry ((x null) &key inherit register)
     3028  (declare (ignorable x))
     3029  (inherit-source-registry inherit :register register))
     3030(defmethod process-source-registry ((form cons) &key inherit register)
     3031  (let ((*default-exclusions* *default-exclusions*))
     3032    (dolist (directive (cdr (validate-source-registry-form form)))
     3033      (process-source-registry-directive directive :inherit inherit :register register))))
     3034
     3035(defun inherit-source-registry (inherit &key register)
     3036  (when inherit
     3037    (process-source-registry (first inherit) :register register :inherit (rest inherit))))
     3038
     3039(defun process-source-registry-directive (directive &key inherit register)
     3040  (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
     3041    (ecase kw
     3042      ((:include)
     3043       (destructuring-bind (pathname) rest
     3044         (process-source-registry (pathname pathname) :inherit nil :register register)))
     3045      ((:directory)
     3046       (destructuring-bind (pathname) rest
     3047         (when pathname
     3048           (funcall register (ensure-directory-pathname pathname)))))
     3049      ((:tree)
     3050       (destructuring-bind (pathname) rest
     3051         (when pathname
     3052           (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *default-exclusions*))))
     3053      ((:exclude)
     3054       (setf *default-exclusions* rest))
     3055      ((:default-registry)
     3056       (inherit-source-registry '(default-source-registry) :register register))
     3057      ((:inherit-configuration)
     3058       (inherit-source-registry inherit :register register))
     3059      ((:ignore-inherited-configuration)
     3060       nil))))
     3061
     3062(defun flatten-source-registry (&optional parameter)
     3063  (remove-duplicates
     3064   (while-collecting (collect)
     3065     (inherit-source-registry
     3066      `(wrapping-source-registry
     3067        ,parameter
     3068        ,@*default-source-registries*)
     3069      :register (lambda (directory &key recurse exclude)
     3070                  (collect (list directory :recurse recurse :exclude exclude)))))
     3071   :test 'equal :from-end t))
     3072
     3073;; Will read the configuration and initialize all internal variables,
     3074;; and return the new configuration.
     3075(defun compute-source-registry (&optional parameter)
     3076  (while-collecting (collect)
     3077    (dolist (entry (flatten-source-registry parameter))
     3078      (destructuring-bind (directory &key recurse exclude) entry
     3079        (register-asd-directory
     3080         directory
     3081         :recurse recurse :exclude exclude :collect #'collect)))))
     3082
     3083(defun initialize-source-registry (&optional parameter)
     3084  (setf (source-registry) (compute-source-registry parameter)))
     3085
     3086;; checks an initial variable to see whether the state is initialized
     3087;; or cleared. In the former case, return current configuration; in
     3088;; the latter, initialize.  ASDF will call this function at the start
     3089;; of (asdf:find-system).
     3090(defun ensure-source-registry ()
     3091  (if (source-registry-initialized-p)
     3092      (source-registry)
     3093      (initialize-source-registry)))
     3094
     3095;;;; -----------------------------------------------------------------
     3096;;;; SBCL and ClozureCL hook into REQUIRE
     3097;;;;
     3098#+(or sbcl clozure abcl)
    11423099(progn
    11433100  (defun module-provide-asdf (name)
    1144     (handler-bind ((style-warning #'muffle-warning))
     3101    (handler-bind
     3102        ((style-warning #'muffle-warning)
     3103         (missing-component (constantly nil))
     3104         (error (lambda (e)
     3105                  (format *error-output* "ASDF could not load ~A because ~A.~%"
     3106                          name e))))
    11453107      (let* ((*verbose-out* (make-broadcast-stream))
    1146        (system (asdf:find-system name nil)))
    1147   (when system
    1148     (asdf:operate 'asdf:load-op name)
    1149     t))))
    1150 
    1151   (defun contrib-sysdef-search (system)
    1152     (let* ((name (coerce-name system))
    1153            (home (truename (sb-ext:posix-getenv "SBCL_HOME")))
    1154            (contrib (merge-pathnames
    1155                      (make-pathname :directory `(:relative ,name)
    1156                                     :name name
    1157                                     :type "asd"
    1158                                     :case :local
    1159                                     :version :newest)
    1160                      home)))
    1161       (probe-file contrib)))
    1162  
    1163   (pushnew
    1164    '(merge-pathnames "site-systems/"
    1165      (truename (sb-ext:posix-getenv "SBCL_HOME")))
    1166    *central-registry*)
    1167  
    1168   (pushnew
    1169    '(merge-pathnames ".sbcl/systems/"
    1170      (user-homedir-pathname))
    1171    *central-registry*)
    1172  
    1173   (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)
    1174   (pushnew 'contrib-sysdef-search *system-definition-search-functions*))
    1175 
    1176 (require 'asdf-abcl)
    1177 (provide 'asdf)
     3108             (system (asdf:find-system name nil)))
     3109        (when system
     3110          (asdf:operate 'asdf:load-op name)
     3111          t))))
     3112  (pushnew 'module-provide-asdf
     3113           #+sbcl sb-ext:*module-provider-functions*
     3114           #+clozure ccl::*module-provider-functions*
     3115           #+abcl sys::*module-provider-functions*))
     3116
     3117;;;; -------------------------------------------------------------------------
     3118;;;; Cleanups after hot-upgrade.
     3119;;;; Things to do in case we're upgrading from a previous version of ASDF.
     3120;;;; See https://bugs.launchpad.net/asdf/+bug/485687
     3121;;;;
     3122;;;; TODO: debug why it's not enough to upgrade from ECL <= 9.11.1
     3123(eval-when (:compile-toplevel :load-toplevel :execute)
     3124  #+ecl ;; Support upgrade from before ECL went to 1.369
     3125  (when (fboundp 'compile-op-system-p)
     3126    (defmethod compile-op-system-p ((op compile-op))
     3127      (getf :system-p (compile-op-flags op)))
     3128    (defmethod initialize-instance :after ((op compile-op)
     3129                                           &rest initargs
     3130                                           &key system-p &allow-other-keys)
     3131      (declare (ignorable initargs))
     3132      (when system-p (appendf (compile-op-flags op) (list :system-p system-p))))))
     3133
     3134;;;; -----------------------------------------------------------------
     3135;;;; Done!
     3136(when *load-verbose*
     3137  (asdf-message ";; ASDF, version ~a" (asdf-version)))
     3138
     3139#+allegro
     3140(eval-when (:compile-toplevel :execute)
     3141  (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
     3142    (setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*)))
     3143
     3144(pushnew :asdf *features*)
     3145;; this is a release candidate for ASDF 2.0
     3146(pushnew :asdf2 *features*)
     3147
     3148(provide :asdf)
     3149
     3150;;; Local Variables:
     3151;;; mode: lisp
     3152;;; End:
  • trunk/abcl/src/org/armedbear/lisp/compile-system.lisp

    r12516 r12618  
    130130                           "apropos.lisp"
    131131                           "arrays.lisp"
    132                            "asdf-abcl.lisp"
    133132                           "assert.lisp"
    134133                           "assoc.lisp"
  • trunk/abcl/test/lisp/abcl/file-system-tests.lisp

    r12402 r12618  
    2727(defparameter *this-file*
    2828  (merge-pathnames (make-pathname :type "lisp")
    29                    *load-truename*))
     29                   (if (find :asdf2 *features*)
     30                       (merge-pathnames
     31                        (make-pathname :name (pathname-name *load-truename*))
     32                        (asdf:system-relative-pathname :abcl-test-lisp "test/lisp/abcl/"))
     33                       *load-truename*)))
    3034
    3135(defparameter *this-directory*
    32   (make-pathname :host (pathname-host *load-truename*)
    33                  :device (pathname-device *load-truename*)
    34                  :directory (pathname-directory *load-truename*)))
     36  (if (find :asdf2 *features*)
     37      (asdf:system-relative-pathname :abcl-test-lisp "test/lisp/abcl/")
     38      (make-pathname :host (pathname-host *load-truename*)
     39                     :device (pathname-device *load-truename*)
     40                     :directory (pathname-directory *load-truename*))))
    3541
    3642(defun pathnames-equal-p (pathname1 pathname2)
  • trunk/abcl/test/lisp/abcl/package.lisp

    r12615 r12618  
    88
    99(defparameter *abcl-test-directory*
    10    (make-pathname :host (pathname-host *load-truename*)
    11                   :device (pathname-device *load-truename*)
    12                   :directory (pathname-directory *load-truename*)))
     10  (if (find :asdf2 *features*)
     11      (asdf:system-relative-pathname :abcl-test-lisp "test/lisp/abcl/")
     12      (make-pathname :host (pathname-host *load-truename*)
     13                     :device (pathname-device *load-truename*)
     14                     :directory (pathname-directory *load-truename*))))
    1315
    1416(defun run ()
  • trunk/abcl/test/lisp/abcl/test-utilities.lisp

    r12402 r12618  
    2525(pushnew :windows *features*)
    2626
    27 #+nil ;; Taken care of by ASDF
    28 (unless (member "ABCL-RT" *modules* :test #'string=)
    29   (load (merge-pathnames "rt-package.lisp" *load-truename*))
    30   (load #+abcl (compile-file-if-needed (merge-pathnames "rt.lisp" *load-truename*))
    31         ;; Force compilation to avoid fasl name conflict between SBCL and
    32         ;; Allegro.
    33         #-abcl (compile-file (merge-pathnames "rt.lisp" *load-truename*)))
    34   (provide "ABCL-RT"))
    35 
    36 
    3727(in-package #:abcl-regression-test)
    3828
     
    4434(export '(signals-error))
    4535
    46 
    47 
    4836#+nil (rem-all-tests)
    4937
  • trunk/abcl/test/lisp/ansi/package.lisp

    r12509 r12618  
    1010
    1111(defparameter *ansi-tests-directory*
    12   (merge-pathnames
    13    #p"../ansi-tests/"
    14    (asdf:component-pathname (asdf:find-system :abcl))))
     12  (if (find :asdf2 *features*)
     13      (asdf:system-relative-pathname
     14       :ansi-compiled "../ansi-tests/")
     15      (merge-pathnames
     16       #p"../ansi-tests/"
     17       (asdf:component-pathname (asdf:find-system :ansi-compiled)))))
    1518
    1619(defun run (&key (compile-tests nil))
  • trunk/abcl/test/lisp/cl-bench/wrapper.lisp

    r12337 r12618  
    1010
    1111(defparameter *cl-bench-directory*
    12   (merge-pathnames #p"../cl-bench/"
    13                    (component-pathname (find-system :abcl))))
    14 
     12  (if (find :asdf2 *features*)
     13      (asdf:system-relative-pathname
     14       :cl-bench "../cl-bench/")
     15      (merge-pathnames #p"../cl-bench/"
     16                       (component-pathname (find-system :abcl)))))
     17 
    1518;;; cl-bench defines BENCH-GC and WITH-SPAWNED-THREAD in
    1619;;; '*cl-bench-directory*/sysdep/setup-ablisp.lisp'. 
Note: See TracChangeset for help on using the changeset viewer.