Changeset 13021


Ignore:
Timestamp:
Oct 15, 2009, 2:26:25 AM (10 years ago)
Author:
greg
Message:

Updating ASDF (primarily because it fixes system-source-file, but there are other nice things like asdf-binary-locations being integrated now)

File:
1 edited

Legend:

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

    r11305 r13021  
    1 ;;; This is asdf: Another System Definition Facility.  $Revision$
     1;;; This is asdf: Another System Definition Facility.
     2;;; hash - $Format:%H$
     3;;;
     4;;; Local Variables:
     5;;; mode: lisp
     6;;; End:
    27;;;
    38;;; 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/>
     9;;; <asdf-devel@common-lisp.net>.  But note first that the canonical
     10;;; source for asdf is presently on common-lisp.net at
     11;;; <URL:http://common-lisp.net/project/asdf/>
    712;;;
    813;;; If you obtained this copy from anywhere else, and you experience
     
    1015;;; location above for a more recent version (and for documentation
    1116;;; and test files, if your copy came without them) before reporting
    12 ;;; bugs.  There are usually two "supported" revisions - the CVS HEAD
     17;;; bugs.  There are usually two "supported" revisions - the git HEAD
    1318;;; is the latest development version, whereas the revision tagged
    1419;;; RELEASE may be slightly older but is considered `stable'
    1520
    16 ;;; Copyright (c) 2001-2008 Daniel Barlow and contributors
     21;;; -- LICENSE START
     22;;; (This is the MIT / X Consortium license as taken from
     23;;;  http://www.opensource.org/licenses/mit-license.html on or about
     24;;;  Monday; July 13, 2009)
     25;;;
     26;;; Copyright (c) 2001-2009 Daniel Barlow and contributors
    1727;;;
    1828;;; Permission is hereby granted, free of charge, to any person obtaining
     
    3444;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
    3545;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
     46;;;
     47;;; -- LICENSE END
    3648
    3749;;; the problem with writing a defsystem replacement is bootstrapping:
    3850;;; we can't use defsystem to compile it.  Hence, all in one file
    3951
     52#+xcvb (module ())
     53
    4054(defpackage #:asdf
     55  (:documentation "Another System Definition Facility")
    4156  (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command
    4257           #:system-definition-pathname #:find-component ; miscellaneous
    43 
    44            #:compile-op #:load-op #:load-source-op 
     58           #:compile-system #:load-system #:test-system
     59           #:compile-op #:load-op #:load-source-op
    4560           #:test-op
    4661           #:operation           ; operations
     
    8196           #:system-source-file
    8297           #:system-relative-pathname
     98           #:map-systems
    8399
    84100           #:operation-on-warnings
     
    91107           #:*compile-file-failure-behaviour*
    92108           #:*asdf-revision*
     109           #:*resolve-symlinks*
    93110
    94111           #:operation-error #:compile-failed #:compile-warned #:compile-error
     
    105122           #:retry
    106123           #:accept                     ; restarts
     124           #:coerce-entry-to-directory
     125           #:remove-entry-from-registry
    107126
    108127           #:standard-asdf-method-combination
    109128           #:around                     ; protocol assistants
    110            )
     129           
     130           #:*source-to-target-mappings*
     131           #:*default-toplevel-directory*
     132           #:*centralize-lisp-binaries*
     133           #:*include-per-user-information*
     134           #:*map-all-source-files*
     135           #:output-files-for-system-and-operation
     136           #:*enable-asdf-binary-locations*
     137           #:implementation-specific-directory-name)
    111138  (:use :cl))
    112139
     
    119146(in-package #:asdf)
    120147
    121 (defvar *asdf-revision* (let* ((v "$Revision$")
    122                                (colon (or (position #\: v) -1))
    123                                (dot (position #\. v)))
    124                           (and v colon dot
    125                                (list (parse-integer v :start (1+ colon)
    126                                                       :junk-allowed t)
    127                                      (parse-integer v :start (1+ dot)
    128                                                       :junk-allowed t)))))
     148(defvar *asdf-revision*
     149  ;; the 1+ hair is to ensure that we don't do an inadvertant find and replace
     150  (subseq "REVISION:1.366" (1+ (length "REVISION"))))
     151 
     152
     153(defvar *resolve-symlinks* t
     154  "Determine whether or not ASDF resolves symlinks when defining systems.
     155
     156Defaults to `t`.")
    129157
    130158(defvar *compile-file-warnings-behaviour* :warn)
     
    136164(defparameter +asdf-methods+
    137165  '(perform explain output-files operation-done-p))
    138 
    139 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    140 ;; utility stuff
    141 
    142 (defmacro aif (test then &optional else)
    143   `(let ((it ,test)) (if it ,then ,else)))
    144 
    145 (defun pathname-sans-name+type (pathname)
    146   "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
    147 and NIL NAME and TYPE components"
    148   (make-pathname :name nil :type nil :defaults pathname))
    149 
    150 (define-modify-macro appendf (&rest args)
    151   append "Append onto list")
    152 
    153 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    154 ;; classes, condiitons
    155 
    156 (define-condition system-definition-error (error) ()
    157   ;; [this use of :report should be redundant, but unfortunately it's not.
    158   ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
    159   ;; over print-object; this is always conditions::%print-condition for
    160   ;; condition objects, which in turn does inheritance of :report options at
    161   ;; run-time.  fortunately, inheritance means we only need this kludge here in
    162   ;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]
    163   #+cmu (:report print-object))
    164 
    165 (define-condition formatted-system-definition-error (system-definition-error)
    166   ((format-control :initarg :format-control :reader format-control)
    167    (format-arguments :initarg :format-arguments :reader format-arguments))
    168   (:report (lambda (c s)
    169              (apply #'format s (format-control c) (format-arguments c)))))
    170 
    171 (define-condition circular-dependency (system-definition-error)
    172   ((components :initarg :components :reader circular-dependency-components)))
    173 
    174 (define-condition duplicate-names (system-definition-error)
    175   ((name :initarg :name :reader duplicate-names-name)))
    176 
    177 (define-condition missing-component (system-definition-error)
    178   ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
    179    (parent :initform nil :reader missing-parent :initarg :parent)))
    180 
    181 (define-condition missing-component-of-version (missing-component)
    182   ((version :initform nil :reader missing-version :initarg :version)))
    183 
    184 (define-condition missing-dependency (missing-component)
    185   ((required-by :initarg :required-by :reader missing-required-by)))
    186 
    187 (define-condition missing-dependency-of-version (missing-dependency
    188                                                  missing-component-of-version)
    189   ())
    190 
    191 (define-condition operation-error (error)
    192   ((component :reader error-component :initarg :component)
    193    (operation :reader error-operation :initarg :operation))
    194   (:report (lambda (c s)
    195              (format s "~@<erred while invoking ~A on ~A~@:>"
    196                      (error-operation c) (error-component c)))))
    197 (define-condition compile-error (operation-error) ())
    198 (define-condition compile-failed (compile-error) ())
    199 (define-condition compile-warned (compile-error) ())
    200 
    201 (defclass component ()
    202   ((name :accessor component-name :initarg :name :documentation
    203          "Component name: designator for a string composed of portable pathname characters")
    204    (version :accessor component-version :initarg :version)
    205    (in-order-to :initform nil :initarg :in-order-to)
    206    ;; XXX crap name
    207    (do-first :initform nil :initarg :do-first)
    208    ;; methods defined using the "inline" style inside a defsystem form:
    209    ;; need to store them somewhere so we can delete them when the system
    210    ;; is re-evaluated
    211    (inline-methods :accessor component-inline-methods :initform nil)
    212    (parent :initarg :parent :initform nil :reader component-parent)
    213    ;; no direct accessor for pathname, we do this as a method to allow
    214    ;; it to default in funky ways if not supplied
    215    (relative-pathname :initarg :pathname)
    216    (operation-times :initform (make-hash-table )
    217                     :accessor component-operation-times)
    218    ;; XXX we should provide some atomic interface for updating the
    219    ;; component properties
    220    (properties :accessor component-properties :initarg :properties
    221                :initform nil)))
    222 
    223 ;;;; methods: conditions
    224 
    225 (defmethod print-object ((c missing-dependency) s)
    226   (format s "~@<~A, required by ~A~@:>"
    227           (call-next-method c nil) (missing-required-by c)))
    228 
    229 (defun sysdef-error (format &rest arguments)
    230   (error 'formatted-system-definition-error :format-control format :format-arguments arguments))
    231 
    232 ;;;; methods: components
    233 
    234 (defmethod print-object ((c missing-component) s)
    235    (format s "~@<component ~S not found~
    236              ~@[ in ~A~]~@:>"
    237           (missing-requires c)
    238           (when (missing-parent c)
    239             (component-name (missing-parent c)))))
    240 
    241 (defmethod print-object ((c missing-component-of-version) s)
    242   (format s "~@<component ~S does not match version ~A~
    243               ~@[ in ~A~]~@:>"
    244            (missing-requires c)
    245            (missing-version c)
    246            (when (missing-parent c)
    247              (component-name (missing-parent c)))))
    248 
    249 (defgeneric component-system (component)
    250   (:documentation "Find the top-level system containing COMPONENT"))
    251 
    252 (defmethod component-system ((component component))
    253   (aif (component-parent component)
    254        (component-system it)
    255        component))
    256 
    257 (defmethod print-object ((c component) stream)
    258   (print-unreadable-object (c stream :type t :identity t)
    259     (ignore-errors
    260       (prin1 (component-name c) stream))))
    261 
    262 (defclass module (component)
    263   ((components :initform nil :accessor module-components :initarg :components)
    264    ;; what to do if we can't satisfy a dependency of one of this module's
    265    ;; components.  This allows a limited form of conditional processing
    266    (if-component-dep-fails :initform :fail
    267                            :accessor module-if-component-dep-fails
    268                            :initarg :if-component-dep-fails)
    269    (default-component-class :accessor module-default-component-class
    270      :initform 'cl-source-file :initarg :default-component-class)))
    271 
    272 (defgeneric component-pathname (component)
    273   (:documentation "Extracts the pathname applicable for a particular component."))
    274 
    275 (defun component-parent-pathname (component)
    276   (aif (component-parent component)
    277        (component-pathname it)
    278        *default-pathname-defaults*))
    279 
    280 (defgeneric component-relative-pathname (component)
    281   (:documentation "Extracts the relative pathname applicable for a particular component."))
    282 
    283 (defmethod component-relative-pathname ((component module))
    284   (or (slot-value component 'relative-pathname)
    285       (make-pathname
    286        :directory `(:relative ,(component-name component))
    287        :host (pathname-host (component-parent-pathname component)))))
    288 
    289 (defmethod component-pathname ((component component))
    290   (let ((*default-pathname-defaults* (component-parent-pathname component)))
    291     (merge-pathnames (component-relative-pathname component))))
    292 
    293 (defgeneric component-property (component property))
    294 
    295 (defmethod component-property ((c component) property)
    296   (cdr (assoc property (slot-value c 'properties) :test #'equal)))
    297 
    298 (defgeneric (setf component-property) (new-value component property))
    299 
    300 (defmethod (setf component-property) (new-value (c component) property)
    301   (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
    302     (if a
    303         (setf (cdr a) new-value)
    304         (setf (slot-value c 'properties)
    305               (acons property new-value (slot-value c 'properties))))))
    306 
    307 (defclass system (module)
    308   ((description :accessor system-description :initarg :description)
    309    (long-description
    310     :accessor system-long-description :initarg :long-description)
    311    (author :accessor system-author :initarg :author)
    312    (maintainer :accessor system-maintainer :initarg :maintainer)
    313    (licence :accessor system-licence :initarg :licence
    314             :accessor system-license :initarg :license)))
    315 
    316 ;;; version-satisfies
    317 
    318 ;;; with apologies to christophe rhodes ...
    319 (defun split (string &optional max (ws '(#\Space #\Tab)))
    320   (flet ((is-ws (char) (find char ws)))
    321     (nreverse
    322      (let ((list nil) (start 0) (words 0) end)
    323        (loop
    324          (when (and max (>= words (1- max)))
    325            (return (cons (subseq string start) list)))
    326          (setf end (position-if #'is-ws string :start start))
    327          (push (subseq string start end) list)
    328          (incf words)
    329          (unless end (return list))
    330          (setf start (1+ end)))))))
    331 
    332 (defgeneric version-satisfies (component version))
    333 
    334 (defmethod version-satisfies ((c component) version)
    335   (unless (and version (slot-boundp c 'version))
    336     (return-from version-satisfies t))
    337   (let ((x (mapcar #'parse-integer
    338                    (split (component-version c) nil '(#\.))))
    339         (y (mapcar #'parse-integer
    340                    (split version nil '(#\.)))))
    341     (labels ((bigger (x y)
    342                (cond ((not y) t)
    343                      ((not x) nil)
    344                      ((> (car x) (car y)) t)
    345                      ((= (car x) (car y))
    346                       (bigger (cdr x) (cdr y))))))
    347       (and (= (car x) (car y))
    348            (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
    349 
    350 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    351 ;;; finding systems
    352 
    353 (defvar *defined-systems* (make-hash-table :test 'equal))
    354 (defun coerce-name (name)
    355   (typecase name
    356     (component (component-name name))
    357     (symbol (string-downcase (symbol-name name)))
    358     (string name)
    359     (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
    360 
    361 ;;; for the sake of keeping things reasonably neat, we adopt a
    362 ;;; convention that functions in this list are prefixed SYSDEF-
    363 
    364 (defvar *system-definition-search-functions*
    365   '(sysdef-central-registry-search))
    366 
    367 (defun system-definition-pathname (system)
    368   (let ((system-name (coerce-name system)))
    369     (or
    370      (some (lambda (x) (funcall x system-name))
    371            *system-definition-search-functions*)
    372      (let ((system-pair (system-registered-p system-name)))
    373        (and system-pair
    374             (system-source-file (cdr system-pair)))))))
    375 
    376 (defvar *central-registry*
    377   '(*default-pathname-defaults*
    378     #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/"
    379     #+nil "telent:asdf;systems;"))
    380 
    381 (defun sysdef-central-registry-search (system)
    382   (let ((name (coerce-name system)))
    383     (block nil
    384       (dolist (dir *central-registry*)
    385         (let* ((defaults (eval dir))
    386                (file (and defaults
    387                           (make-pathname
    388                            :defaults defaults :version :newest
    389                            :name name :type "asd" :case :local))))
    390           (if (and file (probe-file file))
    391               (return file)))))))
    392 
    393 (defun make-temporary-package ()
    394   (flet ((try (counter)
    395            (ignore-errors
    396              (make-package (format nil "ASDF~D" counter)
    397                            :use '(:cl :asdf)))))
    398     (do* ((counter 0 (+ counter 1))
    399           (package (try counter) (try counter)))
    400          (package package))))
    401 
    402 (defun find-system (name &optional (error-p t))
    403   (let* ((name (coerce-name name))
    404          (in-memory (system-registered-p name))
    405          (on-disk (system-definition-pathname name)))
    406     (when (and on-disk
    407                (or (not in-memory)
    408                    (< (car in-memory) (file-write-date on-disk))))
    409       (let ((package (make-temporary-package)))
    410         (unwind-protect
    411              (let ((*package* package))
    412                (format
    413                 *verbose-out*
    414                 "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
    415                 ;; FIXME: This wants to be (ENOUGH-NAMESTRING
    416                 ;; ON-DISK), but CMUCL barfs on that.
    417                 on-disk
    418                 *package*)
    419                (load on-disk))
    420           (delete-package package))))
    421     (let ((in-memory (system-registered-p name)))
    422       (if in-memory
    423           (progn (if on-disk (setf (car in-memory) (file-write-date on-disk)))
    424                  (cdr in-memory))
    425           (if error-p (error 'missing-component :requires name))))))
    426 
    427 (defun register-system (name system)
    428   (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
    429   (setf (gethash (coerce-name name) *defined-systems*)
    430         (cons (get-universal-time) system)))
    431 
    432 (defun system-registered-p (name)
    433   (gethash (coerce-name name) *defined-systems*))
    434 
    435 
    436 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    437 ;;; finding components
    438 
    439 (defgeneric find-component (module name &optional version)
    440   (:documentation "Finds the component with name NAME present in the
    441 MODULE module; if MODULE is nil, then the component is assumed to be a
    442 system."))
    443 
    444 (defmethod find-component ((module module) name &optional version)
    445   (if (slot-boundp module 'components)
    446       (let ((m (find name (module-components module)
    447                      :test #'equal :key #'component-name)))
    448         (if (and m (version-satisfies m version)) m))))
    449 
    450 
    451 ;;; a component with no parent is a system
    452 (defmethod find-component ((module (eql nil)) name &optional version)
    453   (let ((m (find-system name nil)))
    454     (if (and m (version-satisfies m version)) m)))
    455 
    456 ;;; component subclasses
    457 
    458 (defclass source-file (component) ())
    459 
    460 (defclass cl-source-file (source-file) ())
    461 (defclass c-source-file (source-file) ())
    462 (defclass java-source-file (source-file) ())
    463 (defclass static-file (source-file) ())
    464 (defclass doc-file (static-file) ())
    465 (defclass html-file (doc-file) ())
    466 
    467 (defgeneric source-file-type (component system))
    468 (defmethod source-file-type ((c cl-source-file) (s module)) "lisp")
    469 (defmethod source-file-type ((c c-source-file) (s module)) "c")
    470 (defmethod source-file-type ((c java-source-file) (s module)) "java")
    471 (defmethod source-file-type ((c html-file) (s module)) "html")
    472 (defmethod source-file-type ((c static-file) (s module)) nil)
    473 
    474 (defmethod component-relative-pathname ((component source-file))
    475   (let ((relative-pathname (slot-value component 'relative-pathname)))
    476     (if relative-pathname
    477         (merge-pathnames
    478          relative-pathname
    479          (make-pathname
    480           :type (source-file-type component (component-system component))))
    481         (let* ((*default-pathname-defaults*
    482                 (component-parent-pathname component))
    483                (name-type
    484                 (make-pathname
    485                  :name (component-name component)
    486                  :type (source-file-type component
    487                                          (component-system component)))))
    488           name-type))))
    489 
    490 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    491 ;;; operations
    492 
    493 ;;; one of these is instantiated whenever (operate ) is called
    494 
    495 (defclass operation ()
    496   ((forced :initform nil :initarg :force :accessor operation-forced)
    497    (original-initargs :initform nil :initarg :original-initargs
    498                       :accessor operation-original-initargs)
    499    (visited-nodes :initform nil :accessor operation-visited-nodes)
    500    (visiting-nodes :initform nil :accessor operation-visiting-nodes)
    501    (parent :initform nil :initarg :parent :accessor operation-parent)))
    502 
    503 (defmethod print-object ((o operation) stream)
    504   (print-unreadable-object (o stream :type t :identity t)
    505     (ignore-errors
    506       (prin1 (operation-original-initargs o) stream))))
    507 
    508 (defmethod shared-initialize :after ((operation operation) slot-names
    509                                      &key force
    510                                      &allow-other-keys)
    511   (declare (ignore slot-names force))
    512   ;; empty method to disable initarg validity checking
    513   )
    514166
    515167(define-method-combination standard-asdf-method-combination ()
     
    540192          standard-form))))
    541193
     194(setf (documentation 'standard-asdf-method-combination
     195                     'method-combination)
     196      "This method combination is based on the standard method combination,
     197but defines a new method-qualifier, `asdf:around`.  `asdf:around`
     198methods will be run *around* any `:around` methods, so that the core
     199protocol may employ around methods and those around methods will not
     200be overridden by around methods added by a system developer.")
     201
    542202(defgeneric perform (operation component)
    543203  (:method-combination standard-asdf-method-combination))
     
    551211  (:method-combination standard-asdf-method-combination))
    552212
    553 (defun node-for (o c)
    554   (cons (class-name (class-of o)) c))
     213(defgeneric system-source-file (system)
     214  (:documentation "Return the source file in which system is defined."))
     215
     216(defgeneric component-system (component)
     217  (:documentation "Find the top-level system containing COMPONENT"))
     218
     219(defgeneric component-pathname (component)
     220  (:documentation "Extracts the pathname applicable for a particular component."))
     221
     222(defgeneric component-relative-pathname (component)
     223  (:documentation "Extracts the relative pathname applicable for a particular component."))
     224
     225(defgeneric component-property (component property))
     226
     227(defgeneric (setf component-property) (new-value component property))
     228
     229(defgeneric version-satisfies (component version))
     230
     231(defgeneric find-component (module name &optional version)
     232  (:documentation "Finds the component with name NAME present in the
     233MODULE module; if MODULE is nil, then the component is assumed to be a
     234system."))
     235
     236(defgeneric source-file-type (component system))
    555237
    556238(defgeneric operation-ancestor (operation)
     
    558240   "Recursively chase the operation's parent pointer until we get to
    559241the head of the tree"))
     242
     243(defgeneric component-visited-p (operation component))
     244
     245(defgeneric visit-component (operation component data))
     246
     247(defgeneric (setf visiting-component) (new-value operation component))
     248
     249(defgeneric component-visiting-p (operation component))
     250
     251(defgeneric component-depends-on (operation component)
     252  (:documentation
     253   "Returns a list of dependencies needed by the component to perform
     254    the operation.  A dependency has one of the following forms:
     255
     256      (<operation> <component>*), where <operation> is a class
     257        designator and each <component> is a component
     258        designator, which means that the component depends on
     259        <operation> having been performed on each <component>; or
     260
     261      (FEATURE <feature>), which means that the component depends
     262        on <feature>'s presence in *FEATURES*.
     263
     264    Methods specialized on subclasses of existing component types
     265    should usually append the results of CALL-NEXT-METHOD to the
     266    list."))
     267
     268(defgeneric component-self-dependencies (operation component))
     269
     270(defgeneric traverse (operation component)
     271  (:documentation
     272"Generate and return a plan for performing `operation` on `component`.
     273
     274The plan returned is a list of dotted-pairs. Each pair is the `cons`
     275of ASDF operation object and a `component` object. The pairs will be
     276processed in order by `operate`."))
     277
     278(defgeneric output-files-using-mappings (source possible-paths path-mappings)
     279  (:documentation
     280"Use the variable \\*source-to-target-mappings\\* to find
     281an output path for the source. The algorithm transforms each
     282entry in possible-paths as follows: If there is a mapping
     283whose source starts with the path of possible-path, then
     284replace possible-path with a pathname that starts with the
     285target of the mapping and continues with the rest of
     286possible-path. If no such mapping is found, then use the
     287default mapping.
     288
     289If \\*centralize-lisp-binaries\\* is false, then the default
     290mapping is to place the output in a subdirectory of the
     291source. The subdirectory is named using the Lisp
     292implementation \(see
     293implementation-specific-directory-name\). If
     294\\*centralize-lisp-binaries\\* is true, then the default
     295mapping is to place the output in subdirectories of
     296\\*default-toplevel-directory\\* where the subdirectory
     297structure will mirror that of the source."))
     298
     299
     300;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     301;; utility stuff
     302
     303(defmacro aif (test then &optional else)
     304  `(let ((it ,test)) (if it ,then ,else)))
     305
     306(defun pathname-sans-name+type (pathname)
     307  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
     308and NIL NAME and TYPE components"
     309  (make-pathname :name nil :type nil :defaults pathname))
     310
     311(define-modify-macro appendf (&rest args)
     312  append "Append onto list")
     313
     314(defun asdf-message (format-string &rest format-args)
     315  (declare (dynamic-extent format-args))
     316  (apply #'format *verbose-out* format-string format-args))
     317
     318(defun split-path-string (s &optional force-directory)
     319  (check-type s string)
     320  (let* ((components (split s nil "/"))
     321         (last-comp (car (last components))))
     322    (multiple-value-bind (relative components)
     323        (if (equal (first components) "")
     324          (values :absolute (cdr components))
     325          (values :relative components))
     326      (cond
     327        ((equal last-comp "")
     328         (values relative (butlast components) nil))
     329        (force-directory
     330         (values relative components nil))
     331        (t
     332         (values relative (butlast components) last-comp))))))
     333
     334;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     335;; classes, condiitons
     336
     337(define-condition system-definition-error (error) ()
     338  ;; [this use of :report should be redundant, but unfortunately it's not.
     339  ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
     340  ;; over print-object; this is always conditions::%print-condition for
     341  ;; condition objects, which in turn does inheritance of :report options at
     342  ;; run-time.  fortunately, inheritance means we only need this kludge here in
     343  ;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]
     344  #+cmu (:report print-object))
     345
     346(define-condition formatted-system-definition-error (system-definition-error)
     347  ((format-control :initarg :format-control :reader format-control)
     348   (format-arguments :initarg :format-arguments :reader format-arguments))
     349  (:report (lambda (c s)
     350             (apply #'format s (format-control c) (format-arguments c)))))
     351
     352(define-condition circular-dependency (system-definition-error)
     353  ((components :initarg :components :reader circular-dependency-components)))
     354
     355(define-condition duplicate-names (system-definition-error)
     356  ((name :initarg :name :reader duplicate-names-name)))
     357
     358(define-condition missing-component (system-definition-error)
     359  ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
     360   (parent :initform nil :reader missing-parent :initarg :parent)))
     361
     362(define-condition missing-component-of-version (missing-component)
     363  ((version :initform nil :reader missing-version :initarg :version)))
     364
     365(define-condition missing-dependency (missing-component)
     366  ((required-by :initarg :required-by :reader missing-required-by)))
     367
     368(define-condition missing-dependency-of-version (missing-dependency
     369                                                 missing-component-of-version)
     370  ())
     371
     372(define-condition operation-error (error)
     373  ((component :reader error-component :initarg :component)
     374   (operation :reader error-operation :initarg :operation))
     375  (:report (lambda (c s)
     376             (format s "~@<erred while invoking ~A on ~A~@:>"
     377                     (error-operation c) (error-component c)))))
     378(define-condition compile-error (operation-error) ())
     379(define-condition compile-failed (compile-error) ())
     380(define-condition compile-warned (compile-error) ())
     381
     382(defclass component ()
     383  ((name :accessor component-name :initarg :name :documentation
     384         "Component name: designator for a string composed of portable pathname characters")
     385   (version :accessor component-version :initarg :version)
     386   (in-order-to :initform nil :initarg :in-order-to)
     387   ;; XXX crap name
     388   (do-first :initform nil :initarg :do-first)
     389   ;; methods defined using the "inline" style inside a defsystem form:
     390   ;; need to store them somewhere so we can delete them when the system
     391   ;; is re-evaluated
     392   (inline-methods :accessor component-inline-methods :initform nil)
     393   (parent :initarg :parent :initform nil :reader component-parent)
     394   ;; no direct accessor for pathname, we do this as a method to allow
     395   ;; it to default in funky ways if not supplied
     396   (relative-pathname :initarg :pathname)
     397   (operation-times :initform (make-hash-table )
     398                    :accessor component-operation-times)
     399   ;; XXX we should provide some atomic interface for updating the
     400   ;; component properties
     401   (properties :accessor component-properties :initarg :properties
     402               :initform nil)))
     403
     404;;;; methods: conditions
     405
     406(defmethod print-object ((c missing-dependency) s)
     407  (format s "~@<~A, required by ~A~@:>"
     408          (call-next-method c nil) (missing-required-by c)))
     409
     410(defun sysdef-error (format &rest arguments)
     411  (error 'formatted-system-definition-error :format-control
     412         format :format-arguments arguments))
     413
     414;;;; methods: components
     415
     416(defmethod print-object ((c missing-component) s)
     417   (format s "~@<component ~S not found~
     418             ~@[ in ~A~]~@:>"
     419          (missing-requires c)
     420          (when (missing-parent c)
     421            (component-name (missing-parent c)))))
     422
     423(defmethod print-object ((c missing-component-of-version) s)
     424  (format s "~@<component ~S does not match version ~A~
     425              ~@[ in ~A~]~@:>"
     426           (missing-requires c)
     427           (missing-version c)
     428           (when (missing-parent c)
     429             (component-name (missing-parent c)))))
     430
     431(defmethod component-system ((component component))
     432  (aif (component-parent component)
     433       (component-system it)
     434       component))
     435
     436(defmethod print-object ((c component) stream)
     437  (print-unreadable-object (c stream :type t :identity t)
     438    (ignore-errors
     439      (prin1 (component-name c) stream))))
     440
     441(defclass module (component)
     442  ((components :initform nil :accessor module-components :initarg :components)
     443   ;; what to do if we can't satisfy a dependency of one of this module's
     444   ;; components.  This allows a limited form of conditional processing
     445   (if-component-dep-fails :initform :fail
     446                           :accessor module-if-component-dep-fails
     447                           :initarg :if-component-dep-fails)
     448   (default-component-class :accessor module-default-component-class
     449     :initform 'cl-source-file :initarg :default-component-class)))
     450
     451(defun component-parent-pathname (component)
     452  (aif (component-parent component)
     453       (component-pathname it)
     454       *default-pathname-defaults*))
     455
     456(defmethod component-relative-pathname ((component module))
     457  (or (slot-value component 'relative-pathname)
     458      (multiple-value-bind (relative path)
     459          (split-path-string (component-name component) t)
     460        (make-pathname
     461         :directory `(,relative ,@path)
     462         :host (pathname-host (component-parent-pathname component))))))
     463
     464(defmethod component-pathname ((component component))
     465  (let ((*default-pathname-defaults* (component-parent-pathname component)))
     466    (merge-pathnames (component-relative-pathname component))))
     467
     468(defmethod component-property ((c component) property)
     469  (cdr (assoc property (slot-value c 'properties) :test #'equal)))
     470
     471(defmethod (setf component-property) (new-value (c component) property)
     472  (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
     473    (if a
     474        (setf (cdr a) new-value)
     475        (setf (slot-value c 'properties)
     476              (acons property new-value (slot-value c 'properties))))))
     477
     478(defclass system (module)
     479  ((description :accessor system-description :initarg :description)
     480   (long-description
     481    :accessor system-long-description :initarg :long-description)
     482   (author :accessor system-author :initarg :author)
     483   (maintainer :accessor system-maintainer :initarg :maintainer)
     484   (licence :accessor system-licence :initarg :licence
     485            :accessor system-license :initarg :license)
     486   (source-file :reader system-source-file :initarg :source-file
     487                :writer %set-system-source-file)))
     488
     489;;; version-satisfies
     490
     491;;; with apologies to christophe rhodes ...
     492(defun split (string &optional max (ws '(#\Space #\Tab)))
     493  (flet ((is-ws (char) (find char ws)))
     494    (nreverse
     495     (let ((list nil) (start 0) (words 0) end)
     496       (loop
     497         (when (and max (>= words (1- max)))
     498           (return (cons (subseq string start) list)))
     499         (setf end (position-if #'is-ws string :start start))
     500         (push (subseq string start end) list)
     501         (incf words)
     502         (unless end (return list))
     503         (setf start (1+ end)))))))
     504
     505(defmethod version-satisfies ((c component) version)
     506  (unless (and version (slot-boundp c 'version))
     507    (return-from version-satisfies t))
     508  (let ((x (mapcar #'parse-integer
     509                   (split (component-version c) nil '(#\.))))
     510        (y (mapcar #'parse-integer
     511                   (split version nil '(#\.)))))
     512    (labels ((bigger (x y)
     513               (cond ((not y) t)
     514                     ((not x) nil)
     515                     ((> (car x) (car y)) t)
     516                     ((= (car x) (car y))
     517                      (bigger (cdr x) (cdr y))))))
     518      (and (= (car x) (car y))
     519           (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
     520
     521;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     522;;; finding systems
     523
     524(defun make-defined-systems-table ()
     525  (make-hash-table :test 'equal))
     526
     527(defvar *defined-systems* (make-defined-systems-table))
     528
     529(defun coerce-name (name)
     530  (typecase name
     531    (component (component-name name))
     532    (symbol (string-downcase (symbol-name name)))
     533    (string name)
     534    (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
     535
     536(defun system-registered-p (name)
     537  (gethash (coerce-name name) *defined-systems*))
     538
     539(defun map-systems (fn)
     540  "Apply `fn` to each defined system.
     541
     542`fn` should be a function of one argument. It will be
     543called with an object of type asdf:system."
     544  (maphash (lambda (_ datum)
     545             (declare (ignore _))
     546             (destructuring-bind (_ . def) datum
     547               (declare (ignore _))
     548               (funcall fn def)))
     549           *defined-systems*))
     550
     551;;; for the sake of keeping things reasonably neat, we adopt a
     552;;; convention that functions in this list are prefixed SYSDEF-
     553
     554(defvar *system-definition-search-functions*
     555  '(sysdef-central-registry-search))
     556
     557(defun system-definition-pathname (system)
     558  (let ((system-name (coerce-name system)))
     559    (or
     560     (some (lambda (x) (funcall x system-name))
     561           *system-definition-search-functions*)
     562     (let ((system-pair (system-registered-p system-name)))
     563       (and system-pair
     564            (system-source-file (cdr system-pair)))))))
     565
     566(defvar *central-registry*
     567  `((directory-namestring *default-pathname-defaults*))
     568"A list of 'system directory designators' ASDF uses to find systems.
     569
     570A 'system directory designator' is a pathname or a function
     571which evaluates to a pathname. For example:
     572
     573    (setf asdf:*central-registry*
     574          (list '*default-pathname-defaults*
     575                #p\"/home/me/cl/systems/\"
     576                #p\"/usr/share/common-lisp/systems/\"))
     577")
     578
     579(defun directory-pathname-p (pathname)
     580  "Does `pathname` represent a directory?
     581
     582A directory-pathname is a pathname _without_ a filename. The three
     583ways that the filename components can be missing are for it to be `nil`,
     584`:unspecific` or the empty string.
     585
     586Note that this does _not_ check to see that `pathname` points to an
     587actually-existing directory."
     588  (flet ((check-one (x)
     589           (not (null (member x '(nil :unspecific "")
     590                              :test 'equal)))))
     591    (and (check-one (pathname-name pathname))
     592         (check-one (pathname-type pathname)))))
     593
     594#+(or)
     595;;test
     596;;?? move into testsuite sometime soon
     597(every (lambda (p)
     598          (directory-pathname-p p))
     599        (list
     600         (make-pathname :name "." :type nil :directory '(:absolute "tmp"))
     601         (make-pathname :name "." :type "" :directory '(:absolute "tmp"))
     602         (make-pathname :name nil :type "" :directory '(:absolute "tmp"))
     603         (make-pathname :name "" :directory '(:absolute "tmp"))
     604         (make-pathname :type :unspecific :directory '(:absolute "tmp"))
     605         (make-pathname :name :unspecific :directory '(:absolute "tmp"))
     606         (make-pathname :name :unspecific :directory '(:absolute "tmp"))
     607         (make-pathname :type "" :directory '(:absolute "tmp"))
     608         ))
     609
     610(defun ensure-directory-pathname (pathname)
     611  (if (directory-pathname-p pathname)
     612      pathname
     613      (make-pathname :defaults pathname
     614                     :directory (append
     615                                 (pathname-directory pathname)
     616                                 (list (file-namestring pathname)))
     617                     :name nil :type nil :version nil)))
     618
     619(defun sysdef-central-registry-search (system)
     620  (let ((name (coerce-name system))
     621        (to-remove nil)
     622        (to-replace nil))
     623    (block nil
     624      (unwind-protect
     625           (dolist (dir *central-registry*)
     626             (let ((defaults (eval dir)))
     627               (when defaults
     628                 (cond ((directory-pathname-p defaults)
     629                        (let ((file (and defaults
     630                                         (make-pathname
     631                                          :defaults defaults :version :newest
     632                                          :name name :type "asd" :case :local)))
     633                               #+(and (or win32 windows) (not :clisp))
     634                               (shortcut (make-pathname
     635                                          :defaults defaults :version :newest
     636                                          :name name :type "asd.lnk" :case :local)))
     637                          (if (and file (probe-file file))
     638                              (return file))
     639                          #+(and (or win32 windows) (not :clisp))
     640                          (when (probe-file shortcut)
     641                            (let ((target (parse-windows-shortcut shortcut)))
     642                              (when target
     643                                (return (pathname target)))))))
     644                       (t
     645                        (restart-case
     646                            (let* ((*print-circle* nil)
     647                                   (message
     648                                    (format nil
     649                                            "~@<While searching for system `~a`: `~a` evaluated ~
     650to `~a` which is not a directory.~@:>"
     651                                            system dir defaults)))
     652                              (error message))
     653                          (remove-entry-from-registry ()
     654                            :report "Remove entry from *central-registry* and continue"
     655                            (push dir to-remove))
     656                          (coerce-entry-to-directory ()
     657                            :report (lambda (s)
     658                                      (format s "Coerce entry to ~a, replace ~a and continue."
     659                                              (ensure-directory-pathname defaults) dir))
     660                            (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
     661        ;; cleanup
     662        (dolist (dir to-remove)
     663          (setf *central-registry* (remove dir *central-registry*)))
     664        (dolist (pair to-replace)
     665          (let* ((current (car pair))
     666                 (new (cdr pair))
     667                 (position (position current *central-registry*)))
     668            (setf *central-registry*
     669                  (append (subseq *central-registry* 0 position)
     670                          (list new)
     671                          (subseq *central-registry* (1+ position))))))))))
     672
     673(defun make-temporary-package ()
     674  (flet ((try (counter)
     675           (ignore-errors
     676             (make-package (format nil "~a~D" 'asdf counter)
     677                           :use '(:cl :asdf)))))
     678    (do* ((counter 0 (+ counter 1))
     679          (package (try counter) (try counter)))
     680         (package package))))
     681
     682(defun find-system (name &optional (error-p t))
     683  (let* ((name (coerce-name name))
     684         (in-memory (system-registered-p name))
     685         (on-disk (system-definition-pathname name)))
     686    (when (and on-disk
     687               (or (not in-memory)
     688                   (< (car in-memory) (file-write-date on-disk))))
     689      (let ((package (make-temporary-package)))
     690        (unwind-protect
     691             (let ((*package* package))
     692               (asdf-message
     693                "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
     694                ;; FIXME: This wants to be (ENOUGH-NAMESTRING
     695                ;; ON-DISK), but CMUCL barfs on that.
     696                on-disk
     697                *package*)
     698               (load on-disk))
     699          (delete-package package))))
     700    (let ((in-memory (system-registered-p name)))
     701      (if in-memory
     702          (progn (if on-disk (setf (car in-memory) (file-write-date on-disk)))
     703                 (cdr in-memory))
     704          (if error-p (error 'missing-component :requires name))))))
     705
     706(defun register-system (name system)
     707  (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
     708  (setf (gethash (coerce-name name) *defined-systems*)
     709        (cons (get-universal-time) system)))
     710
     711
     712;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     713;;; finding components
     714
     715(defmethod find-component ((module module) name &optional version)
     716  (if (slot-boundp module 'components)
     717      (let ((m (find name (module-components module)
     718                     :test #'equal :key #'component-name)))
     719        (if (and m (version-satisfies m version)) m))))
     720
     721
     722;;; a component with no parent is a system
     723(defmethod find-component ((module (eql nil)) name &optional version)
     724  (let ((m (find-system name nil)))
     725    (if (and m (version-satisfies m version)) m)))
     726
     727;;; component subclasses
     728
     729(defclass source-file (component) ())
     730
     731(defclass cl-source-file (source-file) ())
     732(defclass c-source-file (source-file) ())
     733(defclass java-source-file (source-file) ())
     734(defclass static-file (source-file) ())
     735(defclass doc-file (static-file) ())
     736(defclass html-file (doc-file) ())
     737
     738(defmethod source-file-type ((c cl-source-file) (s module)) "lisp")
     739(defmethod source-file-type ((c c-source-file) (s module)) "c")
     740(defmethod source-file-type ((c java-source-file) (s module)) "java")
     741(defmethod source-file-type ((c html-file) (s module)) "html")
     742(defmethod source-file-type ((c static-file) (s module)) nil)
     743
     744(defmethod component-relative-pathname ((component source-file))
     745  (multiple-value-bind (relative path name)
     746      (split-path-string (component-name component))
     747    (let ((type (source-file-type component (component-system component)))
     748          (relative-pathname (slot-value component 'relative-pathname))
     749          (*default-pathname-defaults* (component-parent-pathname component)))
     750      (if relative-pathname
     751        (merge-pathnames
     752         relative-pathname
     753         (if type
     754           (make-pathname :name name :type type)
     755           name))
     756        (make-pathname :directory `(,relative ,@path) :name name :type type)))))
     757
     758;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     759;;; operations
     760
     761;;; one of these is instantiated whenever (operate ) is called
     762
     763(defclass operation ()
     764  ((forced :initform nil :initarg :force :accessor operation-forced)
     765   (original-initargs :initform nil :initarg :original-initargs
     766                      :accessor operation-original-initargs)
     767   (visited-nodes :initform nil :accessor operation-visited-nodes)
     768   (visiting-nodes :initform nil :accessor operation-visiting-nodes)
     769   (parent :initform nil :initarg :parent :accessor operation-parent)))
     770
     771(defmethod print-object ((o operation) stream)
     772  (print-unreadable-object (o stream :type t :identity t)
     773    (ignore-errors
     774      (prin1 (operation-original-initargs o) stream))))
     775
     776(defmethod shared-initialize :after ((operation operation) slot-names
     777                                     &key force
     778                                     &allow-other-keys)
     779  (declare (ignore slot-names force))
     780  ;; empty method to disable initarg validity checking
     781  )
     782
     783(defun node-for (o c)
     784  (cons (class-name (class-of o)) c))
    560785
    561786(defmethod operation-ancestor ((operation operation))
     
    585810
    586811
    587 (defgeneric component-visited-p (operation component))
    588 
    589 (defgeneric visit-component (operation component data))
    590 
    591812(defmethod visit-component ((o operation) (c component) data)
    592813  (unless (component-visited-p o c)
     
    598819         (operation-visited-nodes (operation-ancestor o))
    599820         :test 'equal))
    600 
    601 (defgeneric (setf visiting-component) (new-value operation component))
    602821
    603822(defmethod (setf visiting-component) (new-value operation component)
     
    613832              (remove node  (operation-visiting-nodes a) :test 'equal)))))
    614833
    615 (defgeneric component-visiting-p (operation component))
    616 
    617834(defmethod component-visiting-p ((o operation) (c component))
    618835  (let ((node (node-for o c)))
     
    620837            :test 'equal)))
    621838
    622 (defgeneric component-depends-on (operation component)
    623   (:documentation
    624    "Returns a list of dependencies needed by the component to perform
    625     the operation.  A dependency has one of the following forms:
    626 
    627       (<operation> <component>*), where <operation> is a class
    628         designator and each <component> is a component
    629         designator, which means that the component depends on
    630         <operation> having been performed on each <component>; or
    631 
    632       (FEATURE <feature>), which means that the component depends
    633         on <feature>'s presence in *FEATURES*.
    634 
    635     Methods specialized on subclasses of existing component types
    636     should usually append the results of CALL-NEXT-METHOD to the
    637     list."))
    638 
    639839(defmethod component-depends-on ((op-spec symbol) (c component))
    640840  (component-depends-on (make-instance op-spec) c))
     
    643843  (cdr (assoc (class-name (class-of o))
    644844              (slot-value c 'in-order-to))))
    645 
    646 (defgeneric component-self-dependencies (operation component))
    647845
    648846(defmethod component-self-dependencies ((o operation) (c component))
     
    706904;;; methods".  And the answer is, because standard method combination
    707905;;; runs :before methods most->least-specific, which is back to front
    708 ;;; for our purposes.  And CLISP doesn't have non-standard method
    709 ;;; combinations, so let's keep it simple and aspire to portability
    710 
    711 (defgeneric traverse (operation component))
     906;;; for our purposes. 
     907
    712908(defmethod traverse ((operation operation) (c component))
    713909  (let ((forced nil))
    714     (labels ((do-one-dep (required-op required-c required-v)
     910    (labels ((%do-one-dep (required-op required-c required-v)
    715911               (let* ((dep-c (or (find-component
    716912                                  (component-parent c)
     
    729925                      (op (make-sub-operation c operation dep-c required-op)))
    730926                 (traverse op dep-c)))
     927             (do-one-dep (required-op required-c required-v)
     928               (loop
     929                  (restart-case
     930                      (return (%do-one-dep required-op required-c required-v))
     931                    (retry ()
     932                      :report (lambda (s)
     933                                (format s "~@<Retry loading component ~S.~@:>"
     934                                        required-c))
     935                      :test
     936                      (lambda (c)
     937#|
     938                        (print (list :c1 c (typep c 'missing-dependency)))
     939                        (when (typep c 'missing-dependency)
     940                          (print (list :c2 (missing-requires c) required-c
     941                                       (equalp (missing-requires c)
     942                                               required-c))))
     943|#
     944                        (and (typep c 'missing-dependency)
     945                             (equalp (missing-requires c)
     946                                     required-c)))))))
    731947             (do-dep (op dep)
    732948               (cond ((eq op 'feature)
     
    738954                      (dolist (d dep)
    739955                        (cond ((consp d)
    740                                (assert (string-equal
    741                                         (symbol-name (first d))
    742                                         "VERSION"))
    743                                (appendf forced
    744                                         (do-one-dep op (second d) (third d))))
     956                               (cond ((string-equal
     957                                       (symbol-name (first d))
     958                                       "VERSION")
     959                                      (appendf
     960                                       forced
     961                                       (do-one-dep op (second d) (third d))))
     962                                     ((and (string-equal
     963                                            (symbol-name (first d))
     964                                            "FEATURE")
     965                                           (find (second d) *features*
     966                                                 :test 'string-equal))
     967                                      (appendf
     968                                       forced
     969                                       (do-one-dep op (second d) (third d))))
     970                                     (t
     971                                      (error "Bad dependency ~a.  Dependencies must be (:version <version>), (:feature <feature>), or a name" d))))
    745972                              (t
    746973                               (appendf forced (do-one-dep op d nil)))))))))
     
    754981      (unwind-protect
    755982           (progn
    756              (loop for (required-op . deps) in 
     983             (loop for (required-op . deps) in
    757984                  (component-depends-on operation c)
    758                 do (do-dep required-op deps))
     985                  do (do-dep required-op deps))
    759986             ;; constituent bits
    760987             (let ((module-ops
     
    767994                                  (appendf forced (traverse operation kid ))
    768995                                (missing-dependency (condition)
    769                                   (if (eq (module-if-component-dep-fails c) 
     996                                  (if (eq (module-if-component-dep-fails c)
    770997                                          :fail)
    771998                                      (error condition))
     
    7821009               (when (or forced module-ops
    7831010                         (not (operation-done-p operation c))
    784                          (let ((f (operation-forced 
     1011                         (let ((f (operation-forced
    7851012                                   (operation-ancestor operation))))
    7861013                           (and f (or (not (consp f))
     
    8111038
    8121039(defmethod explain ((operation operation) (component component))
    813   (format *verbose-out* "~&;;; ~A on ~A~%" operation component))
     1040  (asdf-message "~&;;; ~A on ~A~%" operation component))
    8141041
    8151042;;; compile-op
     
    8901117            (perform (make-instance 'asdf:compile-op) c))
    8911118           (t
    892             (with-simple-restart 
     1119            (with-simple-restart
    8931120                (try-recompiling "Recompile ~a and try loading it again"
    8941121                                  (component-name c))
     
    9101137            (perform (make-instance 'asdf:compile-op) c))
    9111138           (t
    912             (with-simple-restart 
     1139            (with-simple-restart
    9131140                (try-recompiling "Try recompiling ~a"
    9141141                                  (component-name c))
     
    9711198  nil)
    9721199
     1200(defmethod component-depends-on :around ((o test-op) (c system))
     1201  (cons `(load-op ,(component-name c)) (call-next-method)))
     1202
     1203
    9731204;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    9741205;;; invoking operations
    9751206
    976 (defvar *operate-docstring*
    977   "Operate does three things:
    978 
    979 1. It creates an instance of `operation-class` using any keyword parameters
    980 as initargs.
    981 2. It finds the  asdf-system specified by `system` (possibly loading
    982 it from disk).
    983 3. It then calls `traverse` with the operation and system as arguments
    984 
    985 The traverse operation is wrapped in `with-compilation-unit` and error
    986 handling code. If a `version` argument is supplied, then operate also
    987 ensures that the system found satisfies it using the `version-satisfies`
    988 method.")
    989 
    990 (defun operate (operation-class system &rest args &key (verbose t) version
     1207(defun operate (operation-class system &rest args &key (verbose t) version force
    9911208                &allow-other-keys)
    992   (let* ((op (apply #'make-instance operation-class
     1209  (declare (ignore force))
     1210  (let* ((*package* *package*)
     1211         (*readtable* *readtable*)
     1212         (op (apply #'make-instance operation-class
    9931213                    :original-initargs args
    9941214                    args))
     
    10181238                                      (component-operation-times component))
    10191239                             (get-universal-time))
    1020                        (return)))))))))
    1021 
    1022 (setf (documentation 'operate 'function)
    1023       *operate-docstring*)
    1024 
    1025 (defun oos (operation-class system &rest args &key force (verbose t) version)
     1240                       (return)))))))
     1241    op))
     1242
     1243(defun oos (operation-class system &rest args &key force (verbose t) version
     1244            &allow-other-keys)
    10261245  (declare (ignore force verbose version))
    10271246  (apply #'operate operation-class system args))
    10281247
    1029 (setf (documentation 'oos 'function)
    1030       (format nil
    1031               "Short for _operate on system_ and an alias for the `operate` function. ~&~&~a"
    1032               *operate-docstring*))
     1248(let ((operate-docstring
     1249  "Operate does three things:
     1250
     12511. It creates an instance of `operation-class` using any keyword parameters
     1252as initargs.
     12532. It finds the  asdf-system specified by `system` (possibly loading
     1254it from disk).
     12553. It then calls `traverse` with the operation and system as arguments
     1256
     1257The traverse operation is wrapped in `with-compilation-unit` and error
     1258handling code. If a `version` argument is supplied, then operate also
     1259ensures that the system found satisfies it using the `version-satisfies`
     1260method.
     1261
     1262Note that dependencies may cause the operation to invoke other
     1263operations on the system or its components: the new operations will be
     1264created with the same initargs as the original one.
     1265"))
     1266  (setf (documentation 'oos 'function)
     1267        (format nil
     1268                "Short for _operate on system_ and an alias for the [operate][] function. ~&~&~a"
     1269                operate-docstring))
     1270  (setf (documentation 'operate 'function)
     1271        operate-docstring))
     1272
     1273(defun load-system (system &rest args &key force (verbose t) version)
     1274  "Shorthand for `(operate 'asdf:load-op system)`. See [operate][] for details."
     1275  (declare (ignore force verbose version))
     1276  (apply #'operate 'load-op system args))
     1277
     1278(defun compile-system (system &rest args &key force (verbose t) version)
     1279  "Shorthand for `(operate 'asdf:compile-op system)`. See [operate][] for details."
     1280  (declare (ignore force verbose version))
     1281  (apply #'operate 'compile-op system args))
     1282
     1283(defun test-system (system &rest args &key force (verbose t) version)
     1284  "Shorthand for `(operate 'asdf:test-op system)`. See [operate][] for details."
     1285  (declare (ignore force verbose version))
     1286  (apply #'operate 'test-op system args))
    10331287
    10341288;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    10431297                                                 key (cddr arglist))))))))
    10441298    (aux key arglist)))
     1299
     1300(defun resolve-symlinks (path)
     1301  #-allegro (truename path)
     1302  #+allegro (excl:pathname-resolve-symbolic-links path)
     1303  )
     1304
     1305(defun determine-system-pathname (pathname pathname-supplied-p)
     1306  ;; called from the defsystem macro.
     1307  ;; the pathname of a system is either
     1308  ;; 1. the one supplied,
     1309  ;; 2. derived from the *load-truename* (see below), or
     1310  ;; 3. taken from *default-pathname-defaults*
     1311  ;;
     1312  ;; if using *load-truename*, then we also deal with whether or not
     1313  ;; to resolve symbolic links. If not resolving symlinks, then we use
     1314  ;; *load-pathname* instead of *load-truename* since in some
     1315  ;; implementations, the latter has *already resolved it.
     1316  (or (and pathname-supplied-p pathname)
     1317      (when *load-truename*
     1318        (pathname-sans-name+type
     1319         (if *resolve-symlinks*
     1320             (resolve-symlinks *load-truename*)
     1321             *load-pathname*)))
     1322      *default-pathname-defaults*))
    10451323
    10461324(defmacro defsystem (name &body options)
     
    10571335                  (setf (car s) (get-universal-time)))
    10581336                 (s
    1059                   #+clisp
    1060                   (sysdef-error "Cannot redefine the existing system ~A with a different class" s)
    1061                   #-clisp
    10621337                  (change-class (cdr s) ',class))
    10631338                 (t
    10641339                  (register-system (quote ,name)
    1065                                    (make-instance ',class :name ',name)))))
    1066          (parse-component-form nil (apply
    1067                                     #'list
    1068                                     :module (coerce-name ',name)
    1069                                     :pathname
    1070                                     ;; to avoid a note about unreachable code
    1071                                     ,(if pathname-arg-p
    1072                                          pathname
    1073                                          `(or (when *load-truename*
    1074                                                 (pathname-sans-name+type
    1075                                                  (resolve-symlinks
    1076                                                   *load-truename*)))
    1077                                               *default-pathname-defaults*))
    1078                                     ',component-options))))))
     1340                                   (make-instance ',class :name ',name))))
     1341           (%set-system-source-file *load-truename*
     1342                                    (cdr (system-registered-p ',name))))
     1343         (parse-component-form
     1344          nil (apply
     1345               #'list
     1346               :module (coerce-name ',name)
     1347               :pathname
     1348               ,(determine-system-pathname pathname pathname-arg-p)
     1349               ',component-options))))))
    10791350
    10801351
     
    11311402(defvar *serial-depends-on*)
    11321403
     1404(defun sysdef-error-component (msg type name value)
     1405  (sysdef-error (concatenate 'string msg
     1406                             "~&The value specified for ~(~A~) ~A is ~W")
     1407                type name value))
     1408
     1409(defun check-component-input (type name weakly-depends-on
     1410                              depends-on components in-order-to)
     1411  "A partial test of the values of a component."
     1412  (unless (listp depends-on)
     1413    (sysdef-error-component ":depends-on must be a list."
     1414                            type name depends-on))
     1415  (unless (listp weakly-depends-on)
     1416    (sysdef-error-component ":weakly-depends-on must be a list."
     1417                            type name weakly-depends-on))
     1418  (unless (listp components)
     1419    (sysdef-error-component ":components must be NIL or a list of components."
     1420                            type name components))
     1421  (unless (and (listp in-order-to) (listp (car in-order-to)))
     1422    (sysdef-error-component ":in-order-to must be NIL or a list of components."
     1423                            type name in-order-to)))
     1424
     1425(defun %remove-component-inline-methods (component)
     1426  (loop for name in +asdf-methods+
     1427        do (map 'nil
     1428                ;; this is inefficient as most of the stored
     1429                ;; methods will not be for this particular gf n
     1430                ;; But this is hardly performance-critical
     1431                (lambda (m)
     1432                  (remove-method (symbol-function name) m))
     1433                (component-inline-methods component)))
     1434  ;; clear methods, then add the new ones
     1435  (setf (component-inline-methods component) nil))
     1436
     1437(defun %define-component-inline-methods (ret rest)
     1438  (loop for name in +asdf-methods+ do
     1439       (let ((keyword (intern (symbol-name name) :keyword)))
     1440         (loop for data = rest then (cddr data)
     1441              for key = (first data)
     1442              for value = (second data)
     1443              while data
     1444              when (eq key keyword) do
     1445              (destructuring-bind (op qual (o c) &body body) value
     1446              (pushnew
     1447                 (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
     1448                                   ,@body))
     1449                 (component-inline-methods ret)))))))
     1450
     1451(defun %refresh-component-inline-methods (component rest)
     1452  (%remove-component-inline-methods component)
     1453  (%define-component-inline-methods component rest))
     1454 
    11331455(defun parse-component-form (parent options)
    11341456
     
    12051527            (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on))))
    12061528
    1207       (%remove-component-inline-methods ret rest)
     1529      (%refresh-component-inline-methods ret rest)
    12081530
    12091531      ret)))
    1210 
    1211 (defun %remove-component-inline-methods (ret rest)
    1212   (loop for name in +asdf-methods+
    1213         do (map 'nil
    1214                 ;; this is inefficient as most of the stored
    1215                 ;; methods will not be for this particular gf n
    1216                 ;; But this is hardly performance-critical
    1217                 (lambda (m)
    1218                   (remove-method (symbol-function name) m))
    1219                 (component-inline-methods ret)))
    1220   ;; clear methods, then add the new ones
    1221   (setf (component-inline-methods ret) nil)
    1222   (loop for name in +asdf-methods+
    1223         for v = (getf rest (intern (symbol-name name) :keyword))
    1224         when v do
    1225         (destructuring-bind (op qual (o c) &body body) v
    1226           (pushnew
    1227            (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
    1228                              ,@body))
    1229            (component-inline-methods ret)))))
    1230 
    1231 (defun check-component-input (type name weakly-depends-on depends-on components in-order-to)
    1232   "A partial test of the values of a component."
    1233   (when weakly-depends-on (warn "We got one! XXXXX"))
    1234   (unless (listp depends-on)
    1235     (sysdef-error-component ":depends-on must be a list."
    1236                             type name depends-on))
    1237   (unless (listp weakly-depends-on)
    1238     (sysdef-error-component ":weakly-depends-on must be a list."
    1239                             type name weakly-depends-on))
    1240   (unless (listp components)
    1241     (sysdef-error-component ":components must be NIL or a list of components."
    1242                             type name components))
    1243   (unless (and (listp in-order-to) (listp (car in-order-to)))
    1244     (sysdef-error-component ":in-order-to must be NIL or a list of components."
    1245                             type name in-order-to)))
    1246 
    1247 (defun sysdef-error-component (msg type name value)
    1248   (sysdef-error (concatenate 'string msg
    1249                              "~&The value specified for ~(~A~) ~A is ~W")
    1250                 type name value))
    1251 
    1252 (defun resolve-symlinks (path)
    1253   #-allegro (truename path)
    1254   #+allegro (excl:pathname-resolve-symbolic-links path)
    1255   )
    12561532
    12571533;;; optional extras
     
    12621538
    12631539(defun run-shell-command (control-string &rest args)
    1264   "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
     1540  "Interpolate `args` into `control-string` as if by `format`, and
    12651541synchronously execute the result using a Bourne-compatible shell, with
    1266 output to *VERBOSE-OUT*.  Returns the shell's exit code."
     1542output to `*verbose-out*`.  Returns the shell's exit code."
    12671543  (let ((command (apply #'format nil control-string args)))
    1268     (format *verbose-out* "; $ ~A~%" command)
     1544    (asdf-message "; $ ~A~%" command)
    12691545    #+sbcl
    12701546    (sb-ext:process-exit-code
    1271      (sb-ext:run-program
    1272       #+win32 "sh" #-win32 "/bin/sh"
    1273       (list  "-c" command)
    1274       #+win32 #+win32 :search t
    1275       :input nil :output *verbose-out*))
     1547     (apply #'sb-ext:run-program
     1548            #+win32 "sh" #-win32 "/bin/sh"
     1549            (list  "-c" command)
     1550            :input nil :output *verbose-out*
     1551            #+win32 '(:search t) #-win32 nil))
    12761552
    12771553    #+(or cmu scl)
     
    12831559
    12841560    #+allegro
    1285     (excl:run-shell-command command :input nil :output *verbose-out*)
     1561    ;; will this fail if command has embedded quotes - it seems to work
     1562    (multiple-value-bind (stdout stderr exit-code)
     1563        (excl.osi:command-output
     1564         (format nil "~a -c \"~a\""
     1565                 #+mswindows "sh" #-mswindows "/bin/sh" command)
     1566         :input nil :whole nil
     1567         #+mswindows :show-window #+mswindows :hide)
     1568      (format *verbose-out* "~{~&; ~a~%~}~%" stderr)
     1569      (format *verbose-out* "~{~&; ~a~%~}~%" stdout)
     1570      exit-code)
    12861571
    12871572    #+lispworks
     
    13001585                                 :input nil :output *verbose-out*
    13011586                                 :wait t)))
     1587
    13021588    #+ecl ;; courtesy of Juan Jose Garcia Ripoll
    13031589    (si:system command)
     1590
    13041591    #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl)
    13051592    (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
    13061593    ))
    13071594
    1308 (defgeneric system-source-file (system)
    1309   (:documentation "Return the source file in which system is defined."))
    1310 
    13111595(defmethod system-source-file ((system-name t))
    13121596  (system-source-file (find-system system-name)))
    13131597
    1314 (defmethod system-source-file ((system system))
    1315   (let ((pn (and (slot-boundp system 'relative-pathname)
    1316                  (make-pathname
    1317                   :type "asd"
    1318                   :name (asdf:component-name system)
    1319                   :defaults (asdf:component-relative-pathname system)))))
    1320     (when pn
    1321       (probe-file pn))))
    1322  
    13231598(defun system-source-directory (system-name)
    13241599  (make-pathname :name nil
     
    13361611                    :directory directory)
    13371612     (system-source-directory system))))
     1613
     1614;;; ---------------------------------------------------------------------------
     1615;;; asdf-binary-locations
     1616;;;
     1617;;; this bit of code was stolen from Bjorn Lindberg and then it grew!
     1618;;; see http://www.cliki.net/asdf%20binary%20locations
     1619;;; and http://groups.google.com/group/comp.lang.lisp/msg/bd5ea9d2008ab9fd
     1620;;; ---------------------------------------------------------------------------
     1621;;; Portions of this code were once from SWANK / SLIME
     1622
     1623(defparameter *centralize-lisp-binaries*
     1624  nil "
     1625If true, compiled lisp files without an explicit mapping (see
     1626\\*source-to-target-mappings\\*) will be placed in subdirectories of
     1627\\*default-toplevel-directory\\*. If false, then compiled lisp files
     1628without an explicitly mapping will be placed in subdirectories of
     1629their sources.")
     1630
     1631(defparameter *enable-asdf-binary-locations* nil
     1632  "
     1633If true, then compiled lisp files will be placed into a directory
     1634computed from the Lisp version, Operating System and computer archetecture.
     1635See [implementation-specific-directory-name][] for details.")
     1636
     1637
     1638(defparameter *default-toplevel-directory*
     1639  (merge-pathnames
     1640   (make-pathname :directory '(:relative ".fasls"))
     1641   (truename (user-homedir-pathname)))
     1642  "If \\*centralize-lisp-binaries\\* is true, then compiled lisp files without an explicit mapping \(see \\*source-to-target-mappings\\*\) will be placed in subdirectories of \\*default-toplevel-directory\\*.")
     1643
     1644(defparameter *include-per-user-information*
     1645  nil
     1646  "When \\*centralize-lisp-binaries\\* is true this variable controls whether or not to customize the output directory based on the current user. It can be nil, t or a string. If it is nil \(the default\), then no additional information will be added to the output directory. If it is t, then the user's name \(as taken from the return value of #'user-homedir-pathname\) will be included into the centralized path (just before the lisp-implementation directory). Finally, if \\*include-per-user-information\\* is a string, then this string will be included in the output-directory.")
     1647
     1648(defparameter *map-all-source-files*
     1649  nil
     1650  "If true, then all subclasses of source-file will have their output locations mapped by ASDF-Binary-Locations. If nil (the default), then only subclasses of cl-source-file will be mapped.")
     1651
     1652(defvar *source-to-target-mappings*
     1653  #-sbcl
     1654  nil
     1655  #+sbcl
     1656  (list (list (princ-to-string (sb-ext:posix-getenv "SBCL_HOME")) nil))
     1657  "The \\*source-to-target-mappings\\* variable specifies mappings from source to target. If the target is nil, then it means to not map the source to anything. I.e., to leave it as is. This has the effect of turning off ASDF-Binary-Locations for the given source directory. Examples:
     1658
     1659    ;; compile everything in .../src and below into .../cmucl
     1660    '((\"/nfs/home/compbio/d95-bli/share/common-lisp/src/\"
     1661       \"/nfs/home/compbio/d95-bli/lib/common-lisp/cmucl/\"))
     1662
     1663    ;; leave SBCL innards alone (SBCL specific)
     1664    (list (list (princ-to-string (sb-ext:posix-getenv \"SBCL_HOME\")) nil))
     1665")
     1666
     1667(defparameter *implementation-features*
     1668  '(:allegro :lispworks :sbcl :ccl :openmcl :cmu :clisp
     1669    :corman :cormanlisp :armedbear :gcl :ecl :scl))
     1670
     1671(defparameter *os-features*
     1672  '(:windows :mswindows :win32 :mingw32
     1673    :solaris :sunos
     1674    :macosx :darwin :apple
     1675    :freebsd :netbsd :openbsd :bsd
     1676    :linux :unix))
     1677
     1678(defparameter *architecture-features*
     1679  '(:amd64 (:x86-64 :x86_64 :x8664-target) :i686 :i586 :pentium3
     1680    :i486 (:i386 :pc386 :iapx386) (:x86 :x8632-target) :pentium4
     1681    :hppa64 :hppa :ppc64 :ppc32 :powerpc :ppc :sparc64 :sparc))
     1682
     1683;; note to gwking: this is in slime, system-check, and system-check-server too
     1684(defun lisp-version-string ()
     1685  #+cmu       (substitute #\- #\/
     1686                          (substitute #\_ #\Space
     1687                                      (lisp-implementation-version)))
     1688  #+scl       (lisp-implementation-version)
     1689  #+sbcl      (lisp-implementation-version)
     1690  #+ecl       (reduce (lambda (x str) (substitute #\_ str x))
     1691                      '(#\Space #\: #\( #\))
     1692                      :initial-value (lisp-implementation-version))
     1693  #+gcl       (let ((s (lisp-implementation-version))) (subseq s 4))
     1694  #+openmcl   (format nil "~d.~d~@[-~d~]"
     1695                      ccl::*openmcl-major-version*
     1696                      ccl::*openmcl-minor-version*
     1697                      #+ppc64-target 64
     1698                      #-ppc64-target nil)
     1699  #+lispworks (format nil "~A~@[~A~]"
     1700                      (lisp-implementation-version)
     1701                      (when (member :lispworks-64bit *features*) "-64bit"))
     1702  #+allegro   (format nil
     1703                      "~A~A~A~A"
     1704                      excl::*common-lisp-version-number*
     1705                                        ; ANSI vs MoDeRn
     1706                      ;; thanks to Robert Goldman and Charley Cox for
     1707                      ;; an improvement to my hack
     1708                      (if (eq excl:*current-case-mode*
     1709                              :case-sensitive-lower) "M" "A")
     1710                      ;; Note if not using International ACL
     1711                      ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
     1712                      (excl:ics-target-case
     1713                        (:-ics "8")
     1714                        (:+ics ""))
     1715                      (if (member :64bit *features*) "-64bit" ""))
     1716  #+clisp     (let ((s (lisp-implementation-version)))
     1717                (subseq s 0 (position #\space s)))
     1718  #+armedbear (lisp-implementation-version)
     1719  #+cormanlisp (lisp-implementation-version)
     1720  #+digitool   (subseq (lisp-implementation-version) 8))
     1721
     1722
     1723(defparameter *implementation-specific-directory-name* nil)
     1724
     1725(defun implementation-specific-directory-name ()
     1726  "Return a name that can be used as a directory name that is
     1727unique to a Lisp implementation, Lisp implementation version,
     1728operating system, and hardware architecture."
     1729  (and *enable-asdf-binary-locations*
     1730       (list
     1731        (or *implementation-specific-directory-name*
     1732            (setf *implementation-specific-directory-name*
     1733                  (labels
     1734                      ((fp (thing)
     1735                         (etypecase thing
     1736                           (symbol
     1737                            (let ((feature (find thing *features*)))
     1738                              (when feature (return-from fp feature))))
     1739                           ;; allows features to be lists of which the first
     1740                           ;; member is the "main name", the rest being aliases
     1741                           (cons
     1742                            (dolist (subf thing)
     1743                              (let ((feature (find subf *features*)))
     1744                                (when feature (return-from fp (first thing))))))))
     1745                       (first-of (features)
     1746                         (loop for f in features
     1747                            when (fp f) return it))
     1748                       (maybe-warn (value fstring &rest args)
     1749                         (cond (value)
     1750                               (t (apply #'warn fstring args)
     1751                                  "unknown"))))
     1752                    (let ((lisp (maybe-warn (first-of *implementation-features*)
     1753                                            "No implementation feature found in ~a."
     1754                                            *implementation-features*))
     1755                          (os   (maybe-warn (first-of *os-features*)
     1756                                            "No os feature found in ~a." *os-features*))
     1757                          (arch (maybe-warn (first-of *architecture-features*)
     1758                                            "No architecture feature found in ~a."
     1759                                            *architecture-features*))
     1760                          (version (maybe-warn (lisp-version-string)
     1761                                               "Don't know how to get Lisp ~
     1762                                          implementation version.")))
     1763                      (format nil "~(~@{~a~^-~}~)" lisp version os arch))))))))
     1764
     1765(defun pathname-prefix-p (prefix pathname)
     1766  (let ((prefix-ns (namestring prefix))
     1767        (pathname-ns (namestring pathname)))
     1768    (= (length prefix-ns)
     1769       (mismatch prefix-ns pathname-ns))))
     1770
     1771(defgeneric output-files-for-system-and-operation
     1772  (system operation component source possible-paths)
     1773  (:documentation "Returns the directory where the componets output files should be placed. This may depends on the system, the operation and the component. The ASDF default input and outputs are provided in the source and possible-paths parameters."))
     1774
     1775(defun source-to-target-resolved-mappings ()
     1776  "Answer `*source-to-target-mappings*` with additional entries made
     1777by resolving sources that are symlinks.
     1778
     1779As ASDF sometimes resolves symlinks to compute source paths, we must
     1780follow that.  For example, if SBCL is installed under a symlink, and
     1781SBCL_HOME is set through that symlink, the default rule above
     1782preventing SBCL contribs from being mapped elsewhere will not be
     1783applied by the plain `*source-to-target-mappings*`."
     1784  (loop for mapping in asdf:*source-to-target-mappings*
     1785        for (source target) = mapping
     1786        for true-source = (and source (resolve-symlinks source))
     1787        if (equal source true-source)
     1788          collect mapping
     1789        else append (list mapping (list true-source target))))
     1790
     1791(defmethod output-files-for-system-and-operation
     1792           ((system system) operation component source possible-paths)
     1793  (declare (ignore operation component))
     1794  (output-files-using-mappings
     1795   source possible-paths (source-to-target-resolved-mappings)))
     1796
     1797(defmethod output-files-using-mappings (source possible-paths path-mappings)
     1798  (mapcar
     1799   (lambda (path)
     1800     (loop for (from to) in path-mappings
     1801        when (pathname-prefix-p from source)
     1802        do (return
     1803             (if to
     1804                 (merge-pathnames
     1805                  (make-pathname :type (pathname-type path))
     1806                  (merge-pathnames (enough-namestring source from)
     1807                                   to))
     1808                 path))
     1809                 
     1810        finally
     1811          (return
     1812            ;; Instead of just returning the path when we
     1813            ;; don't find a mapping, we stick stuff into
     1814            ;; the appropriate binary directory based on
     1815            ;; the implementation
     1816            (if *centralize-lisp-binaries*
     1817                (merge-pathnames
     1818                 (make-pathname
     1819                  :type (pathname-type path)
     1820                  :directory `(:relative
     1821                               ,@(cond ((eq *include-per-user-information* t)
     1822                                        (cdr (pathname-directory
     1823                                              (user-homedir-pathname))))
     1824                                       ((not (null *include-per-user-information*))
     1825                                        (list *include-per-user-information*)))
     1826                               ,@(implementation-specific-directory-name)
     1827                               ,@(rest (pathname-directory path)))
     1828                  :defaults path)
     1829                 *default-toplevel-directory*)
     1830                (make-pathname
     1831                 :type (pathname-type path)
     1832                 :directory (append
     1833                             (pathname-directory path)
     1834                             (implementation-specific-directory-name))
     1835                 :defaults path)))))
     1836          possible-paths))
     1837
     1838(defmethod output-files
     1839    :around ((operation compile-op) (component source-file))
     1840  (if (or *map-all-source-files*
     1841            (typecase component
     1842              (cl-source-file t)
     1843              (t nil)))
     1844    (let ((source (component-pathname component ))
     1845          (paths (call-next-method)))
     1846      (output-files-for-system-and-operation
     1847       (component-system component) operation component source paths))
     1848    (call-next-method)))
     1849
     1850;;;; -----------------------------------------------------------------
     1851;;;; Windows shortcut support.  Based on:
     1852;;;;
     1853;;;; Jesse Hager: The Windows Shortcut File Format.
     1854;;;; http://www.wotsit.org/list.asp?fc=13
     1855;;;; -----------------------------------------------------------------
     1856
     1857(defparameter *link-initial-dword* 76)
     1858(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
     1859
     1860(defun read-null-terminated-string (s)
     1861  (with-output-to-string (out)
     1862    (loop
     1863        for code = (read-byte s)
     1864        until (zerop code)
     1865        do (write-char (code-char code) out))))
     1866
     1867(defun read-little-endian (s &optional (bytes 4))
     1868  (let ((result 0))
     1869    (loop
     1870        for i from 0 below bytes
     1871        do
     1872          (setf result (logior result (ash (read-byte s) (* 8 i)))))
     1873    result))
     1874
     1875(defun parse-windows-shortcut (pathname)
     1876  (with-open-file (s pathname :element-type '(unsigned-byte 8))
     1877    (handler-case
     1878        (when (and (= (read-little-endian s) *link-initial-dword*)
     1879                   (let ((header (make-array (length *link-guid*))))
     1880                     (read-sequence header s)
     1881                     (equalp header *link-guid*)))
     1882          (let ((flags (read-little-endian s)))
     1883            (file-position s 76)        ;skip rest of header
     1884            (when (logbitp 0 flags)
     1885              ;; skip shell item id list
     1886              (let ((length (read-little-endian s 2)))
     1887                (file-position s (+ length (file-position s)))))
     1888            (cond
     1889              ((logbitp 1 flags)
     1890                (parse-file-location-info s))
     1891              (t
     1892                (when (logbitp 2 flags)
     1893                  ;; skip description string
     1894                  (let ((length (read-little-endian s 2)))
     1895                    (file-position s (+ length (file-position s)))))
     1896                (when (logbitp 3 flags)
     1897                  ;; finally, our pathname
     1898                  (let* ((length (read-little-endian s 2))
     1899                         (buffer (make-array length)))
     1900                    (read-sequence buffer s)
     1901                    (map 'string #'code-char buffer)))))))
     1902      (end-of-file ()
     1903        nil))))
     1904
     1905(defun parse-file-location-info (s)
     1906  (let ((start (file-position s))
     1907        (total-length (read-little-endian s))
     1908        (end-of-header (read-little-endian s))
     1909        (fli-flags (read-little-endian s))
     1910        (local-volume-offset (read-little-endian s))
     1911        (local-offset (read-little-endian s))
     1912        (network-volume-offset (read-little-endian s))
     1913        (remaining-offset (read-little-endian s)))
     1914    (declare (ignore total-length end-of-header local-volume-offset))
     1915    (unless (zerop fli-flags)
     1916      (cond
     1917        ((logbitp 0 fli-flags)
     1918          (file-position s (+ start local-offset)))
     1919        ((logbitp 1 fli-flags)
     1920          (file-position s (+ start
     1921                              network-volume-offset
     1922                              #x14))))
     1923      (concatenate 'string
     1924        (read-null-terminated-string s)
     1925        (progn
     1926          (file-position s (+ start remaining-offset))
     1927          (read-null-terminated-string s))))))
     1928
    13381929
    13391930(pushnew :asdf *features*)
     
    13821973  (pushnew 'contrib-sysdef-search *system-definition-search-functions*))
    13831974
     1975(if *asdf-revision*
     1976    (asdf-message ";; ASDF, revision ~a" *asdf-revision*)
     1977    (asdf-message ";; ASDF, revision unknown; possibly a development version"))
     1978
    13841979(provide 'asdf)
     1980
     1981
     1982#+(or)
     1983;;?? ignore -- so how will ABL get "installed"
     1984;; should be unnecessary with newer versions of ASDF
     1985;; load customizations
     1986(eval-when (:load-toplevel :execute)
     1987  (let* ((*package* (find-package :common-lisp)))
     1988    (load
     1989     (merge-pathnames
     1990      (make-pathname :name "asdf-binary-locations"
     1991                     :type "lisp"
     1992                     :directory '(:relative ".asdf"))
     1993      (truename (user-homedir-pathname)))
     1994     :if-does-not-exist nil)))
Note: See TracChangeset for help on using the changeset viewer.