Changeset 9202 for release/1.2


Ignore:
Timestamp:
Apr 20, 2008, 8:03:39 AM (13 years ago)
Author:
gb
Message:

from trunk

File:
1 edited

Legend:

Unmodified
Added
Removed

  • release/1.2/source/tools/asdf.lisp

    r4703 r9202  
    1 ;;; This is asdf: Another System Definition Facility.  $Revision$
    2 ;;;
    3 ;;; Feedback, bug reports, and patches are all welcome: please mail to
    4 ;;; <cclan-list@lists.sf.net>.  But note first that the canonical
    5 ;;; source for asdf is presently the cCLan CVS repository at
    6 ;;; <URL:http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/>
    7 ;;;
    8 ;;; If you obtained this copy from anywhere else, and you experience
    9 ;;; trouble using it, or find bugs, you may want to check at the
    10 ;;; location above for a more recent version (and for documentation
    11 ;;; and test files, if your copy came without them) before reporting
    12 ;;; bugs.  There are usually two "supported" revisions - the CVS HEAD
    13 ;;; is the latest development version, whereas the revision tagged
    14 ;;; RELEASE may be slightly older but is considered `stable'
    15 
    16 ;;; Copyright (c) 2001-2003 Daniel Barlow and contributors
    17 ;;;
    18 ;;; Permission is hereby granted, free of charge, to any person obtaining
    19 ;;; a copy of this software and associated documentation files (the
    20 ;;; "Software"), to deal in the Software without restriction, including
    21 ;;; without limitation the rights to use, copy, modify, merge, publish,
    22 ;;; distribute, sublicense, and/or sell copies of the Software, and to
    23 ;;; permit persons to whom the Software is furnished to do so, subject to
    24 ;;; the following conditions:
    25 ;;;
    26 ;;; The above copyright notice and this permission notice shall be
    27 ;;; included in all copies or substantial portions of the Software.
    28 ;;;
    29 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
    30 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
    31 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
    32 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
    33 ;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
    34 ;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
    35 ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
    36 
    37 ;;; the problem with writing a defsystem replacement is bootstrapping:
    38 ;;; we can't use defsystem to compile it.  Hence, all in one file
    39 
    40 (defpackage #:asdf
    41   (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command
    42            #:system-definition-pathname #:find-component ; miscellaneous
    43            #:hyperdocumentation #:hyperdoc
    44            
    45            #:compile-op #:load-op #:load-source-op #:test-system-version
    46            #:test-op
    47            #:operation                  ; operations
    48            #:feature                    ; sort-of operation
    49            #:version                    ; metaphorically sort-of an operation
    50            
    51            #:input-files #:output-files #:perform       ; operation methods
    52            #:operation-done-p #:explain
    53            
    54            #:component #:source-file
    55            #:c-source-file #:cl-source-file #:java-source-file
    56            #:static-file
    57            #:doc-file
    58            #:html-file
    59            #:text-file
    60            #:source-file-type
    61            #:module                     ; components
    62            #:system
    63            #:unix-dso
    64            
    65            #:module-components          ; component accessors
    66            #:component-pathname
    67            #:component-relative-pathname
    68            #:component-name
    69            #:component-version
    70            #:component-parent
    71            #:component-property
    72            #:component-system
    73            
    74            #:component-depends-on
    75 
    76            #:system-description
    77            #:system-long-description
    78            #:system-author
    79            #:system-maintainer
    80            #:system-license
    81            
    82            #:operation-on-warnings
    83            #:operation-on-failure
    84            
    85            ;#:*component-parent-pathname*
    86            #:*system-definition-search-functions*
    87            #:*central-registry*         ; variables
    88            #:*compile-file-warnings-behaviour*
    89            #:*compile-file-failure-behaviour*
    90            #:*asdf-revision*
    91            
    92            #:operation-error #:compile-failed #:compile-warned #:compile-error
    93            #:error-component #:error-operation
    94            #:system-definition-error
    95            #:missing-component
    96            #:missing-dependency
    97            #:circular-dependency        ; errors
    98            #:duplicate-names
    99            
    100            #:retry
    101            #:accept                     ; restarts
    102            
    103            )
    104   (:use :cl))
    105 
    106 #+nil
    107 (error "The author of this file habitually uses #+nil to comment out forms.  But don't worry, it was unlikely to work in the New Implementation of Lisp anyway")
    108 
    109 
    110 (in-package #:asdf)
    111 
    112 (defvar *asdf-revision* (let* ((v "$Revision$")
    113                                (colon (or (position #\: v) -1))
    114                                (dot (position #\. v)))
    115                           (and v colon dot
    116                                (list (parse-integer v :start (1+ colon)
    117                                                     :junk-allowed t)
    118                                      (parse-integer v :start (1+ dot)
    119                                                     :junk-allowed t)))))
    120 
    121 (defvar *compile-file-warnings-behaviour* :warn)
    122 (defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn)
    123 
    124 (defvar *verbose-out* nil)
    125 
    126 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    127 ;; utility stuff
    128 
    129 (defmacro aif (test then &optional else)
    130   `(let ((it ,test)) (if it ,then ,else)))
    131 
    132 (defun pathname-sans-name+type (pathname)
    133   "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
    134 and NIL NAME and TYPE components"
    135   (make-pathname :name nil :type nil :defaults pathname))
    136 
    137 (define-modify-macro appendf (&rest args)
    138                      append "Append onto list")
    139 
    140 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    141 ;; classes, condiitons
    142 
    143 (define-condition system-definition-error (error) ()
    144   ;; [this use of :report should be redundant, but unfortunately it's not.
    145   ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
    146   ;; over print-object; this is always conditions::%print-condition for
    147   ;; condition objects, which in turn does inheritance of :report options at
    148   ;; run-time.  fortunately, inheritance means we only need this kludge here in
    149   ;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]
    150   #+cmu (:report print-object))
    151 
    152 (define-condition formatted-system-definition-error (system-definition-error)
    153   ((format-control :initarg :format-control :reader format-control)
    154    (format-arguments :initarg :format-arguments :reader format-arguments))
    155   (:report (lambda (c s)
    156              (apply #'format s (format-control c) (format-arguments c)))))
    157 
    158 (define-condition circular-dependency (system-definition-error)
    159   ((components :initarg :components :reader circular-dependency-components)))
    160 
    161 (define-condition duplicate-names (system-definition-error)
    162   ((name :initarg :name :reader duplicate-names-name)))
    163 
    164 (define-condition missing-component (system-definition-error)
    165   ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
    166    (version :initform nil :reader missing-version :initarg :version)
    167    (parent :initform nil :reader missing-parent :initarg :parent)))
    168 
    169 (define-condition missing-dependency (missing-component)
    170   ((required-by :initarg :required-by :reader missing-required-by)))
    171 
    172 (define-condition operation-error (error)
    173   ((component :reader error-component :initarg :component)
    174    (operation :reader error-operation :initarg :operation))
    175   (:report (lambda (c s)
    176              (format s "~@<erred while invoking ~A on ~A~@:>"
    177                      (error-operation c) (error-component c)))))
    178 (define-condition compile-error (operation-error) ())
    179 (define-condition compile-failed (compile-error) ())
    180 (define-condition compile-warned (compile-error) ())
    181 
    182 (defclass component ()
    183   ((name :accessor component-name :initarg :name :documentation
    184          "Component name: designator for a string composed of portable pathname characters")
    185    (version :accessor component-version :initarg :version)
    186    (in-order-to :initform nil :initarg :in-order-to)
    187    ;;; XXX crap name
    188    (do-first :initform nil :initarg :do-first)
    189    ;; methods defined using the "inline" style inside a defsystem form:
    190    ;; need to store them somewhere so we can delete them when the system
    191    ;; is re-evaluated
    192    (inline-methods :accessor component-inline-methods :initform nil)
    193    (parent :initarg :parent :initform nil :reader component-parent)
    194    ;; no direct accessor for pathname, we do this as a method to allow
    195    ;; it to default in funky ways if not supplied
    196    (relative-pathname :initarg :pathname)
    197    (operation-times :initform (make-hash-table )
    198                     :accessor component-operation-times)
    199    ;; XXX we should provide some atomic interface for updating the
    200    ;; component properties
    201    (properties :accessor component-properties :initarg :properties
    202                :initform nil)))
    203 
    204 ;;;; methods: conditions
    205 
    206 (defmethod print-object ((c missing-dependency) s)
    207   (format s "~@<~A, required by ~A~@:>"
    208           (call-next-method c nil) (missing-required-by c)))
    209 
    210 (defun sysdef-error (format &rest arguments)
    211   (error 'formatted-system-definition-error :format-control format :format-arguments arguments))
    212 
    213 ;;;; methods: components
    214 
    215 (defmethod print-object ((c missing-component) s)
    216   (format s "~@<component ~S not found~
    217              ~@[ or does not match version ~A~]~
    218              ~@[ in ~A~]~@:>"
    219           (missing-requires c)
    220           (missing-version c)
    221           (when (missing-parent c)
    222             (component-name (missing-parent c)))))
    223 
    224 (defgeneric component-system (component)
    225   (:documentation "Find the top-level system containing COMPONENT"))
    226  
    227 (defmethod component-system ((component component))
    228   (aif (component-parent component)
    229        (component-system it)
    230        component))
    231 
    232 (defmethod print-object ((c component) stream)
    233   (print-unreadable-object (c stream :type t :identity t)
    234     (ignore-errors
    235       (prin1 (component-name c) stream))))
    236 
    237 (defclass module (component)
    238   ((components :initform nil :accessor module-components :initarg :components)
    239    ;; what to do if we can't satisfy a dependency of one of this module's
    240    ;; components.  This allows a limited form of conditional processing
    241    (if-component-dep-fails :initform :fail
    242                            :accessor module-if-component-dep-fails
    243                            :initarg :if-component-dep-fails)
    244    (default-component-class :accessor module-default-component-class
    245      :initform 'cl-source-file :initarg :default-component-class)))
    246 
    247 (defgeneric component-pathname (component)
    248   (:documentation "Extracts the pathname applicable for a particular component."))
    249 
    250 (defun component-parent-pathname (component)
    251   (aif (component-parent component)
    252        (component-pathname it)
    253        *default-pathname-defaults*))
    254 
    255 (defgeneric component-relative-pathname (component)
    256   (:documentation "Extracts the relative pathname applicable for a particular component."))
    257    
    258 (defmethod component-relative-pathname ((component module))
    259   (or (slot-value component 'relative-pathname)
    260       (make-pathname
    261        :directory `(:relative ,(component-name component))
    262        :host (pathname-host (component-parent-pathname component)))))
    263 
    264 (defmethod component-pathname ((component component))
    265   (let ((*default-pathname-defaults* (component-parent-pathname component)))
    266     (merge-pathnames (component-relative-pathname component))))
    267 
    268 (defgeneric component-property (component property))
    269 
    270 (defmethod component-property ((c component) property)
    271   (cdr (assoc property (slot-value c 'properties) :test #'equal)))
    272 
    273 (defgeneric (setf component-property) (new-value component property))
    274 
    275 (defmethod (setf component-property) (new-value (c component) property)
    276   (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
    277     (if a
    278         (setf (cdr a) new-value)
    279         (setf (slot-value c 'properties)
    280               (acons property new-value (slot-value c 'properties))))))
    281 
    282 (defclass system (module)
    283   ((description :accessor system-description :initarg :description)
    284    (long-description
    285     :accessor system-long-description :initarg :long-description)
    286    (author :accessor system-author :initarg :author)
    287    (maintainer :accessor system-maintainer :initarg :maintainer)
    288    (licence :accessor system-licence :initarg :licence)))
    289 
    290 ;;; version-satisfies
    291 
    292 ;;; with apologies to christophe rhodes ...
    293 (defun split (string &optional max (ws '(#\Space #\Tab)))
    294   (flet ((is-ws (char) (find char ws)))
    295     (nreverse
    296      (let ((list nil) (start 0) (words 0) end)
    297        (loop
    298         (when (and max (>= words (1- max)))
    299           (return (cons (subseq string start) list)))
    300         (setf end (position-if #'is-ws string :start start))
    301         (push (subseq string start end) list)
    302         (incf words)
    303         (unless end (return list))
    304         (setf start (1+ end)))))))
    305 
    306 (defgeneric version-satisfies (component version))
    307 
    308 (defmethod version-satisfies ((c component) version)
    309   (unless (and version (slot-boundp c 'version))
    310     (return-from version-satisfies t))
    311   (let ((x (mapcar #'parse-integer
    312                    (split (component-version c) nil '(#\.))))
    313         (y (mapcar #'parse-integer
    314                    (split version nil '(#\.)))))
    315     (labels ((bigger (x y)
    316                (cond ((not y) t)
    317                      ((not x) nil)
    318                      ((> (car x) (car y)) t)
    319                      ((= (car x) (car y))
    320                       (bigger (cdr x) (cdr y))))))
    321       (and (= (car x) (car y))
    322            (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
    323 
    324 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    325 ;;; finding systems
    326 
    327 (defvar *defined-systems* (make-hash-table :test 'equal))
    328 (defun coerce-name (name)
    329    (typecase name
    330      (component (component-name name))
    331      (symbol (string-downcase (symbol-name name)))
    332      (string name)
    333      (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
    334 
    335 ;;; for the sake of keeping things reasonably neat, we adopt a
    336 ;;; convention that functions in this list are prefixed SYSDEF-
    337 
    338 (defvar *system-definition-search-functions*
    339   '(sysdef-central-registry-search))
    340 
    341 (defun system-definition-pathname (system)
    342   (some (lambda (x) (funcall x system))
    343         *system-definition-search-functions*))
    344        
    345 (defvar *central-registry*
    346   '(*default-pathname-defaults*
    347     #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/"
    348     #+nil "telent:asdf;systems;"))
    349 
    350 (defun sysdef-central-registry-search (system)
    351   (let ((name (coerce-name system)))
    352     (block nil
    353       (dolist (dir *central-registry*)
    354         (let* ((defaults (eval dir))
    355                (file (and defaults
    356                           (make-pathname
    357                            :defaults defaults :version :newest
    358                            :name name :type "asd" :case :local))))
    359           (if (and file (probe-file file))
    360               (return file)))))))
    361 
    362 (defun make-temporary-package ()
    363   (flet ((try (counter)
    364            (ignore-errors
    365                    (make-package (format nil "ASDF~D" counter)
    366                                  :use '(:cl :asdf)))))
    367     (do* ((counter 0 (+ counter 1))
    368           (package (try counter) (try counter)))
    369          (package package))))
    370 
    371 (defun find-system (name &optional (error-p t))
    372   (let* ((name (coerce-name name))
    373          (in-memory (gethash name *defined-systems*))
    374          (on-disk (system-definition-pathname name)))   
    375     (when (and on-disk
    376                (or (not in-memory)
    377                    (< (car in-memory) (file-write-date on-disk))))
    378       (let ((package (make-temporary-package)))
    379         (unwind-protect
    380              (let ((*package* package))
    381                (format
    382                 *verbose-out*
    383                 "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
    384                 ;; FIXME: This wants to be (ENOUGH-NAMESTRING
    385                 ;; ON-DISK), but CMUCL barfs on that.
    386                 on-disk
    387                 *package*)
    388                (load on-disk))
    389           (delete-package package))))
    390     (let ((in-memory (gethash name *defined-systems*)))
    391       (if in-memory
    392           (progn (if on-disk (setf (car in-memory) (file-write-date on-disk)))
    393                  (cdr in-memory))
    394           (if error-p (error 'missing-component :requires name))))))
    395 
    396 (defun register-system (name system)
    397   (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
    398   (setf (gethash (coerce-name  name) *defined-systems*)
    399         (cons (get-universal-time) system)))
    400 
    401 (defun system-registered-p (name)
    402   (gethash (coerce-name name) *defined-systems*))
    403 
    404 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    405 ;;; finding components
    406 
    407 (defgeneric find-component (module name &optional version)
    408   (:documentation "Finds the component with name NAME present in the
    409 MODULE module; if MODULE is nil, then the component is assumed to be a
    410 system."))
    411 
    412 (defmethod find-component ((module module) name &optional version)
    413   (if (slot-boundp module 'components)
    414       (let ((m (find name (module-components module)
    415                      :test #'equal :key #'component-name)))
    416         (if (and m (version-satisfies m version)) m))))
    417            
    418 
    419 ;;; a component with no parent is a system
    420 (defmethod find-component ((module (eql nil)) name &optional version)
    421   (let ((m (find-system name nil)))
    422     (if (and m (version-satisfies m version)) m)))
    423 
    424 ;;; component subclasses
    425 
    426 (defclass source-file (component) ())
    427 
    428 (defclass cl-source-file (source-file) ())
    429 (defclass c-source-file (source-file) ())
    430 (defclass java-source-file (source-file) ())
    431 (defclass static-file (source-file) ())
    432 (defclass doc-file (static-file) ())
    433 (defclass html-file (doc-file) ())
    434 
    435 (defgeneric source-file-type (component system))
    436 (defmethod source-file-type ((c cl-source-file) (s module)) "lisp")
    437 (defmethod source-file-type ((c c-source-file) (s module)) "c")
    438 (defmethod source-file-type ((c java-source-file) (s module)) "java")
    439 (defmethod source-file-type ((c html-file) (s module)) "html")
    440 (defmethod source-file-type ((c static-file) (s module)) nil)
    441 
    442 (defmethod component-relative-pathname ((component source-file))
    443   (let ((relative-pathname (slot-value component 'relative-pathname)))
    444     (if relative-pathname
    445         (merge-pathnames
    446          relative-pathname
    447          (make-pathname
    448           :type (source-file-type component (component-system component))))
    449         (let* ((*default-pathname-defaults*
    450                 (component-parent-pathname component))
    451                (name-type
    452                 (make-pathname
    453                  :name (component-name component)
    454                  :type (source-file-type component
    455                                          (component-system component)))))
    456           name-type))))
    457 
    458 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    459 ;;; operations
    460 
    461 ;;; one of these is instantiated whenever (operate ) is called
    462 
    463 (defclass operation ()
    464   ((forced :initform nil :initarg :force :accessor operation-forced)
    465    (original-initargs :initform nil :initarg :original-initargs
    466                       :accessor operation-original-initargs)
    467    (visited-nodes :initform nil :accessor operation-visited-nodes)
    468    (visiting-nodes :initform nil :accessor operation-visiting-nodes)
    469    (parent :initform nil :initarg :parent :accessor operation-parent)))
    470 
    471 (defmethod print-object ((o operation) stream)
    472   (print-unreadable-object (o stream :type t :identity t)
    473     (ignore-errors
    474       (prin1 (operation-original-initargs o) stream))))
    475 
    476 (defmethod shared-initialize :after ((operation operation) slot-names
    477                                      &key force
    478                                      &allow-other-keys)
    479   (declare (ignore slot-names force))
    480   ;; empty method to disable initarg validity checking
    481   )
    482 
    483 (defgeneric perform (operation component))
    484 (defgeneric operation-done-p (operation component))
    485 (defgeneric explain (operation component))
    486 (defgeneric output-files (operation component))
    487 (defgeneric input-files (operation component))
    488 
    489 (defun node-for (o c)
    490   (cons (class-name (class-of o)) c))
    491 
    492 (defgeneric operation-ancestor (operation)
    493   (:documentation   "Recursively chase the operation's parent pointer until we get to the head of the tree"))
    494 
    495 (defmethod operation-ancestor ((operation operation))
    496   (aif (operation-parent operation)
    497        (operation-ancestor it)
    498        operation))
    499 
    500 
    501 (defun make-sub-operation (c o dep-c dep-o)
    502   (let* ((args (copy-list (operation-original-initargs o)))
    503          (force-p (getf args :force)))
    504     ;; note explicit comparison with T: any other non-NIL force value
    505     ;; (e.g. :recursive) will pass through
    506     (cond ((and (null (component-parent c))
    507                 (null (component-parent dep-c))
    508                 (not (eql c dep-c)))
    509            (when (eql force-p t)
    510              (setf (getf args :force) nil))
    511            (apply #'make-instance dep-o
    512                   :parent o
    513                   :original-initargs args args))
    514           ((subtypep (type-of o) dep-o)
    515            o)
    516           (t
    517            (apply #'make-instance dep-o
    518                   :parent o :original-initargs args args)))))
    519 
    520 
    521 (defgeneric visit-component (operation component data))
    522 
    523 (defmethod visit-component ((o operation) (c component) data)
    524   (unless (component-visited-p o c)
    525     (push (cons (node-for o c) data)
    526           (operation-visited-nodes (operation-ancestor o)))))
    527 
    528 (defgeneric component-visited-p (operation component))
    529 
    530 (defmethod component-visited-p ((o operation) (c component))
    531   (assoc (node-for o c)
    532          (operation-visited-nodes (operation-ancestor o))
    533          :test 'equal))
    534 
    535 (defgeneric (setf visiting-component) (new-value operation component))
    536 
    537 (defmethod (setf visiting-component) (new-value operation component)
    538   ;; MCL complains about unused lexical variables
    539   (declare (ignorable new-value operation component)))
    540 
    541 (defmethod (setf visiting-component) (new-value (o operation) (c component))
    542   (let ((node (node-for o c))
    543         (a (operation-ancestor o)))
    544     (if new-value
    545         (pushnew node (operation-visiting-nodes a) :test 'equal)
    546         (setf (operation-visiting-nodes a)
    547               (remove node  (operation-visiting-nodes a) :test 'equal)))))
    548 
    549 (defgeneric component-visiting-p (operation component))
    550 
    551 (defmethod component-visiting-p ((o operation) (c component))
    552   (let ((node (cons o c)))
    553     (member node (operation-visiting-nodes (operation-ancestor o))
    554             :test 'equal)))
    555 
    556 (defgeneric component-depends-on (operation component))
    557 
    558 (defmethod component-depends-on ((o operation) (c component))
    559   (cdr (assoc (class-name (class-of o))
    560               (slot-value c 'in-order-to))))
    561 
    562 (defgeneric component-self-dependencies (operation component))
    563 
    564 (defmethod component-self-dependencies ((o operation) (c component))
    565   (let ((all-deps (component-depends-on o c)))
    566     (remove-if-not (lambda (x)
    567                      (member (component-name c) (cdr x) :test #'string=))
    568                    all-deps)))
    569    
    570 (defmethod input-files ((operation operation) (c component))
    571   (let ((parent (component-parent c))
    572         (self-deps (component-self-dependencies operation c)))
    573     (if self-deps
    574         (mapcan (lambda (dep)
    575                   (destructuring-bind (op name) dep
    576                     (output-files (make-instance op)
    577                                   (find-component parent name))))
    578                 self-deps)
    579         ;; no previous operations needed?  I guess we work with the
    580         ;; original source file, then
    581         (list (component-pathname c)))))
    582 
    583 (defmethod input-files ((operation operation) (c module)) nil)
    584 
    585 (defmethod operation-done-p ((o operation) (c component))
    586   (flet ((fwd-or-return-t (file)
    587            ;; if FILE-WRITE-DATE returns NIL, it's possible that the
    588            ;; user or some other agent has deleted an input file.  If
    589            ;; that's the case, well, that's not good, but as long as
    590            ;; the operation is otherwise considered to be done we
    591            ;; could continue and survive.
    592            (let ((date (file-write-date file)))
    593              (cond
    594                (date)
    595                (t
    596                 (warn "~@<Missing FILE-WRITE-DATE for ~S: treating ~
    597                        operation ~S on component ~S as done.~@:>"
    598                       file o c)
    599                 (return-from operation-done-p t))))))
    600     (let ((out-files (output-files o c))
    601           (in-files (input-files o c)))
    602       (cond ((and (not in-files) (not out-files))
    603              ;; arbitrary decision: an operation that uses nothing to
    604              ;; produce nothing probably isn't doing much
    605              t)
    606             ((not out-files)
    607              (let ((op-done
    608                     (gethash (type-of o)
    609                              (component-operation-times c))))
    610                (and op-done
    611                     (>= op-done
    612                         (apply #'max
    613                                (mapcar #'fwd-or-return-t in-files))))))
    614             ((not in-files) nil)
    615             (t
    616              (and
    617               (every #'probe-file out-files)
    618               (> (apply #'min (mapcar #'file-write-date out-files))
    619                  (apply #'max (mapcar #'fwd-or-return-t in-files)))))))))
    620 
    621 ;;; So you look at this code and think "why isn't it a bunch of
    622 ;;; methods".  And the answer is, because standard method combination
    623 ;;; runs :before methods most->least-specific, which is back to front
    624 ;;; for our purposes.  And CLISP doesn't have non-standard method
    625 ;;; combinations, so let's keep it simple and aspire to portability
    626 
    627 (defgeneric traverse (operation component))
    628 (defmethod traverse ((operation operation) (c component))
    629   (let ((forced nil))
    630     (labels ((do-one-dep (required-op required-c required-v)
    631                (let* ((dep-c (or (find-component
    632                                   (component-parent c)
    633                                   ;; XXX tacky.  really we should build the
    634                                   ;; in-order-to slot with canonicalized
    635                                   ;; names instead of coercing this late
    636                                   (coerce-name required-c) required-v)
    637                                  (error 'missing-dependency :required-by c
    638                                         :version required-v
    639                                         :requires required-c)))
    640                       (op (make-sub-operation c operation dep-c required-op)))
    641                  (traverse op dep-c)))             
    642              (do-dep (op dep)
    643                (cond ((eq op 'feature)
    644                       (or (member (car dep) *features*)
    645                           (error 'missing-dependency :required-by c
    646                                  :requires (car dep) :version nil)))
    647                      (t
    648                       (dolist (d dep)
    649                         (cond ((consp d)
    650                                (assert (string-equal
    651                                         (symbol-name (first d))
    652                                         "VERSION"))
    653                                (appendf forced
    654                                         (do-one-dep op (second d) (third d))))
    655                               (t
    656                                (appendf forced (do-one-dep op d nil)))))))))
    657       (aif (component-visited-p operation c)
    658            (return-from traverse
    659              (if (cdr it) (list (cons 'pruned-op c)) nil)))
    660       ;; dependencies
    661       (if (component-visiting-p operation c)
    662           (error 'circular-dependency :components (list c)))
    663       (setf (visiting-component operation c) t)
    664       (loop for (required-op . deps) in (component-depends-on operation c)
    665             do (do-dep required-op deps))
    666       ;; constituent bits
    667       (let ((module-ops
    668              (when (typep c 'module)
    669                (let ((at-least-one nil)
    670                      (forced nil)
    671                      (error nil))
    672                  (loop for kid in (module-components c)
    673                        do (handler-case
    674                               (appendf forced (traverse operation kid ))
    675                             (missing-dependency (condition)
    676                               (if (eq (module-if-component-dep-fails c) :fail)
    677                                   (error condition))
    678                               (setf error condition))
    679                             (:no-error (c)
    680                               (declare (ignore c))
    681                               (setf at-least-one t))))
    682                  (when (and (eq (module-if-component-dep-fails c) :try-next)
    683                             (not at-least-one))
    684                    (error error))
    685                  forced))))
    686         ;; now the thing itself
    687         (when (or forced module-ops
    688                   (not (operation-done-p operation c))
    689                   (let ((f (operation-forced (operation-ancestor operation))))
    690                     (and f (or (not (consp f))
    691                                (member (component-name
    692                                         (operation-ancestor operation))
    693                                        (mapcar #'coerce-name f)
    694                                        :test #'string=)))))
    695           (let ((do-first (cdr (assoc (class-name (class-of operation))
    696                                       (slot-value c 'do-first)))))
    697             (loop for (required-op . deps) in do-first
    698                   do (do-dep required-op deps)))
    699           (setf forced (append (delete 'pruned-op forced :key #'car)
    700                                (delete 'pruned-op module-ops :key #'car)
    701                                (list (cons operation c))))))
    702       (setf (visiting-component operation c) nil)
    703       (visit-component operation c (and forced t))
    704       forced)))
    705  
    706 
    707 (defmethod perform ((operation operation) (c source-file))
    708   (sysdef-error
    709    "~@<required method PERFORM not implemented ~
    710     for operation ~A, component ~A~@:>"
    711    (class-of operation) (class-of c)))
    712 
    713 (defmethod perform ((operation operation) (c module))
    714   nil)
    715 
    716 (defmethod explain ((operation operation) (component component))
    717   (format *verbose-out* "~&;;; ~A on ~A~%" operation component))
    718 
    719 ;;; compile-op
    720 
    721 (defclass compile-op (operation)
    722   ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
    723    (on-warnings :initarg :on-warnings :accessor operation-on-warnings
    724                 :initform *compile-file-warnings-behaviour*)
    725    (on-failure :initarg :on-failure :accessor operation-on-failure
    726                :initform *compile-file-failure-behaviour*)))
    727 
    728 (defmethod perform :before ((operation compile-op) (c source-file))
    729   (map nil #'ensure-directories-exist (output-files operation c)))
    730 
    731 (defmethod perform :after ((operation operation) (c component))
    732   (setf (gethash (type-of operation) (component-operation-times c))
    733         (get-universal-time)))
    734 
    735 ;;; perform is required to check output-files to find out where to put
    736 ;;; its answers, in case it has been overridden for site policy
    737 (defmethod perform ((operation compile-op) (c cl-source-file))
    738   #-:broken-fasl-loader
    739   (let ((source-file (component-pathname c))
    740         (output-file (car (output-files operation c))))
    741     (multiple-value-bind (output warnings-p failure-p)
    742         (compile-file source-file
    743                       :output-file output-file)
    744       ;(declare (ignore output))
    745       (when warnings-p
    746         (case (operation-on-warnings operation)
    747           (:warn (warn
    748                   "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
    749                   operation c))
    750           (:error (error 'compile-warned :component c :operation operation))
    751           (:ignore nil)))
    752       (when failure-p
    753         (case (operation-on-failure operation)
    754           (:warn (warn
    755                   "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
    756                   operation c))
    757           (:error (error 'compile-failed :component c :operation operation))
    758           (:ignore nil)))
    759       (unless output
    760         (error 'compile-error :component c :operation operation)))))
    761 
    762 (defmethod output-files ((operation compile-op) (c cl-source-file))
    763   #-:broken-fasl-loader (list (compile-file-pathname (component-pathname c)))
    764   #+:broken-fasl-loader (list (component-pathname c)))
    765 
    766 (defmethod perform ((operation compile-op) (c static-file))
    767   nil)
    768 
    769 (defmethod output-files ((operation compile-op) (c static-file))
    770   nil)
    771 
    772 ;;; load-op
    773 
    774 (defclass load-op (operation) ())
    775 
    776 (defmethod perform ((o load-op) (c cl-source-file))
    777   (mapcar #'load (input-files o c)))
    778 
    779 (defmethod perform ((operation load-op) (c static-file))
    780   nil)
    781 (defmethod operation-done-p ((operation load-op) (c static-file))
    782   t)
    783 
    784 (defmethod output-files ((o operation) (c component))
    785   nil)
    786 
    787 (defmethod component-depends-on ((operation load-op) (c component))
    788   (cons (list 'compile-op (component-name c))
    789         (call-next-method)))
    790 
    791 ;;; load-source-op
    792 
    793 (defclass load-source-op (operation) ())
    794 
    795 (defmethod perform ((o load-source-op) (c cl-source-file))
    796   (let ((source (component-pathname c)))
    797     (setf (component-property c 'last-loaded-as-source)
    798           (and (load source)
    799                (get-universal-time)))))
    800 
    801 (defmethod perform ((operation load-source-op) (c static-file))
    802   nil)
    803 
    804 (defmethod output-files ((operation load-source-op) (c component))
    805   nil)
    806 
    807 ;;; FIXME: we simply copy load-op's dependencies.  this is Just Not Right.
    808 (defmethod component-depends-on ((o load-source-op) (c component))
    809   (let ((what-would-load-op-do (cdr (assoc 'load-op
    810                                            (slot-value c 'in-order-to)))))
    811     (mapcar (lambda (dep)
    812               (if (eq (car dep) 'load-op)
    813                   (cons 'load-source-op (cdr dep))
    814                   dep))
    815             what-would-load-op-do)))
    816 
    817 (defmethod operation-done-p ((o load-source-op) (c source-file))
    818   (if (or (not (component-property c 'last-loaded-as-source))
    819           (> (file-write-date (component-pathname c))
    820              (component-property c 'last-loaded-as-source)))
    821       nil t))
    822 
    823 (defclass test-op (operation) ())
    824 
    825 (defmethod perform ((operation test-op) (c component))
    826   nil)
    827 
    828 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    829 ;;; invoking operations
    830 
    831 (defun operate (operation-class system &rest args &key (verbose t) version
    832                                 &allow-other-keys)
    833   (let* ((op (apply #'make-instance operation-class
    834                     :original-initargs args
    835                     args))
    836          (*verbose-out* (if verbose *trace-output* (make-broadcast-stream)))
    837          (system (if (typep system 'component) system (find-system system))))
    838     (unless (version-satisfies system version)
    839       (error 'missing-component :requires system :version version))
    840     (let ((steps (traverse op system)))
    841       (with-compilation-unit ()
    842         (loop for (op . component) in steps do
    843              (loop
    844                 (restart-case
    845                     (progn (perform op component)
    846                            (return))
    847                   (retry ()
    848                     :report
    849                     (lambda (s)
    850                       (format s "~@<Retry performing ~S on ~S.~@:>"
    851                               op component)))
    852                   (accept ()
    853                     :report
    854                     (lambda (s)
    855                       (format s
    856                               "~@<Continue, treating ~S on ~S as ~
    857                                having been successful.~@:>"
    858                               op component))
    859                     (setf (gethash (type-of op)
    860                                    (component-operation-times component))
    861                           (get-universal-time))
    862                     (return)))))))))
    863 
    864 (defun oos (&rest args)
    865   "Alias of OPERATE function"
    866   (apply #'operate args))
    867 
    868 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    869 ;;; syntax
    870 
    871 (defun remove-keyword (key arglist)
    872   (labels ((aux (key arglist)
    873              (cond ((null arglist) nil)
    874                    ((eq key (car arglist)) (cddr arglist))
    875                    (t (cons (car arglist) (cons (cadr arglist)
    876                                                 (remove-keyword
    877                                                  key (cddr arglist))))))))
    878     (aux key arglist)))
    879 
    880 (defmacro defsystem (name &body options)
    881   (destructuring-bind (&key pathname (class 'system) &allow-other-keys) options
    882     (let ((component-options (remove-keyword :class options)))
    883       `(progn
    884         ;; system must be registered before we parse the body, otherwise
    885         ;; we recur when trying to find an existing system of the same name
    886         ;; to reuse options (e.g. pathname) from
    887         (let ((s (system-registered-p ',name)))
    888           (cond ((and s (eq (type-of (cdr s)) ',class))
    889                  (setf (car s) (get-universal-time)))
    890                 (s
    891                  #+clisp
    892                  (sysdef-error "Cannot redefine the existing system ~A with a different class" s)
    893                  #-clisp
    894                  (change-class (cdr s) ',class))
    895                 (t
    896                  (register-system (quote ,name)
    897                                   (make-instance ',class :name ',name)))))
    898         (parse-component-form nil (apply
    899                                    #'list
    900                                    :module (coerce-name ',name)
    901                                    :pathname
    902                                    (or ,pathname
    903                                        (pathname-sans-name+type
    904                                         (resolve-symlinks  *load-truename*))
    905                                        *default-pathname-defaults*)
    906                                    ',component-options))))))
    907  
    908 
    909 (defun class-for-type (parent type)
    910   (let ((class
    911          (find-class
    912           (or (find-symbol (symbol-name type) *package*)
    913               (find-symbol (symbol-name type) #.(package-name *package*)))
    914           nil)))
    915     (or class
    916         (and (eq type :file)
    917              (or (module-default-component-class parent)
    918                  (find-class 'cl-source-file)))
    919         (sysdef-error "~@<don't recognize component type ~A~@:>" type))))
    920 
    921 (defun maybe-add-tree (tree op1 op2 c)
    922   "Add the node C at /OP1/OP2 in TREE, unless it's there already.
    923 Returns the new tree (which probably shares structure with the old one)"
    924   (let ((first-op-tree (assoc op1 tree)))
    925     (if first-op-tree
    926         (progn
    927           (aif (assoc op2 (cdr first-op-tree))
    928                (if (find c (cdr it))
    929                    nil
    930                    (setf (cdr it) (cons c (cdr it))))
    931                (setf (cdr first-op-tree)
    932                      (acons op2 (list c) (cdr first-op-tree))))
    933           tree)
    934         (acons op1 (list (list op2 c)) tree))))
    935                
    936 (defun union-of-dependencies (&rest deps)
    937   (let ((new-tree nil))
    938     (dolist (dep deps)
    939       (dolist (op-tree dep)
    940         (dolist (op  (cdr op-tree))
    941           (dolist (c (cdr op))
    942             (setf new-tree
    943                   (maybe-add-tree new-tree (car op-tree) (car op) c))))))
    944     new-tree))
    945 
    946 
    947 (defun remove-keys (key-names args)
    948   (loop for ( name val ) on args by #'cddr
    949         unless (member (symbol-name name) key-names
    950                        :key #'symbol-name :test 'equal)
    951         append (list name val)))
    952 
    953 (defvar *serial-depends-on*)
    954 
    955 (defun parse-component-form (parent options)
    956   (destructuring-bind
    957         (type name &rest rest &key
    958               ;; the following list of keywords is reproduced below in the
    959               ;; remove-keys form.  important to keep them in sync
    960               components pathname default-component-class
    961               perform explain output-files operation-done-p
    962               weakly-depends-on
    963               depends-on serial in-order-to
    964               ;; list ends
    965               &allow-other-keys) options
    966     (check-component-input type name weakly-depends-on depends-on components in-order-to)
    967 
    968     (when (and parent
    969              (find-component parent name)
    970              ;; ignore the same object when rereading the defsystem
    971              (not
    972               (typep (find-component parent name)
    973                      (class-for-type parent type))))         
    974       (error 'duplicate-names :name name))
    975    
    976     (let* ((other-args (remove-keys
    977                         '(components pathname default-component-class
    978                           perform explain output-files operation-done-p
    979                           weakly-depends-on
    980                           depends-on serial in-order-to)
    981                         rest))
    982            (ret
    983             (or (find-component parent name)
    984                 (make-instance (class-for-type parent type)))))
    985       (when weakly-depends-on
    986         (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on))))
    987       (when (boundp '*serial-depends-on*)
    988         (setf depends-on
    989               (concatenate 'list *serial-depends-on* depends-on)))     
    990       (apply #'reinitialize-instance
    991              ret
    992              :name (coerce-name name)
    993              :pathname pathname
    994              :parent parent
    995              other-args)
    996       (when (typep ret 'module)
    997         (setf (module-default-component-class ret)
    998               (or default-component-class
    999                   (and (typep parent 'module)
    1000                        (module-default-component-class parent))))
    1001         (let ((*serial-depends-on* nil))
    1002           (setf (module-components ret)
    1003                 (loop for c-form in components
    1004                       for c = (parse-component-form ret c-form)
    1005                       collect c
    1006                       if serial
    1007                       do (push (component-name c) *serial-depends-on*))))
    1008 
    1009         ;; check for duplicate names
    1010         (let ((name-hash (make-hash-table :test #'equal)))
    1011           (loop for c in (module-components ret)
    1012                 do
    1013                 (if (gethash (component-name c)
    1014                              name-hash)
    1015                     (error 'duplicate-names
    1016                            :name (component-name c))
    1017                   (setf (gethash (component-name c)
    1018                                  name-hash)
    1019                         t)))))
    1020      
    1021       (setf (slot-value ret 'in-order-to)
    1022             (union-of-dependencies
    1023              in-order-to
    1024              `((compile-op (compile-op ,@depends-on))
    1025                (load-op (load-op ,@depends-on))))
    1026             (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on))))
    1027      
    1028       (loop for (n v) in `((perform ,perform) (explain ,explain)
    1029                            (output-files ,output-files)
    1030                            (operation-done-p ,operation-done-p))
    1031             do (map 'nil
    1032                     ;; this is inefficient as most of the stored
    1033                     ;; methods will not be for this particular gf n
    1034                     ;; But this is hardly performance-critical
    1035                     (lambda (m) (remove-method (symbol-function n) m))
    1036                     (component-inline-methods ret))
    1037             when v
    1038             do (destructuring-bind (op qual (o c) &body body) v
    1039                  (pushnew
    1040                   (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret)))
    1041                           ,@body))
    1042                   (component-inline-methods ret))))
    1043       ret)))
    1044 
    1045 (defun check-component-input (type name weakly-depends-on depends-on components in-order-to)
    1046   "A partial test of the values of a component."
    1047   (when weakly-depends-on (warn "We got one! XXXXX"))
    1048   (unless (listp depends-on)
    1049     (sysdef-error-component ":depends-on must be a list."
    1050                             type name depends-on))
    1051   (unless (listp weakly-depends-on)
    1052     (sysdef-error-component ":weakly-depends-on must be a list."
    1053                             type name weakly-depends-on))
    1054   (unless (listp components)
    1055     (sysdef-error-component ":components must be NIL or a list of components."
    1056                             type name components))
    1057   (unless (and (listp in-order-to) (listp (car in-order-to)))
    1058     (sysdef-error-component ":in-order-to must be NIL or a list of components."
    1059                            type name in-order-to)))
    1060 
    1061 (defun sysdef-error-component (msg type name value)
    1062   (sysdef-error (concatenate 'string msg
    1063                              "~&The value specified for ~(~A~) ~A is ~W")
    1064                 type name value))
    1065 
    1066 (defun resolve-symlinks (path)
    1067   #-allegro (truename path)
    1068   #+allegro (excl:pathname-resolve-symbolic-links path)
    1069   )
    1070 
    1071 ;;; optional extras
    1072 
    1073 ;;; run-shell-command functions for other lisp implementations will be
    1074 ;;; gratefully accepted, if they do the same thing.  If the docstring
    1075 ;;; is ambiguous, send a bug report
    1076 
    1077 (defun run-shell-command (control-string &rest args)
    1078   "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
    1079 synchronously execute the result using a Bourne-compatible shell, with
    1080 output to *VERBOSE-OUT*.  Returns the shell's exit code."
    1081   (let ((command (apply #'format nil control-string args)))
    1082     (format *verbose-out* "; $ ~A~%" command)
    1083     #+sbcl
    1084     (sb-ext:process-exit-code
    1085      (sb-ext:run-program 
    1086       #+win32 "sh" #-win32 "/bin/sh"
    1087       (list  "-c" command)
    1088       #+win32 #+win32 :search t
    1089       :input nil :output *verbose-out*))
    1090    
    1091     #+(or cmu scl)
    1092     (ext:process-exit-code
    1093      (ext:run-program 
    1094       "/bin/sh"
    1095       (list  "-c" command)
    1096       :input nil :output *verbose-out*))
    1097 
    1098     #+allegro
    1099     (excl:run-shell-command command :input nil :output *verbose-out*)
    1100    
    1101     #+lispworks
    1102     (system:call-system-showing-output
    1103      command
    1104      :shell-type "/bin/sh"
    1105      :output-stream *verbose-out*)
    1106    
    1107     #+clisp                             ;XXX not exactly *verbose-out*, I know
    1108     (ext:run-shell-command  command :output :terminal :wait t)
    1109 
    1110     #+openmcl
    1111     (nth-value 1
    1112                (ccl:external-process-status
    1113                 (ccl:run-program "/bin/sh" (list "-c" command)
    1114                                  :input nil :output *verbose-out*
    1115                                  :wait t)))
    1116     #+ecl ;; courtesy of Juan Jose Garcia Ripoll
    1117     (si:system command)
    1118     #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl)
    1119     (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
    1120     ))
    1121 
    1122 
    1123 (defgeneric hyperdocumentation (package name doc-type))
    1124 (defmethod hyperdocumentation ((package symbol) name doc-type)
    1125   (hyperdocumentation (find-package package) name doc-type))
    1126 
    1127 (defun hyperdoc (name doc-type)
    1128   (hyperdocumentation (symbol-package name) name doc-type))
    1129 
    1130 
    1131 (pushnew :asdf *features*)
    1132 
    1133 #+sbcl
    1134 (eval-when (:compile-toplevel :load-toplevel :execute)
    1135   (when (sb-ext:posix-getenv "SBCL_BUILDING_CONTRIB")
    1136     (pushnew :sbcl-hooks-require *features*)))
    1137 
    1138 #+(and sbcl sbcl-hooks-require)
    1139 (progn
    1140   (defun module-provide-asdf (name)
    1141     (handler-bind ((style-warning #'muffle-warning))
    1142       (let* ((*verbose-out* (make-broadcast-stream))
    1143              (system (asdf:find-system name nil)))
    1144         (when system
    1145           (asdf:operate 'asdf:load-op name)
    1146           t))))
    1147 
    1148   (defun contrib-sysdef-search (system)
    1149     (let* ((name (coerce-name system))
    1150            (home (truename (sb-ext:posix-getenv "SBCL_HOME")))
    1151            (contrib (merge-pathnames
    1152                      (make-pathname :directory `(:relative ,name)
    1153                                     :name name
    1154                                     :type "asd"
    1155                                     :case :local
    1156                                     :version :newest)
    1157                      home)))
    1158       (probe-file contrib)))
    1159  
    1160   (pushnew
    1161    '(merge-pathnames "site-systems/"
    1162      (truename (sb-ext:posix-getenv "SBCL_HOME")))
    1163    *central-registry*)
    1164  
    1165   (pushnew
    1166    '(merge-pathnames ".sbcl/systems/"
    1167      (user-homedir-pathname))
    1168    *central-registry*)
    1169  
    1170   (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)
    1171   (pushnew 'contrib-sysdef-search *system-definition-search-functions*))
    1172 
    1173 (provide 'asdf)
     1
     2
     3
     4
     5<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
     6"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
     7<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
     8<!-- ViewVC - http://viewvc.org/
     9by Greg Stein - mailto:gstein@lyra.org -->
     10<head>
     11<title>SourceForge.net Repository - [cclan] View of /asdf/asdf.lisp</title>
     12<meta name="generator" content="ViewVC 1.0.3" />
     13<link rel="stylesheet" href="/*docroot*/styles.css" type="text/css" />
     14</head>
     15<body>
     16<table style="padding:0.1em;">
     17<tr>
     18<td>
     19<strong>
     20
     21<a href="/cclan/">
     22
     23[cclan]</a>
     24/
     25
     26<a href="/cclan/asdf/">
     27
     28asdf</a>
     29/
     30
     31<a href="/cclan/asdf/asdf.lisp?view=log">
     32
     33asdf.lisp</a>
     34
     35
     36</strong>
     37
     38</td>
     39</tr>
     40</table>
     41
     42
     43<div style="float: right; padding: 5px;"><a href="http://sourceforge.net"><img src="/*docroot*/images/sflogo-210pxtrans.png" alt="(logo)" border=0 width=210 height=62></a></div>
     44<h1>View of /asdf/asdf.lisp</h1>
     45
     46<p style="margin:0;">
     47
     48<a href="/cclan/asdf/"><img src="/*docroot*/images/back_small.png" width="16" height="16" alt="Parent Directory" /> Parent Directory</a>
     49
     50| <a href="/cclan/asdf/asdf.lisp?view=log#rev1.115"><img src="/*docroot*/images/log.png" width="16" height="16" alt="Revision Log" /> Revision Log</a>
     51
     52
     53
     54
     55</p>
     56
     57<hr />
     58<div class="vc_summary">
     59Revision <strong>1.115</strong> -
     60(<a href="/*checkout*/cclan/asdf/asdf.lisp?revision=1.115"><strong>download</strong></a>)
     61
     62(<a href="/cclan/asdf/asdf.lisp?annotate=1.115"><strong>annotate</strong></a>)
     63
     64<br /><em>Fri Feb 15 12:14:48 2008 UTC</em>
     65(2 months ago)
     66by <em>demoss</em>
     67
     68
     69<br />Branch: <strong>MAIN</strong>
     70
     71
     72<br />CVS Tags: <strong>HEAD</strong>
     73
     74
     75
     76
     77<br />Changes since <strong>1.114: +2 -2 lines</strong>
     78
     79
     80
     81
     82
     83<pre class="vc_log">fix CVS revision magic in *asdf-revision*
     84
     85 gah.
     86</pre>
     87
     88</div>
     89<div id="vc_markup"><pre><a id="l_1"></a><span class="hl line">    1 </span><span class="hl slc">;;; This is asdf: Another System Definition Facility.  $Revision$</span>
     90<a id="l_2"></a><span class="hl line">    2 </span><span class="hl slc">;;;</span>
     91<a id="l_3"></a><span class="hl line">    3 </span><span class="hl slc">;;; Feedback, bug reports, and patches are all welcome: please mail to</span>
     92<a id="l_4"></a><span class="hl line">    4 </span><span class="hl slc">;;; &lt;cclan-list&#64;lists.sf.net&gt;.  But note first that the canonical</span>
     93<a id="l_5"></a><span class="hl line">    5 </span><span class="hl slc">;;; source for asdf is presently the cCLan CVS repository at</span>
     94<a id="l_6"></a><span class="hl line">    6 </span><span class="hl slc">;;; &lt;URL:http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/&gt;</span>
     95<a id="l_7"></a><span class="hl line">    7 </span><span class="hl slc">;;;</span>
     96<a id="l_8"></a><span class="hl line">    8 </span><span class="hl slc">;;; If you obtained this copy from anywhere else, and you experience</span>
     97<a id="l_9"></a><span class="hl line">    9 </span><span class="hl slc">;;; trouble using it, or find bugs, you may want to check at the</span>
     98<a id="l_10"></a><span class="hl line">   10 </span><span class="hl slc">;;; location above for a more recent version (and for documentation</span>
     99<a id="l_11"></a><span class="hl line">   11 </span><span class="hl slc">;;; and test files, if your copy came without them) before reporting</span>
     100<a id="l_12"></a><span class="hl line">   12 </span><span class="hl slc">;;; bugs.  There are usually two &quot;supported&quot; revisions - the CVS HEAD</span>
     101<a id="l_13"></a><span class="hl line">   13 </span><span class="hl slc">;;; is the latest development version, whereas the revision tagged</span>
     102<a id="l_14"></a><span class="hl line">   14 </span><span class="hl slc">;;; RELEASE may be slightly older but is considered `stable'</span>
     103<a id="l_15"></a><span class="hl line">   15 </span>
     104<a id="l_16"></a><span class="hl line">   16 </span><span class="hl slc">;;; Copyright (c) 2001-2007 Daniel Barlow and contributors</span>
     105<a id="l_17"></a><span class="hl line">   17 </span><span class="hl slc">;;;</span>
     106<a id="l_18"></a><span class="hl line">   18 </span><span class="hl slc">;;; Permission is hereby granted, free of charge, to any person obtaining</span>
     107<a id="l_19"></a><span class="hl line">   19 </span><span class="hl slc">;;; a copy of this software and associated documentation files (the</span>
     108<a id="l_20"></a><span class="hl line">   20 </span><span class="hl slc">;;; &quot;Software&quot;), to deal in the Software without restriction, including</span>
     109<a id="l_21"></a><span class="hl line">   21 </span><span class="hl slc">;;; without limitation the rights to use, copy, modify, merge, publish,</span>
     110<a id="l_22"></a><span class="hl line">   22 </span><span class="hl slc">;;; distribute, sublicense, and/or sell copies of the Software, and to</span>
     111<a id="l_23"></a><span class="hl line">   23 </span><span class="hl slc">;;; permit persons to whom the Software is furnished to do so, subject to</span>
     112<a id="l_24"></a><span class="hl line">   24 </span><span class="hl slc">;;; the following conditions:</span>
     113<a id="l_25"></a><span class="hl line">   25 </span><span class="hl slc">;;;</span>
     114<a id="l_26"></a><span class="hl line">   26 </span><span class="hl slc">;;; The above copyright notice and this permission notice shall be</span>
     115<a id="l_27"></a><span class="hl line">   27 </span><span class="hl slc">;;; included in all copies or substantial portions of the Software.</span>
     116<a id="l_28"></a><span class="hl line">   28 </span><span class="hl slc">;;;</span>
     117<a id="l_29"></a><span class="hl line">   29 </span><span class="hl slc">;;; THE SOFTWARE IS PROVIDED &quot;AS IS&quot;, WITHOUT WARRANTY OF ANY KIND,</span>
     118<a id="l_30"></a><span class="hl line">   30 </span><span class="hl slc">;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF</span>
     119<a id="l_31"></a><span class="hl line">   31 </span><span class="hl slc">;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND</span>
     120<a id="l_32"></a><span class="hl line">   32 </span><span class="hl slc">;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE</span>
     121<a id="l_33"></a><span class="hl line">   33 </span><span class="hl slc">;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION</span>
     122<a id="l_34"></a><span class="hl line">   34 </span><span class="hl slc">;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION</span>
     123<a id="l_35"></a><span class="hl line">   35 </span><span class="hl slc">;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.</span>
     124<a id="l_36"></a><span class="hl line">   36 </span>
     125<a id="l_37"></a><span class="hl line">   37 </span><span class="hl slc">;;; the problem with writing a defsystem replacement is bootstrapping:</span>
     126<a id="l_38"></a><span class="hl line">   38 </span><span class="hl slc">;;; we can't use defsystem to compile it.  Hence, all in one file</span>
     127<a id="l_39"></a><span class="hl line">   39 </span>
     128<a id="l_40"></a><span class="hl line">   40 </span><span class="hl sym">(</span>defpackage #<span class="hl sym">:</span>asdf
     129<a id="l_41"></a><span class="hl line">   41 </span>  <span class="hl sym">(:</span>export #<span class="hl sym">:</span>defsystem #<span class="hl sym">:</span>oos #<span class="hl sym">:</span>operate #<span class="hl sym">:</span>find-system #<span class="hl sym">:</span>run-shell-<span class="hl kwa">command</span>
     130<a id="l_42"></a><span class="hl line">   42 </span>           #<span class="hl sym">:</span>system-definition-pathname #<span class="hl sym">:</span>find-component <span class="hl slc">; miscellaneous</span>
     131<a id="l_43"></a><span class="hl line">   43 </span>           #<span class="hl sym">:</span>hyperdocumentation #<span class="hl sym">:</span>hyperdoc
     132<a id="l_44"></a><span class="hl line">   44 </span>
     133<a id="l_45"></a><span class="hl line">   45 </span>           #<span class="hl sym">:</span>compile-op #<span class="hl sym">:</span><span class="hl kwa">load</span>-op #<span class="hl sym">:</span><span class="hl kwa">load</span>-source-op #<span class="hl sym">:</span>test-system-version
     134<a id="l_46"></a><span class="hl line">   46 </span>           #<span class="hl sym">:</span>test-op
     135<a id="l_47"></a><span class="hl line">   47 </span>           #<span class="hl sym">:</span>operation                  <span class="hl slc">; operations</span>
     136<a id="l_48"></a><span class="hl line">   48 </span>           #<span class="hl sym">:</span>feature                    <span class="hl slc">; sort-of operation</span>
     137<a id="l_49"></a><span class="hl line">   49 </span>           #<span class="hl sym">:</span>version                    <span class="hl slc">; metaphorically sort-of an operation</span>
     138<a id="l_50"></a><span class="hl line">   50 </span>
     139<a id="l_51"></a><span class="hl line">   51 </span>           #<span class="hl sym">:</span>input-files #<span class="hl sym">:</span>output-files #<span class="hl sym">:</span>perform       <span class="hl slc">; operation methods</span>
     140<a id="l_52"></a><span class="hl line">   52 </span>           #<span class="hl sym">:</span>operation-done-p #<span class="hl sym">:</span>explain
     141<a id="l_53"></a><span class="hl line">   53 </span>
     142<a id="l_54"></a><span class="hl line">   54 </span>           #<span class="hl sym">:</span>component #<span class="hl sym">:</span>source-file
     143<a id="l_55"></a><span class="hl line">   55 </span>           #<span class="hl sym">:</span>c-source-file #<span class="hl sym">:</span>cl-source-file #<span class="hl sym">:</span>java-source-file
     144<a id="l_56"></a><span class="hl line">   56 </span>           #<span class="hl sym">:</span>static-file
     145<a id="l_57"></a><span class="hl line">   57 </span>           #<span class="hl sym">:</span>doc-file
     146<a id="l_58"></a><span class="hl line">   58 </span>           #<span class="hl sym">:</span>html-file
     147<a id="l_59"></a><span class="hl line">   59 </span>           #<span class="hl sym">:</span>text-file
     148<a id="l_60"></a><span class="hl line">   60 </span>           #<span class="hl sym">:</span>source-file-<span class="hl kwa">type</span>
     149<a id="l_61"></a><span class="hl line">   61 </span>           #<span class="hl sym">:</span>module                     <span class="hl slc">; components</span>
     150<a id="l_62"></a><span class="hl line">   62 </span>           #<span class="hl sym">:</span>system
     151<a id="l_63"></a><span class="hl line">   63 </span>           #<span class="hl sym">:</span>unix-dso
     152<a id="l_64"></a><span class="hl line">   64 </span>
     153<a id="l_65"></a><span class="hl line">   65 </span>           #<span class="hl sym">:</span>module-components          <span class="hl slc">; component accessors</span>
     154<a id="l_66"></a><span class="hl line">   66 </span>           #<span class="hl sym">:</span>component-pathname
     155<a id="l_67"></a><span class="hl line">   67 </span>           #<span class="hl sym">:</span>component-relative-pathname
     156<a id="l_68"></a><span class="hl line">   68 </span>           #<span class="hl sym">:</span>component-name
     157<a id="l_69"></a><span class="hl line">   69 </span>           #<span class="hl sym">:</span>component-version
     158<a id="l_70"></a><span class="hl line">   70 </span>           #<span class="hl sym">:</span>component-parent
     159<a id="l_71"></a><span class="hl line">   71 </span>           #<span class="hl sym">:</span>component-property
     160<a id="l_72"></a><span class="hl line">   72 </span>           #<span class="hl sym">:</span>component-system
     161<a id="l_73"></a><span class="hl line">   73 </span>
     162<a id="l_74"></a><span class="hl line">   74 </span>           #<span class="hl sym">:</span>component-depends-on
     163<a id="l_75"></a><span class="hl line">   75 </span>
     164<a id="l_76"></a><span class="hl line">   76 </span>           #<span class="hl sym">:</span>system-description
     165<a id="l_77"></a><span class="hl line">   77 </span>           #<span class="hl sym">:</span>system-long-description
     166<a id="l_78"></a><span class="hl line">   78 </span>           #<span class="hl sym">:</span>system-author
     167<a id="l_79"></a><span class="hl line">   79 </span>           #<span class="hl sym">:</span>system-maintainer
     168<a id="l_80"></a><span class="hl line">   80 </span>           #<span class="hl sym">:</span>system-license
     169<a id="l_81"></a><span class="hl line">   81 </span>           #<span class="hl sym">:</span>system-licence
     170<a id="l_82"></a><span class="hl line">   82 </span>           #<span class="hl sym">:</span>system-source-file
     171<a id="l_83"></a><span class="hl line">   83 </span>           #<span class="hl sym">:</span>system-relative-pathname
     172<a id="l_84"></a><span class="hl line">   84 </span>
     173<a id="l_85"></a><span class="hl line">   85 </span>           #<span class="hl sym">:</span>operation-on-warnings
     174<a id="l_86"></a><span class="hl line">   86 </span>           #<span class="hl sym">:</span>operation-on-failure
     175<a id="l_87"></a><span class="hl line">   87 </span>
     176<a id="l_88"></a><span class="hl line">   88 </span>           <span class="hl slc">;#:*component-parent-pathname*</span>
     177<a id="l_89"></a><span class="hl line">   89 </span>           #<span class="hl sym">:*</span>system-definition-search-functions<span class="hl sym">*</span>
     178<a id="l_90"></a><span class="hl line">   90 </span>           #<span class="hl sym">:*</span>central-registry<span class="hl sym">*</span>         <span class="hl slc">; variables</span>
     179<a id="l_91"></a><span class="hl line">   91 </span>           #<span class="hl sym">:*</span>compile-file-warnings-behaviour<span class="hl sym">*</span>
     180<a id="l_92"></a><span class="hl line">   92 </span>           #<span class="hl sym">:*</span>compile-file-failure-behaviour<span class="hl sym">*</span>
     181<a id="l_93"></a><span class="hl line">   93 </span>           #<span class="hl sym">:*</span>asdf-revision<span class="hl sym">*</span>
     182<a id="l_94"></a><span class="hl line">   94 </span>
     183<a id="l_95"></a><span class="hl line">   95 </span>           #<span class="hl sym">:</span>operation-error #<span class="hl sym">:</span>compile-failed #<span class="hl sym">:</span>compile-warned #<span class="hl sym">:</span>compile-error
     184<a id="l_96"></a><span class="hl line">   96 </span>           #<span class="hl sym">:</span>error-component #<span class="hl sym">:</span>error-operation
     185<a id="l_97"></a><span class="hl line">   97 </span>           #<span class="hl sym">:</span>system-definition-error
     186<a id="l_98"></a><span class="hl line">   98 </span>           #<span class="hl sym">:</span>missing-component
     187<a id="l_99"></a><span class="hl line">   99 </span>           #<span class="hl sym">:</span>missing-dependency
     188<a id="l_100"></a><span class="hl line">  100 </span>           #<span class="hl sym">:</span>circular-dependency        <span class="hl slc">; errors</span>
     189<a id="l_101"></a><span class="hl line">  101 </span>           #<span class="hl sym">:</span>duplicate-names
     190<a id="l_102"></a><span class="hl line">  102 </span>
     191<a id="l_103"></a><span class="hl line">  103 </span>           #<span class="hl sym">:</span>retry
     192<a id="l_104"></a><span class="hl line">  104 </span>           #<span class="hl sym">:</span>accept                     <span class="hl slc">; restarts</span>
     193<a id="l_105"></a><span class="hl line">  105 </span>
     194<a id="l_106"></a><span class="hl line">  106 </span>           #<span class="hl sym">:</span>preference-file-for-system<span class="hl sym">/</span>operation
     195<a id="l_107"></a><span class="hl line">  107 </span>           #<span class="hl sym">:</span><span class="hl kwa">load</span>-preferences
     196<a id="l_108"></a><span class="hl line">  108 </span>           <span class="hl sym">)</span>
     197<a id="l_109"></a><span class="hl line">  109 </span>  <span class="hl sym">(:</span>use <span class="hl sym">:</span>cl<span class="hl sym">))</span>
     198<a id="l_110"></a><span class="hl line">  110 </span>
     199<a id="l_111"></a><span class="hl line">  111 </span>
     200<a id="l_112"></a><span class="hl line">  112 </span>#<span class="hl sym">+</span>nil
     201<a id="l_113"></a><span class="hl line">  113 </span><span class="hl sym">(</span>error <span class="hl str">&quot;The author of this file habitually uses #+nil to comment out ~</span>
     202<a id="l_114"></a><span class="hl line">  114 </span><span class="hl str">        forms. But don't worry, it was unlikely to work in the New ~</span>
     203<a id="l_115"></a><span class="hl line">  115 </span><span class="hl str">        Implementation of Lisp anyway&quot;</span><span class="hl sym">)</span>
     204<a id="l_116"></a><span class="hl line">  116 </span>
     205<a id="l_117"></a><span class="hl line">  117 </span><span class="hl sym">(</span>in-package #<span class="hl sym">:</span>asdf<span class="hl sym">)</span>
     206<a id="l_118"></a><span class="hl line">  118 </span>
     207<a id="l_119"></a><span class="hl line">  119 </span><span class="hl sym">(</span>defvar <span class="hl sym">*</span>asdf-revision<span class="hl sym">* (</span>let<span class="hl sym">* ((</span>v <span class="hl str">&quot;$Revision$&quot;</span><span class="hl sym">)</span>
     208<a id="l_120"></a><span class="hl line">  120 </span>                               <span class="hl sym">(</span>colon <span class="hl sym">(</span><span class="hl kwa">or</span> <span class="hl sym">(</span>position #\: v<span class="hl sym">)</span> -<span class="hl num">1</span><span class="hl sym">))</span>
     209<a id="l_121"></a><span class="hl line">  121 </span>                               <span class="hl sym">(</span>dot <span class="hl sym">(</span>position #\. v<span class="hl sym">)))</span>
     210<a id="l_122"></a><span class="hl line">  122 </span>                          <span class="hl sym">(</span><span class="hl kwa">and</span> v colon dot
     211<a id="l_123"></a><span class="hl line">  123 </span>                               <span class="hl sym">(</span><span class="hl kwa">list</span> <span class="hl sym">(</span>parse-integer v <span class="hl sym">:</span>start <span class="hl sym">(</span><span class="hl num">1</span><span class="hl sym">+</span> colon<span class="hl sym">)</span>
     212<a id="l_124"></a><span class="hl line">  124 </span>                                                      <span class="hl sym">:</span>junk-allowed t<span class="hl sym">)</span>
     213<a id="l_125"></a><span class="hl line">  125 </span>                                     <span class="hl sym">(</span>parse-integer v <span class="hl sym">:</span>start <span class="hl sym">(</span><span class="hl num">1</span><span class="hl sym">+</span> dot<span class="hl sym">)</span>
     214<a id="l_126"></a><span class="hl line">  126 </span>                                                      <span class="hl sym">:</span>junk-allowed t<span class="hl sym">)))))</span>
     215<a id="l_127"></a><span class="hl line">  127 </span>
     216<a id="l_128"></a><span class="hl line">  128 </span><span class="hl sym">(</span>defvar <span class="hl sym">*</span>compile-file-warnings-behaviour<span class="hl sym">* :</span>warn<span class="hl sym">)</span>
     217<a id="l_129"></a><span class="hl line">  129 </span>
     218<a id="l_130"></a><span class="hl line">  130 </span><span class="hl sym">(</span>defvar <span class="hl sym">*</span>compile-file-failure-behaviour<span class="hl sym">*</span> #<span class="hl sym">+</span>sbcl <span class="hl sym">:</span>error #-sbcl <span class="hl sym">:</span>warn<span class="hl sym">)</span>
     219<a id="l_131"></a><span class="hl line">  131 </span>
     220<a id="l_132"></a><span class="hl line">  132 </span><span class="hl sym">(</span>defvar <span class="hl sym">*</span>verbose-out<span class="hl sym">*</span> nil<span class="hl sym">)</span>
     221<a id="l_133"></a><span class="hl line">  133 </span>
     222<a id="l_134"></a><span class="hl line">  134 </span><span class="hl sym">(</span>defparameter <span class="hl sym">+</span>asdf-methods<span class="hl sym">+</span>
     223<a id="l_135"></a><span class="hl line">  135 </span>  <span class="hl sym">'(</span>perform explain output-files operation-done-p<span class="hl sym">))</span>
     224<a id="l_136"></a><span class="hl line">  136 </span>
     225<a id="l_137"></a><span class="hl line">  137 </span><span class="hl slc">;;;;;;;;;;;;;;;;;;;;;;;;;;;;;</span>
     226<a id="l_138"></a><span class="hl line">  138 </span><span class="hl slc">;; utility stuff</span>
     227<a id="l_139"></a><span class="hl line">  139 </span>
     228<a id="l_140"></a><span class="hl line">  140 </span><span class="hl sym">(</span>defmacro aif <span class="hl sym">(</span>test then <span class="hl sym">&amp;</span>optional else<span class="hl sym">)</span>
     229<a id="l_141"></a><span class="hl line">  141 </span>  `<span class="hl sym">(</span>let <span class="hl sym">((</span>it <span class="hl sym">,</span>test<span class="hl sym">)) (</span><span class="hl kwa">if</span> it <span class="hl sym">,</span>then <span class="hl sym">,</span>else<span class="hl sym">)))</span>
     230<a id="l_142"></a><span class="hl line">  142 </span>
     231<a id="l_143"></a><span class="hl line">  143 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> pathname-sans-name<span class="hl sym">+</span><span class="hl kwa">type</span> <span class="hl sym">(</span>pathname<span class="hl sym">)</span>
     232<a id="l_144"></a><span class="hl line">  144 </span>  <span class="hl str">&quot;Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,</span>
     233<a id="l_145"></a><span class="hl line">  145 </span><span class="hl str">and NIL NAME and TYPE components&quot;</span>
     234<a id="l_146"></a><span class="hl line">  146 </span>  <span class="hl sym">(</span>make-pathname <span class="hl sym">:</span>name nil <span class="hl sym">:</span><span class="hl kwa">type</span> nil <span class="hl sym">:</span>defaults pathname<span class="hl sym">))</span>
     235<a id="l_147"></a><span class="hl line">  147 </span>
     236<a id="l_148"></a><span class="hl line">  148 </span><span class="hl sym">(</span>define-modify-macro appendf <span class="hl sym">(&amp;</span>rest args<span class="hl sym">)</span>
     237<a id="l_149"></a><span class="hl line">  149 </span>  <span class="hl kwa">append</span> <span class="hl str">&quot;Append onto list&quot;</span><span class="hl sym">)</span>
     238<a id="l_150"></a><span class="hl line">  150 </span>
     239<a id="l_151"></a><span class="hl line">  151 </span><span class="hl slc">;;;;;;;;;;;;;;;;;;;;;;;;;;;;;</span>
     240<a id="l_152"></a><span class="hl line">  152 </span><span class="hl slc">;; classes, condiitons</span>
     241<a id="l_153"></a><span class="hl line">  153 </span>
     242<a id="l_154"></a><span class="hl line">  154 </span><span class="hl sym">(</span>define-condition system-definition-error <span class="hl sym">(</span>error<span class="hl sym">) ()</span>
     243<a id="l_155"></a><span class="hl line">  155 </span>  <span class="hl slc">;; [this use of :report should be redundant, but unfortunately it's not.</span>
     244<a id="l_156"></a><span class="hl line">  156 </span>  <span class="hl slc">;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function</span>
     245<a id="l_157"></a><span class="hl line">  157 </span>  <span class="hl slc">;; over print-object; this is always conditions::%print-condition for</span>
     246<a id="l_158"></a><span class="hl line">  158 </span>  <span class="hl slc">;; condition objects, which in turn does inheritance of :report options at</span>
     247<a id="l_159"></a><span class="hl line">  159 </span>  <span class="hl slc">;; run-time.  fortunately, inheritance means we only need this kludge here in</span>
     248<a id="l_160"></a><span class="hl line">  160 </span>  <span class="hl slc">;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]</span>
     249<a id="l_161"></a><span class="hl line">  161 </span>  #<span class="hl sym">+</span>cmu <span class="hl sym">(:</span>report <span class="hl kwa">print</span>-object<span class="hl sym">))</span>
     250<a id="l_162"></a><span class="hl line">  162 </span>
     251<a id="l_163"></a><span class="hl line">  163 </span><span class="hl sym">(</span>define-condition formatted-system-definition-error <span class="hl sym">(</span>system-definition-error<span class="hl sym">)</span>
     252<a id="l_164"></a><span class="hl line">  164 </span>  <span class="hl sym">((</span>format-control <span class="hl sym">:</span>initarg <span class="hl sym">:</span>format-control <span class="hl sym">:</span>reader format-control<span class="hl sym">)</span>
     253<a id="l_165"></a><span class="hl line">  165 </span>   <span class="hl sym">(</span>format-arguments <span class="hl sym">:</span>initarg <span class="hl sym">:</span>format-arguments <span class="hl sym">:</span>reader format-arguments<span class="hl sym">))</span>
     254<a id="l_166"></a><span class="hl line">  166 </span>  <span class="hl sym">(:</span>report <span class="hl sym">(</span><span class="hl kwa">lambda</span> <span class="hl sym">(</span>c s<span class="hl sym">)</span>
     255<a id="l_167"></a><span class="hl line">  167 </span>             <span class="hl sym">(</span><span class="hl kwa">apply</span> #<span class="hl sym">'</span>format s <span class="hl sym">(</span>format-control c<span class="hl sym">) (</span>format-arguments c<span class="hl sym">)))))</span>
     256<a id="l_168"></a><span class="hl line">  168 </span>
     257<a id="l_169"></a><span class="hl line">  169 </span><span class="hl sym">(</span>define-condition circular-dependency <span class="hl sym">(</span>system-definition-error<span class="hl sym">)</span>
     258<a id="l_170"></a><span class="hl line">  170 </span>  <span class="hl sym">((</span>components <span class="hl sym">:</span>initarg <span class="hl sym">:</span>components <span class="hl sym">:</span>reader circular-dependency-components<span class="hl sym">)))</span>
     259<a id="l_171"></a><span class="hl line">  171 </span>
     260<a id="l_172"></a><span class="hl line">  172 </span><span class="hl sym">(</span>define-condition duplicate-names <span class="hl sym">(</span>system-definition-error<span class="hl sym">)</span>
     261<a id="l_173"></a><span class="hl line">  173 </span>  <span class="hl sym">((</span>name <span class="hl sym">:</span>initarg <span class="hl sym">:</span>name <span class="hl sym">:</span>reader duplicate-names-name<span class="hl sym">)))</span>
     262<a id="l_174"></a><span class="hl line">  174 </span>
     263<a id="l_175"></a><span class="hl line">  175 </span><span class="hl sym">(</span>define-condition missing-component <span class="hl sym">(</span>system-definition-error<span class="hl sym">)</span>
     264<a id="l_176"></a><span class="hl line">  176 </span>  <span class="hl sym">((</span>requires <span class="hl sym">:</span>initform <span class="hl str">&quot;(unnamed)&quot;</span> <span class="hl sym">:</span>reader missing-requires <span class="hl sym">:</span>initarg <span class="hl sym">:</span>requires<span class="hl sym">)</span>
     265<a id="l_177"></a><span class="hl line">  177 </span>   <span class="hl sym">(</span>version <span class="hl sym">:</span>initform nil <span class="hl sym">:</span>reader missing-version <span class="hl sym">:</span>initarg <span class="hl sym">:</span>version<span class="hl sym">)</span>
     266<a id="l_178"></a><span class="hl line">  178 </span>   <span class="hl sym">(</span>parent <span class="hl sym">:</span>initform nil <span class="hl sym">:</span>reader missing-parent <span class="hl sym">:</span>initarg <span class="hl sym">:</span>parent<span class="hl sym">)))</span>
     267<a id="l_179"></a><span class="hl line">  179 </span>
     268<a id="l_180"></a><span class="hl line">  180 </span><span class="hl sym">(</span>define-condition missing-dependency <span class="hl sym">(</span>missing-component<span class="hl sym">)</span>
     269<a id="l_181"></a><span class="hl line">  181 </span>  <span class="hl sym">((</span>required-by <span class="hl sym">:</span>initarg <span class="hl sym">:</span>required-by <span class="hl sym">:</span>reader missing-required-by<span class="hl sym">)))</span>
     270<a id="l_182"></a><span class="hl line">  182 </span>
     271<a id="l_183"></a><span class="hl line">  183 </span><span class="hl sym">(</span>define-condition operation-error <span class="hl sym">(</span>error<span class="hl sym">)</span>
     272<a id="l_184"></a><span class="hl line">  184 </span>  <span class="hl sym">((</span>component <span class="hl sym">:</span>reader error-component <span class="hl sym">:</span>initarg <span class="hl sym">:</span>component<span class="hl sym">)</span>
     273<a id="l_185"></a><span class="hl line">  185 </span>   <span class="hl sym">(</span>operation <span class="hl sym">:</span>reader error-operation <span class="hl sym">:</span>initarg <span class="hl sym">:</span>operation<span class="hl sym">))</span>
     274<a id="l_186"></a><span class="hl line">  186 </span>  <span class="hl sym">(:</span>report <span class="hl sym">(</span><span class="hl kwa">lambda</span> <span class="hl sym">(</span>c s<span class="hl sym">)</span>
     275<a id="l_187"></a><span class="hl line">  187 </span>             <span class="hl sym">(</span>format s <span class="hl str">&quot;~&#64;&lt;erred while invoking ~A on ~A~&#64;:&gt;&quot;</span>
     276<a id="l_188"></a><span class="hl line">  188 </span>                     <span class="hl sym">(</span>error-operation c<span class="hl sym">) (</span>error-component c<span class="hl sym">)))))</span>
     277<a id="l_189"></a><span class="hl line">  189 </span><span class="hl sym">(</span>define-condition compile-error <span class="hl sym">(</span>operation-error<span class="hl sym">) ())</span>
     278<a id="l_190"></a><span class="hl line">  190 </span><span class="hl sym">(</span>define-condition compile-failed <span class="hl sym">(</span>compile-error<span class="hl sym">) ())</span>
     279<a id="l_191"></a><span class="hl line">  191 </span><span class="hl sym">(</span>define-condition compile-warned <span class="hl sym">(</span>compile-error<span class="hl sym">) ())</span>
     280<a id="l_192"></a><span class="hl line">  192 </span>
     281<a id="l_193"></a><span class="hl line">  193 </span><span class="hl sym">(</span>defclass component <span class="hl sym">()</span>
     282<a id="l_194"></a><span class="hl line">  194 </span>  <span class="hl sym">((</span>name <span class="hl sym">:</span>accessor component-name <span class="hl sym">:</span>initarg <span class="hl sym">:</span>name <span class="hl sym">:</span>documentation
     283<a id="l_195"></a><span class="hl line">  195 </span>         <span class="hl str">&quot;Component name: designator for a string composed of portable pathname characters&quot;</span><span class="hl sym">)</span>
     284<a id="l_196"></a><span class="hl line">  196 </span>   <span class="hl sym">(</span>version <span class="hl sym">:</span>accessor component-version <span class="hl sym">:</span>initarg <span class="hl sym">:</span>version<span class="hl sym">)</span>
     285<a id="l_197"></a><span class="hl line">  197 </span>   <span class="hl sym">(</span>in-order-to <span class="hl sym">:</span>initform nil <span class="hl sym">:</span>initarg <span class="hl sym">:</span>in-order-to<span class="hl sym">)</span>
     286<a id="l_198"></a><span class="hl line">  198 </span>   <span class="hl slc">;; XXX crap name</span>
     287<a id="l_199"></a><span class="hl line">  199 </span>   <span class="hl sym">(</span>do-first <span class="hl sym">:</span>initform nil <span class="hl sym">:</span>initarg <span class="hl sym">:</span>do-first<span class="hl sym">)</span>
     288<a id="l_200"></a><span class="hl line">  200 </span>   <span class="hl slc">;; methods defined using the &quot;inline&quot; style inside a defsystem form:</span>
     289<a id="l_201"></a><span class="hl line">  201 </span>   <span class="hl slc">;; need to store them somewhere so we can delete them when the system</span>
     290<a id="l_202"></a><span class="hl line">  202 </span>   <span class="hl slc">;; is re-evaluated</span>
     291<a id="l_203"></a><span class="hl line">  203 </span>   <span class="hl sym">(</span>inline-methods <span class="hl sym">:</span>accessor component-inline-methods <span class="hl sym">:</span>initform nil<span class="hl sym">)</span>
     292<a id="l_204"></a><span class="hl line">  204 </span>   <span class="hl sym">(</span>parent <span class="hl sym">:</span>initarg <span class="hl sym">:</span>parent <span class="hl sym">:</span>initform nil <span class="hl sym">:</span>reader component-parent<span class="hl sym">)</span>
     293<a id="l_205"></a><span class="hl line">  205 </span>   <span class="hl slc">;; no direct accessor for pathname, we do this as a method to allow</span>
     294<a id="l_206"></a><span class="hl line">  206 </span>   <span class="hl slc">;; it to default in funky ways if not supplied</span>
     295<a id="l_207"></a><span class="hl line">  207 </span>   <span class="hl sym">(</span>relative-pathname <span class="hl sym">:</span>initarg <span class="hl sym">:</span>pathname<span class="hl sym">)</span>
     296<a id="l_208"></a><span class="hl line">  208 </span>   <span class="hl sym">(</span>operation-times <span class="hl sym">:</span>initform <span class="hl sym">(</span>make-hash-table <span class="hl sym">)</span>
     297<a id="l_209"></a><span class="hl line">  209 </span>                    <span class="hl sym">:</span>accessor component-operation-times<span class="hl sym">)</span>
     298<a id="l_210"></a><span class="hl line">  210 </span>   <span class="hl slc">;; XXX we should provide some atomic interface for updating the</span>
     299<a id="l_211"></a><span class="hl line">  211 </span>   <span class="hl slc">;; component properties</span>
     300<a id="l_212"></a><span class="hl line">  212 </span>   <span class="hl sym">(</span>properties <span class="hl sym">:</span>accessor component-properties <span class="hl sym">:</span>initarg <span class="hl sym">:</span>properties
     301<a id="l_213"></a><span class="hl line">  213 </span>               <span class="hl sym">:</span>initform nil<span class="hl sym">)))</span>
     302<a id="l_214"></a><span class="hl line">  214 </span>
     303<a id="l_215"></a><span class="hl line">  215 </span><span class="hl slc">;;;; methods: conditions</span>
     304<a id="l_216"></a><span class="hl line">  216 </span>
     305<a id="l_217"></a><span class="hl line">  217 </span><span class="hl sym">(</span>defmethod <span class="hl kwa">print</span>-object <span class="hl sym">((</span>c missing-dependency<span class="hl sym">)</span> s<span class="hl sym">)</span>
     306<a id="l_218"></a><span class="hl line">  218 </span>  <span class="hl sym">(</span>format s <span class="hl str">&quot;~&#64;&lt;~A, required by ~A~&#64;:&gt;&quot;</span>
     307<a id="l_219"></a><span class="hl line">  219 </span>          <span class="hl sym">(</span>call-next-method c nil<span class="hl sym">) (</span>missing-required-by c<span class="hl sym">)))</span>
     308<a id="l_220"></a><span class="hl line">  220 </span>
     309<a id="l_221"></a><span class="hl line">  221 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> sysdef-error <span class="hl sym">(</span>format <span class="hl sym">&amp;</span>rest arguments<span class="hl sym">)</span>
     310<a id="l_222"></a><span class="hl line">  222 </span>  <span class="hl sym">(</span>error <span class="hl sym">'</span>formatted-system-definition-error <span class="hl sym">:</span>format-control format <span class="hl sym">:</span>format-arguments arguments<span class="hl sym">))</span>
     311<a id="l_223"></a><span class="hl line">  223 </span>
     312<a id="l_224"></a><span class="hl line">  224 </span><span class="hl slc">;;;; methods: components</span>
     313<a id="l_225"></a><span class="hl line">  225 </span>
     314<a id="l_226"></a><span class="hl line">  226 </span><span class="hl sym">(</span>defmethod <span class="hl kwa">print</span>-object <span class="hl sym">((</span>c missing-component<span class="hl sym">)</span> s<span class="hl sym">)</span>
     315<a id="l_227"></a><span class="hl line">  227 </span>  <span class="hl sym">(</span>format s <span class="hl str">&quot;~&#64;&lt;component ~S not found~</span>
     316<a id="l_228"></a><span class="hl line">  228 </span><span class="hl str">             ~&#64;[ or does not match version ~A~]~</span>
     317<a id="l_229"></a><span class="hl line">  229 </span><span class="hl str">             ~&#64;[ in ~A~]~&#64;:&gt;&quot;</span>
     318<a id="l_230"></a><span class="hl line">  230 </span>          <span class="hl sym">(</span>missing-requires c<span class="hl sym">)</span>
     319<a id="l_231"></a><span class="hl line">  231 </span>          <span class="hl sym">(</span>missing-version c<span class="hl sym">)</span>
     320<a id="l_232"></a><span class="hl line">  232 </span>          <span class="hl sym">(</span>when <span class="hl sym">(</span>missing-parent c<span class="hl sym">)</span>
     321<a id="l_233"></a><span class="hl line">  233 </span>            <span class="hl sym">(</span>component-name <span class="hl sym">(</span>missing-parent c<span class="hl sym">)))))</span>
     322<a id="l_234"></a><span class="hl line">  234 </span>
     323<a id="l_235"></a><span class="hl line">  235 </span><span class="hl sym">(</span>defgeneric component-system <span class="hl sym">(</span>component<span class="hl sym">)</span>
     324<a id="l_236"></a><span class="hl line">  236 </span>  <span class="hl sym">(:</span>documentation <span class="hl str">&quot;Find the top-level system containing COMPONENT&quot;</span><span class="hl sym">))</span>
     325<a id="l_237"></a><span class="hl line">  237 </span>
     326<a id="l_238"></a><span class="hl line">  238 </span><span class="hl sym">(</span>defmethod component-system <span class="hl sym">((</span>component component<span class="hl sym">))</span>
     327<a id="l_239"></a><span class="hl line">  239 </span>  <span class="hl sym">(</span>aif <span class="hl sym">(</span>component-parent component<span class="hl sym">)</span>
     328<a id="l_240"></a><span class="hl line">  240 </span>       <span class="hl sym">(</span>component-system it<span class="hl sym">)</span>
     329<a id="l_241"></a><span class="hl line">  241 </span>       component<span class="hl sym">))</span>
     330<a id="l_242"></a><span class="hl line">  242 </span>
     331<a id="l_243"></a><span class="hl line">  243 </span><span class="hl sym">(</span>defmethod <span class="hl kwa">print</span>-object <span class="hl sym">((</span>c component<span class="hl sym">)</span> stream<span class="hl sym">)</span>
     332<a id="l_244"></a><span class="hl line">  244 </span>  <span class="hl sym">(</span><span class="hl kwa">print</span>-unreadable-object <span class="hl sym">(</span>c stream <span class="hl sym">:</span><span class="hl kwa">type</span> t <span class="hl sym">:</span>identity t<span class="hl sym">)</span>
     333<a id="l_245"></a><span class="hl line">  245 </span>    <span class="hl sym">(</span>ignore-errors
     334<a id="l_246"></a><span class="hl line">  246 </span>      <span class="hl sym">(</span><span class="hl kwa">prin1</span> <span class="hl sym">(</span>component-name c<span class="hl sym">)</span> stream<span class="hl sym">))))</span>
     335<a id="l_247"></a><span class="hl line">  247 </span>
     336<a id="l_248"></a><span class="hl line">  248 </span><span class="hl sym">(</span>defclass module <span class="hl sym">(</span>component<span class="hl sym">)</span>
     337<a id="l_249"></a><span class="hl line">  249 </span>  <span class="hl sym">((</span>components <span class="hl sym">:</span>initform nil <span class="hl sym">:</span>accessor module-components <span class="hl sym">:</span>initarg <span class="hl sym">:</span>components<span class="hl sym">)</span>
     338<a id="l_250"></a><span class="hl line">  250 </span>   <span class="hl slc">;; what to do if we can't satisfy a dependency of one of this module's</span>
     339<a id="l_251"></a><span class="hl line">  251 </span>   <span class="hl slc">;; components.  This allows a limited form of conditional processing</span>
     340<a id="l_252"></a><span class="hl line">  252 </span>   <span class="hl sym">(</span><span class="hl kwa">if</span>-component-dep-fails <span class="hl sym">:</span>initform <span class="hl sym">:</span>fail
     341<a id="l_253"></a><span class="hl line">  253 </span>                           <span class="hl sym">:</span>accessor module-<span class="hl kwa">if</span>-component-dep-fails
     342<a id="l_254"></a><span class="hl line">  254 </span>                           <span class="hl sym">:</span>initarg <span class="hl sym">:</span><span class="hl kwa">if</span>-component-dep-fails<span class="hl sym">)</span>
     343<a id="l_255"></a><span class="hl line">  255 </span>   <span class="hl sym">(</span>default-component-class <span class="hl sym">:</span>accessor module-default-component-class
     344<a id="l_256"></a><span class="hl line">  256 </span>     <span class="hl sym">:</span>initform <span class="hl sym">'</span>cl-source-file <span class="hl sym">:</span>initarg <span class="hl sym">:</span>default-component-class<span class="hl sym">)))</span>
     345<a id="l_257"></a><span class="hl line">  257 </span>
     346<a id="l_258"></a><span class="hl line">  258 </span><span class="hl sym">(</span>defgeneric component-pathname <span class="hl sym">(</span>component<span class="hl sym">)</span>
     347<a id="l_259"></a><span class="hl line">  259 </span>  <span class="hl sym">(:</span>documentation <span class="hl str">&quot;Extracts the pathname applicable for a particular component.&quot;</span><span class="hl sym">))</span>
     348<a id="l_260"></a><span class="hl line">  260 </span>
     349<a id="l_261"></a><span class="hl line">  261 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> component-parent-pathname <span class="hl sym">(</span>component<span class="hl sym">)</span>
     350<a id="l_262"></a><span class="hl line">  262 </span>  <span class="hl sym">(</span>aif <span class="hl sym">(</span>component-parent component<span class="hl sym">)</span>
     351<a id="l_263"></a><span class="hl line">  263 </span>       <span class="hl sym">(</span>component-pathname it<span class="hl sym">)</span>
     352<a id="l_264"></a><span class="hl line">  264 </span>       <span class="hl sym">*</span>default-pathname-defaults<span class="hl sym">*))</span>
     353<a id="l_265"></a><span class="hl line">  265 </span>
     354<a id="l_266"></a><span class="hl line">  266 </span><span class="hl sym">(</span>defgeneric component-relative-pathname <span class="hl sym">(</span>component<span class="hl sym">)</span>
     355<a id="l_267"></a><span class="hl line">  267 </span>  <span class="hl sym">(:</span>documentation <span class="hl str">&quot;Extracts the relative pathname applicable for a particular component.&quot;</span><span class="hl sym">))</span>
     356<a id="l_268"></a><span class="hl line">  268 </span>
     357<a id="l_269"></a><span class="hl line">  269 </span><span class="hl sym">(</span>defmethod component-relative-pathname <span class="hl sym">((</span>component module<span class="hl sym">))</span>
     358<a id="l_270"></a><span class="hl line">  270 </span>  <span class="hl sym">(</span><span class="hl kwa">or</span> <span class="hl sym">(</span>slot-value component <span class="hl sym">'</span>relative-pathname<span class="hl sym">)</span>
     359<a id="l_271"></a><span class="hl line">  271 </span>      <span class="hl sym">(</span>make-pathname
     360<a id="l_272"></a><span class="hl line">  272 </span>       <span class="hl sym">:</span>directory `<span class="hl sym">(:</span>relative <span class="hl sym">,(</span>component-name component<span class="hl sym">))</span>
     361<a id="l_273"></a><span class="hl line">  273 </span>       <span class="hl sym">:</span>host <span class="hl sym">(</span>pathname-host <span class="hl sym">(</span>component-parent-pathname component<span class="hl sym">)))))</span>
     362<a id="l_274"></a><span class="hl line">  274 </span>
     363<a id="l_275"></a><span class="hl line">  275 </span><span class="hl sym">(</span>defmethod component-pathname <span class="hl sym">((</span>component component<span class="hl sym">))</span>
     364<a id="l_276"></a><span class="hl line">  276 </span>  <span class="hl sym">(</span>let <span class="hl sym">((*</span>default-pathname-defaults<span class="hl sym">* (</span>component-parent-pathname component<span class="hl sym">)))</span>
     365<a id="l_277"></a><span class="hl line">  277 </span>    <span class="hl sym">(</span>merge-pathnames <span class="hl sym">(</span>component-relative-pathname component<span class="hl sym">))))</span>
     366<a id="l_278"></a><span class="hl line">  278 </span>
     367<a id="l_279"></a><span class="hl line">  279 </span><span class="hl sym">(</span>defgeneric component-property <span class="hl sym">(</span>component property<span class="hl sym">))</span>
     368<a id="l_280"></a><span class="hl line">  280 </span>
     369<a id="l_281"></a><span class="hl line">  281 </span><span class="hl sym">(</span>defmethod component-property <span class="hl sym">((</span>c component<span class="hl sym">)</span> property<span class="hl sym">)</span>
     370<a id="l_282"></a><span class="hl line">  282 </span>  <span class="hl sym">(</span><span class="hl kwa">cdr</span> <span class="hl sym">(</span><span class="hl kwa">assoc</span> property <span class="hl sym">(</span>slot-value c <span class="hl sym">'</span>properties<span class="hl sym">) :</span>test #<span class="hl sym">'</span><span class="hl kwa">equal</span><span class="hl sym">)))</span>
     371<a id="l_283"></a><span class="hl line">  283 </span>
     372<a id="l_284"></a><span class="hl line">  284 </span><span class="hl sym">(</span>defgeneric <span class="hl sym">(</span>setf component-property<span class="hl sym">) (</span>new-value component property<span class="hl sym">))</span>
     373<a id="l_285"></a><span class="hl line">  285 </span>
     374<a id="l_286"></a><span class="hl line">  286 </span><span class="hl sym">(</span>defmethod <span class="hl sym">(</span>setf component-property<span class="hl sym">) (</span>new-value <span class="hl sym">(</span>c component<span class="hl sym">)</span> property<span class="hl sym">)</span>
     375<a id="l_287"></a><span class="hl line">  287 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>a <span class="hl sym">(</span><span class="hl kwa">assoc</span> property <span class="hl sym">(</span>slot-value c <span class="hl sym">'</span>properties<span class="hl sym">) :</span>test #<span class="hl sym">'</span><span class="hl kwa">equal</span><span class="hl sym">)))</span>
     376<a id="l_288"></a><span class="hl line">  288 </span>    <span class="hl sym">(</span><span class="hl kwa">if</span> a
     377<a id="l_289"></a><span class="hl line">  289 </span>        <span class="hl sym">(</span>setf <span class="hl sym">(</span><span class="hl kwa">cdr</span> a<span class="hl sym">)</span> new-value<span class="hl sym">)</span>
     378<a id="l_290"></a><span class="hl line">  290 </span>        <span class="hl sym">(</span>setf <span class="hl sym">(</span>slot-value c <span class="hl sym">'</span>properties<span class="hl sym">)</span>
     379<a id="l_291"></a><span class="hl line">  291 </span>              <span class="hl sym">(</span>acons property new-value <span class="hl sym">(</span>slot-value c <span class="hl sym">'</span>properties<span class="hl sym">))))))</span>
     380<a id="l_292"></a><span class="hl line">  292 </span>
     381<a id="l_293"></a><span class="hl line">  293 </span><span class="hl sym">(</span>defclass system <span class="hl sym">(</span>module<span class="hl sym">)</span>
     382<a id="l_294"></a><span class="hl line">  294 </span>  <span class="hl sym">((</span>description <span class="hl sym">:</span>accessor system-description <span class="hl sym">:</span>initarg <span class="hl sym">:</span>description<span class="hl sym">)</span>
     383<a id="l_295"></a><span class="hl line">  295 </span>   <span class="hl sym">(</span>long-description
     384<a id="l_296"></a><span class="hl line">  296 </span>    <span class="hl sym">:</span>accessor system-long-description <span class="hl sym">:</span>initarg <span class="hl sym">:</span>long-description<span class="hl sym">)</span>
     385<a id="l_297"></a><span class="hl line">  297 </span>   <span class="hl sym">(</span>author <span class="hl sym">:</span>accessor system-author <span class="hl sym">:</span>initarg <span class="hl sym">:</span>author<span class="hl sym">)</span>
     386<a id="l_298"></a><span class="hl line">  298 </span>   <span class="hl sym">(</span>maintainer <span class="hl sym">:</span>accessor system-maintainer <span class="hl sym">:</span>initarg <span class="hl sym">:</span>maintainer<span class="hl sym">)</span>
     387<a id="l_299"></a><span class="hl line">  299 </span>   <span class="hl sym">(</span>licence <span class="hl sym">:</span>accessor system-licence <span class="hl sym">:</span>initarg <span class="hl sym">:</span>licence
     388<a id="l_300"></a><span class="hl line">  300 </span>            <span class="hl sym">:</span>accessor system-license <span class="hl sym">:</span>initarg <span class="hl sym">:</span>license<span class="hl sym">)))</span>
     389<a id="l_301"></a><span class="hl line">  301 </span>
     390<a id="l_302"></a><span class="hl line">  302 </span><span class="hl slc">;;; version-satisfies</span>
     391<a id="l_303"></a><span class="hl line">  303 </span>
     392<a id="l_304"></a><span class="hl line">  304 </span><span class="hl slc">;;; with apologies to christophe rhodes ...</span>
     393<a id="l_305"></a><span class="hl line">  305 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> split <span class="hl sym">(</span>string <span class="hl sym">&amp;</span>optional <span class="hl kwa">max</span> <span class="hl sym">(</span>ws <span class="hl sym">'(</span>#\Space #\Tab<span class="hl sym">)))</span>
     394<a id="l_306"></a><span class="hl line">  306 </span>  <span class="hl sym">(</span>flet <span class="hl sym">((</span>is-ws <span class="hl sym">(</span>char<span class="hl sym">) (</span>find char ws<span class="hl sym">)))</span>
     395<a id="l_307"></a><span class="hl line">  307 </span>    <span class="hl sym">(</span>nreverse
     396<a id="l_308"></a><span class="hl line">  308 </span>     <span class="hl sym">(</span>let <span class="hl sym">((</span><span class="hl kwa">list</span> nil<span class="hl sym">) (</span>start <span class="hl num">0</span><span class="hl sym">) (</span>words <span class="hl num">0</span><span class="hl sym">)</span> end<span class="hl sym">)</span>
     397<a id="l_309"></a><span class="hl line">  309 </span>       <span class="hl sym">(</span>loop
     398<a id="l_310"></a><span class="hl line">  310 </span>         <span class="hl sym">(</span>when <span class="hl sym">(</span><span class="hl kwa">and max</span> <span class="hl sym">(&gt;=</span> words <span class="hl sym">(</span><span class="hl num">1</span>- <span class="hl kwa">max</span><span class="hl sym">)))</span>
     399<a id="l_311"></a><span class="hl line">  311 </span>           <span class="hl sym">(</span>return <span class="hl sym">(</span><span class="hl kwa">cons</span> <span class="hl sym">(</span>subseq string start<span class="hl sym">)</span> <span class="hl kwa">list</span><span class="hl sym">)))</span>
     400<a id="l_312"></a><span class="hl line">  312 </span>         <span class="hl sym">(</span>setf end <span class="hl sym">(</span>position-<span class="hl kwa">if</span> #<span class="hl sym">'</span>is-ws string <span class="hl sym">:</span>start start<span class="hl sym">))</span>
     401<a id="l_313"></a><span class="hl line">  313 </span>         <span class="hl sym">(</span>push <span class="hl sym">(</span>subseq string start end<span class="hl sym">)</span> <span class="hl kwa">list</span><span class="hl sym">)</span>
     402<a id="l_314"></a><span class="hl line">  314 </span>         <span class="hl sym">(</span>incf words<span class="hl sym">)</span>
     403<a id="l_315"></a><span class="hl line">  315 </span>         <span class="hl sym">(</span>unless end <span class="hl sym">(</span>return <span class="hl kwa">list</span><span class="hl sym">))</span>
     404<a id="l_316"></a><span class="hl line">  316 </span>         <span class="hl sym">(</span>setf start <span class="hl sym">(</span><span class="hl num">1</span><span class="hl sym">+</span> end<span class="hl sym">)))))))</span>
     405<a id="l_317"></a><span class="hl line">  317 </span>
     406<a id="l_318"></a><span class="hl line">  318 </span><span class="hl sym">(</span>defgeneric version-satisfies <span class="hl sym">(</span>component version<span class="hl sym">))</span>
     407<a id="l_319"></a><span class="hl line">  319 </span>
     408<a id="l_320"></a><span class="hl line">  320 </span><span class="hl sym">(</span>defmethod version-satisfies <span class="hl sym">((</span>c component<span class="hl sym">)</span> version<span class="hl sym">)</span>
     409<a id="l_321"></a><span class="hl line">  321 </span>  <span class="hl sym">(</span>unless <span class="hl sym">(</span><span class="hl kwa">and</span> version <span class="hl sym">(</span>slot-<span class="hl kwa">boundp</span> c <span class="hl sym">'</span>version<span class="hl sym">))</span>
     410<a id="l_322"></a><span class="hl line">  322 </span>    <span class="hl sym">(</span>return-from version-satisfies t<span class="hl sym">))</span>
     411<a id="l_323"></a><span class="hl line">  323 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>x <span class="hl sym">(</span><span class="hl kwa">mapcar</span> #<span class="hl sym">'</span>parse-integer
     412<a id="l_324"></a><span class="hl line">  324 </span>                   <span class="hl sym">(</span>split <span class="hl sym">(</span>component-version c<span class="hl sym">)</span> nil <span class="hl sym">'(</span>#\.<span class="hl sym">))))</span>
     413<a id="l_325"></a><span class="hl line">  325 </span>        <span class="hl sym">(</span>y <span class="hl sym">(</span><span class="hl kwa">mapcar</span> #<span class="hl sym">'</span>parse-integer
     414<a id="l_326"></a><span class="hl line">  326 </span>                   <span class="hl sym">(</span>split version nil <span class="hl sym">'(</span>#\.<span class="hl sym">)))))</span>
     415<a id="l_327"></a><span class="hl line">  327 </span>    <span class="hl sym">(</span>labels <span class="hl sym">((</span>bigger <span class="hl sym">(</span>x y<span class="hl sym">)</span>
     416<a id="l_328"></a><span class="hl line">  328 </span>               <span class="hl sym">(</span><span class="hl kwa">cond</span> <span class="hl sym">((</span><span class="hl kwa">not</span> y<span class="hl sym">)</span> t<span class="hl sym">)</span>
     417<a id="l_329"></a><span class="hl line">  329 </span>                     <span class="hl sym">((</span><span class="hl kwa">not</span> x<span class="hl sym">)</span> nil<span class="hl sym">)</span>
     418<a id="l_330"></a><span class="hl line">  330 </span>                     <span class="hl sym">((&gt; (</span><span class="hl kwa">car</span> x<span class="hl sym">) (</span><span class="hl kwa">car</span> y<span class="hl sym">))</span> t<span class="hl sym">)</span>
     419<a id="l_331"></a><span class="hl line">  331 </span>                     <span class="hl sym">((= (</span><span class="hl kwa">car</span> x<span class="hl sym">) (</span><span class="hl kwa">car</span> y<span class="hl sym">))</span>
     420<a id="l_332"></a><span class="hl line">  332 </span>                      <span class="hl sym">(</span>bigger <span class="hl sym">(</span><span class="hl kwa">cdr</span> x<span class="hl sym">) (</span><span class="hl kwa">cdr</span> y<span class="hl sym">))))))</span>
     421<a id="l_333"></a><span class="hl line">  333 </span>      <span class="hl sym">(</span><span class="hl kwa">and</span> <span class="hl sym">(= (</span><span class="hl kwa">car</span> x<span class="hl sym">) (</span><span class="hl kwa">car</span> y<span class="hl sym">))</span>
     422<a id="l_334"></a><span class="hl line">  334 </span>           <span class="hl sym">(</span><span class="hl kwa">or</span> <span class="hl sym">(</span><span class="hl kwa">not</span> <span class="hl sym">(</span><span class="hl kwa">cdr</span> y<span class="hl sym">)) (</span>bigger <span class="hl sym">(</span><span class="hl kwa">cdr</span> x<span class="hl sym">) (</span><span class="hl kwa">cdr</span> y<span class="hl sym">)))))))</span>
     423<a id="l_335"></a><span class="hl line">  335 </span>
     424<a id="l_336"></a><span class="hl line">  336 </span><span class="hl slc">;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;</span>
     425<a id="l_337"></a><span class="hl line">  337 </span><span class="hl slc">;;; finding systems</span>
     426<a id="l_338"></a><span class="hl line">  338 </span>
     427<a id="l_339"></a><span class="hl line">  339 </span><span class="hl sym">(</span>defvar <span class="hl sym">*</span>defined-systems<span class="hl sym">* (</span>make-hash-table <span class="hl sym">:</span>test <span class="hl sym">'</span><span class="hl kwa">equal</span><span class="hl sym">))</span>
     428<a id="l_340"></a><span class="hl line">  340 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> coerce-name <span class="hl sym">(</span>name<span class="hl sym">)</span>
     429<a id="l_341"></a><span class="hl line">  341 </span>  <span class="hl sym">(</span>typecase name
     430<a id="l_342"></a><span class="hl line">  342 </span>    <span class="hl sym">(</span>component <span class="hl sym">(</span>component-name name<span class="hl sym">))</span>
     431<a id="l_343"></a><span class="hl line">  343 </span>    <span class="hl sym">(</span>symbol <span class="hl sym">(</span>string-downcase <span class="hl sym">(</span>symbol-name name<span class="hl sym">)))</span>
     432<a id="l_344"></a><span class="hl line">  344 </span>    <span class="hl sym">(</span>string name<span class="hl sym">)</span>
     433<a id="l_345"></a><span class="hl line">  345 </span>    <span class="hl sym">(</span>t <span class="hl sym">(</span>sysdef-error <span class="hl str">&quot;~&#64;&lt;invalid component designator ~A~&#64;:&gt;&quot;</span> name<span class="hl sym">))))</span>
     434<a id="l_346"></a><span class="hl line">  346 </span>
     435<a id="l_347"></a><span class="hl line">  347 </span><span class="hl slc">;;; for the sake of keeping things reasonably neat, we adopt a</span>
     436<a id="l_348"></a><span class="hl line">  348 </span><span class="hl slc">;;; convention that functions in this list are prefixed SYSDEF-</span>
     437<a id="l_349"></a><span class="hl line">  349 </span>
     438<a id="l_350"></a><span class="hl line">  350 </span><span class="hl sym">(</span>defvar <span class="hl sym">*</span>system-definition-search-functions<span class="hl sym">*</span>
     439<a id="l_351"></a><span class="hl line">  351 </span>  <span class="hl sym">'(</span>sysdef-central-registry-search<span class="hl sym">))</span>
     440<a id="l_352"></a><span class="hl line">  352 </span>
     441<a id="l_353"></a><span class="hl line">  353 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> system-definition-pathname <span class="hl sym">(</span>system<span class="hl sym">)</span>
     442<a id="l_354"></a><span class="hl line">  354 </span>  <span class="hl sym">(</span>some <span class="hl sym">(</span><span class="hl kwa">lambda</span> <span class="hl sym">(</span>x<span class="hl sym">) (</span>funcall x system<span class="hl sym">))</span>
     443<a id="l_355"></a><span class="hl line">  355 </span>        <span class="hl sym">*</span>system-definition-search-functions<span class="hl sym">*))</span>
     444<a id="l_356"></a><span class="hl line">  356 </span>
     445<a id="l_357"></a><span class="hl line">  357 </span><span class="hl sym">(</span>defvar <span class="hl sym">*</span>central-registry<span class="hl sym">*</span>
     446<a id="l_358"></a><span class="hl line">  358 </span>  <span class="hl sym">'(*</span>default-pathname-defaults<span class="hl sym">*</span>
     447<a id="l_359"></a><span class="hl line">  359 </span>    #<span class="hl sym">+</span>nil <span class="hl str">&quot;/home/dan/src/sourceforge/cclan/asdf/systems/&quot;</span>
     448<a id="l_360"></a><span class="hl line">  360 </span>    #<span class="hl sym">+</span>nil <span class="hl str">&quot;telent:asdf;systems;&quot;</span><span class="hl sym">))</span>
     449<a id="l_361"></a><span class="hl line">  361 </span>
     450<a id="l_362"></a><span class="hl line">  362 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> sysdef-central-registry-search <span class="hl sym">(</span>system<span class="hl sym">)</span>
     451<a id="l_363"></a><span class="hl line">  363 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>name <span class="hl sym">(</span>coerce-name system<span class="hl sym">)))</span>
     452<a id="l_364"></a><span class="hl line">  364 </span>    <span class="hl sym">(</span>block nil
     453<a id="l_365"></a><span class="hl line">  365 </span>      <span class="hl sym">(</span>dolist <span class="hl sym">(</span>dir <span class="hl sym">*</span>central-registry<span class="hl sym">*)</span>
     454<a id="l_366"></a><span class="hl line">  366 </span>        <span class="hl sym">(</span>let<span class="hl sym">* ((</span>defaults <span class="hl sym">(</span><span class="hl kwa">eval</span> dir<span class="hl sym">))</span>
     455<a id="l_367"></a><span class="hl line">  367 </span>               <span class="hl sym">(</span>file <span class="hl sym">(</span><span class="hl kwa">and</span> defaults
     456<a id="l_368"></a><span class="hl line">  368 </span>                          <span class="hl sym">(</span>make-pathname
     457<a id="l_369"></a><span class="hl line">  369 </span>                           <span class="hl sym">:</span>defaults defaults <span class="hl sym">:</span>version <span class="hl sym">:</span>newest
     458<a id="l_370"></a><span class="hl line">  370 </span>                           <span class="hl sym">:</span>name name <span class="hl sym">:</span><span class="hl kwa">type</span> <span class="hl str">&quot;asd&quot;</span> <span class="hl sym">:</span>case <span class="hl sym">:</span>local<span class="hl sym">))))</span>
     459<a id="l_371"></a><span class="hl line">  371 </span>          <span class="hl sym">(</span><span class="hl kwa">if</span> <span class="hl sym">(</span><span class="hl kwa">and</span> file <span class="hl sym">(</span>probe-file file<span class="hl sym">))</span>
     460<a id="l_372"></a><span class="hl line">  372 </span>              <span class="hl sym">(</span>return file<span class="hl sym">)))))))</span>
     461<a id="l_373"></a><span class="hl line">  373 </span>
     462<a id="l_374"></a><span class="hl line">  374 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> make-temporary-package <span class="hl sym">()</span>
     463<a id="l_375"></a><span class="hl line">  375 </span>  <span class="hl sym">(</span>flet <span class="hl sym">((</span>try <span class="hl sym">(</span>counter<span class="hl sym">)</span>
     464<a id="l_376"></a><span class="hl line">  376 </span>           <span class="hl sym">(</span>ignore-errors
     465<a id="l_377"></a><span class="hl line">  377 </span>             <span class="hl sym">(</span>make-package <span class="hl sym">(</span>format nil <span class="hl str">&quot;ASDF~D&quot;</span> counter<span class="hl sym">)</span>
     466<a id="l_378"></a><span class="hl line">  378 </span>                           <span class="hl sym">:</span>use <span class="hl sym">'(:</span>cl <span class="hl sym">:</span>asdf<span class="hl sym">)))))</span>
     467<a id="l_379"></a><span class="hl line">  379 </span>    <span class="hl sym">(</span>do<span class="hl sym">* ((</span>counter <span class="hl num">0</span> <span class="hl sym">(+</span> counter <span class="hl num">1</span><span class="hl sym">))</span>
     468<a id="l_380"></a><span class="hl line">  380 </span>          <span class="hl sym">(</span>package <span class="hl sym">(</span>try counter<span class="hl sym">) (</span>try counter<span class="hl sym">)))</span>
     469<a id="l_381"></a><span class="hl line">  381 </span>         <span class="hl sym">(</span>package package<span class="hl sym">))))</span>
     470<a id="l_382"></a><span class="hl line">  382 </span>
     471<a id="l_383"></a><span class="hl line">  383 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> find-system <span class="hl sym">(</span>name <span class="hl sym">&amp;</span>optional <span class="hl sym">(</span>error-p t<span class="hl sym">))</span>
     472<a id="l_384"></a><span class="hl line">  384 </span>  <span class="hl sym">(</span>let<span class="hl sym">* ((</span>name <span class="hl sym">(</span>coerce-name name<span class="hl sym">))</span>
     473<a id="l_385"></a><span class="hl line">  385 </span>         <span class="hl sym">(</span>in-memory <span class="hl sym">(</span>gethash name <span class="hl sym">*</span>defined-systems<span class="hl sym">*))</span>
     474<a id="l_386"></a><span class="hl line">  386 </span>         <span class="hl sym">(</span>on-disk <span class="hl sym">(</span>system-definition-pathname name<span class="hl sym">)))</span>
     475<a id="l_387"></a><span class="hl line">  387 </span>    <span class="hl sym">(</span>when <span class="hl sym">(</span><span class="hl kwa">and</span> on-disk
     476<a id="l_388"></a><span class="hl line">  388 </span>               <span class="hl sym">(</span><span class="hl kwa">or</span> <span class="hl sym">(</span><span class="hl kwa">not</span> in-memory<span class="hl sym">)</span>
     477<a id="l_389"></a><span class="hl line">  389 </span>                   <span class="hl sym">(&lt; (</span><span class="hl kwa">car</span> in-memory<span class="hl sym">) (</span>file-write-date on-disk<span class="hl sym">))))</span>
     478<a id="l_390"></a><span class="hl line">  390 </span>      <span class="hl sym">(</span>let <span class="hl sym">((</span>package <span class="hl sym">(</span>make-temporary-package<span class="hl sym">)))</span>
     479<a id="l_391"></a><span class="hl line">  391 </span>        <span class="hl sym">(</span>unwind-protect
     480<a id="l_392"></a><span class="hl line">  392 </span>             <span class="hl sym">(</span>let <span class="hl sym">((*</span>package<span class="hl sym">*</span> package<span class="hl sym">))</span>
     481<a id="l_393"></a><span class="hl line">  393 </span>               <span class="hl sym">(</span>format
     482<a id="l_394"></a><span class="hl line">  394 </span>                <span class="hl sym">*</span>verbose-out<span class="hl sym">*</span>
     483<a id="l_395"></a><span class="hl line">  395 </span>                <span class="hl str">&quot;~&amp;~&#64;&lt;; ~&#64;;loading system definition from ~A into ~A~&#64;:&gt;~%&quot;</span>
     484<a id="l_396"></a><span class="hl line">  396 </span>                <span class="hl slc">;; FIXME: This wants to be (ENOUGH-NAMESTRING</span>
     485<a id="l_397"></a><span class="hl line">  397 </span>                <span class="hl slc">;; ON-DISK), but CMUCL barfs on that.</span>
     486<a id="l_398"></a><span class="hl line">  398 </span>                on-disk
     487<a id="l_399"></a><span class="hl line">  399 </span>                <span class="hl sym">*</span>package<span class="hl sym">*)</span>
     488<a id="l_400"></a><span class="hl line">  400 </span>               <span class="hl sym">(</span><span class="hl kwa">load</span> on-disk<span class="hl sym">))</span>
     489<a id="l_401"></a><span class="hl line">  401 </span>          <span class="hl sym">(</span>delete-package package<span class="hl sym">))))</span>
     490<a id="l_402"></a><span class="hl line">  402 </span>    <span class="hl sym">(</span>let <span class="hl sym">((</span>in-memory <span class="hl sym">(</span>gethash name <span class="hl sym">*</span>defined-systems<span class="hl sym">*)))</span>
     491<a id="l_403"></a><span class="hl line">  403 </span>      <span class="hl sym">(</span><span class="hl kwa">if</span> in-memory
     492<a id="l_404"></a><span class="hl line">  404 </span>          <span class="hl sym">(</span><span class="hl kwa">progn</span> <span class="hl sym">(</span><span class="hl kwa">if</span> on-disk <span class="hl sym">(</span>setf <span class="hl sym">(</span><span class="hl kwa">car</span> in-memory<span class="hl sym">) (</span>file-write-date on-disk<span class="hl sym">)))</span>
     493<a id="l_405"></a><span class="hl line">  405 </span>                 <span class="hl sym">(</span><span class="hl kwa">cdr</span> in-memory<span class="hl sym">))</span>
     494<a id="l_406"></a><span class="hl line">  406 </span>          <span class="hl sym">(</span><span class="hl kwa">if</span> error-p <span class="hl sym">(</span>error <span class="hl sym">'</span>missing-component <span class="hl sym">:</span>requires name<span class="hl sym">))))))</span>
     495<a id="l_407"></a><span class="hl line">  407 </span>
     496<a id="l_408"></a><span class="hl line">  408 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> register-system <span class="hl sym">(</span>name system<span class="hl sym">)</span>
     497<a id="l_409"></a><span class="hl line">  409 </span>  <span class="hl sym">(</span>format <span class="hl sym">*</span>verbose-out<span class="hl sym">*</span> <span class="hl str">&quot;~&amp;~&#64;&lt;; ~&#64;;registering ~A as ~A~&#64;:&gt;~%&quot;</span> system name<span class="hl sym">)</span>
     498<a id="l_410"></a><span class="hl line">  410 </span>  <span class="hl sym">(</span>setf <span class="hl sym">(</span>gethash <span class="hl sym">(</span>coerce-name  name<span class="hl sym">) *</span>defined-systems<span class="hl sym">*)</span>
     499<a id="l_411"></a><span class="hl line">  411 </span>        <span class="hl sym">(</span><span class="hl kwa">cons</span> <span class="hl sym">(</span>get-universal-time<span class="hl sym">)</span> system<span class="hl sym">)))</span>
     500<a id="l_412"></a><span class="hl line">  412 </span>
     501<a id="l_413"></a><span class="hl line">  413 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> system-registered-p <span class="hl sym">(</span>name<span class="hl sym">)</span>
     502<a id="l_414"></a><span class="hl line">  414 </span>  <span class="hl sym">(</span>gethash <span class="hl sym">(</span>coerce-name name<span class="hl sym">) *</span>defined-systems<span class="hl sym">*))</span>
     503<a id="l_415"></a><span class="hl line">  415 </span>
     504<a id="l_416"></a><span class="hl line">  416 </span><span class="hl slc">;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;</span>
     505<a id="l_417"></a><span class="hl line">  417 </span><span class="hl slc">;;; finding components</span>
     506<a id="l_418"></a><span class="hl line">  418 </span>
     507<a id="l_419"></a><span class="hl line">  419 </span><span class="hl sym">(</span>defgeneric find-component <span class="hl sym">(</span>module name <span class="hl sym">&amp;</span>optional version<span class="hl sym">)</span>
     508<a id="l_420"></a><span class="hl line">  420 </span>  <span class="hl sym">(:</span>documentation <span class="hl str">&quot;Finds the component with name NAME present in the</span>
     509<a id="l_421"></a><span class="hl line">  421 </span><span class="hl str">MODULE module; if MODULE is nil, then the component is assumed to be a</span>
     510<a id="l_422"></a><span class="hl line">  422 </span><span class="hl str">system.&quot;</span><span class="hl sym">))</span>
     511<a id="l_423"></a><span class="hl line">  423 </span>
     512<a id="l_424"></a><span class="hl line">  424 </span><span class="hl sym">(</span>defmethod find-component <span class="hl sym">((</span>module module<span class="hl sym">)</span> name <span class="hl sym">&amp;</span>optional version<span class="hl sym">)</span>
     513<a id="l_425"></a><span class="hl line">  425 </span>  <span class="hl sym">(</span><span class="hl kwa">if</span> <span class="hl sym">(</span>slot-<span class="hl kwa">boundp</span> module <span class="hl sym">'</span>components<span class="hl sym">)</span>
     514<a id="l_426"></a><span class="hl line">  426 </span>      <span class="hl sym">(</span>let <span class="hl sym">((</span>m <span class="hl sym">(</span>find name <span class="hl sym">(</span>module-components module<span class="hl sym">)</span>
     515<a id="l_427"></a><span class="hl line">  427 </span>                     <span class="hl sym">:</span>test #<span class="hl sym">'</span><span class="hl kwa">equal</span> <span class="hl sym">:</span>key #<span class="hl sym">'</span>component-name<span class="hl sym">)))</span>
     516<a id="l_428"></a><span class="hl line">  428 </span>        <span class="hl sym">(</span><span class="hl kwa">if</span> <span class="hl sym">(</span><span class="hl kwa">and</span> m <span class="hl sym">(</span>version-satisfies m version<span class="hl sym">))</span> m<span class="hl sym">))))</span>
     517<a id="l_429"></a><span class="hl line">  429 </span>
     518<a id="l_430"></a><span class="hl line">  430 </span>
     519<a id="l_431"></a><span class="hl line">  431 </span><span class="hl slc">;;; a component with no parent is a system</span>
     520<a id="l_432"></a><span class="hl line">  432 </span><span class="hl sym">(</span>defmethod find-component <span class="hl sym">((</span>module <span class="hl sym">(</span>eql nil<span class="hl sym">))</span> name <span class="hl sym">&amp;</span>optional version<span class="hl sym">)</span>
     521<a id="l_433"></a><span class="hl line">  433 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>m <span class="hl sym">(</span>find-system name nil<span class="hl sym">)))</span>
     522<a id="l_434"></a><span class="hl line">  434 </span>    <span class="hl sym">(</span><span class="hl kwa">if</span> <span class="hl sym">(</span><span class="hl kwa">and</span> m <span class="hl sym">(</span>version-satisfies m version<span class="hl sym">))</span> m<span class="hl sym">)))</span>
     523<a id="l_435"></a><span class="hl line">  435 </span>
     524<a id="l_436"></a><span class="hl line">  436 </span><span class="hl slc">;;; component subclasses</span>
     525<a id="l_437"></a><span class="hl line">  437 </span>
     526<a id="l_438"></a><span class="hl line">  438 </span><span class="hl sym">(</span>defclass source-file <span class="hl sym">(</span>component<span class="hl sym">) ())</span>
     527<a id="l_439"></a><span class="hl line">  439 </span>
     528<a id="l_440"></a><span class="hl line">  440 </span><span class="hl sym">(</span>defclass cl-source-file <span class="hl sym">(</span>source-file<span class="hl sym">) ())</span>
     529<a id="l_441"></a><span class="hl line">  441 </span><span class="hl sym">(</span>defclass c-source-file <span class="hl sym">(</span>source-file<span class="hl sym">) ())</span>
     530<a id="l_442"></a><span class="hl line">  442 </span><span class="hl sym">(</span>defclass java-source-file <span class="hl sym">(</span>source-file<span class="hl sym">) ())</span>
     531<a id="l_443"></a><span class="hl line">  443 </span><span class="hl sym">(</span>defclass static-file <span class="hl sym">(</span>source-file<span class="hl sym">) ())</span>
     532<a id="l_444"></a><span class="hl line">  444 </span><span class="hl sym">(</span>defclass doc-file <span class="hl sym">(</span>static-file<span class="hl sym">) ())</span>
     533<a id="l_445"></a><span class="hl line">  445 </span><span class="hl sym">(</span>defclass html-file <span class="hl sym">(</span>doc-file<span class="hl sym">) ())</span>
     534<a id="l_446"></a><span class="hl line">  446 </span>
     535<a id="l_447"></a><span class="hl line">  447 </span><span class="hl sym">(</span>defgeneric source-file-<span class="hl kwa">type</span> <span class="hl sym">(</span>component system<span class="hl sym">))</span>
     536<a id="l_448"></a><span class="hl line">  448 </span><span class="hl sym">(</span>defmethod source-file-<span class="hl kwa">type</span> <span class="hl sym">((</span>c cl-source-file<span class="hl sym">) (</span>s module<span class="hl sym">))</span> <span class="hl str">&quot;lisp&quot;</span><span class="hl sym">)</span>
     537<a id="l_449"></a><span class="hl line">  449 </span><span class="hl sym">(</span>defmethod source-file-<span class="hl kwa">type</span> <span class="hl sym">((</span>c c-source-file<span class="hl sym">) (</span>s module<span class="hl sym">))</span> <span class="hl str">&quot;c&quot;</span><span class="hl sym">)</span>
     538<a id="l_450"></a><span class="hl line">  450 </span><span class="hl sym">(</span>defmethod source-file-<span class="hl kwa">type</span> <span class="hl sym">((</span>c java-source-file<span class="hl sym">) (</span>s module<span class="hl sym">))</span> <span class="hl str">&quot;java&quot;</span><span class="hl sym">)</span>
     539<a id="l_451"></a><span class="hl line">  451 </span><span class="hl sym">(</span>defmethod source-file-<span class="hl kwa">type</span> <span class="hl sym">((</span>c html-file<span class="hl sym">) (</span>s module<span class="hl sym">))</span> <span class="hl str">&quot;html&quot;</span><span class="hl sym">)</span>
     540<a id="l_452"></a><span class="hl line">  452 </span><span class="hl sym">(</span>defmethod source-file-<span class="hl kwa">type</span> <span class="hl sym">((</span>c static-file<span class="hl sym">) (</span>s module<span class="hl sym">))</span> nil<span class="hl sym">)</span>
     541<a id="l_453"></a><span class="hl line">  453 </span>
     542<a id="l_454"></a><span class="hl line">  454 </span><span class="hl sym">(</span>defmethod component-relative-pathname <span class="hl sym">((</span>component source-file<span class="hl sym">))</span>
     543<a id="l_455"></a><span class="hl line">  455 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>relative-pathname <span class="hl sym">(</span>slot-value component <span class="hl sym">'</span>relative-pathname<span class="hl sym">)))</span>
     544<a id="l_456"></a><span class="hl line">  456 </span>    <span class="hl sym">(</span><span class="hl kwa">if</span> relative-pathname
     545<a id="l_457"></a><span class="hl line">  457 </span>        <span class="hl sym">(</span>merge-pathnames
     546<a id="l_458"></a><span class="hl line">  458 </span>         relative-pathname
     547<a id="l_459"></a><span class="hl line">  459 </span>         <span class="hl sym">(</span>make-pathname
     548<a id="l_460"></a><span class="hl line">  460 </span>          <span class="hl sym">:</span><span class="hl kwa">type</span> <span class="hl sym">(</span>source-file-<span class="hl kwa">type</span> component <span class="hl sym">(</span>component-system component<span class="hl sym">))))</span>
     549<a id="l_461"></a><span class="hl line">  461 </span>        <span class="hl sym">(</span>let<span class="hl sym">* ((*</span>default-pathname-defaults<span class="hl sym">*</span>
     550<a id="l_462"></a><span class="hl line">  462 </span>                <span class="hl sym">(</span>component-parent-pathname component<span class="hl sym">))</span>
     551<a id="l_463"></a><span class="hl line">  463 </span>               <span class="hl sym">(</span>name-<span class="hl kwa">type</span>
     552<a id="l_464"></a><span class="hl line">  464 </span>                <span class="hl sym">(</span>make-pathname
     553<a id="l_465"></a><span class="hl line">  465 </span>                 <span class="hl sym">:</span>name <span class="hl sym">(</span>component-name component<span class="hl sym">)</span>
     554<a id="l_466"></a><span class="hl line">  466 </span>                 <span class="hl sym">:</span><span class="hl kwa">type</span> <span class="hl sym">(</span>source-file-<span class="hl kwa">type</span> component
     555<a id="l_467"></a><span class="hl line">  467 </span>                                         <span class="hl sym">(</span>component-system component<span class="hl sym">)))))</span>
     556<a id="l_468"></a><span class="hl line">  468 </span>          name-<span class="hl kwa">type</span><span class="hl sym">))))</span>
     557<a id="l_469"></a><span class="hl line">  469 </span>
     558<a id="l_470"></a><span class="hl line">  470 </span><span class="hl slc">;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;</span>
     559<a id="l_471"></a><span class="hl line">  471 </span><span class="hl slc">;;; operations</span>
     560<a id="l_472"></a><span class="hl line">  472 </span>
     561<a id="l_473"></a><span class="hl line">  473 </span><span class="hl slc">;;; one of these is instantiated whenever (operate ) is called</span>
     562<a id="l_474"></a><span class="hl line">  474 </span>
     563<a id="l_475"></a><span class="hl line">  475 </span><span class="hl sym">(</span>defclass operation <span class="hl sym">()</span>
     564<a id="l_476"></a><span class="hl line">  476 </span>  <span class="hl sym">((</span>forced <span class="hl sym">:</span>initform nil <span class="hl sym">:</span>initarg <span class="hl sym">:</span>force <span class="hl sym">:</span>accessor operation-forced<span class="hl sym">)</span>
     565<a id="l_477"></a><span class="hl line">  477 </span>   <span class="hl sym">(</span>original-initargs <span class="hl sym">:</span>initform nil <span class="hl sym">:</span>initarg <span class="hl sym">:</span>original-initargs
     566<a id="l_478"></a><span class="hl line">  478 </span>                      <span class="hl sym">:</span>accessor operation-original-initargs<span class="hl sym">)</span>
     567<a id="l_479"></a><span class="hl line">  479 </span>   <span class="hl sym">(</span>visited-nodes <span class="hl sym">:</span>initform nil <span class="hl sym">:</span>accessor operation-visited-nodes<span class="hl sym">)</span>
     568<a id="l_480"></a><span class="hl line">  480 </span>   <span class="hl sym">(</span>visiting-nodes <span class="hl sym">:</span>initform nil <span class="hl sym">:</span>accessor operation-visiting-nodes<span class="hl sym">)</span>
     569<a id="l_481"></a><span class="hl line">  481 </span>   <span class="hl sym">(</span>parent <span class="hl sym">:</span>initform nil <span class="hl sym">:</span>initarg <span class="hl sym">:</span>parent <span class="hl sym">:</span>accessor operation-parent<span class="hl sym">)))</span>
     570<a id="l_482"></a><span class="hl line">  482 </span>
     571<a id="l_483"></a><span class="hl line">  483 </span><span class="hl sym">(</span>defmethod <span class="hl kwa">print</span>-object <span class="hl sym">((</span>o operation<span class="hl sym">)</span> stream<span class="hl sym">)</span>
     572<a id="l_484"></a><span class="hl line">  484 </span>  <span class="hl sym">(</span><span class="hl kwa">print</span>-unreadable-object <span class="hl sym">(</span>o stream <span class="hl sym">:</span><span class="hl kwa">type</span> t <span class="hl sym">:</span>identity t<span class="hl sym">)</span>
     573<a id="l_485"></a><span class="hl line">  485 </span>    <span class="hl sym">(</span>ignore-errors
     574<a id="l_486"></a><span class="hl line">  486 </span>      <span class="hl sym">(</span><span class="hl kwa">prin1</span> <span class="hl sym">(</span>operation-original-initargs o<span class="hl sym">)</span> stream<span class="hl sym">))))</span>
     575<a id="l_487"></a><span class="hl line">  487 </span>
     576<a id="l_488"></a><span class="hl line">  488 </span><span class="hl sym">(</span>defmethod shared-initialize <span class="hl sym">:</span>after <span class="hl sym">((</span>operation operation<span class="hl sym">)</span> slot-names
     577<a id="l_489"></a><span class="hl line">  489 </span>                                     <span class="hl sym">&amp;</span>key force
     578<a id="l_490"></a><span class="hl line">  490 </span>                                     <span class="hl sym">&amp;</span>allow-other-keys<span class="hl sym">)</span>
     579<a id="l_491"></a><span class="hl line">  491 </span>  <span class="hl sym">(</span>declare <span class="hl sym">(</span>ignore slot-names force<span class="hl sym">))</span>
     580<a id="l_492"></a><span class="hl line">  492 </span>  <span class="hl slc">;; empty method to disable initarg validity checking</span>
     581<a id="l_493"></a><span class="hl line">  493 </span>  <span class="hl sym">)</span>
     582<a id="l_494"></a><span class="hl line">  494 </span>
     583<a id="l_495"></a><span class="hl line">  495 </span><span class="hl sym">(</span>defgeneric perform <span class="hl sym">(</span>operation component<span class="hl sym">))</span>
     584<a id="l_496"></a><span class="hl line">  496 </span><span class="hl sym">(</span>defgeneric operation-done-p <span class="hl sym">(</span>operation component<span class="hl sym">))</span>
     585<a id="l_497"></a><span class="hl line">  497 </span><span class="hl sym">(</span>defgeneric explain <span class="hl sym">(</span>operation component<span class="hl sym">))</span>
     586<a id="l_498"></a><span class="hl line">  498 </span><span class="hl sym">(</span>defgeneric output-files <span class="hl sym">(</span>operation component<span class="hl sym">))</span>
     587<a id="l_499"></a><span class="hl line">  499 </span><span class="hl sym">(</span>defgeneric input-files <span class="hl sym">(</span>operation component<span class="hl sym">))</span>
     588<a id="l_500"></a><span class="hl line">  500 </span>
     589<a id="l_501"></a><span class="hl line">  501 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> node-for <span class="hl sym">(</span>o c<span class="hl sym">)</span>
     590<a id="l_502"></a><span class="hl line">  502 </span>  <span class="hl sym">(</span><span class="hl kwa">cons</span> <span class="hl sym">(</span>class-name <span class="hl sym">(</span>class-of o<span class="hl sym">))</span> c<span class="hl sym">))</span>
     591<a id="l_503"></a><span class="hl line">  503 </span>
     592<a id="l_504"></a><span class="hl line">  504 </span><span class="hl sym">(</span>defgeneric operation-ancestor <span class="hl sym">(</span>operation<span class="hl sym">)</span>
     593<a id="l_505"></a><span class="hl line">  505 </span>  <span class="hl sym">(:</span>documentation
     594<a id="l_506"></a><span class="hl line">  506 </span>   <span class="hl str">&quot;Recursively chase the operation's parent pointer until we get to</span>
     595<a id="l_507"></a><span class="hl line">  507 </span><span class="hl str">the head of the tree&quot;</span><span class="hl sym">))</span>
     596<a id="l_508"></a><span class="hl line">  508 </span>
     597<a id="l_509"></a><span class="hl line">  509 </span><span class="hl sym">(</span>defmethod operation-ancestor <span class="hl sym">((</span>operation operation<span class="hl sym">))</span>
     598<a id="l_510"></a><span class="hl line">  510 </span>  <span class="hl sym">(</span>aif <span class="hl sym">(</span>operation-parent operation<span class="hl sym">)</span>
     599<a id="l_511"></a><span class="hl line">  511 </span>       <span class="hl sym">(</span>operation-ancestor it<span class="hl sym">)</span>
     600<a id="l_512"></a><span class="hl line">  512 </span>       operation<span class="hl sym">))</span>
     601<a id="l_513"></a><span class="hl line">  513 </span>
     602<a id="l_514"></a><span class="hl line">  514 </span>
     603<a id="l_515"></a><span class="hl line">  515 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> make-sub-operation <span class="hl sym">(</span>c o dep-c dep-o<span class="hl sym">)</span>
     604<a id="l_516"></a><span class="hl line">  516 </span>  <span class="hl sym">(</span>let<span class="hl sym">* ((</span>args <span class="hl sym">(</span>copy-<span class="hl kwa">list</span> <span class="hl sym">(</span>operation-original-initargs o<span class="hl sym">)))</span>
     605<a id="l_517"></a><span class="hl line">  517 </span>         <span class="hl sym">(</span>force-p <span class="hl sym">(</span>getf args <span class="hl sym">:</span>force<span class="hl sym">)))</span>
     606<a id="l_518"></a><span class="hl line">  518 </span>    <span class="hl slc">;; note explicit comparison with T: any other non-NIL force value</span>
     607<a id="l_519"></a><span class="hl line">  519 </span>    <span class="hl slc">;; (e.g. :recursive) will pass through</span>
     608<a id="l_520"></a><span class="hl line">  520 </span>    <span class="hl sym">(</span><span class="hl kwa">cond</span> <span class="hl sym">((</span><span class="hl kwa">and</span> <span class="hl sym">(</span><span class="hl kwa">null</span> <span class="hl sym">(</span>component-parent c<span class="hl sym">))</span>
     609<a id="l_521"></a><span class="hl line">  521 </span>                <span class="hl sym">(</span><span class="hl kwa">null</span> <span class="hl sym">(</span>component-parent dep-c<span class="hl sym">))</span>
     610<a id="l_522"></a><span class="hl line">  522 </span>                <span class="hl sym">(</span><span class="hl kwa">not</span> <span class="hl sym">(</span>eql c dep-c<span class="hl sym">)))</span>
     611<a id="l_523"></a><span class="hl line">  523 </span>           <span class="hl sym">(</span>when <span class="hl sym">(</span>eql force-p t<span class="hl sym">)</span>
     612<a id="l_524"></a><span class="hl line">  524 </span>             <span class="hl sym">(</span>setf <span class="hl sym">(</span>getf args <span class="hl sym">:</span>force<span class="hl sym">)</span> nil<span class="hl sym">))</span>
     613<a id="l_525"></a><span class="hl line">  525 </span>           <span class="hl sym">(</span><span class="hl kwa">apply</span> #<span class="hl sym">'</span>make-instance dep-o
     614<a id="l_526"></a><span class="hl line">  526 </span>                  <span class="hl sym">:</span>parent o
     615<a id="l_527"></a><span class="hl line">  527 </span>                  <span class="hl sym">:</span>original-initargs args args<span class="hl sym">))</span>
     616<a id="l_528"></a><span class="hl line">  528 </span>          <span class="hl sym">((</span>subtypep <span class="hl sym">(</span><span class="hl kwa">type</span>-of o<span class="hl sym">)</span> dep-o<span class="hl sym">)</span>
     617<a id="l_529"></a><span class="hl line">  529 </span>           o<span class="hl sym">)</span>
     618<a id="l_530"></a><span class="hl line">  530 </span>          <span class="hl sym">(</span>t
     619<a id="l_531"></a><span class="hl line">  531 </span>           <span class="hl sym">(</span><span class="hl kwa">apply</span> #<span class="hl sym">'</span>make-instance dep-o
     620<a id="l_532"></a><span class="hl line">  532 </span>                  <span class="hl sym">:</span>parent o <span class="hl sym">:</span>original-initargs args args<span class="hl sym">)))))</span>
     621<a id="l_533"></a><span class="hl line">  533 </span>
     622<a id="l_534"></a><span class="hl line">  534 </span>
     623<a id="l_535"></a><span class="hl line">  535 </span><span class="hl sym">(</span>defgeneric visit-component <span class="hl sym">(</span>operation component data<span class="hl sym">))</span>
     624<a id="l_536"></a><span class="hl line">  536 </span>
     625<a id="l_537"></a><span class="hl line">  537 </span><span class="hl sym">(</span>defmethod visit-component <span class="hl sym">((</span>o operation<span class="hl sym">) (</span>c component<span class="hl sym">)</span> data<span class="hl sym">)</span>
     626<a id="l_538"></a><span class="hl line">  538 </span>  <span class="hl sym">(</span>unless <span class="hl sym">(</span>component-visited-p o c<span class="hl sym">)</span>
     627<a id="l_539"></a><span class="hl line">  539 </span>    <span class="hl sym">(</span>push <span class="hl sym">(</span><span class="hl kwa">cons</span> <span class="hl sym">(</span>node-for o c<span class="hl sym">)</span> data<span class="hl sym">)</span>
     628<a id="l_540"></a><span class="hl line">  540 </span>          <span class="hl sym">(</span>operation-visited-nodes <span class="hl sym">(</span>operation-ancestor o<span class="hl sym">)))))</span>
     629<a id="l_541"></a><span class="hl line">  541 </span>
     630<a id="l_542"></a><span class="hl line">  542 </span><span class="hl sym">(</span>defgeneric component-visited-p <span class="hl sym">(</span>operation component<span class="hl sym">))</span>
     631<a id="l_543"></a><span class="hl line">  543 </span>
     632<a id="l_544"></a><span class="hl line">  544 </span><span class="hl sym">(</span>defmethod component-visited-p <span class="hl sym">((</span>o operation<span class="hl sym">) (</span>c component<span class="hl sym">))</span>
     633<a id="l_545"></a><span class="hl line">  545 </span>  <span class="hl sym">(</span><span class="hl kwa">assoc</span> <span class="hl sym">(</span>node-for o c<span class="hl sym">)</span>
     634<a id="l_546"></a><span class="hl line">  546 </span>         <span class="hl sym">(</span>operation-visited-nodes <span class="hl sym">(</span>operation-ancestor o<span class="hl sym">))</span>
     635<a id="l_547"></a><span class="hl line">  547 </span>         <span class="hl sym">:</span>test <span class="hl sym">'</span><span class="hl kwa">equal</span><span class="hl sym">))</span>
     636<a id="l_548"></a><span class="hl line">  548 </span>
     637<a id="l_549"></a><span class="hl line">  549 </span><span class="hl sym">(</span>defgeneric <span class="hl sym">(</span>setf visiting-component<span class="hl sym">) (</span>new-value operation component<span class="hl sym">))</span>
     638<a id="l_550"></a><span class="hl line">  550 </span>
     639<a id="l_551"></a><span class="hl line">  551 </span><span class="hl sym">(</span>defmethod <span class="hl sym">(</span>setf visiting-component<span class="hl sym">) (</span>new-value operation component<span class="hl sym">)</span>
     640<a id="l_552"></a><span class="hl line">  552 </span>  <span class="hl slc">;; MCL complains about unused lexical variables</span>
     641<a id="l_553"></a><span class="hl line">  553 </span>  <span class="hl sym">(</span>declare <span class="hl sym">(</span>ignorable new-value operation component<span class="hl sym">)))</span>
     642<a id="l_554"></a><span class="hl line">  554 </span>
     643<a id="l_555"></a><span class="hl line">  555 </span><span class="hl sym">(</span>defmethod <span class="hl sym">(</span>setf visiting-component<span class="hl sym">) (</span>new-value <span class="hl sym">(</span>o operation<span class="hl sym">) (</span>c component<span class="hl sym">))</span>
     644<a id="l_556"></a><span class="hl line">  556 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>node <span class="hl sym">(</span>node-for o c<span class="hl sym">))</span>
     645<a id="l_557"></a><span class="hl line">  557 </span>        <span class="hl sym">(</span>a <span class="hl sym">(</span>operation-ancestor o<span class="hl sym">)))</span>
     646<a id="l_558"></a><span class="hl line">  558 </span>    <span class="hl sym">(</span><span class="hl kwa">if</span> new-value
     647<a id="l_559"></a><span class="hl line">  559 </span>        <span class="hl sym">(</span>pushnew node <span class="hl sym">(</span>operation-visiting-nodes a<span class="hl sym">) :</span>test <span class="hl sym">'</span><span class="hl kwa">equal</span><span class="hl sym">)</span>
     648<a id="l_560"></a><span class="hl line">  560 </span>        <span class="hl sym">(</span>setf <span class="hl sym">(</span>operation-visiting-nodes a<span class="hl sym">)</span>
     649<a id="l_561"></a><span class="hl line">  561 </span>              <span class="hl sym">(</span>remove node  <span class="hl sym">(</span>operation-visiting-nodes a<span class="hl sym">) :</span>test <span class="hl sym">'</span><span class="hl kwa">equal</span><span class="hl sym">)))))</span>
     650<a id="l_562"></a><span class="hl line">  562 </span>
     651<a id="l_563"></a><span class="hl line">  563 </span><span class="hl sym">(</span>defgeneric component-visiting-p <span class="hl sym">(</span>operation component<span class="hl sym">))</span>
     652<a id="l_564"></a><span class="hl line">  564 </span>
     653<a id="l_565"></a><span class="hl line">  565 </span><span class="hl sym">(</span>defmethod component-visiting-p <span class="hl sym">((</span>o operation<span class="hl sym">) (</span>c component<span class="hl sym">))</span>
     654<a id="l_566"></a><span class="hl line">  566 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>node <span class="hl sym">(</span><span class="hl kwa">cons</span> o c<span class="hl sym">)))</span>
     655<a id="l_567"></a><span class="hl line">  567 </span>    <span class="hl sym">(</span><span class="hl kwa">member</span> node <span class="hl sym">(</span>operation-visiting-nodes <span class="hl sym">(</span>operation-ancestor o<span class="hl sym">))</span>
     656<a id="l_568"></a><span class="hl line">  568 </span>            <span class="hl sym">:</span>test <span class="hl sym">'</span><span class="hl kwa">equal</span><span class="hl sym">)))</span>
     657<a id="l_569"></a><span class="hl line">  569 </span>
     658<a id="l_570"></a><span class="hl line">  570 </span><span class="hl sym">(</span>defgeneric component-depends-on <span class="hl sym">(</span>operation component<span class="hl sym">)</span>
     659<a id="l_571"></a><span class="hl line">  571 </span>  <span class="hl sym">(:</span>documentation
     660<a id="l_572"></a><span class="hl line">  572 </span>   <span class="hl str">&quot;Returns a list of dependencies needed by the component to perform</span>
     661<a id="l_573"></a><span class="hl line">  573 </span><span class="hl str">    the operation.  A dependency has one of the following forms:</span>
     662<a id="l_574"></a><span class="hl line">  574 </span><span class="hl str"></span>
     663<a id="l_575"></a><span class="hl line">  575 </span><span class="hl str">      (&lt;operation&gt; &lt;component&gt;*), where &lt;operation&gt; is a class</span>
     664<a id="l_576"></a><span class="hl line">  576 </span><span class="hl str">        designator and each &lt;component&gt; is a component</span>
     665<a id="l_577"></a><span class="hl line">  577 </span><span class="hl str">        designator, which means that the component depends on</span>
     666<a id="l_578"></a><span class="hl line">  578 </span><span class="hl str">        &lt;operation&gt; having been performed on each &lt;component&gt;; or</span>
     667<a id="l_579"></a><span class="hl line">  579 </span><span class="hl str"></span>
     668<a id="l_580"></a><span class="hl line">  580 </span><span class="hl str">      (FEATURE &lt;feature&gt;), which means that the component depends</span>
     669<a id="l_581"></a><span class="hl line">  581 </span><span class="hl str">        on &lt;feature&gt;'s presence in *FEATURES*.</span>
     670<a id="l_582"></a><span class="hl line">  582 </span><span class="hl str"></span>
     671<a id="l_583"></a><span class="hl line">  583 </span><span class="hl str">    Methods specialized on subclasses of existing component types</span>
     672<a id="l_584"></a><span class="hl line">  584 </span><span class="hl str">    should usually append the results of CALL-NEXT-METHOD to the</span>
     673<a id="l_585"></a><span class="hl line">  585 </span><span class="hl str">    list.&quot;</span><span class="hl sym">))</span>
     674<a id="l_586"></a><span class="hl line">  586 </span>
     675<a id="l_587"></a><span class="hl line">  587 </span><span class="hl sym">(</span>defmethod component-depends-on <span class="hl sym">((</span>op-spec symbol<span class="hl sym">) (</span>c component<span class="hl sym">))</span>
     676<a id="l_588"></a><span class="hl line">  588 </span>  <span class="hl sym">(</span>component-depends-on <span class="hl sym">(</span>make-instance op-spec<span class="hl sym">)</span> c<span class="hl sym">))</span>
     677<a id="l_589"></a><span class="hl line">  589 </span>
     678<a id="l_590"></a><span class="hl line">  590 </span><span class="hl sym">(</span>defmethod component-depends-on <span class="hl sym">((</span>o operation<span class="hl sym">) (</span>c component<span class="hl sym">))</span>
     679<a id="l_591"></a><span class="hl line">  591 </span>  <span class="hl sym">(</span><span class="hl kwa">cdr</span> <span class="hl sym">(</span><span class="hl kwa">assoc</span> <span class="hl sym">(</span>class-name <span class="hl sym">(</span>class-of o<span class="hl sym">))</span>
     680<a id="l_592"></a><span class="hl line">  592 </span>              <span class="hl sym">(</span>slot-value c <span class="hl sym">'</span>in-order-to<span class="hl sym">))))</span>
     681<a id="l_593"></a><span class="hl line">  593 </span>
     682<a id="l_594"></a><span class="hl line">  594 </span><span class="hl sym">(</span>defgeneric component-self-dependencies <span class="hl sym">(</span>operation component<span class="hl sym">))</span>
     683<a id="l_595"></a><span class="hl line">  595 </span>
     684<a id="l_596"></a><span class="hl line">  596 </span><span class="hl sym">(</span>defmethod component-self-dependencies <span class="hl sym">((</span>o operation<span class="hl sym">) (</span>c component<span class="hl sym">))</span>
     685<a id="l_597"></a><span class="hl line">  597 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>all-deps <span class="hl sym">(</span>component-depends-on o c<span class="hl sym">)))</span>
     686<a id="l_598"></a><span class="hl line">  598 </span>    <span class="hl sym">(</span>remove-<span class="hl kwa">if</span>-<span class="hl kwa">not</span> <span class="hl sym">(</span><span class="hl kwa">lambda</span> <span class="hl sym">(</span>x<span class="hl sym">)</span>
     687<a id="l_599"></a><span class="hl line">  599 </span>                     <span class="hl sym">(</span><span class="hl kwa">member</span> <span class="hl sym">(</span>component-name c<span class="hl sym">) (</span><span class="hl kwa">cdr</span> x<span class="hl sym">) :</span>test #<span class="hl sym">'</span>string<span class="hl sym">=))</span>
     688<a id="l_600"></a><span class="hl line">  600 </span>                   all-deps<span class="hl sym">)))</span>
     689<a id="l_601"></a><span class="hl line">  601 </span>
     690<a id="l_602"></a><span class="hl line">  602 </span><span class="hl sym">(</span>defmethod input-files <span class="hl sym">((</span>operation operation<span class="hl sym">) (</span>c component<span class="hl sym">))</span>
     691<a id="l_603"></a><span class="hl line">  603 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>parent <span class="hl sym">(</span>component-parent c<span class="hl sym">))</span>
     692<a id="l_604"></a><span class="hl line">  604 </span>        <span class="hl sym">(</span>self-deps <span class="hl sym">(</span>component-self-dependencies operation c<span class="hl sym">)))</span>
     693<a id="l_605"></a><span class="hl line">  605 </span>    <span class="hl sym">(</span><span class="hl kwa">if</span> self-deps
     694<a id="l_606"></a><span class="hl line">  606 </span>        <span class="hl sym">(</span>mapcan <span class="hl sym">(</span><span class="hl kwa">lambda</span> <span class="hl sym">(</span>dep<span class="hl sym">)</span>
     695<a id="l_607"></a><span class="hl line">  607 </span>                  <span class="hl sym">(</span>destructuring-bind <span class="hl sym">(</span>op name<span class="hl sym">)</span> dep
     696<a id="l_608"></a><span class="hl line">  608 </span>                    <span class="hl sym">(</span>output-files <span class="hl sym">(</span>make-instance op<span class="hl sym">)</span>
     697<a id="l_609"></a><span class="hl line">  609 </span>                                  <span class="hl sym">(</span>find-component parent name<span class="hl sym">))))</span>
     698<a id="l_610"></a><span class="hl line">  610 </span>                self-deps<span class="hl sym">)</span>
     699<a id="l_611"></a><span class="hl line">  611 </span>        <span class="hl slc">;; no previous operations needed?  I guess we work with the</span>
     700<a id="l_612"></a><span class="hl line">  612 </span>        <span class="hl slc">;; original source file, then</span>
     701<a id="l_613"></a><span class="hl line">  613 </span>        <span class="hl sym">(</span><span class="hl kwa">list</span> <span class="hl sym">(</span>component-pathname c<span class="hl sym">)))))</span>
     702<a id="l_614"></a><span class="hl line">  614 </span>
     703<a id="l_615"></a><span class="hl line">  615 </span><span class="hl sym">(</span>defmethod input-files <span class="hl sym">((</span>operation operation<span class="hl sym">) (</span>c module<span class="hl sym">))</span> nil<span class="hl sym">)</span>
     704<a id="l_616"></a><span class="hl line">  616 </span>
     705<a id="l_617"></a><span class="hl line">  617 </span><span class="hl sym">(</span>defmethod operation-done-p <span class="hl sym">((</span>o operation<span class="hl sym">) (</span>c component<span class="hl sym">))</span>
     706<a id="l_618"></a><span class="hl line">  618 </span>  <span class="hl sym">(</span>flet <span class="hl sym">((</span>fwd-<span class="hl kwa">or</span>-return-t <span class="hl sym">(</span>file<span class="hl sym">)</span>
     707<a id="l_619"></a><span class="hl line">  619 </span>           <span class="hl slc">;; if FILE-WRITE-DATE returns NIL, it's possible that the</span>
     708<a id="l_620"></a><span class="hl line">  620 </span>           <span class="hl slc">;; user or some other agent has deleted an input file.  If</span>
     709<a id="l_621"></a><span class="hl line">  621 </span>           <span class="hl slc">;; that's the case, well, that's not good, but as long as</span>
     710<a id="l_622"></a><span class="hl line">  622 </span>           <span class="hl slc">;; the operation is otherwise considered to be done we</span>
     711<a id="l_623"></a><span class="hl line">  623 </span>           <span class="hl slc">;; could continue and survive.</span>
     712<a id="l_624"></a><span class="hl line">  624 </span>           <span class="hl sym">(</span>let <span class="hl sym">((</span>date <span class="hl sym">(</span>file-write-date file<span class="hl sym">)))</span>
     713<a id="l_625"></a><span class="hl line">  625 </span>             <span class="hl sym">(</span><span class="hl kwa">cond</span>
     714<a id="l_626"></a><span class="hl line">  626 </span>               <span class="hl sym">(</span>date<span class="hl sym">)</span>
     715<a id="l_627"></a><span class="hl line">  627 </span>               <span class="hl sym">(</span>t
     716<a id="l_628"></a><span class="hl line">  628 </span>                <span class="hl sym">(</span>warn <span class="hl str">&quot;~&#64;&lt;Missing FILE-WRITE-DATE for ~S: treating ~</span>
     717<a id="l_629"></a><span class="hl line">  629 </span><span class="hl str">                       operation ~S on component ~S as done.~&#64;:&gt;&quot;</span>
     718<a id="l_630"></a><span class="hl line">  630 </span>                      file o c<span class="hl sym">)</span>
     719<a id="l_631"></a><span class="hl line">  631 </span>                <span class="hl sym">(</span>return-from operation-done-p t<span class="hl sym">))))))</span>
     720<a id="l_632"></a><span class="hl line">  632 </span>    <span class="hl sym">(</span>let <span class="hl sym">((</span>out-files <span class="hl sym">(</span>output-files o c<span class="hl sym">))</span>
     721<a id="l_633"></a><span class="hl line">  633 </span>          <span class="hl sym">(</span>in-files <span class="hl sym">(</span>input-files o c<span class="hl sym">)))</span>
     722<a id="l_634"></a><span class="hl line">  634 </span>      <span class="hl sym">(</span><span class="hl kwa">cond</span> <span class="hl sym">((</span><span class="hl kwa">and</span> <span class="hl sym">(</span><span class="hl kwa">not</span> in-files<span class="hl sym">) (</span><span class="hl kwa">not</span> out-files<span class="hl sym">))</span>
     723<a id="l_635"></a><span class="hl line">  635 </span>             <span class="hl slc">;; arbitrary decision: an operation that uses nothing to</span>
     724<a id="l_636"></a><span class="hl line">  636 </span>             <span class="hl slc">;; produce nothing probably isn't doing much</span>
     725<a id="l_637"></a><span class="hl line">  637 </span>             t<span class="hl sym">)</span>
     726<a id="l_638"></a><span class="hl line">  638 </span>            <span class="hl sym">((</span><span class="hl kwa">not</span> out-files<span class="hl sym">)</span>
     727<a id="l_639"></a><span class="hl line">  639 </span>             <span class="hl sym">(</span>let <span class="hl sym">((</span>op-done
     728<a id="l_640"></a><span class="hl line">  640 </span>                    <span class="hl sym">(</span>gethash <span class="hl sym">(</span><span class="hl kwa">type</span>-of o<span class="hl sym">)</span>
     729<a id="l_641"></a><span class="hl line">  641 </span>                             <span class="hl sym">(</span>component-operation-times c<span class="hl sym">))))</span>
     730<a id="l_642"></a><span class="hl line">  642 </span>               <span class="hl sym">(</span><span class="hl kwa">and</span> op-done
     731<a id="l_643"></a><span class="hl line">  643 </span>                    <span class="hl sym">(&gt;=</span> op-done
     732<a id="l_644"></a><span class="hl line">  644 </span>                        <span class="hl sym">(</span><span class="hl kwa">apply</span> #<span class="hl sym">'</span><span class="hl kwa">max</span>
     733<a id="l_645"></a><span class="hl line">  645 </span>                               <span class="hl sym">(</span><span class="hl kwa">mapcar</span> #<span class="hl sym">'</span>fwd-<span class="hl kwa">or</span>-return-t in-files<span class="hl sym">))))))</span>
     734<a id="l_646"></a><span class="hl line">  646 </span>            <span class="hl sym">((</span><span class="hl kwa">not</span> in-files<span class="hl sym">)</span> nil<span class="hl sym">)</span>
     735<a id="l_647"></a><span class="hl line">  647 </span>            <span class="hl sym">(</span>t
     736<a id="l_648"></a><span class="hl line">  648 </span>             <span class="hl sym">(</span><span class="hl kwa">and</span>
     737<a id="l_649"></a><span class="hl line">  649 </span>              <span class="hl sym">(</span>every #<span class="hl sym">'</span>probe-file out-files<span class="hl sym">)</span>
     738<a id="l_650"></a><span class="hl line">  650 </span>              <span class="hl sym">(&gt; (</span><span class="hl kwa">apply</span> #<span class="hl sym">'</span><span class="hl kwa">min</span> <span class="hl sym">(</span><span class="hl kwa">mapcar</span> #<span class="hl sym">'</span>file-write-date out-files<span class="hl sym">))</span>
     739<a id="l_651"></a><span class="hl line">  651 </span>                 <span class="hl sym">(</span><span class="hl kwa">apply</span> #<span class="hl sym">'</span><span class="hl kwa">max</span> <span class="hl sym">(</span><span class="hl kwa">mapcar</span> #<span class="hl sym">'</span>fwd-<span class="hl kwa">or</span>-return-t in-files<span class="hl sym">)))))))))</span>
     740<a id="l_652"></a><span class="hl line">  652 </span>
     741<a id="l_653"></a><span class="hl line">  653 </span><span class="hl slc">;;; So you look at this code and think &quot;why isn't it a bunch of</span>
     742<a id="l_654"></a><span class="hl line">  654 </span><span class="hl slc">;;; methods&quot;.  And the answer is, because standard method combination</span>
     743<a id="l_655"></a><span class="hl line">  655 </span><span class="hl slc">;;; runs :before methods most-&gt;least-specific, which is back to front</span>
     744<a id="l_656"></a><span class="hl line">  656 </span><span class="hl slc">;;; for our purposes.  And CLISP doesn't have non-standard method</span>
     745<a id="l_657"></a><span class="hl line">  657 </span><span class="hl slc">;;; combinations, so let's keep it simple and aspire to portability</span>
     746<a id="l_658"></a><span class="hl line">  658 </span>
     747<a id="l_659"></a><span class="hl line">  659 </span><span class="hl sym">(</span>defgeneric traverse <span class="hl sym">(</span>operation component<span class="hl sym">))</span>
     748<a id="l_660"></a><span class="hl line">  660 </span><span class="hl sym">(</span>defmethod traverse <span class="hl sym">((</span>operation operation<span class="hl sym">) (</span>c component<span class="hl sym">))</span>
     749<a id="l_661"></a><span class="hl line">  661 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>forced nil<span class="hl sym">))</span>
     750<a id="l_662"></a><span class="hl line">  662 </span>    <span class="hl sym">(</span>labels <span class="hl sym">((</span>do-one-dep <span class="hl sym">(</span>required-op required-c required-v<span class="hl sym">)</span>
     751<a id="l_663"></a><span class="hl line">  663 </span>               <span class="hl sym">(</span>let<span class="hl sym">* ((</span>dep-c <span class="hl sym">(</span><span class="hl kwa">or</span> <span class="hl sym">(</span>find-component
     752<a id="l_664"></a><span class="hl line">  664 </span>                                  <span class="hl sym">(</span>component-parent c<span class="hl sym">)</span>
     753<a id="l_665"></a><span class="hl line">  665 </span>                                  <span class="hl slc">;; XXX tacky.  really we should build the</span>
     754<a id="l_666"></a><span class="hl line">  666 </span>                                  <span class="hl slc">;; in-order-to slot with canonicalized</span>
     755<a id="l_667"></a><span class="hl line">  667 </span>                                  <span class="hl slc">;; names instead of coercing this late</span>
     756<a id="l_668"></a><span class="hl line">  668 </span>                                  <span class="hl sym">(</span>coerce-name required-c<span class="hl sym">)</span> required-v<span class="hl sym">)</span>
     757<a id="l_669"></a><span class="hl line">  669 </span>                                 <span class="hl sym">(</span>error <span class="hl sym">'</span>missing-dependency
     758<a id="l_670"></a><span class="hl line">  670 </span>                                        <span class="hl sym">:</span>required-by c
     759<a id="l_671"></a><span class="hl line">  671 </span>                                        <span class="hl sym">:</span>version required-v
     760<a id="l_672"></a><span class="hl line">  672 </span>                                        <span class="hl sym">:</span>requires required-c<span class="hl sym">)))</span>
     761<a id="l_673"></a><span class="hl line">  673 </span>                      <span class="hl sym">(</span>op <span class="hl sym">(</span>make-sub-operation c operation dep-c required-op<span class="hl sym">)))</span>
     762<a id="l_674"></a><span class="hl line">  674 </span>                 <span class="hl sym">(</span>traverse op dep-c<span class="hl sym">)))</span>
     763<a id="l_675"></a><span class="hl line">  675 </span>             <span class="hl sym">(</span>do-dep <span class="hl sym">(</span>op dep<span class="hl sym">)</span>
     764<a id="l_676"></a><span class="hl line">  676 </span>               <span class="hl sym">(</span><span class="hl kwa">cond</span> <span class="hl sym">((</span><span class="hl kwa">eq</span> op <span class="hl sym">'</span>feature<span class="hl sym">)</span>
     765<a id="l_677"></a><span class="hl line">  677 </span>                      <span class="hl sym">(</span><span class="hl kwa">or</span> <span class="hl sym">(</span><span class="hl kwa">member</span> <span class="hl sym">(</span><span class="hl kwa">car</span> dep<span class="hl sym">) *</span>features<span class="hl sym">*)</span>
     766<a id="l_678"></a><span class="hl line">  678 </span>                          <span class="hl sym">(</span>error <span class="hl sym">'</span>missing-dependency
     767<a id="l_679"></a><span class="hl line">  679 </span>                                 <span class="hl sym">:</span>required-by c
     768<a id="l_680"></a><span class="hl line">  680 </span>                                 <span class="hl sym">:</span>requires <span class="hl sym">(</span><span class="hl kwa">car</span> dep<span class="hl sym">)</span>
     769<a id="l_681"></a><span class="hl line">  681 </span>                                 <span class="hl sym">:</span>version nil<span class="hl sym">)))</span>
     770<a id="l_682"></a><span class="hl line">  682 </span>                     <span class="hl sym">(</span>t
     771<a id="l_683"></a><span class="hl line">  683 </span>                      <span class="hl sym">(</span>dolist <span class="hl sym">(</span>d dep<span class="hl sym">)</span>
     772<a id="l_684"></a><span class="hl line">  684 </span>                        <span class="hl sym">(</span><span class="hl kwa">cond</span> <span class="hl sym">((</span>consp d<span class="hl sym">)</span>
     773<a id="l_685"></a><span class="hl line">  685 </span>                               <span class="hl sym">(</span>assert <span class="hl sym">(</span>string-<span class="hl kwa">equal</span>
     774<a id="l_686"></a><span class="hl line">  686 </span>                                        <span class="hl sym">(</span>symbol-name <span class="hl sym">(</span>first d<span class="hl sym">))</span>
     775<a id="l_687"></a><span class="hl line">  687 </span>                                        <span class="hl str">&quot;VERSION&quot;</span><span class="hl sym">))</span>
     776<a id="l_688"></a><span class="hl line">  688 </span>                               <span class="hl sym">(</span>appendf forced
     777<a id="l_689"></a><span class="hl line">  689 </span>                                        <span class="hl sym">(</span>do-one-dep op <span class="hl sym">(</span>second d<span class="hl sym">) (</span>third d<span class="hl sym">))))</span>
     778<a id="l_690"></a><span class="hl line">  690 </span>                              <span class="hl sym">(</span>t
     779<a id="l_691"></a><span class="hl line">  691 </span>                               <span class="hl sym">(</span>appendf forced <span class="hl sym">(</span>do-one-dep op d nil<span class="hl sym">)))))))))</span>
     780<a id="l_692"></a><span class="hl line">  692 </span>      <span class="hl sym">(</span>aif <span class="hl sym">(</span>component-visited-p operation c<span class="hl sym">)</span>
     781<a id="l_693"></a><span class="hl line">  693 </span>           <span class="hl sym">(</span>return-from traverse
     782<a id="l_694"></a><span class="hl line">  694 </span>             <span class="hl sym">(</span><span class="hl kwa">if</span> <span class="hl sym">(</span><span class="hl kwa">cdr</span> it<span class="hl sym">) (</span><span class="hl kwa">list</span> <span class="hl sym">(</span><span class="hl kwa">cons</span> <span class="hl sym">'</span>pruned-op c<span class="hl sym">))</span> nil<span class="hl sym">)))</span>
     783<a id="l_695"></a><span class="hl line">  695 </span>      <span class="hl slc">;; dependencies</span>
     784<a id="l_696"></a><span class="hl line">  696 </span>      <span class="hl sym">(</span><span class="hl kwa">if</span> <span class="hl sym">(</span>component-visiting-p operation c<span class="hl sym">)</span>
     785<a id="l_697"></a><span class="hl line">  697 </span>          <span class="hl sym">(</span>error <span class="hl sym">'</span>circular-dependency <span class="hl sym">:</span>components <span class="hl sym">(</span><span class="hl kwa">list</span> c<span class="hl sym">)))</span>
     786<a id="l_698"></a><span class="hl line">  698 </span>      <span class="hl sym">(</span>setf <span class="hl sym">(</span>visiting-component operation c<span class="hl sym">)</span> t<span class="hl sym">)</span>
     787<a id="l_699"></a><span class="hl line">  699 </span>      <span class="hl sym">(</span>loop for <span class="hl sym">(</span>required-op . deps<span class="hl sym">)</span> in <span class="hl sym">(</span>component-depends-on operation c<span class="hl sym">)</span>
     788<a id="l_700"></a><span class="hl line">  700 </span>            do <span class="hl sym">(</span>do-dep required-op deps<span class="hl sym">))</span>
     789<a id="l_701"></a><span class="hl line">  701 </span>      <span class="hl slc">;; constituent bits</span>
     790<a id="l_702"></a><span class="hl line">  702 </span>      <span class="hl sym">(</span>let <span class="hl sym">((</span>module-ops
     791<a id="l_703"></a><span class="hl line">  703 </span>             <span class="hl sym">(</span>when <span class="hl sym">(</span>typep c <span class="hl sym">'</span>module<span class="hl sym">)</span>
     792<a id="l_704"></a><span class="hl line">  704 </span>               <span class="hl sym">(</span>let <span class="hl sym">((</span>at-least-one nil<span class="hl sym">)</span>
     793<a id="l_705"></a><span class="hl line">  705 </span>                     <span class="hl sym">(</span>forced nil<span class="hl sym">)</span>
     794<a id="l_706"></a><span class="hl line">  706 </span>                     <span class="hl sym">(</span>error nil<span class="hl sym">))</span>
     795<a id="l_707"></a><span class="hl line">  707 </span>                 <span class="hl sym">(</span>loop for kid in <span class="hl sym">(</span>module-components c<span class="hl sym">)</span>
     796<a id="l_708"></a><span class="hl line">  708 </span>                       do <span class="hl sym">(</span>handler-case
     797<a id="l_709"></a><span class="hl line">  709 </span>                              <span class="hl sym">(</span>appendf forced <span class="hl sym">(</span>traverse operation kid <span class="hl sym">))</span>
     798<a id="l_710"></a><span class="hl line">  710 </span>                            <span class="hl sym">(</span>missing-dependency <span class="hl sym">(</span>condition<span class="hl sym">)</span>
     799<a id="l_711"></a><span class="hl line">  711 </span>                              <span class="hl sym">(</span><span class="hl kwa">if</span> <span class="hl sym">(</span><span class="hl kwa">eq</span> <span class="hl sym">(</span>module-<span class="hl kwa">if</span>-component-dep-fails c<span class="hl sym">) :</span>fail<span class="hl sym">)</span>
     800<a id="l_712"></a><span class="hl line">  712 </span>                                  <span class="hl sym">(</span>error condition<span class="hl sym">))</span>
     801<a id="l_713"></a><span class="hl line">  713 </span>                              <span class="hl sym">(</span>setf error condition<span class="hl sym">))</span>
     802<a id="l_714"></a><span class="hl line">  714 </span>                            <span class="hl sym">(:</span>no-error <span class="hl sym">(</span>c<span class="hl sym">)</span>
     803<a id="l_715"></a><span class="hl line">  715 </span>                              <span class="hl sym">(</span>declare <span class="hl sym">(</span>ignore c<span class="hl sym">))</span>
     804<a id="l_716"></a><span class="hl line">  716 </span>                              <span class="hl sym">(</span>setf at-least-one t<span class="hl sym">))))</span>
     805<a id="l_717"></a><span class="hl line">  717 </span>                 <span class="hl sym">(</span>when <span class="hl sym">(</span><span class="hl kwa">and</span> <span class="hl sym">(</span><span class="hl kwa">eq</span> <span class="hl sym">(</span>module-<span class="hl kwa">if</span>-component-dep-fails c<span class="hl sym">) :</span>try-next<span class="hl sym">)</span>
     806<a id="l_718"></a><span class="hl line">  718 </span>                            <span class="hl sym">(</span><span class="hl kwa">not</span> at-least-one<span class="hl sym">))</span>
     807<a id="l_719"></a><span class="hl line">  719 </span>                   <span class="hl sym">(</span>error error<span class="hl sym">))</span>
     808<a id="l_720"></a><span class="hl line">  720 </span>                 forced<span class="hl sym">))))</span>
     809<a id="l_721"></a><span class="hl line">  721 </span>        <span class="hl slc">;; now the thing itself</span>
     810<a id="l_722"></a><span class="hl line">  722 </span>        <span class="hl sym">(</span>when <span class="hl sym">(</span><span class="hl kwa">or</span> forced module-ops
     811<a id="l_723"></a><span class="hl line">  723 </span>                  <span class="hl sym">(</span><span class="hl kwa">not</span> <span class="hl sym">(</span>operation-done-p operation c<span class="hl sym">))</span>
     812<a id="l_724"></a><span class="hl line">  724 </span>                  <span class="hl sym">(</span>let <span class="hl sym">((</span>f <span class="hl sym">(</span>operation-forced <span class="hl sym">(</span>operation-ancestor operation<span class="hl sym">))))</span>
     813<a id="l_725"></a><span class="hl line">  725 </span>                    <span class="hl sym">(</span><span class="hl kwa">and</span> f <span class="hl sym">(</span><span class="hl kwa">or</span> <span class="hl sym">(</span><span class="hl kwa">not</span> <span class="hl sym">(</span>consp f<span class="hl sym">))</span>
     814<a id="l_726"></a><span class="hl line">  726 </span>                               <span class="hl sym">(</span><span class="hl kwa">member</span> <span class="hl sym">(</span>component-name
     815<a id="l_727"></a><span class="hl line">  727 </span>                                        <span class="hl sym">(</span>operation-ancestor operation<span class="hl sym">))</span>
     816<a id="l_728"></a><span class="hl line">  728 </span>                                       <span class="hl sym">(</span><span class="hl kwa">mapcar</span> #<span class="hl sym">'</span>coerce-name f<span class="hl sym">)</span>
     817<a id="l_729"></a><span class="hl line">  729 </span>                                       <span class="hl sym">:</span>test #<span class="hl sym">'</span>string<span class="hl sym">=)))))</span>
     818<a id="l_730"></a><span class="hl line">  730 </span>          <span class="hl sym">(</span>let <span class="hl sym">((</span>do-first <span class="hl sym">(</span><span class="hl kwa">cdr</span> <span class="hl sym">(</span><span class="hl kwa">assoc</span> <span class="hl sym">(</span>class-name <span class="hl sym">(</span>class-of operation<span class="hl sym">))</span>
     819<a id="l_731"></a><span class="hl line">  731 </span>                                      <span class="hl sym">(</span>slot-value c <span class="hl sym">'</span>do-first<span class="hl sym">)))))</span>
     820<a id="l_732"></a><span class="hl line">  732 </span>            <span class="hl sym">(</span>loop for <span class="hl sym">(</span>required-op . deps<span class="hl sym">)</span> in do-first
     821<a id="l_733"></a><span class="hl line">  733 </span>                  do <span class="hl sym">(</span>do-dep required-op deps<span class="hl sym">)))</span>
     822<a id="l_734"></a><span class="hl line">  734 </span>          <span class="hl sym">(</span>setf forced <span class="hl sym">(</span><span class="hl kwa">append</span> <span class="hl sym">(</span>delete <span class="hl sym">'</span>pruned-op forced <span class="hl sym">:</span>key #<span class="hl sym">'</span><span class="hl kwa">car</span><span class="hl sym">)</span>
     823<a id="l_735"></a><span class="hl line">  735 </span>                               <span class="hl sym">(</span>delete <span class="hl sym">'</span>pruned-op module-ops <span class="hl sym">:</span>key #<span class="hl sym">'</span><span class="hl kwa">car</span><span class="hl sym">)</span>
     824<a id="l_736"></a><span class="hl line">  736 </span>                               <span class="hl sym">(</span><span class="hl kwa">list</span> <span class="hl sym">(</span><span class="hl kwa">cons</span> operation c<span class="hl sym">))))))</span>
     825<a id="l_737"></a><span class="hl line">  737 </span>      <span class="hl sym">(</span>setf <span class="hl sym">(</span>visiting-component operation c<span class="hl sym">)</span> nil<span class="hl sym">)</span>
     826<a id="l_738"></a><span class="hl line">  738 </span>      <span class="hl sym">(</span>visit-component operation c <span class="hl sym">(</span><span class="hl kwa">and</span> forced t<span class="hl sym">))</span>
     827<a id="l_739"></a><span class="hl line">  739 </span>      forced<span class="hl sym">)))</span>
     828<a id="l_740"></a><span class="hl line">  740 </span>
     829<a id="l_741"></a><span class="hl line">  741 </span>
     830<a id="l_742"></a><span class="hl line">  742 </span><span class="hl sym">(</span>defmethod perform <span class="hl sym">((</span>operation operation<span class="hl sym">) (</span>c source-file<span class="hl sym">))</span>
     831<a id="l_743"></a><span class="hl line">  743 </span>  <span class="hl sym">(</span>sysdef-error
     832<a id="l_744"></a><span class="hl line">  744 </span>   <span class="hl str">&quot;~&#64;&lt;required method PERFORM not implemented ~</span>
     833<a id="l_745"></a><span class="hl line">  745 </span><span class="hl str">    for operation ~A, component ~A~&#64;:&gt;&quot;</span>
     834<a id="l_746"></a><span class="hl line">  746 </span>   <span class="hl sym">(</span>class-of operation<span class="hl sym">) (</span>class-of c<span class="hl sym">)))</span>
     835<a id="l_747"></a><span class="hl line">  747 </span>
     836<a id="l_748"></a><span class="hl line">  748 </span><span class="hl sym">(</span>defmethod perform <span class="hl sym">((</span>operation operation<span class="hl sym">) (</span>c module<span class="hl sym">))</span>
     837<a id="l_749"></a><span class="hl line">  749 </span>  nil<span class="hl sym">)</span>
     838<a id="l_750"></a><span class="hl line">  750 </span>
     839<a id="l_751"></a><span class="hl line">  751 </span><span class="hl sym">(</span>defmethod explain <span class="hl sym">((</span>operation operation<span class="hl sym">) (</span>component component<span class="hl sym">))</span>
     840<a id="l_752"></a><span class="hl line">  752 </span>  <span class="hl sym">(</span>format <span class="hl sym">*</span>verbose-out<span class="hl sym">*</span> <span class="hl str">&quot;~&amp;;;; ~A on ~A~%&quot;</span> operation component<span class="hl sym">))</span>
     841<a id="l_753"></a><span class="hl line">  753 </span>
     842<a id="l_754"></a><span class="hl line">  754 </span><span class="hl slc">;;; compile-op</span>
     843<a id="l_755"></a><span class="hl line">  755 </span>
     844<a id="l_756"></a><span class="hl line">  756 </span><span class="hl sym">(</span>defclass compile-op <span class="hl sym">(</span>operation<span class="hl sym">)</span>
     845<a id="l_757"></a><span class="hl line">  757 </span>  <span class="hl sym">((</span>proclamations <span class="hl sym">:</span>initarg <span class="hl sym">:</span>proclamations <span class="hl sym">:</span>accessor compile-op-proclamations <span class="hl sym">:</span>initform nil<span class="hl sym">)</span>
     846<a id="l_758"></a><span class="hl line">  758 </span>   <span class="hl sym">(</span>on-warnings <span class="hl sym">:</span>initarg <span class="hl sym">:</span>on-warnings <span class="hl sym">:</span>accessor operation-on-warnings
     847<a id="l_759"></a><span class="hl line">  759 </span>                <span class="hl sym">:</span>initform <span class="hl sym">*</span>compile-file-warnings-behaviour<span class="hl sym">*)</span>
     848<a id="l_760"></a><span class="hl line">  760 </span>   <span class="hl sym">(</span>on-failure <span class="hl sym">:</span>initarg <span class="hl sym">:</span>on-failure <span class="hl sym">:</span>accessor operation-on-failure
     849<a id="l_761"></a><span class="hl line">  761 </span>               <span class="hl sym">:</span>initform <span class="hl sym">*</span>compile-file-failure-behaviour<span class="hl sym">*)))</span>
     850<a id="l_762"></a><span class="hl line">  762 </span>
     851<a id="l_763"></a><span class="hl line">  763 </span><span class="hl sym">(</span>defmethod perform <span class="hl sym">:</span>before <span class="hl sym">((</span>operation compile-op<span class="hl sym">) (</span>c source-file<span class="hl sym">))</span>
     852<a id="l_764"></a><span class="hl line">  764 </span>  <span class="hl sym">(</span>map nil #<span class="hl sym">'</span>ensure-directories-exist <span class="hl sym">(</span>output-files operation c<span class="hl sym">)))</span>
     853<a id="l_765"></a><span class="hl line">  765 </span>
     854<a id="l_766"></a><span class="hl line">  766 </span><span class="hl sym">(</span>defmethod perform <span class="hl sym">:</span>after <span class="hl sym">((</span>operation operation<span class="hl sym">) (</span>c component<span class="hl sym">))</span>
     855<a id="l_767"></a><span class="hl line">  767 </span>  <span class="hl sym">(</span>setf <span class="hl sym">(</span>gethash <span class="hl sym">(</span><span class="hl kwa">type</span>-of operation<span class="hl sym">) (</span>component-operation-times c<span class="hl sym">))</span>
     856<a id="l_768"></a><span class="hl line">  768 </span>        <span class="hl sym">(</span>get-universal-time<span class="hl sym">))</span>
     857<a id="l_769"></a><span class="hl line">  769 </span>  <span class="hl sym">(</span><span class="hl kwa">load</span>-preferences c operation<span class="hl sym">))</span>
     858<a id="l_770"></a><span class="hl line">  770 </span>
     859<a id="l_771"></a><span class="hl line">  771 </span><span class="hl slc">;;; perform is required to check output-files to find out where to put</span>
     860<a id="l_772"></a><span class="hl line">  772 </span><span class="hl slc">;;; its answers, in case it has been overridden for site policy</span>
     861<a id="l_773"></a><span class="hl line">  773 </span><span class="hl sym">(</span>defmethod perform <span class="hl sym">((</span>operation compile-op<span class="hl sym">) (</span>c cl-source-file<span class="hl sym">))</span>
     862<a id="l_774"></a><span class="hl line">  774 </span>  #-<span class="hl sym">:</span>broken-fasl-loader
     863<a id="l_775"></a><span class="hl line">  775 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>source-file <span class="hl sym">(</span>component-pathname c<span class="hl sym">))</span>
     864<a id="l_776"></a><span class="hl line">  776 </span>        <span class="hl sym">(</span>output-file <span class="hl sym">(</span><span class="hl kwa">car</span> <span class="hl sym">(</span>output-files operation c<span class="hl sym">))))</span>
     865<a id="l_777"></a><span class="hl line">  777 </span>    <span class="hl sym">(</span>multiple-value-bind <span class="hl sym">(</span>output warnings-p failure-p<span class="hl sym">)</span>
     866<a id="l_778"></a><span class="hl line">  778 </span>        <span class="hl sym">(</span>compile-file source-file <span class="hl sym">:</span>output-file output-file<span class="hl sym">)</span>
     867<a id="l_779"></a><span class="hl line">  779 </span>      <span class="hl sym">(</span>when warnings-p
     868<a id="l_780"></a><span class="hl line">  780 </span>        <span class="hl sym">(</span>case <span class="hl sym">(</span>operation-on-warnings operation<span class="hl sym">)</span>
     869<a id="l_781"></a><span class="hl line">  781 </span>          <span class="hl sym">(:</span>warn <span class="hl sym">(</span>warn
     870<a id="l_782"></a><span class="hl line">  782 </span>                  <span class="hl str">&quot;~&#64;&lt;COMPILE-FILE warned while performing ~A on ~A.~&#64;:&gt;&quot;</span>
     871<a id="l_783"></a><span class="hl line">  783 </span>                  operation c<span class="hl sym">))</span>
     872<a id="l_784"></a><span class="hl line">  784 </span>          <span class="hl sym">(:</span>error <span class="hl sym">(</span>error <span class="hl sym">'</span>compile-warned <span class="hl sym">:</span>component c <span class="hl sym">:</span>operation operation<span class="hl sym">))</span>
     873<a id="l_785"></a><span class="hl line">  785 </span>          <span class="hl sym">(:</span>ignore nil<span class="hl sym">)))</span>
     874<a id="l_786"></a><span class="hl line">  786 </span>      <span class="hl sym">(</span>when failure-p
     875<a id="l_787"></a><span class="hl line">  787 </span>        <span class="hl sym">(</span>case <span class="hl sym">(</span>operation-on-failure operation<span class="hl sym">)</span>
     876<a id="l_788"></a><span class="hl line">  788 </span>          <span class="hl sym">(:</span>warn <span class="hl sym">(</span>warn
     877<a id="l_789"></a><span class="hl line">  789 </span>                  <span class="hl str">&quot;~&#64;&lt;COMPILE-FILE failed while performing ~A on ~A.~&#64;:&gt;&quot;</span>
     878<a id="l_790"></a><span class="hl line">  790 </span>                  operation c<span class="hl sym">))</span>
     879<a id="l_791"></a><span class="hl line">  791 </span>          <span class="hl sym">(:</span>error <span class="hl sym">(</span>error <span class="hl sym">'</span>compile-failed <span class="hl sym">:</span>component c <span class="hl sym">:</span>operation operation<span class="hl sym">))</span>
     880<a id="l_792"></a><span class="hl line">  792 </span>          <span class="hl sym">(:</span>ignore nil<span class="hl sym">)))</span>
     881<a id="l_793"></a><span class="hl line">  793 </span>      <span class="hl sym">(</span>unless output
     882<a id="l_794"></a><span class="hl line">  794 </span>        <span class="hl sym">(</span>error <span class="hl sym">'</span>compile-error <span class="hl sym">:</span>component c <span class="hl sym">:</span>operation operation<span class="hl sym">)))))</span>
     883<a id="l_795"></a><span class="hl line">  795 </span>
     884<a id="l_796"></a><span class="hl line">  796 </span><span class="hl sym">(</span>defmethod output-files <span class="hl sym">((</span>operation compile-op<span class="hl sym">) (</span>c cl-source-file<span class="hl sym">))</span>
     885<a id="l_797"></a><span class="hl line">  797 </span>  #-<span class="hl sym">:</span>broken-fasl-loader <span class="hl sym">(</span><span class="hl kwa">list</span> <span class="hl sym">(</span>compile-file-pathname <span class="hl sym">(</span>component-pathname c<span class="hl sym">)))</span>
     886<a id="l_798"></a><span class="hl line">  798 </span>  #<span class="hl sym">+:</span>broken-fasl-loader <span class="hl sym">(</span><span class="hl kwa">list</span> <span class="hl sym">(</span>component-pathname c<span class="hl sym">)))</span>
     887<a id="l_799"></a><span class="hl line">  799 </span>
     888<a id="l_800"></a><span class="hl line">  800 </span><span class="hl sym">(</span>defmethod perform <span class="hl sym">((</span>operation compile-op<span class="hl sym">) (</span>c static-file<span class="hl sym">))</span>
     889<a id="l_801"></a><span class="hl line">  801 </span>  nil<span class="hl sym">)</span>
     890<a id="l_802"></a><span class="hl line">  802 </span>
     891<a id="l_803"></a><span class="hl line">  803 </span><span class="hl sym">(</span>defmethod output-files <span class="hl sym">((</span>operation compile-op<span class="hl sym">) (</span>c static-file<span class="hl sym">))</span>
     892<a id="l_804"></a><span class="hl line">  804 </span>  nil<span class="hl sym">)</span>
     893<a id="l_805"></a><span class="hl line">  805 </span>
     894<a id="l_806"></a><span class="hl line">  806 </span><span class="hl sym">(</span>defmethod input-files <span class="hl sym">((</span>op compile-op<span class="hl sym">) (</span>c static-file<span class="hl sym">))</span>
     895<a id="l_807"></a><span class="hl line">  807 </span>  nil<span class="hl sym">)</span>
     896<a id="l_808"></a><span class="hl line">  808 </span>
     897<a id="l_809"></a><span class="hl line">  809 </span>
     898<a id="l_810"></a><span class="hl line">  810 </span><span class="hl slc">;;; load-op</span>
     899<a id="l_811"></a><span class="hl line">  811 </span>
     900<a id="l_812"></a><span class="hl line">  812 </span><span class="hl sym">(</span>defclass basic-<span class="hl kwa">load</span>-op <span class="hl sym">(</span>operation<span class="hl sym">) ())</span>
     901<a id="l_813"></a><span class="hl line">  813 </span>
     902<a id="l_814"></a><span class="hl line">  814 </span><span class="hl sym">(</span>defclass <span class="hl kwa">load</span>-op <span class="hl sym">(</span>basic-<span class="hl kwa">load</span>-op<span class="hl sym">) ())</span>
     903<a id="l_815"></a><span class="hl line">  815 </span>
     904<a id="l_816"></a><span class="hl line">  816 </span><span class="hl sym">(</span>defmethod perform <span class="hl sym">((</span>o <span class="hl kwa">load</span>-op<span class="hl sym">) (</span>c cl-source-file<span class="hl sym">))</span>
     905<a id="l_817"></a><span class="hl line">  817 </span>  <span class="hl sym">(</span><span class="hl kwa">mapcar</span> #<span class="hl sym">'</span><span class="hl kwa">load</span> <span class="hl sym">(</span>input-files o c<span class="hl sym">)))</span>
     906<a id="l_818"></a><span class="hl line">  818 </span>
     907<a id="l_819"></a><span class="hl line">  819 </span><span class="hl sym">(</span>defmethod perform <span class="hl sym">((</span>operation <span class="hl kwa">load</span>-op<span class="hl sym">) (</span>c static-file<span class="hl sym">))</span>
     908<a id="l_820"></a><span class="hl line">  820 </span>  nil<span class="hl sym">)</span>
     909<a id="l_821"></a><span class="hl line">  821 </span><span class="hl sym">(</span>defmethod operation-done-p <span class="hl sym">((</span>operation <span class="hl kwa">load</span>-op<span class="hl sym">) (</span>c static-file<span class="hl sym">))</span>
     910<a id="l_822"></a><span class="hl line">  822 </span>  t<span class="hl sym">)</span>
     911<a id="l_823"></a><span class="hl line">  823 </span>
     912<a id="l_824"></a><span class="hl line">  824 </span><span class="hl sym">(</span>defmethod output-files <span class="hl sym">((</span>o operation<span class="hl sym">) (</span>c component<span class="hl sym">))</span>
     913<a id="l_825"></a><span class="hl line">  825 </span>  nil<span class="hl sym">)</span>
     914<a id="l_826"></a><span class="hl line">  826 </span>
     915<a id="l_827"></a><span class="hl line">  827 </span><span class="hl sym">(</span>defmethod component-depends-on <span class="hl sym">((</span>operation <span class="hl kwa">load</span>-op<span class="hl sym">) (</span>c component<span class="hl sym">))</span>
     916<a id="l_828"></a><span class="hl line">  828 </span>  <span class="hl sym">(</span><span class="hl kwa">cons</span> <span class="hl sym">(</span><span class="hl kwa">list</span> <span class="hl sym">'</span>compile-op <span class="hl sym">(</span>component-name c<span class="hl sym">))</span>
     917<a id="l_829"></a><span class="hl line">  829 </span>        <span class="hl sym">(</span>call-next-method<span class="hl sym">)))</span>
     918<a id="l_830"></a><span class="hl line">  830 </span>
     919<a id="l_831"></a><span class="hl line">  831 </span><span class="hl slc">;;; load-source-op</span>
     920<a id="l_832"></a><span class="hl line">  832 </span>
     921<a id="l_833"></a><span class="hl line">  833 </span><span class="hl sym">(</span>defclass <span class="hl kwa">load</span>-source-op <span class="hl sym">(</span>basic-<span class="hl kwa">load</span>-op<span class="hl sym">) ())</span>
     922<a id="l_834"></a><span class="hl line">  834 </span>
     923<a id="l_835"></a><span class="hl line">  835 </span><span class="hl sym">(</span>defmethod perform <span class="hl sym">((</span>o <span class="hl kwa">load</span>-source-op<span class="hl sym">) (</span>c cl-source-file<span class="hl sym">))</span>
     924<a id="l_836"></a><span class="hl line">  836 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>source <span class="hl sym">(</span>component-pathname c<span class="hl sym">)))</span>
     925<a id="l_837"></a><span class="hl line">  837 </span>    <span class="hl sym">(</span>setf <span class="hl sym">(</span>component-property c <span class="hl sym">'</span><span class="hl kwa">last</span>-loaded-as-source<span class="hl sym">)</span>
     926<a id="l_838"></a><span class="hl line">  838 </span>          <span class="hl sym">(</span><span class="hl kwa">and</span> <span class="hl sym">(</span><span class="hl kwa">load</span> source<span class="hl sym">)</span>
     927<a id="l_839"></a><span class="hl line">  839 </span>               <span class="hl sym">(</span>get-universal-time<span class="hl sym">)))))</span>
     928<a id="l_840"></a><span class="hl line">  840 </span>
     929<a id="l_841"></a><span class="hl line">  841 </span><span class="hl sym">(</span>defmethod perform <span class="hl sym">((</span>operation <span class="hl kwa">load</span>-source-op<span class="hl sym">) (</span>c static-file<span class="hl sym">))</span>
     930<a id="l_842"></a><span class="hl line">  842 </span>  nil<span class="hl sym">)</span>
     931<a id="l_843"></a><span class="hl line">  843 </span>
     932<a id="l_844"></a><span class="hl line">  844 </span><span class="hl sym">(</span>defmethod output-files <span class="hl sym">((</span>operation <span class="hl kwa">load</span>-source-op<span class="hl sym">) (</span>c component<span class="hl sym">))</span>
     933<a id="l_845"></a><span class="hl line">  845 </span>  nil<span class="hl sym">)</span>
     934<a id="l_846"></a><span class="hl line">  846 </span>
     935<a id="l_847"></a><span class="hl line">  847 </span><span class="hl slc">;;; FIXME: we simply copy load-op's dependencies.  this is Just Not Right.</span>
     936<a id="l_848"></a><span class="hl line">  848 </span><span class="hl sym">(</span>defmethod component-depends-on <span class="hl sym">((</span>o <span class="hl kwa">load</span>-source-op<span class="hl sym">) (</span>c component<span class="hl sym">))</span>
     937<a id="l_849"></a><span class="hl line">  849 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>what-would-<span class="hl kwa">load</span>-op-do <span class="hl sym">(</span><span class="hl kwa">cdr</span> <span class="hl sym">(</span><span class="hl kwa">assoc</span> <span class="hl sym">'</span><span class="hl kwa">load</span>-op
     938<a id="l_850"></a><span class="hl line">  850 </span>                                           <span class="hl sym">(</span>slot-value c <span class="hl sym">'</span>in-order-to<span class="hl sym">)))))</span>
     939<a id="l_851"></a><span class="hl line">  851 </span>    <span class="hl sym">(</span><span class="hl kwa">mapcar</span> <span class="hl sym">(</span><span class="hl kwa">lambda</span> <span class="hl sym">(</span>dep<span class="hl sym">)</span>
     940<a id="l_852"></a><span class="hl line">  852 </span>              <span class="hl sym">(</span><span class="hl kwa">if</span> <span class="hl sym">(</span><span class="hl kwa">eq</span> <span class="hl sym">(</span><span class="hl kwa">car</span> dep<span class="hl sym">) '</span><span class="hl kwa">load</span>-op<span class="hl sym">)</span>
     941<a id="l_853"></a><span class="hl line">  853 </span>                  <span class="hl sym">(</span><span class="hl kwa">cons</span> <span class="hl sym">'</span><span class="hl kwa">load</span>-source-op <span class="hl sym">(</span><span class="hl kwa">cdr</span> dep<span class="hl sym">))</span>
     942<a id="l_854"></a><span class="hl line">  854 </span>                  dep<span class="hl sym">))</span>
     943<a id="l_855"></a><span class="hl line">  855 </span>            what-would-<span class="hl kwa">load</span>-op-do<span class="hl sym">)))</span>
     944<a id="l_856"></a><span class="hl line">  856 </span>
     945<a id="l_857"></a><span class="hl line">  857 </span><span class="hl sym">(</span>defmethod operation-done-p <span class="hl sym">((</span>o <span class="hl kwa">load</span>-source-op<span class="hl sym">) (</span>c source-file<span class="hl sym">))</span>
     946<a id="l_858"></a><span class="hl line">  858 </span>  <span class="hl sym">(</span><span class="hl kwa">if</span> <span class="hl sym">(</span><span class="hl kwa">or</span> <span class="hl sym">(</span><span class="hl kwa">not</span> <span class="hl sym">(</span>component-property c <span class="hl sym">'</span><span class="hl kwa">last</span>-loaded-as-source<span class="hl sym">))</span>
     947<a id="l_859"></a><span class="hl line">  859 </span>          <span class="hl sym">(&gt; (</span>file-write-date <span class="hl sym">(</span>component-pathname c<span class="hl sym">))</span>
     948<a id="l_860"></a><span class="hl line">  860 </span>             <span class="hl sym">(</span>component-property c <span class="hl sym">'</span><span class="hl kwa">last</span>-loaded-as-source<span class="hl sym">)))</span>
     949<a id="l_861"></a><span class="hl line">  861 </span>      nil t<span class="hl sym">))</span>
     950<a id="l_862"></a><span class="hl line">  862 </span>
     951<a id="l_863"></a><span class="hl line">  863 </span><span class="hl sym">(</span>defclass test-op <span class="hl sym">(</span>operation<span class="hl sym">) ())</span>
     952<a id="l_864"></a><span class="hl line">  864 </span>
     953<a id="l_865"></a><span class="hl line">  865 </span><span class="hl sym">(</span>defmethod perform <span class="hl sym">((</span>operation test-op<span class="hl sym">) (</span>c component<span class="hl sym">))</span>
     954<a id="l_866"></a><span class="hl line">  866 </span>  nil<span class="hl sym">)</span>
     955<a id="l_867"></a><span class="hl line">  867 </span>
     956<a id="l_868"></a><span class="hl line">  868 </span><span class="hl sym">(</span>defgeneric <span class="hl kwa">load</span>-preferences <span class="hl sym">(</span>system operation<span class="hl sym">)</span>
     957<a id="l_869"></a><span class="hl line">  869 </span>  <span class="hl sym">(:</span>documentation
     958<a id="l_870"></a><span class="hl line">  870 </span>   <span class="hl str">&quot;Called to load system preferences after &lt;perform operation</span>
     959<a id="l_871"></a><span class="hl line">  871 </span><span class="hl str">system&gt;. Typical uses are to set parameters that don't exist until</span>
     960<a id="l_872"></a><span class="hl line">  872 </span><span class="hl str">after the system has been loaded.&quot;</span><span class="hl sym">))</span>
     961<a id="l_873"></a><span class="hl line">  873 </span>
     962<a id="l_874"></a><span class="hl line">  874 </span><span class="hl sym">(</span>defgeneric preference-file-for-system<span class="hl sym">/</span>operation <span class="hl sym">(</span>system operation<span class="hl sym">)</span>
     963<a id="l_875"></a><span class="hl line">  875 </span>  <span class="hl sym">(:</span>documentation
     964<a id="l_876"></a><span class="hl line">  876 </span>   <span class="hl str">&quot;Returns the pathname of the preference file for this system.</span>
     965<a id="l_877"></a><span class="hl line">  877 </span><span class="hl str">Called by 'load-preferences to determine what file to load.&quot;</span><span class="hl sym">))</span>
     966<a id="l_878"></a><span class="hl line">  878 </span>
     967<a id="l_879"></a><span class="hl line">  879 </span><span class="hl sym">(</span>defmethod <span class="hl kwa">load</span>-preferences <span class="hl sym">((</span>s t<span class="hl sym">) (</span>operation t<span class="hl sym">))</span>
     968<a id="l_880"></a><span class="hl line">  880 </span>  <span class="hl slc">;; do nothing</span>
     969<a id="l_881"></a><span class="hl line">  881 </span>  <span class="hl sym">(</span>values<span class="hl sym">))</span>
     970<a id="l_882"></a><span class="hl line">  882 </span>
     971<a id="l_883"></a><span class="hl line">  883 </span><span class="hl sym">(</span>defmethod <span class="hl kwa">load</span>-preferences <span class="hl sym">((</span>s system<span class="hl sym">) (</span>operation basic-<span class="hl kwa">load</span>-op<span class="hl sym">))</span>
     972<a id="l_884"></a><span class="hl line">  884 </span>  <span class="hl sym">(</span>let<span class="hl sym">* ((*</span>package<span class="hl sym">* (</span>find-package <span class="hl sym">:</span>common-lisp<span class="hl sym">))</span>
     973<a id="l_885"></a><span class="hl line">  885 </span>         <span class="hl sym">(</span>file <span class="hl sym">(</span>probe-file <span class="hl sym">(</span>preference-file-for-system<span class="hl sym">/</span>operation s operation<span class="hl sym">))))</span>
     974<a id="l_886"></a><span class="hl line">  886 </span>    <span class="hl sym">(</span>when file
     975<a id="l_887"></a><span class="hl line">  887 </span>      <span class="hl sym">(</span>when <span class="hl sym">*</span>verbose-out<span class="hl sym">*</span>
     976<a id="l_888"></a><span class="hl line">  888 </span>        <span class="hl sym">(</span>format <span class="hl sym">*</span>verbose-out<span class="hl sym">*</span>
     977<a id="l_889"></a><span class="hl line">  889 </span>                <span class="hl str">&quot;~&amp;~&#64;&lt;; ~&#64;;loading preferences for ~A/~(~A~) from ~A~&#64;:&gt;~%&quot;</span>
     978<a id="l_890"></a><span class="hl line">  890 </span>                <span class="hl sym">(</span>component-name s<span class="hl sym">)</span>
     979<a id="l_891"></a><span class="hl line">  891 </span>                <span class="hl sym">(</span><span class="hl kwa">type</span>-of operation<span class="hl sym">)</span> file<span class="hl sym">))</span>
     980<a id="l_892"></a><span class="hl line">  892 </span>      <span class="hl sym">(</span><span class="hl kwa">load</span> file<span class="hl sym">))))</span>
     981<a id="l_893"></a><span class="hl line">  893 </span>
     982<a id="l_894"></a><span class="hl line">  894 </span><span class="hl sym">(</span>defmethod preference-file-for-system<span class="hl sym">/</span>operation <span class="hl sym">((</span>system t<span class="hl sym">) (</span>operation t<span class="hl sym">))</span>
     983<a id="l_895"></a><span class="hl line">  895 </span>  <span class="hl slc">;; cope with anything other than systems</span>
     984<a id="l_896"></a><span class="hl line">  896 </span>  <span class="hl sym">(</span>preference-file-for-system<span class="hl sym">/</span>operation <span class="hl sym">(</span>find-system system t<span class="hl sym">)</span> operation<span class="hl sym">))</span>
     985<a id="l_897"></a><span class="hl line">  897 </span>
     986<a id="l_898"></a><span class="hl line">  898 </span><span class="hl sym">(</span>defmethod preference-file-for-system<span class="hl sym">/</span>operation <span class="hl sym">((</span>s system<span class="hl sym">) (</span>operation t<span class="hl sym">))</span>
     987<a id="l_899"></a><span class="hl line">  899 </span>  <span class="hl sym">(</span>let <span class="hl sym">((*</span>default-pathname-defaults<span class="hl sym">*</span>
     988<a id="l_900"></a><span class="hl line">  900 </span>         <span class="hl sym">(</span>make-pathname <span class="hl sym">:</span>name nil <span class="hl sym">:</span><span class="hl kwa">type</span> nil
     989<a id="l_901"></a><span class="hl line">  901 </span>                        <span class="hl sym">:</span>defaults <span class="hl sym">*</span>default-pathname-defaults<span class="hl sym">*)))</span>
     990<a id="l_902"></a><span class="hl line">  902 </span>     <span class="hl sym">(</span>merge-pathnames
     991<a id="l_903"></a><span class="hl line">  903 </span>      <span class="hl sym">(</span>make-pathname <span class="hl sym">:</span>name <span class="hl sym">(</span>component-name s<span class="hl sym">)</span>
     992<a id="l_904"></a><span class="hl line">  904 </span>                     <span class="hl sym">:</span><span class="hl kwa">type</span> <span class="hl str">&quot;lisp&quot;</span>
     993<a id="l_905"></a><span class="hl line">  905 </span>                     <span class="hl sym">:</span>directory <span class="hl sym">'(:</span>relative <span class="hl str">&quot;.asdf&quot;</span><span class="hl sym">))</span>
     994<a id="l_906"></a><span class="hl line">  906 </span>      <span class="hl sym">(</span>truename <span class="hl sym">(</span>user-homedir-pathname<span class="hl sym">)))))</span>
     995<a id="l_907"></a><span class="hl line">  907 </span>
     996<a id="l_908"></a><span class="hl line">  908 </span><span class="hl slc">;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;</span>
     997<a id="l_909"></a><span class="hl line">  909 </span><span class="hl slc">;;; invoking operations</span>
     998<a id="l_910"></a><span class="hl line">  910 </span>
     999<a id="l_911"></a><span class="hl line">  911 </span><span class="hl sym">(</span>defvar <span class="hl sym">*</span>operate-docstring<span class="hl sym">*</span>
     1000<a id="l_912"></a><span class="hl line">  912 </span>  <span class="hl str">&quot;Operate does three things:</span>
     1001<a id="l_913"></a><span class="hl line">  913 </span><span class="hl str"></span>
     1002<a id="l_914"></a><span class="hl line">  914 </span><span class="hl str">1. It creates an instance of `operation-class` using any keyword parameters</span>
     1003<a id="l_915"></a><span class="hl line">  915 </span><span class="hl str">as initargs.</span>
     1004<a id="l_916"></a><span class="hl line">  916 </span><span class="hl str">2. It finds the  asdf-system specified by `system` (possibly loading</span>
     1005<a id="l_917"></a><span class="hl line">  917 </span><span class="hl str">it from disk).</span>
     1006<a id="l_918"></a><span class="hl line">  918 </span><span class="hl str">3. It then calls `traverse` with the operation and system as arguments</span>
     1007<a id="l_919"></a><span class="hl line">  919 </span><span class="hl str"></span>
     1008<a id="l_920"></a><span class="hl line">  920 </span><span class="hl str">The traverse operation is wrapped in `with-compilation-unit` and error</span>
     1009<a id="l_921"></a><span class="hl line">  921 </span><span class="hl str">handling code. If a `version` argument is supplied, then operate also</span>
     1010<a id="l_922"></a><span class="hl line">  922 </span><span class="hl str">ensures that the system found satisfies it using the `version-satisfies`</span>
     1011<a id="l_923"></a><span class="hl line">  923 </span><span class="hl str">method.&quot;</span><span class="hl sym">)</span>
     1012<a id="l_924"></a><span class="hl line">  924 </span>
     1013<a id="l_925"></a><span class="hl line">  925 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> operate <span class="hl sym">(</span>operation-class system <span class="hl sym">&amp;</span>rest args <span class="hl sym">&amp;</span>key <span class="hl sym">(</span>verbose t<span class="hl sym">)</span> version
     1014<a id="l_926"></a><span class="hl line">  926 </span>                <span class="hl sym">&amp;</span>allow-other-keys<span class="hl sym">)</span>
     1015<a id="l_927"></a><span class="hl line">  927 </span>  <span class="hl sym">(</span>let<span class="hl sym">* ((</span>op <span class="hl sym">(</span><span class="hl kwa">apply</span> #<span class="hl sym">'</span>make-instance operation-class
     1016<a id="l_928"></a><span class="hl line">  928 </span>                    <span class="hl sym">:</span>original-initargs args
     1017<a id="l_929"></a><span class="hl line">  929 </span>                    args<span class="hl sym">))</span>
     1018<a id="l_930"></a><span class="hl line">  930 </span>         <span class="hl sym">(*</span>verbose-out<span class="hl sym">* (</span><span class="hl kwa">if</span> verbose <span class="hl sym">*</span>standard-output<span class="hl sym">* (</span>make-broadcast-stream<span class="hl sym">)))</span>
     1019<a id="l_931"></a><span class="hl line">  931 </span>         <span class="hl sym">(</span>system <span class="hl sym">(</span><span class="hl kwa">if</span> <span class="hl sym">(</span>typep system <span class="hl sym">'</span>component<span class="hl sym">)</span> system <span class="hl sym">(</span>find-system system<span class="hl sym">))))</span>
     1020<a id="l_932"></a><span class="hl line">  932 </span>    <span class="hl sym">(</span>unless <span class="hl sym">(</span>version-satisfies system version<span class="hl sym">)</span>
     1021<a id="l_933"></a><span class="hl line">  933 </span>      <span class="hl sym">(</span>error <span class="hl sym">'</span>missing-component <span class="hl sym">:</span>requires system <span class="hl sym">:</span>version version<span class="hl sym">))</span>
     1022<a id="l_934"></a><span class="hl line">  934 </span>    <span class="hl sym">(</span>let <span class="hl sym">((</span>steps <span class="hl sym">(</span>traverse op system<span class="hl sym">)))</span>
     1023<a id="l_935"></a><span class="hl line">  935 </span>      <span class="hl sym">(</span>with-compilation-unit <span class="hl sym">()</span>
     1024<a id="l_936"></a><span class="hl line">  936 </span>        <span class="hl sym">(</span>loop for <span class="hl sym">(</span>op . component<span class="hl sym">)</span> in steps do
     1025<a id="l_937"></a><span class="hl line">  937 </span>                 <span class="hl sym">(</span>loop
     1026<a id="l_938"></a><span class="hl line">  938 </span>                   <span class="hl sym">(</span>restart-case
     1027<a id="l_939"></a><span class="hl line">  939 </span>                       <span class="hl sym">(</span><span class="hl kwa">progn</span> <span class="hl sym">(</span>perform op component<span class="hl sym">)</span>
     1028<a id="l_940"></a><span class="hl line">  940 </span>                              <span class="hl sym">(</span>return<span class="hl sym">))</span>
     1029<a id="l_941"></a><span class="hl line">  941 </span>                     <span class="hl sym">(</span>retry <span class="hl sym">()</span>
     1030<a id="l_942"></a><span class="hl line">  942 </span>                       <span class="hl sym">:</span>report
     1031<a id="l_943"></a><span class="hl line">  943 </span>                       <span class="hl sym">(</span><span class="hl kwa">lambda</span> <span class="hl sym">(</span>s<span class="hl sym">)</span>
     1032<a id="l_944"></a><span class="hl line">  944 </span>                         <span class="hl sym">(</span>format s <span class="hl str">&quot;~&#64;&lt;Retry performing ~S on ~S.~&#64;:&gt;&quot;</span>
     1033<a id="l_945"></a><span class="hl line">  945 </span>                                 op component<span class="hl sym">)))</span>
     1034<a id="l_946"></a><span class="hl line">  946 </span>                     <span class="hl sym">(</span>accept <span class="hl sym">()</span>
     1035<a id="l_947"></a><span class="hl line">  947 </span>                       <span class="hl sym">:</span>report
     1036<a id="l_948"></a><span class="hl line">  948 </span>                       <span class="hl sym">(</span><span class="hl kwa">lambda</span> <span class="hl sym">(</span>s<span class="hl sym">)</span>
     1037<a id="l_949"></a><span class="hl line">  949 </span>                         <span class="hl sym">(</span>format s <span class="hl str">&quot;~&#64;&lt;Continue, treating ~S on ~S as ~</span>
     1038<a id="l_950"></a><span class="hl line">  950 </span><span class="hl str">                                   having been successful.~&#64;:&gt;&quot;</span>
     1039<a id="l_951"></a><span class="hl line">  951 </span>                                 op component<span class="hl sym">))</span>
     1040<a id="l_952"></a><span class="hl line">  952 </span>                       <span class="hl sym">(</span>setf <span class="hl sym">(</span>gethash <span class="hl sym">(</span><span class="hl kwa">type</span>-of op<span class="hl sym">)</span>
     1041<a id="l_953"></a><span class="hl line">  953 </span>                                      <span class="hl sym">(</span>component-operation-times component<span class="hl sym">))</span>
     1042<a id="l_954"></a><span class="hl line">  954 </span>                             <span class="hl sym">(</span>get-universal-time<span class="hl sym">))</span>
     1043<a id="l_955"></a><span class="hl line">  955 </span>                       <span class="hl sym">(</span>return<span class="hl sym">)))))))))</span>
     1044<a id="l_956"></a><span class="hl line">  956 </span>
     1045<a id="l_957"></a><span class="hl line">  957 </span><span class="hl sym">(</span>setf <span class="hl sym">(</span>documentation <span class="hl sym">'</span>operate <span class="hl sym">'</span>function<span class="hl sym">)</span>
     1046<a id="l_958"></a><span class="hl line">  958 </span>      <span class="hl sym">*</span>operate-docstring<span class="hl sym">*)</span>
     1047<a id="l_959"></a><span class="hl line">  959 </span>
     1048<a id="l_960"></a><span class="hl line">  960 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> oos <span class="hl sym">(</span>operation-class system <span class="hl sym">&amp;</span>rest args <span class="hl sym">&amp;</span>key force <span class="hl sym">(</span>verbose t<span class="hl sym">)</span> version<span class="hl sym">)</span>
     1049<a id="l_961"></a><span class="hl line">  961 </span>  <span class="hl sym">(</span>declare <span class="hl sym">(</span>ignore force verbose version<span class="hl sym">))</span>
     1050<a id="l_962"></a><span class="hl line">  962 </span>  <span class="hl sym">(</span><span class="hl kwa">apply</span> #<span class="hl sym">'</span>operate operation-class system args<span class="hl sym">))</span>
     1051<a id="l_963"></a><span class="hl line">  963 </span>
     1052<a id="l_964"></a><span class="hl line">  964 </span><span class="hl sym">(</span>setf <span class="hl sym">(</span>documentation <span class="hl sym">'</span>oos <span class="hl sym">'</span>function<span class="hl sym">)</span>
     1053<a id="l_965"></a><span class="hl line">  965 </span>      <span class="hl sym">(</span>format nil
     1054<a id="l_966"></a><span class="hl line">  966 </span>              <span class="hl str">&quot;Short for _operate on system_ and an alias for the `operate` function. ~&amp;~&amp;~a&quot;</span>
     1055<a id="l_967"></a><span class="hl line">  967 </span>              <span class="hl sym">*</span>operate-docstring<span class="hl sym">*))</span>
     1056<a id="l_968"></a><span class="hl line">  968 </span>
     1057<a id="l_969"></a><span class="hl line">  969 </span><span class="hl slc">;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;</span>
     1058<a id="l_970"></a><span class="hl line">  970 </span><span class="hl slc">;;; syntax</span>
     1059<a id="l_971"></a><span class="hl line">  971 </span>
     1060<a id="l_972"></a><span class="hl line">  972 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> remove-keyword <span class="hl sym">(</span>key arglist<span class="hl sym">)</span>
     1061<a id="l_973"></a><span class="hl line">  973 </span>  <span class="hl sym">(</span>labels <span class="hl sym">((</span>aux <span class="hl sym">(</span>key arglist<span class="hl sym">)</span>
     1062<a id="l_974"></a><span class="hl line">  974 </span>             <span class="hl sym">(</span><span class="hl kwa">cond</span> <span class="hl sym">((</span><span class="hl kwa">null</span> arglist<span class="hl sym">)</span> nil<span class="hl sym">)</span>
     1063<a id="l_975"></a><span class="hl line">  975 </span>                   <span class="hl sym">((</span><span class="hl kwa">eq</span> key <span class="hl sym">(</span><span class="hl kwa">car</span> arglist<span class="hl sym">)) (</span><span class="hl kwa">cddr</span> arglist<span class="hl sym">))</span>
     1064<a id="l_976"></a><span class="hl line">  976 </span>                   <span class="hl sym">(</span>t <span class="hl sym">(</span><span class="hl kwa">cons</span> <span class="hl sym">(</span><span class="hl kwa">car</span> arglist<span class="hl sym">) (</span><span class="hl kwa">cons</span> <span class="hl sym">(</span><span class="hl kwa">cadr</span> arglist<span class="hl sym">)</span>
     1065<a id="l_977"></a><span class="hl line">  977 </span>                                                <span class="hl sym">(</span>remove-keyword
     1066<a id="l_978"></a><span class="hl line">  978 </span>                                                 key <span class="hl sym">(</span><span class="hl kwa">cddr</span> arglist<span class="hl sym">))))))))</span>
     1067<a id="l_979"></a><span class="hl line">  979 </span>    <span class="hl sym">(</span>aux key arglist<span class="hl sym">)))</span>
     1068<a id="l_980"></a><span class="hl line">  980 </span>
     1069<a id="l_981"></a><span class="hl line">  981 </span><span class="hl sym">(</span>defmacro defsystem <span class="hl sym">(</span>name <span class="hl sym">&amp;</span>body options<span class="hl sym">)</span>
     1070<a id="l_982"></a><span class="hl line">  982 </span>  <span class="hl sym">(</span>destructuring-bind <span class="hl sym">(&amp;</span>key <span class="hl sym">(</span>pathname nil pathname-arg-p<span class="hl sym">) (</span>class <span class="hl sym">'</span>system<span class="hl sym">)</span>
     1071<a id="l_983"></a><span class="hl line">  983 </span>                            <span class="hl sym">&amp;</span>allow-other-keys<span class="hl sym">)</span>
     1072<a id="l_984"></a><span class="hl line">  984 </span>      options
     1073<a id="l_985"></a><span class="hl line">  985 </span>    <span class="hl sym">(</span>let <span class="hl sym">((</span>component-options <span class="hl sym">(</span>remove-keyword <span class="hl sym">:</span>class options<span class="hl sym">)))</span>
     1074<a id="l_986"></a><span class="hl line">  986 </span>      `<span class="hl sym">(</span><span class="hl kwa">progn</span>
     1075<a id="l_987"></a><span class="hl line">  987 </span>         <span class="hl slc">;; system must be registered before we parse the body, otherwise</span>
     1076<a id="l_988"></a><span class="hl line">  988 </span>         <span class="hl slc">;; we recur when trying to find an existing system of the same name</span>
     1077<a id="l_989"></a><span class="hl line">  989 </span>         <span class="hl slc">;; to reuse options (e.g. pathname) from</span>
     1078<a id="l_990"></a><span class="hl line">  990 </span>         <span class="hl sym">(</span>let <span class="hl sym">((</span>s <span class="hl sym">(</span>system-registered-p <span class="hl sym">',</span>name<span class="hl sym">)))</span>
     1079<a id="l_991"></a><span class="hl line">  991 </span>           <span class="hl sym">(</span><span class="hl kwa">cond</span> <span class="hl sym">((</span><span class="hl kwa">and</span> s <span class="hl sym">(</span><span class="hl kwa">eq</span> <span class="hl sym">(</span><span class="hl kwa">type</span>-of <span class="hl sym">(</span><span class="hl kwa">cdr</span> s<span class="hl sym">)) ',</span>class<span class="hl sym">))</span>
     1080<a id="l_992"></a><span class="hl line">  992 </span>                  <span class="hl sym">(</span>setf <span class="hl sym">(</span><span class="hl kwa">car</span> s<span class="hl sym">) (</span>get-universal-time<span class="hl sym">)))</span>
     1081<a id="l_993"></a><span class="hl line">  993 </span>                 <span class="hl sym">(</span>s
     1082<a id="l_994"></a><span class="hl line">  994 </span>                  #<span class="hl sym">+</span>clisp
     1083<a id="l_995"></a><span class="hl line">  995 </span>                  <span class="hl sym">(</span>sysdef-error <span class="hl str">&quot;Cannot redefine the existing system ~A with a different class&quot;</span> s<span class="hl sym">)</span>
     1084<a id="l_996"></a><span class="hl line">  996 </span>                  #-clisp
     1085<a id="l_997"></a><span class="hl line">  997 </span>                  <span class="hl sym">(</span>change-class <span class="hl sym">(</span><span class="hl kwa">cdr</span> s<span class="hl sym">) ',</span>class<span class="hl sym">))</span>
     1086<a id="l_998"></a><span class="hl line">  998 </span>                 <span class="hl sym">(</span>t
     1087<a id="l_999"></a><span class="hl line">  999 </span>                  <span class="hl sym">(</span>register-system <span class="hl sym">(</span><span class="hl kwa">quote</span> <span class="hl sym">,</span>name<span class="hl sym">)</span>
     1088<a id="l_1000"></a><span class="hl line"> 1000 </span>                                   <span class="hl sym">(</span>make-instance <span class="hl sym">',</span>class <span class="hl sym">:</span>name <span class="hl sym">',</span>name<span class="hl sym">)))))</span>
     1089<a id="l_1001"></a><span class="hl line"> 1001 </span>         <span class="hl sym">(</span>parse-component-form nil <span class="hl sym">(</span><span class="hl kwa">apply</span>
     1090<a id="l_1002"></a><span class="hl line"> 1002 </span>                                    #<span class="hl sym">'</span><span class="hl kwa">list</span>
     1091<a id="l_1003"></a><span class="hl line"> 1003 </span>                                    <span class="hl sym">:</span>module <span class="hl sym">(</span>coerce-name <span class="hl sym">',</span>name<span class="hl sym">)</span>
     1092<a id="l_1004"></a><span class="hl line"> 1004 </span>                                    <span class="hl sym">:</span>pathname
     1093<a id="l_1005"></a><span class="hl line"> 1005 </span>                                    <span class="hl slc">;; to avoid a note about unreachable code</span>
     1094<a id="l_1006"></a><span class="hl line"> 1006 </span>                                    <span class="hl sym">,(</span><span class="hl kwa">if</span> pathname-arg-p
     1095<a id="l_1007"></a><span class="hl line"> 1007 </span>                                         pathname
     1096<a id="l_1008"></a><span class="hl line"> 1008 </span>                                         `<span class="hl sym">(</span><span class="hl kwa">or</span> <span class="hl sym">(</span>when <span class="hl sym">*</span><span class="hl kwa">load</span>-truename<span class="hl sym">*</span>
     1097<a id="l_1009"></a><span class="hl line"> 1009 </span>                                                <span class="hl sym">(</span>pathname-sans-name<span class="hl sym">+</span><span class="hl kwa">type</span>
     1098<a id="l_1010"></a><span class="hl line"> 1010 </span>                                                 <span class="hl sym">(</span>resolve-symlinks
     1099<a id="l_1011"></a><span class="hl line"> 1011 </span>                                                  <span class="hl sym">*</span><span class="hl kwa">load</span>-truename<span class="hl sym">*)))</span>
     1100<a id="l_1012"></a><span class="hl line"> 1012 </span>                                              <span class="hl sym">*</span>default-pathname-defaults<span class="hl sym">*))</span>
     1101<a id="l_1013"></a><span class="hl line"> 1013 </span>                                    <span class="hl sym">',</span>component-options<span class="hl sym">))))))</span>
     1102<a id="l_1014"></a><span class="hl line"> 1014 </span>
     1103<a id="l_1015"></a><span class="hl line"> 1015 </span>
     1104<a id="l_1016"></a><span class="hl line"> 1016 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> class-for-<span class="hl kwa">type</span> <span class="hl sym">(</span>parent <span class="hl kwa">type</span><span class="hl sym">)</span>
     1105<a id="l_1017"></a><span class="hl line"> 1017 </span>  <span class="hl sym">(</span>let<span class="hl sym">* ((</span>extra-symbols <span class="hl sym">(</span><span class="hl kwa">list</span> <span class="hl sym">(</span>find-symbol <span class="hl sym">(</span>symbol-name <span class="hl kwa">type</span><span class="hl sym">) *</span>package<span class="hl sym">*)</span>
     1106<a id="l_1018"></a><span class="hl line"> 1018 </span>                              <span class="hl sym">(</span>find-symbol <span class="hl sym">(</span>symbol-name <span class="hl kwa">type</span><span class="hl sym">)</span>
     1107<a id="l_1019"></a><span class="hl line"> 1019 </span>                                           <span class="hl sym">(</span><span class="hl kwa">load</span>-time-value
     1108<a id="l_1020"></a><span class="hl line"> 1020 </span>                                            <span class="hl sym">(</span>package-name <span class="hl sym">:</span>asdf<span class="hl sym">)))))</span>
     1109<a id="l_1021"></a><span class="hl line"> 1021 </span>         <span class="hl sym">(</span>class <span class="hl sym">(</span>dolist <span class="hl sym">(</span>symbol <span class="hl sym">(</span><span class="hl kwa">if</span> <span class="hl sym">(</span>keywordp <span class="hl kwa">type</span><span class="hl sym">)</span>
     1110<a id="l_1022"></a><span class="hl line"> 1022 </span>                                    extra-symbols
     1111<a id="l_1023"></a><span class="hl line"> 1023 </span>                                    <span class="hl sym">(</span><span class="hl kwa">cons type</span> extra-symbols<span class="hl sym">)))</span>
     1112<a id="l_1024"></a><span class="hl line"> 1024 </span>                  <span class="hl sym">(</span>when <span class="hl sym">(</span><span class="hl kwa">and</span> symbol
     1113<a id="l_1025"></a><span class="hl line"> 1025 </span>                             <span class="hl sym">(</span>find-class symbol nil<span class="hl sym">)</span>
     1114<a id="l_1026"></a><span class="hl line"> 1026 </span>                             <span class="hl sym">(</span>subtypep symbol <span class="hl sym">'</span>component<span class="hl sym">))</span>
     1115<a id="l_1027"></a><span class="hl line"> 1027 </span>                    <span class="hl sym">(</span>return <span class="hl sym">(</span>find-class symbol<span class="hl sym">))))))</span>
     1116<a id="l_1028"></a><span class="hl line"> 1028 </span>    <span class="hl sym">(</span><span class="hl kwa">or</span> class
     1117<a id="l_1029"></a><span class="hl line"> 1029 </span>        <span class="hl sym">(</span><span class="hl kwa">and</span> <span class="hl sym">(</span><span class="hl kwa">eq type</span> <span class="hl sym">:</span>file<span class="hl sym">)</span>
     1118<a id="l_1030"></a><span class="hl line"> 1030 </span>             <span class="hl sym">(</span><span class="hl kwa">or</span> <span class="hl sym">(</span>module-default-component-class parent<span class="hl sym">)</span>
     1119<a id="l_1031"></a><span class="hl line"> 1031 </span>                 <span class="hl sym">(</span>find-class <span class="hl sym">'</span>cl-source-file<span class="hl sym">)))</span>
     1120<a id="l_1032"></a><span class="hl line"> 1032 </span>        <span class="hl sym">(</span>sysdef-error <span class="hl str">&quot;~&#64;&lt;don't recognize component type ~A~&#64;:&gt;&quot;</span> <span class="hl kwa">type</span><span class="hl sym">))))</span>
     1121<a id="l_1033"></a><span class="hl line"> 1033 </span>
     1122<a id="l_1034"></a><span class="hl line"> 1034 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> maybe-add-tree <span class="hl sym">(</span>tree op1 op2 c<span class="hl sym">)</span>
     1123<a id="l_1035"></a><span class="hl line"> 1035 </span>  <span class="hl str">&quot;Add the node C at /OP1/OP2 in TREE, unless it's there already.</span>
     1124<a id="l_1036"></a><span class="hl line"> 1036 </span><span class="hl str">Returns the new tree (which probably shares structure with the old one)&quot;</span>
     1125<a id="l_1037"></a><span class="hl line"> 1037 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>first-op-tree <span class="hl sym">(</span><span class="hl kwa">assoc</span> op1 tree<span class="hl sym">)))</span>
     1126<a id="l_1038"></a><span class="hl line"> 1038 </span>    <span class="hl sym">(</span><span class="hl kwa">if</span> first-op-tree
     1127<a id="l_1039"></a><span class="hl line"> 1039 </span>        <span class="hl sym">(</span><span class="hl kwa">progn</span>
     1128<a id="l_1040"></a><span class="hl line"> 1040 </span>          <span class="hl sym">(</span>aif <span class="hl sym">(</span><span class="hl kwa">assoc</span> op2 <span class="hl sym">(</span><span class="hl kwa">cdr</span> first-op-tree<span class="hl sym">))</span>
     1129<a id="l_1041"></a><span class="hl line"> 1041 </span>               <span class="hl sym">(</span><span class="hl kwa">if</span> <span class="hl sym">(</span>find c <span class="hl sym">(</span><span class="hl kwa">cdr</span> it<span class="hl sym">))</span>
     1130<a id="l_1042"></a><span class="hl line"> 1042 </span>                   nil
     1131<a id="l_1043"></a><span class="hl line"> 1043 </span>                   <span class="hl sym">(</span>setf <span class="hl sym">(</span><span class="hl kwa">cdr</span> it<span class="hl sym">) (</span><span class="hl kwa">cons</span> c <span class="hl sym">(</span><span class="hl kwa">cdr</span> it<span class="hl sym">))))</span>
     1132<a id="l_1044"></a><span class="hl line"> 1044 </span>               <span class="hl sym">(</span>setf <span class="hl sym">(</span><span class="hl kwa">cdr</span> first-op-tree<span class="hl sym">)</span>
     1133<a id="l_1045"></a><span class="hl line"> 1045 </span>                     <span class="hl sym">(</span>acons op2 <span class="hl sym">(</span><span class="hl kwa">list</span> c<span class="hl sym">) (</span><span class="hl kwa">cdr</span> first-op-tree<span class="hl sym">))))</span>
     1134<a id="l_1046"></a><span class="hl line"> 1046 </span>          tree<span class="hl sym">)</span>
     1135<a id="l_1047"></a><span class="hl line"> 1047 </span>        <span class="hl sym">(</span>acons op1 <span class="hl sym">(</span><span class="hl kwa">list</span> <span class="hl sym">(</span><span class="hl kwa">list</span> op2 c<span class="hl sym">))</span> tree<span class="hl sym">))))</span>
     1136<a id="l_1048"></a><span class="hl line"> 1048 </span>
     1137<a id="l_1049"></a><span class="hl line"> 1049 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> union-of-dependencies <span class="hl sym">(&amp;</span>rest deps<span class="hl sym">)</span>
     1138<a id="l_1050"></a><span class="hl line"> 1050 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>new-tree nil<span class="hl sym">))</span>
     1139<a id="l_1051"></a><span class="hl line"> 1051 </span>    <span class="hl sym">(</span>dolist <span class="hl sym">(</span>dep deps<span class="hl sym">)</span>
     1140<a id="l_1052"></a><span class="hl line"> 1052 </span>      <span class="hl sym">(</span>dolist <span class="hl sym">(</span>op-tree dep<span class="hl sym">)</span>
     1141<a id="l_1053"></a><span class="hl line"> 1053 </span>        <span class="hl sym">(</span>dolist <span class="hl sym">(</span>op  <span class="hl sym">(</span><span class="hl kwa">cdr</span> op-tree<span class="hl sym">))</span>
     1142<a id="l_1054"></a><span class="hl line"> 1054 </span>          <span class="hl sym">(</span>dolist <span class="hl sym">(</span>c <span class="hl sym">(</span><span class="hl kwa">cdr</span> op<span class="hl sym">))</span>
     1143<a id="l_1055"></a><span class="hl line"> 1055 </span>            <span class="hl sym">(</span>setf new-tree
     1144<a id="l_1056"></a><span class="hl line"> 1056 </span>                  <span class="hl sym">(</span>maybe-add-tree new-tree <span class="hl sym">(</span><span class="hl kwa">car</span> op-tree<span class="hl sym">) (</span><span class="hl kwa">car</span> op<span class="hl sym">)</span> c<span class="hl sym">))))))</span>
     1145<a id="l_1057"></a><span class="hl line"> 1057 </span>    new-tree<span class="hl sym">))</span>
     1146<a id="l_1058"></a><span class="hl line"> 1058 </span>
     1147<a id="l_1059"></a><span class="hl line"> 1059 </span>
     1148<a id="l_1060"></a><span class="hl line"> 1060 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> remove-keys <span class="hl sym">(</span>key-names args<span class="hl sym">)</span>
     1149<a id="l_1061"></a><span class="hl line"> 1061 </span>  <span class="hl sym">(</span>loop for <span class="hl sym">(</span> name val <span class="hl sym">)</span> on args by #<span class="hl sym">'</span><span class="hl kwa">cddr</span>
     1150<a id="l_1062"></a><span class="hl line"> 1062 </span>        unless <span class="hl sym">(</span><span class="hl kwa">member</span> <span class="hl sym">(</span>symbol-name name<span class="hl sym">)</span> key-names
     1151<a id="l_1063"></a><span class="hl line"> 1063 </span>                       <span class="hl sym">:</span>key #<span class="hl sym">'</span>symbol-name <span class="hl sym">:</span>test <span class="hl sym">'</span><span class="hl kwa">equal</span><span class="hl sym">)</span>
     1152<a id="l_1064"></a><span class="hl line"> 1064 </span>        <span class="hl kwa">append</span> <span class="hl sym">(</span><span class="hl kwa">list</span> name val<span class="hl sym">)))</span>
     1153<a id="l_1065"></a><span class="hl line"> 1065 </span>
     1154<a id="l_1066"></a><span class="hl line"> 1066 </span><span class="hl sym">(</span>defvar <span class="hl sym">*</span>serial-depends-on<span class="hl sym">*)</span>
     1155<a id="l_1067"></a><span class="hl line"> 1067 </span>
     1156<a id="l_1068"></a><span class="hl line"> 1068 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> parse-component-form <span class="hl sym">(</span>parent options<span class="hl sym">)</span>
     1157<a id="l_1069"></a><span class="hl line"> 1069 </span>
     1158<a id="l_1070"></a><span class="hl line"> 1070 </span>  <span class="hl sym">(</span>destructuring-bind
     1159<a id="l_1071"></a><span class="hl line"> 1071 </span>        <span class="hl sym">(</span><span class="hl kwa">type</span> name <span class="hl sym">&amp;</span>rest rest <span class="hl sym">&amp;</span>key
     1160<a id="l_1072"></a><span class="hl line"> 1072 </span>              <span class="hl slc">;; the following list of keywords is reproduced below in the</span>
     1161<a id="l_1073"></a><span class="hl line"> 1073 </span>              <span class="hl slc">;; remove-keys form.  important to keep them in sync</span>
     1162<a id="l_1074"></a><span class="hl line"> 1074 </span>              components pathname default-component-class
     1163<a id="l_1075"></a><span class="hl line"> 1075 </span>              perform explain output-files operation-done-p
     1164<a id="l_1076"></a><span class="hl line"> 1076 </span>              weakly-depends-on
     1165<a id="l_1077"></a><span class="hl line"> 1077 </span>              depends-on serial in-order-to
     1166<a id="l_1078"></a><span class="hl line"> 1078 </span>              <span class="hl slc">;; list ends</span>
     1167<a id="l_1079"></a><span class="hl line"> 1079 </span>              <span class="hl sym">&amp;</span>allow-other-keys<span class="hl sym">)</span> options
     1168<a id="l_1080"></a><span class="hl line"> 1080 </span>    <span class="hl sym">(</span>declare <span class="hl sym">(</span>ignorable perform explain output-files operation-done-p<span class="hl sym">))</span>
     1169<a id="l_1081"></a><span class="hl line"> 1081 </span>    <span class="hl sym">(</span>check-component-input <span class="hl kwa">type</span> name weakly-depends-on depends-on components in-order-to<span class="hl sym">)</span>
     1170<a id="l_1082"></a><span class="hl line"> 1082 </span>
     1171<a id="l_1083"></a><span class="hl line"> 1083 </span>    <span class="hl sym">(</span>when <span class="hl sym">(</span><span class="hl kwa">and</span> parent
     1172<a id="l_1084"></a><span class="hl line"> 1084 </span>               <span class="hl sym">(</span>find-component parent name<span class="hl sym">)</span>
     1173<a id="l_1085"></a><span class="hl line"> 1085 </span>               <span class="hl slc">;; ignore the same object when rereading the defsystem</span>
     1174<a id="l_1086"></a><span class="hl line"> 1086 </span>               <span class="hl sym">(</span><span class="hl kwa">not</span>
     1175<a id="l_1087"></a><span class="hl line"> 1087 </span>                <span class="hl sym">(</span>typep <span class="hl sym">(</span>find-component parent name<span class="hl sym">)</span>
     1176<a id="l_1088"></a><span class="hl line"> 1088 </span>                       <span class="hl sym">(</span>class-for-<span class="hl kwa">type</span> parent <span class="hl kwa">type</span><span class="hl sym">))))</span>
     1177<a id="l_1089"></a><span class="hl line"> 1089 </span>      <span class="hl sym">(</span>error <span class="hl sym">'</span>duplicate-names <span class="hl sym">:</span>name name<span class="hl sym">))</span>
     1178<a id="l_1090"></a><span class="hl line"> 1090 </span>
     1179<a id="l_1091"></a><span class="hl line"> 1091 </span>    <span class="hl sym">(</span>let<span class="hl sym">* ((</span>other-args <span class="hl sym">(</span>remove-keys
     1180<a id="l_1092"></a><span class="hl line"> 1092 </span>                        <span class="hl sym">'(</span>components pathname default-component-class
     1181<a id="l_1093"></a><span class="hl line"> 1093 </span>                          perform explain output-files operation-done-p
     1182<a id="l_1094"></a><span class="hl line"> 1094 </span>                          weakly-depends-on
     1183<a id="l_1095"></a><span class="hl line"> 1095 </span>                          depends-on serial in-order-to<span class="hl sym">)</span>
     1184<a id="l_1096"></a><span class="hl line"> 1096 </span>                        rest<span class="hl sym">))</span>
     1185<a id="l_1097"></a><span class="hl line"> 1097 </span>           <span class="hl sym">(</span>ret
     1186<a id="l_1098"></a><span class="hl line"> 1098 </span>            <span class="hl sym">(</span><span class="hl kwa">or</span> <span class="hl sym">(</span>find-component parent name<span class="hl sym">)</span>
     1187<a id="l_1099"></a><span class="hl line"> 1099 </span>                <span class="hl sym">(</span>make-instance <span class="hl sym">(</span>class-for-<span class="hl kwa">type</span> parent <span class="hl kwa">type</span><span class="hl sym">)))))</span>
     1188<a id="l_1100"></a><span class="hl line"> 1100 </span>      <span class="hl sym">(</span>when weakly-depends-on
     1189<a id="l_1101"></a><span class="hl line"> 1101 </span>        <span class="hl sym">(</span>setf depends-on <span class="hl sym">(</span><span class="hl kwa">append</span> depends-on <span class="hl sym">(</span>remove-<span class="hl kwa">if</span> <span class="hl sym">(</span>complement #<span class="hl sym">'</span>find-system<span class="hl sym">)</span> weakly-depends-on<span class="hl sym">))))</span>
     1190<a id="l_1102"></a><span class="hl line"> 1102 </span>      <span class="hl sym">(</span>when <span class="hl sym">(</span><span class="hl kwa">boundp</span> <span class="hl sym">'*</span>serial-depends-on<span class="hl sym">*)</span>
     1191<a id="l_1103"></a><span class="hl line"> 1103 </span>        <span class="hl sym">(</span>setf depends-on
     1192<a id="l_1104"></a><span class="hl line"> 1104 </span>              <span class="hl sym">(</span>concatenate <span class="hl sym">'</span><span class="hl kwa">list</span> <span class="hl sym">*</span>serial-depends-on<span class="hl sym">*</span> depends-on<span class="hl sym">)))</span>
     1193<a id="l_1105"></a><span class="hl line"> 1105 </span>      <span class="hl sym">(</span><span class="hl kwa">apply</span> #<span class="hl sym">'</span>reinitialize-instance ret
     1194<a id="l_1106"></a><span class="hl line"> 1106 </span>             <span class="hl sym">:</span>name <span class="hl sym">(</span>coerce-name name<span class="hl sym">)</span>
     1195<a id="l_1107"></a><span class="hl line"> 1107 </span>             <span class="hl sym">:</span>pathname pathname
     1196<a id="l_1108"></a><span class="hl line"> 1108 </span>             <span class="hl sym">:</span>parent parent
     1197<a id="l_1109"></a><span class="hl line"> 1109 </span>             other-args<span class="hl sym">)</span>
     1198<a id="l_1110"></a><span class="hl line"> 1110 </span>      <span class="hl sym">(</span>when <span class="hl sym">(</span>typep ret <span class="hl sym">'</span>module<span class="hl sym">)</span>
     1199<a id="l_1111"></a><span class="hl line"> 1111 </span>        <span class="hl sym">(</span>setf <span class="hl sym">(</span>module-default-component-class ret<span class="hl sym">)</span>
     1200<a id="l_1112"></a><span class="hl line"> 1112 </span>              <span class="hl sym">(</span><span class="hl kwa">or</span> default-component-class
     1201<a id="l_1113"></a><span class="hl line"> 1113 </span>                  <span class="hl sym">(</span><span class="hl kwa">and</span> <span class="hl sym">(</span>typep parent <span class="hl sym">'</span>module<span class="hl sym">)</span>
     1202<a id="l_1114"></a><span class="hl line"> 1114 </span>                       <span class="hl sym">(</span>module-default-component-class parent<span class="hl sym">))))</span>
     1203<a id="l_1115"></a><span class="hl line"> 1115 </span>        <span class="hl sym">(</span>let <span class="hl sym">((*</span>serial-depends-on<span class="hl sym">*</span> nil<span class="hl sym">))</span>
     1204<a id="l_1116"></a><span class="hl line"> 1116 </span>          <span class="hl sym">(</span>setf <span class="hl sym">(</span>module-components ret<span class="hl sym">)</span>
     1205<a id="l_1117"></a><span class="hl line"> 1117 </span>                <span class="hl sym">(</span>loop for c-form in components
     1206<a id="l_1118"></a><span class="hl line"> 1118 </span>                      for c <span class="hl sym">= (</span>parse-component-form ret c-form<span class="hl sym">)</span>
     1207<a id="l_1119"></a><span class="hl line"> 1119 </span>                      collect c
     1208<a id="l_1120"></a><span class="hl line"> 1120 </span>                      <span class="hl kwa">if</span> serial
     1209<a id="l_1121"></a><span class="hl line"> 1121 </span>                      do <span class="hl sym">(</span>push <span class="hl sym">(</span>component-name c<span class="hl sym">) *</span>serial-depends-on<span class="hl sym">*))))</span>
     1210<a id="l_1122"></a><span class="hl line"> 1122 </span>
     1211<a id="l_1123"></a><span class="hl line"> 1123 </span>        <span class="hl slc">;; check for duplicate names</span>
     1212<a id="l_1124"></a><span class="hl line"> 1124 </span>        <span class="hl sym">(</span>let <span class="hl sym">((</span>name-hash <span class="hl sym">(</span>make-hash-table <span class="hl sym">:</span>test #<span class="hl sym">'</span><span class="hl kwa">equal</span><span class="hl sym">)))</span>
     1213<a id="l_1125"></a><span class="hl line"> 1125 </span>          <span class="hl sym">(</span>loop for c in <span class="hl sym">(</span>module-components ret<span class="hl sym">)</span>
     1214<a id="l_1126"></a><span class="hl line"> 1126 </span>                do
     1215<a id="l_1127"></a><span class="hl line"> 1127 </span>                <span class="hl sym">(</span><span class="hl kwa">if</span> <span class="hl sym">(</span>gethash <span class="hl sym">(</span>component-name c<span class="hl sym">)</span>
     1216<a id="l_1128"></a><span class="hl line"> 1128 </span>                             name-hash<span class="hl sym">)</span>
     1217<a id="l_1129"></a><span class="hl line"> 1129 </span>                    <span class="hl sym">(</span>error <span class="hl sym">'</span>duplicate-names
     1218<a id="l_1130"></a><span class="hl line"> 1130 </span>                           <span class="hl sym">:</span>name <span class="hl sym">(</span>component-name c<span class="hl sym">))</span>
     1219<a id="l_1131"></a><span class="hl line"> 1131 </span>                    <span class="hl sym">(</span>setf <span class="hl sym">(</span>gethash <span class="hl sym">(</span>component-name c<span class="hl sym">)</span>
     1220<a id="l_1132"></a><span class="hl line"> 1132 </span>                                   name-hash<span class="hl sym">)</span>
     1221<a id="l_1133"></a><span class="hl line"> 1133 </span>                          t<span class="hl sym">)))))</span>
     1222<a id="l_1134"></a><span class="hl line"> 1134 </span>
     1223<a id="l_1135"></a><span class="hl line"> 1135 </span>      <span class="hl sym">(</span>setf <span class="hl sym">(</span>slot-value ret <span class="hl sym">'</span>in-order-to<span class="hl sym">)</span>
     1224<a id="l_1136"></a><span class="hl line"> 1136 </span>            <span class="hl sym">(</span>union-of-dependencies
     1225<a id="l_1137"></a><span class="hl line"> 1137 </span>             in-order-to
     1226<a id="l_1138"></a><span class="hl line"> 1138 </span>             `<span class="hl sym">((</span>compile-op <span class="hl sym">(</span>compile-op <span class="hl sym">,</span>&#64;depends-on<span class="hl sym">))</span>
     1227<a id="l_1139"></a><span class="hl line"> 1139 </span>               <span class="hl sym">(</span><span class="hl kwa">load</span>-op <span class="hl sym">(</span><span class="hl kwa">load</span>-op <span class="hl sym">,</span>&#64;depends-on<span class="hl sym">))))</span>
     1228<a id="l_1140"></a><span class="hl line"> 1140 </span>            <span class="hl sym">(</span>slot-value ret <span class="hl sym">'</span>do-first<span class="hl sym">)</span> `<span class="hl sym">((</span>compile-op <span class="hl sym">(</span><span class="hl kwa">load</span>-op <span class="hl sym">,</span>&#64;depends-on<span class="hl sym">))))</span>
     1229<a id="l_1141"></a><span class="hl line"> 1141 </span>
     1230<a id="l_1142"></a><span class="hl line"> 1142 </span>      <span class="hl sym">(</span>%remove-component-inline-methods ret rest<span class="hl sym">)</span>
     1231<a id="l_1143"></a><span class="hl line"> 1143 </span>
     1232<a id="l_1144"></a><span class="hl line"> 1144 </span>      ret<span class="hl sym">)))</span>
     1233<a id="l_1145"></a><span class="hl line"> 1145 </span>
     1234<a id="l_1146"></a><span class="hl line"> 1146 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> %remove-component-inline-methods <span class="hl sym">(</span>ret rest<span class="hl sym">)</span>
     1235<a id="l_1147"></a><span class="hl line"> 1147 </span>  <span class="hl sym">(</span>loop for name in <span class="hl sym">+</span>asdf-methods<span class="hl sym">+</span>
     1236<a id="l_1148"></a><span class="hl line"> 1148 </span>        do <span class="hl sym">(</span>map <span class="hl sym">'</span>nil
     1237<a id="l_1149"></a><span class="hl line"> 1149 </span>                <span class="hl slc">;; this is inefficient as most of the stored</span>
     1238<a id="l_1150"></a><span class="hl line"> 1150 </span>                <span class="hl slc">;; methods will not be for this particular gf n</span>
     1239<a id="l_1151"></a><span class="hl line"> 1151 </span>                <span class="hl slc">;; But this is hardly performance-critical</span>
     1240<a id="l_1152"></a><span class="hl line"> 1152 </span>                <span class="hl sym">(</span><span class="hl kwa">lambda</span> <span class="hl sym">(</span>m<span class="hl sym">)</span>
     1241<a id="l_1153"></a><span class="hl line"> 1153 </span>                  <span class="hl sym">(</span>remove-method <span class="hl sym">(</span>symbol-function name<span class="hl sym">)</span> m<span class="hl sym">))</span>
     1242<a id="l_1154"></a><span class="hl line"> 1154 </span>                <span class="hl sym">(</span>component-inline-methods ret<span class="hl sym">)))</span>
     1243<a id="l_1155"></a><span class="hl line"> 1155 </span>  <span class="hl slc">;; clear methods, then add the new ones</span>
     1244<a id="l_1156"></a><span class="hl line"> 1156 </span>  <span class="hl sym">(</span>setf <span class="hl sym">(</span>component-inline-methods ret<span class="hl sym">)</span> nil<span class="hl sym">)</span>
     1245<a id="l_1157"></a><span class="hl line"> 1157 </span>  <span class="hl sym">(</span>loop for name in <span class="hl sym">+</span>asdf-methods<span class="hl sym">+</span>
     1246<a id="l_1158"></a><span class="hl line"> 1158 </span>        for v <span class="hl sym">= (</span>getf rest <span class="hl sym">(</span>intern <span class="hl sym">(</span>symbol-name name<span class="hl sym">) :</span>keyword<span class="hl sym">))</span>
     1247<a id="l_1159"></a><span class="hl line"> 1159 </span>        when v do
     1248<a id="l_1160"></a><span class="hl line"> 1160 </span>        <span class="hl sym">(</span>destructuring-bind <span class="hl sym">(</span>op qual <span class="hl sym">(</span>o c<span class="hl sym">) &amp;</span>body body<span class="hl sym">)</span> v
     1249<a id="l_1161"></a><span class="hl line"> 1161 </span>          <span class="hl sym">(</span>pushnew
     1250<a id="l_1162"></a><span class="hl line"> 1162 </span>           <span class="hl sym">(</span><span class="hl kwa">eval</span> `<span class="hl sym">(</span>defmethod <span class="hl sym">,</span>name <span class="hl sym">,</span>qual <span class="hl sym">((,</span>o <span class="hl sym">,</span>op<span class="hl sym">) (,</span>c <span class="hl sym">(</span>eql <span class="hl sym">,</span>ret<span class="hl sym">)))</span>
     1251<a id="l_1163"></a><span class="hl line"> 1163 </span>                             <span class="hl sym">,</span>&#64;body<span class="hl sym">))</span>
     1252<a id="l_1164"></a><span class="hl line"> 1164 </span>           <span class="hl sym">(</span>component-inline-methods ret<span class="hl sym">)))))</span>
     1253<a id="l_1165"></a><span class="hl line"> 1165 </span>
     1254<a id="l_1166"></a><span class="hl line"> 1166 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> check-component-input <span class="hl sym">(</span><span class="hl kwa">type</span> name weakly-depends-on depends-on components in-order-to<span class="hl sym">)</span>
     1255<a id="l_1167"></a><span class="hl line"> 1167 </span>  <span class="hl str">&quot;A partial test of the values of a component.&quot;</span>
     1256<a id="l_1168"></a><span class="hl line"> 1168 </span>  <span class="hl sym">(</span>when weakly-depends-on <span class="hl sym">(</span>warn <span class="hl str">&quot;We got one! XXXXX&quot;</span><span class="hl sym">))</span>
     1257<a id="l_1169"></a><span class="hl line"> 1169 </span>  <span class="hl sym">(</span>unless <span class="hl sym">(</span><span class="hl kwa">listp</span> depends-on<span class="hl sym">)</span>
     1258<a id="l_1170"></a><span class="hl line"> 1170 </span>    <span class="hl sym">(</span>sysdef-error-component <span class="hl str">&quot;:depends-on must be a list.&quot;</span>
     1259<a id="l_1171"></a><span class="hl line"> 1171 </span>                            <span class="hl kwa">type</span> name depends-on<span class="hl sym">))</span>
     1260<a id="l_1172"></a><span class="hl line"> 1172 </span>  <span class="hl sym">(</span>unless <span class="hl sym">(</span><span class="hl kwa">listp</span> weakly-depends-on<span class="hl sym">)</span>
     1261<a id="l_1173"></a><span class="hl line"> 1173 </span>    <span class="hl sym">(</span>sysdef-error-component <span class="hl str">&quot;:weakly-depends-on must be a list.&quot;</span>
     1262<a id="l_1174"></a><span class="hl line"> 1174 </span>                            <span class="hl kwa">type</span> name weakly-depends-on<span class="hl sym">))</span>
     1263<a id="l_1175"></a><span class="hl line"> 1175 </span>  <span class="hl sym">(</span>unless <span class="hl sym">(</span><span class="hl kwa">listp</span> components<span class="hl sym">)</span>
     1264<a id="l_1176"></a><span class="hl line"> 1176 </span>    <span class="hl sym">(</span>sysdef-error-component <span class="hl str">&quot;:components must be NIL or a list of components.&quot;</span>
     1265<a id="l_1177"></a><span class="hl line"> 1177 </span>                            <span class="hl kwa">type</span> name components<span class="hl sym">))</span>
     1266<a id="l_1178"></a><span class="hl line"> 1178 </span>  <span class="hl sym">(</span>unless <span class="hl sym">(</span><span class="hl kwa">and</span> <span class="hl sym">(</span><span class="hl kwa">listp</span> in-order-to<span class="hl sym">) (</span><span class="hl kwa">listp</span> <span class="hl sym">(</span><span class="hl kwa">car</span> in-order-to<span class="hl sym">)))</span>
     1267<a id="l_1179"></a><span class="hl line"> 1179 </span>    <span class="hl sym">(</span>sysdef-error-component <span class="hl str">&quot;:in-order-to must be NIL or a list of components.&quot;</span>
     1268<a id="l_1180"></a><span class="hl line"> 1180 </span>                            <span class="hl kwa">type</span> name in-order-to<span class="hl sym">)))</span>
     1269<a id="l_1181"></a><span class="hl line"> 1181 </span>
     1270<a id="l_1182"></a><span class="hl line"> 1182 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> sysdef-error-component <span class="hl sym">(</span>msg <span class="hl kwa">type</span> name value<span class="hl sym">)</span>
     1271<a id="l_1183"></a><span class="hl line"> 1183 </span>  <span class="hl sym">(</span>sysdef-error <span class="hl sym">(</span>concatenate <span class="hl sym">'</span>string msg
     1272<a id="l_1184"></a><span class="hl line"> 1184 </span>                             <span class="hl str">&quot;~&amp;The value specified for ~(~A~) ~A is ~W&quot;</span><span class="hl sym">)</span>
     1273<a id="l_1185"></a><span class="hl line"> 1185 </span>                <span class="hl kwa">type</span> name value<span class="hl sym">))</span>
     1274<a id="l_1186"></a><span class="hl line"> 1186 </span>
     1275<a id="l_1187"></a><span class="hl line"> 1187 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> resolve-symlinks <span class="hl sym">(</span>path<span class="hl sym">)</span>
     1276<a id="l_1188"></a><span class="hl line"> 1188 </span>  #-allegro <span class="hl sym">(</span>truename path<span class="hl sym">)</span>
     1277<a id="l_1189"></a><span class="hl line"> 1189 </span>  #<span class="hl sym">+</span>allegro <span class="hl sym">(</span>excl<span class="hl sym">:</span>pathname-resolve-symbolic-links path<span class="hl sym">)</span>
     1278<a id="l_1190"></a><span class="hl line"> 1190 </span>  <span class="hl sym">)</span>
     1279<a id="l_1191"></a><span class="hl line"> 1191 </span>
     1280<a id="l_1192"></a><span class="hl line"> 1192 </span><span class="hl slc">;;; optional extras</span>
     1281<a id="l_1193"></a><span class="hl line"> 1193 </span>
     1282<a id="l_1194"></a><span class="hl line"> 1194 </span><span class="hl slc">;;; run-shell-command functions for other lisp implementations will be</span>
     1283<a id="l_1195"></a><span class="hl line"> 1195 </span><span class="hl slc">;;; gratefully accepted, if they do the same thing.  If the docstring</span>
     1284<a id="l_1196"></a><span class="hl line"> 1196 </span><span class="hl slc">;;; is ambiguous, send a bug report</span>
     1285<a id="l_1197"></a><span class="hl line"> 1197 </span>
     1286<a id="l_1198"></a><span class="hl line"> 1198 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> run-shell-<span class="hl kwa">command</span> <span class="hl sym">(</span>control-string <span class="hl sym">&amp;</span>rest args<span class="hl sym">)</span>
     1287<a id="l_1199"></a><span class="hl line"> 1199 </span>  <span class="hl str">&quot;Interpolate ARGS into CONTROL-STRING as if by FORMAT, and</span>
     1288<a id="l_1200"></a><span class="hl line"> 1200 </span><span class="hl str">synchronously execute the result using a Bourne-compatible shell, with</span>
     1289<a id="l_1201"></a><span class="hl line"> 1201 </span><span class="hl str">output to *VERBOSE-OUT*.  Returns the shell's exit code.&quot;</span>
     1290<a id="l_1202"></a><span class="hl line"> 1202 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span><span class="hl kwa">command</span> <span class="hl sym">(</span><span class="hl kwa">apply</span> #<span class="hl sym">'</span>format nil control-string args<span class="hl sym">)))</span>
     1291<a id="l_1203"></a><span class="hl line"> 1203 </span>    <span class="hl sym">(</span>format <span class="hl sym">*</span>verbose-out<span class="hl sym">*</span> <span class="hl str">&quot;; $ ~A~%&quot;</span> <span class="hl kwa">command</span><span class="hl sym">)</span>
     1292<a id="l_1204"></a><span class="hl line"> 1204 </span>    #<span class="hl sym">+</span>sbcl
     1293<a id="l_1205"></a><span class="hl line"> 1205 </span>    <span class="hl sym">(</span>sb-ext<span class="hl sym">:</span>process-<span class="hl kwa">exit</span>-code
     1294<a id="l_1206"></a><span class="hl line"> 1206 </span>     <span class="hl sym">(</span>sb-ext<span class="hl sym">:</span>run-program
     1295<a id="l_1207"></a><span class="hl line"> 1207 </span>      #<span class="hl sym">+</span>win32 <span class="hl str">&quot;sh&quot;</span> #-win32 <span class="hl str">&quot;/bin/sh&quot;</span>
     1296<a id="l_1208"></a><span class="hl line"> 1208 </span>      <span class="hl sym">(</span><span class="hl kwa">list</span>  <span class="hl str">&quot;-c&quot;</span> <span class="hl kwa">command</span><span class="hl sym">)</span>
     1297<a id="l_1209"></a><span class="hl line"> 1209 </span>      #<span class="hl sym">+</span>win32 #<span class="hl sym">+</span>win32 <span class="hl sym">:</span>search t
     1298<a id="l_1210"></a><span class="hl line"> 1210 </span>      <span class="hl sym">:</span>input nil <span class="hl sym">:</span>output <span class="hl sym">*</span>verbose-out<span class="hl sym">*))</span>
     1299<a id="l_1211"></a><span class="hl line"> 1211 </span>
     1300<a id="l_1212"></a><span class="hl line"> 1212 </span>    #<span class="hl sym">+(</span><span class="hl kwa">or</span> cmu scl<span class="hl sym">)</span>
     1301<a id="l_1213"></a><span class="hl line"> 1213 </span>    <span class="hl sym">(</span>ext<span class="hl sym">:</span>process-<span class="hl kwa">exit</span>-code
     1302<a id="l_1214"></a><span class="hl line"> 1214 </span>     <span class="hl sym">(</span>ext<span class="hl sym">:</span>run-program
     1303<a id="l_1215"></a><span class="hl line"> 1215 </span>      <span class="hl str">&quot;/bin/sh&quot;</span>
     1304<a id="l_1216"></a><span class="hl line"> 1216 </span>      <span class="hl sym">(</span><span class="hl kwa">list</span>  <span class="hl str">&quot;-c&quot;</span> <span class="hl kwa">command</span><span class="hl sym">)</span>
     1305<a id="l_1217"></a><span class="hl line"> 1217 </span>      <span class="hl sym">:</span>input nil <span class="hl sym">:</span>output <span class="hl sym">*</span>verbose-out<span class="hl sym">*))</span>
     1306<a id="l_1218"></a><span class="hl line"> 1218 </span>
     1307<a id="l_1219"></a><span class="hl line"> 1219 </span>    #<span class="hl sym">+</span>allegro
     1308<a id="l_1220"></a><span class="hl line"> 1220 </span>    <span class="hl sym">(</span>excl<span class="hl sym">:</span>run-shell-<span class="hl kwa">command command</span> <span class="hl sym">:</span>input nil <span class="hl sym">:</span>output <span class="hl sym">*</span>verbose-out<span class="hl sym">*)</span>
     1309<a id="l_1221"></a><span class="hl line"> 1221 </span>
     1310<a id="l_1222"></a><span class="hl line"> 1222 </span>    #<span class="hl sym">+</span>lispworks
     1311<a id="l_1223"></a><span class="hl line"> 1223 </span>    <span class="hl sym">(</span>system<span class="hl sym">:</span>call-system-showing-output
     1312<a id="l_1224"></a><span class="hl line"> 1224 </span>     <span class="hl kwa">command</span>
     1313<a id="l_1225"></a><span class="hl line"> 1225 </span>     <span class="hl sym">:</span>shell-<span class="hl kwa">type</span> <span class="hl str">&quot;/bin/sh&quot;</span>
     1314<a id="l_1226"></a><span class="hl line"> 1226 </span>     <span class="hl sym">:</span>output-stream <span class="hl sym">*</span>verbose-out<span class="hl sym">*)</span>
     1315<a id="l_1227"></a><span class="hl line"> 1227 </span>
     1316<a id="l_1228"></a><span class="hl line"> 1228 </span>    #<span class="hl sym">+</span>clisp                     <span class="hl slc">;XXX not exactly *verbose-out*, I know</span>
     1317<a id="l_1229"></a><span class="hl line"> 1229 </span>    <span class="hl sym">(</span>ext<span class="hl sym">:</span>run-shell-<span class="hl kwa">command  command</span> <span class="hl sym">:</span>output <span class="hl sym">:</span>terminal <span class="hl sym">:</span>wait t<span class="hl sym">)</span>
     1318<a id="l_1230"></a><span class="hl line"> 1230 </span>
     1319<a id="l_1231"></a><span class="hl line"> 1231 </span>    #<span class="hl sym">+</span>openmcl
     1320<a id="l_1232"></a><span class="hl line"> 1232 </span>    <span class="hl sym">(</span><span class="hl kwa">nth</span>-value <span class="hl num">1</span>
     1321<a id="l_1233"></a><span class="hl line"> 1233 </span>               <span class="hl sym">(</span>ccl<span class="hl sym">:</span>external-process-status
     1322<a id="l_1234"></a><span class="hl line"> 1234 </span>                <span class="hl sym">(</span>ccl<span class="hl sym">:</span>run-program <span class="hl str">&quot;/bin/sh&quot;</span> <span class="hl sym">(</span><span class="hl kwa">list</span> <span class="hl str">&quot;-c&quot;</span> <span class="hl kwa">command</span><span class="hl sym">)</span>
     1323<a id="l_1235"></a><span class="hl line"> 1235 </span>                                 <span class="hl sym">:</span>input nil <span class="hl sym">:</span>output <span class="hl sym">*</span>verbose-out<span class="hl sym">*</span>
     1324<a id="l_1236"></a><span class="hl line"> 1236 </span>                                 <span class="hl sym">:</span>wait t<span class="hl sym">)))</span>
     1325<a id="l_1237"></a><span class="hl line"> 1237 </span>    #<span class="hl sym">+</span>ecl <span class="hl slc">;; courtesy of Juan Jose Garcia Ripoll</span>
     1326<a id="l_1238"></a><span class="hl line"> 1238 </span>    <span class="hl sym">(</span>si<span class="hl sym">:</span>system <span class="hl kwa">command</span><span class="hl sym">)</span>
     1327<a id="l_1239"></a><span class="hl line"> 1239 </span>    #-<span class="hl sym">(</span><span class="hl kwa">or</span> openmcl clisp lispworks allegro scl cmu sbcl ecl<span class="hl sym">)</span>
     1328<a id="l_1240"></a><span class="hl line"> 1240 </span>    <span class="hl sym">(</span>error <span class="hl str">&quot;RUN-SHELL-PROGRAM not implemented for this Lisp&quot;</span><span class="hl sym">)</span>
     1329<a id="l_1241"></a><span class="hl line"> 1241 </span>    <span class="hl sym">))</span>
     1330<a id="l_1242"></a><span class="hl line"> 1242 </span>
     1331<a id="l_1243"></a><span class="hl line"> 1243 </span>
     1332<a id="l_1244"></a><span class="hl line"> 1244 </span><span class="hl sym">(</span>defgeneric hyperdocumentation <span class="hl sym">(</span>package name doc-<span class="hl kwa">type</span><span class="hl sym">))</span>
     1333<a id="l_1245"></a><span class="hl line"> 1245 </span><span class="hl sym">(</span>defmethod hyperdocumentation <span class="hl sym">((</span>package symbol<span class="hl sym">)</span> name doc-<span class="hl kwa">type</span><span class="hl sym">)</span>
     1334<a id="l_1246"></a><span class="hl line"> 1246 </span>  <span class="hl sym">(</span>hyperdocumentation <span class="hl sym">(</span>find-package package<span class="hl sym">)</span> name doc-<span class="hl kwa">type</span><span class="hl sym">))</span>
     1335<a id="l_1247"></a><span class="hl line"> 1247 </span>
     1336<a id="l_1248"></a><span class="hl line"> 1248 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> hyperdoc <span class="hl sym">(</span>name doc-<span class="hl kwa">type</span><span class="hl sym">)</span>
     1337<a id="l_1249"></a><span class="hl line"> 1249 </span>  <span class="hl sym">(</span>hyperdocumentation <span class="hl sym">(</span>symbol-package name<span class="hl sym">)</span> name doc-<span class="hl kwa">type</span><span class="hl sym">))</span>
     1338<a id="l_1250"></a><span class="hl line"> 1250 </span>
     1339<a id="l_1251"></a><span class="hl line"> 1251 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> system-source-file <span class="hl sym">(</span>system-name<span class="hl sym">)</span>
     1340<a id="l_1252"></a><span class="hl line"> 1252 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>system <span class="hl sym">(</span>asdf<span class="hl sym">:</span>find-system system-name<span class="hl sym">)))</span>
     1341<a id="l_1253"></a><span class="hl line"> 1253 </span>    <span class="hl sym">(</span>make-pathname
     1342<a id="l_1254"></a><span class="hl line"> 1254 </span>     <span class="hl sym">:</span><span class="hl kwa">type</span> <span class="hl str">&quot;asd&quot;</span>
     1343<a id="l_1255"></a><span class="hl line"> 1255 </span>     <span class="hl sym">:</span>name <span class="hl sym">(</span>asdf<span class="hl sym">:</span>component-name system<span class="hl sym">)</span>
     1344<a id="l_1256"></a><span class="hl line"> 1256 </span>     <span class="hl sym">:</span>defaults <span class="hl sym">(</span>asdf<span class="hl sym">:</span>component-relative-pathname system<span class="hl sym">))))</span>
     1345<a id="l_1257"></a><span class="hl line"> 1257 </span>
     1346<a id="l_1258"></a><span class="hl line"> 1258 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> system-source-directory <span class="hl sym">(</span>system-name<span class="hl sym">)</span>
     1347<a id="l_1259"></a><span class="hl line"> 1259 </span>  <span class="hl sym">(</span>make-pathname <span class="hl sym">:</span>name nil
     1348<a id="l_1260"></a><span class="hl line"> 1260 </span>                 <span class="hl sym">:</span><span class="hl kwa">type</span> nil
     1349<a id="l_1261"></a><span class="hl line"> 1261 </span>                 <span class="hl sym">:</span>defaults <span class="hl sym">(</span>system-source-file system-name<span class="hl sym">)))</span>
     1350<a id="l_1262"></a><span class="hl line"> 1262 </span>
     1351<a id="l_1263"></a><span class="hl line"> 1263 </span><span class="hl sym">(</span><span class="hl kwa">defun</span> system-relative-pathname <span class="hl sym">(</span>system pathname <span class="hl sym">&amp;</span>key name <span class="hl kwa">type</span><span class="hl sym">)</span>
     1352<a id="l_1264"></a><span class="hl line"> 1264 </span>  <span class="hl sym">(</span>let <span class="hl sym">((</span>directory <span class="hl sym">(</span>pathname-directory pathname<span class="hl sym">)))</span>
     1353<a id="l_1265"></a><span class="hl line"> 1265 </span>    <span class="hl sym">(</span>when <span class="hl sym">(</span><span class="hl kwa">eq</span> <span class="hl sym">(</span><span class="hl kwa">car</span> directory<span class="hl sym">) :</span>absolute<span class="hl sym">)</span>
     1354<a id="l_1266"></a><span class="hl line"> 1266 </span>      <span class="hl sym">(</span>setf <span class="hl sym">(</span><span class="hl kwa">car</span> directory<span class="hl sym">) :</span>relative<span class="hl sym">))</span>
     1355<a id="l_1267"></a><span class="hl line"> 1267 </span>    <span class="hl sym">(</span>merge-pathnames
     1356<a id="l_1268"></a><span class="hl line"> 1268 </span>     <span class="hl sym">(</span>make-pathname <span class="hl sym">:</span>name <span class="hl sym">(</span><span class="hl kwa">or</span> name <span class="hl sym">(</span>pathname-name pathname<span class="hl sym">))</span>
     1357<a id="l_1269"></a><span class="hl line"> 1269 </span>                    <span class="hl sym">:</span><span class="hl kwa">type</span> <span class="hl sym">(</span><span class="hl kwa">or type</span> <span class="hl sym">(</span>pathname-<span class="hl kwa">type</span> pathname<span class="hl sym">))</span>
     1358<a id="l_1270"></a><span class="hl line"> 1270 </span>                    <span class="hl sym">:</span>directory directory<span class="hl sym">)</span>
     1359<a id="l_1271"></a><span class="hl line"> 1271 </span>     <span class="hl sym">(</span>system-source-directory system<span class="hl sym">))))</span>
     1360<a id="l_1272"></a><span class="hl line"> 1272 </span>
     1361<a id="l_1273"></a><span class="hl line"> 1273 </span>
     1362<a id="l_1274"></a><span class="hl line"> 1274 </span><span class="hl sym">(</span>pushnew <span class="hl sym">:</span>asdf <span class="hl sym">*</span>features<span class="hl sym">*)</span>
     1363<a id="l_1275"></a><span class="hl line"> 1275 </span>
     1364<a id="l_1276"></a><span class="hl line"> 1276 </span>#<span class="hl sym">+</span>sbcl
     1365<a id="l_1277"></a><span class="hl line"> 1277 </span><span class="hl sym">(</span><span class="hl kwa">eval</span>-when <span class="hl sym">(:</span>compile-toplevel <span class="hl sym">:</span><span class="hl kwa">load</span>-toplevel <span class="hl sym">:</span>execute<span class="hl sym">)</span>
     1366<a id="l_1278"></a><span class="hl line"> 1278 </span>  <span class="hl sym">(</span>when <span class="hl sym">(</span>sb-ext<span class="hl sym">:</span>posix-<span class="hl kwa">getenv</span> <span class="hl str">&quot;SBCL_BUILDING_CONTRIB&quot;</span><span class="hl sym">)</span>
     1367<a id="l_1279"></a><span class="hl line"> 1279 </span>    <span class="hl sym">(</span>pushnew <span class="hl sym">:</span>sbcl-hooks-require <span class="hl sym">*</span>features<span class="hl sym">*)))</span>
     1368<a id="l_1280"></a><span class="hl line"> 1280 </span>
     1369<a id="l_1281"></a><span class="hl line"> 1281 </span>#<span class="hl sym">+(</span><span class="hl kwa">and</span> sbcl sbcl-hooks-require<span class="hl sym">)</span>
     1370<a id="l_1282"></a><span class="hl line"> 1282 </span><span class="hl sym">(</span><span class="hl kwa">progn</span>
     1371<a id="l_1283"></a><span class="hl line"> 1283 </span>  <span class="hl sym">(</span><span class="hl kwa">defun</span> module-provide-asdf <span class="hl sym">(</span>name<span class="hl sym">)</span>
     1372<a id="l_1284"></a><span class="hl line"> 1284 </span>    <span class="hl sym">(</span>handler-bind <span class="hl sym">((</span>style-warning #<span class="hl sym">'</span>muffle-warning<span class="hl sym">))</span>
     1373<a id="l_1285"></a><span class="hl line"> 1285 </span>      <span class="hl sym">(</span>let<span class="hl sym">* ((*</span>verbose-out<span class="hl sym">* (</span>make-broadcast-stream<span class="hl sym">))</span>
     1374<a id="l_1286"></a><span class="hl line"> 1286 </span>             <span class="hl sym">(</span>system <span class="hl sym">(</span>asdf<span class="hl sym">:</span>find-system name nil<span class="hl sym">)))</span>
     1375<a id="l_1287"></a><span class="hl line"> 1287 </span>        <span class="hl sym">(</span>when system
     1376<a id="l_1288"></a><span class="hl line"> 1288 </span>          <span class="hl sym">(</span>asdf<span class="hl sym">:</span>operate <span class="hl sym">'</span>asdf<span class="hl sym">:</span><span class="hl kwa">load</span>-op name<span class="hl sym">)</span>
     1377<a id="l_1289"></a><span class="hl line"> 1289 </span>          t<span class="hl sym">))))</span>
     1378<a id="l_1290"></a><span class="hl line"> 1290 </span>
     1379<a id="l_1291"></a><span class="hl line"> 1291 </span>  <span class="hl sym">(</span><span class="hl kwa">defun</span> contrib-sysdef-search <span class="hl sym">(</span>system<span class="hl sym">)</span>
     1380<a id="l_1292"></a><span class="hl line"> 1292 </span>    <span class="hl sym">(</span>let <span class="hl sym">((</span>home <span class="hl sym">(</span>sb-ext<span class="hl sym">:</span>posix-<span class="hl kwa">getenv</span> <span class="hl str">&quot;SBCL_HOME&quot;</span><span class="hl sym">)))</span>
     1381<a id="l_1293"></a><span class="hl line"> 1293 </span>      <span class="hl sym">(</span>when <span class="hl sym">(</span><span class="hl kwa">and</span> home <span class="hl sym">(</span><span class="hl kwa">not</span> <span class="hl sym">(</span>string<span class="hl sym">=</span> home <span class="hl str">&quot;&quot;</span><span class="hl sym">)))</span>
     1382<a id="l_1294"></a><span class="hl line"> 1294 </span>        <span class="hl sym">(</span>let<span class="hl sym">* ((</span>name <span class="hl sym">(</span>coerce-name system<span class="hl sym">))</span>
     1383<a id="l_1295"></a><span class="hl line"> 1295 </span>               <span class="hl sym">(</span>home <span class="hl sym">(</span>truename home<span class="hl sym">))</span>
     1384<a id="l_1296"></a><span class="hl line"> 1296 </span>               <span class="hl sym">(</span>contrib <span class="hl sym">(</span>merge-pathnames
     1385<a id="l_1297"></a><span class="hl line"> 1297 </span>                         <span class="hl sym">(</span>make-pathname <span class="hl sym">:</span>directory `<span class="hl sym">(:</span>relative <span class="hl sym">,</span>name<span class="hl sym">)</span>
     1386<a id="l_1298"></a><span class="hl line"> 1298 </span>                                        <span class="hl sym">:</span>name name
     1387<a id="l_1299"></a><span class="hl line"> 1299 </span>                                        <span class="hl sym">:</span><span class="hl kwa">type</span> <span class="hl str">&quot;asd&quot;</span>
     1388<a id="l_1300"></a><span class="hl line"> 1300 </span>                                        <span class="hl sym">:</span>case <span class="hl sym">:</span>local
     1389<a id="l_1301"></a><span class="hl line"> 1301 </span>                                        <span class="hl sym">:</span>version <span class="hl sym">:</span>newest<span class="hl sym">)</span>
     1390<a id="l_1302"></a><span class="hl line"> 1302 </span>                         home<span class="hl sym">)))</span>
     1391<a id="l_1303"></a><span class="hl line"> 1303 </span>          <span class="hl sym">(</span>probe-file contrib<span class="hl sym">)))))</span>
     1392<a id="l_1304"></a><span class="hl line"> 1304 </span>
     1393<a id="l_1305"></a><span class="hl line"> 1305 </span>  <span class="hl sym">(</span>pushnew
     1394<a id="l_1306"></a><span class="hl line"> 1306 </span>   <span class="hl sym">'(</span>let <span class="hl sym">((</span>home <span class="hl sym">(</span>sb-ext<span class="hl sym">:</span>posix-<span class="hl kwa">getenv</span> <span class="hl str">&quot;SBCL_HOME&quot;</span><span class="hl sym">)))</span>
     1395<a id="l_1307"></a><span class="hl line"> 1307 </span>      <span class="hl sym">(</span>when <span class="hl sym">(</span><span class="hl kwa">and</span> home <span class="hl sym">(</span><span class="hl kwa">not</span> <span class="hl sym">(</span>string<span class="hl sym">=</span> home <span class="hl str">&quot;&quot;</span><span class="hl sym">)))</span>
     1396<a id="l_1308"></a><span class="hl line"> 1308 </span>        <span class="hl sym">(</span>merge-pathnames <span class="hl str">&quot;site-systems/&quot;</span> <span class="hl sym">(</span>truename home<span class="hl sym">))))</span>
     1397<a id="l_1309"></a><span class="hl line"> 1309 </span>   <span class="hl sym">*</span>central-registry<span class="hl sym">*)</span>
     1398<a id="l_1310"></a><span class="hl line"> 1310 </span>
     1399<a id="l_1311"></a><span class="hl line"> 1311 </span>  <span class="hl sym">(</span>pushnew
     1400<a id="l_1312"></a><span class="hl line"> 1312 </span>   <span class="hl sym">'(</span>merge-pathnames <span class="hl str">&quot;.sbcl/systems/&quot;</span>
     1401<a id="l_1313"></a><span class="hl line"> 1313 </span>     <span class="hl sym">(</span>user-homedir-pathname<span class="hl sym">))</span>
     1402<a id="l_1314"></a><span class="hl line"> 1314 </span>   <span class="hl sym">*</span>central-registry<span class="hl sym">*)</span>
     1403<a id="l_1315"></a><span class="hl line"> 1315 </span>
     1404<a id="l_1316"></a><span class="hl line"> 1316 </span>  <span class="hl sym">(</span>pushnew <span class="hl sym">'</span>module-provide-asdf sb-ext<span class="hl sym">:*</span>module-provider-functions<span class="hl sym">*)</span>
     1405<a id="l_1317"></a><span class="hl line"> 1317 </span>  <span class="hl sym">(</span>pushnew <span class="hl sym">'</span>contrib-sysdef-search <span class="hl sym">*</span>system-definition-search-functions<span class="hl sym">*))</span>
     1406<a id="l_1318"></a><span class="hl line"> 1318 </span>
     1407<a id="l_1319"></a><span class="hl line"> 1319 </span><span class="hl sym">(</span>provide <span class="hl sym">'</span>asdf<span class="hl sym">)</span>
     1408</pre></div>
     1409
     1410<hr />
     1411<table>
     1412<tr>
     1413<td>
     1414<address><a href="http://sourceforge.net/">Back to SourceForge.net</a></address><br />
     1415Powered by <a href="http://viewvc.tigris.org/">ViewVC 1.0.3</a>
     1416</td>
     1417<td style="text-align:right;">
     1418<h3><a href="/*docroot*/help_rootview.html">ViewVC and Help</a></h3>
     1419</td>
     1420</tr>
     1421</table>
     1422</body>
     1423</html>
     1424
Note: See TracChangeset for help on using the changeset viewer.