Ignore:
Timestamp:
Apr 20, 2008, 12:06:22 PM (13 years ago)
Author:
gb
Message:

synch from trunk

Location:
release/1.2/source/tools
Files:
10 edited
8 copied

Legend:

Unmodified
Added
Removed
  • release/1.2/source/tools/asdf-install/COPYRIGHT

    r2590 r9219  
    1515MK:DEFSYSTEM which includes the files load-asdf-install.lisp,
    1616loader.lisp, and finally split-sequence.lisp which has its own
    17 copyright notice.
     17copyright notice. ASDF-Install is currently maintained by Gary King
     18<gwking@metabang.com> and is hosted on Common-Lisp.net.
    1819
    1920The complete code distributed with this archive (asdf-install.tar.gz)
  • release/1.2/source/tools/asdf-install/asdf-install.asd

    r926 r9219  
    11;;; -*-  Lisp -*-
     2
     3;;; Portatble ASDF-Install is based on Dan Barlow's ASDF-Install
     4;; (see the file COPYRIGHT for details). It is currently maintained
     5;; by Gary King <gwking@metabang.com>.
    26
    37(defpackage #:asdf-install-system
     
    59
    610(in-package #:asdf-install-system)
    7 #+:sbcl
    8 (require 'sb-executable)
    9 
    10 ;;; this is appalling misuse of asdf.  please don't treat it as any
    11 ;;; kind of example.  this shouldn't be a compile-op, or if it is, should
    12 ;;; define output-files properly instead of leaving it be the fasl
    13 #+:sbcl
    14 (defclass exe-file (cl-source-file) ())
    15 #+:sbcl
    16 (defmethod perform :after ((o compile-op) (c exe-file))
    17   (sb-executable:make-executable
    18    (make-pathname :name "asdf-install"
    19                   :type nil
    20                   :defaults (component-pathname c))
    21    (output-files o c)
    22    :initial-function "RUN"))
    23 
    24 #+:sbcl
    25 (defmethod perform ((o load-op) (c exe-file)) nil)
    2611
    2712(defsystem asdf-install
    2813  #+:sbcl :depends-on
    29   #+:sbcl (sb-posix sb-bsd-sockets)
    30   :version "0.3"
     14  #+:sbcl (sb-bsd-sockets)
     15  :version "0.6.10"
     16  :author "Dan Barlow <dan@telent.net>, Edi Weitz <edi@agharta.de> and many others. See the file COPYRIGHT for more details."
     17  :maintainer "Gary Warren King <gwking@metabang.com>"
    3118  :components ((:file "defpackage")
    32                #+:sbcl
    33                (:exe-file "loader" :depends-on ("installer"))
    34                (:file "split-sequence")
     19               (:file "split-sequence" :depends-on ("defpackage"))
     20               
    3521               (:file "port" :depends-on ("defpackage"))
    3622               #+:digitool
    3723               (:file "digitool" :depends-on ("port"))
    38                (:file "installer" :depends-on ("port" "split-sequence" #+:digitool "digitool"))))
    39                
     24               
     25               (:file "conditions" :depends-on ("defpackage" "variables"))
     26               (:file "variables" :depends-on ("port"))
     27               (:file "installer"
     28                      :depends-on ("port" "split-sequence"
     29                                          #+:digitool "digitool"
     30                                          "conditions" "variables"))
     31               (:file "deprecated" :depends-on ("installer")))
     32  :in-order-to ((test-op (load-op test-asdf-install)))
     33  :perform (test-op :after (op c)
     34                    (funcall
     35                      (intern (symbol-name '#:run-tests) :lift)
     36                      :config :generic)))
     37           
    4038(defmethod perform :after ((o load-op) (c (eql (find-system :asdf-install))))
     39  (let ((show-version (find-symbol
     40                       (symbol-name '#:show-version-information)
     41                       '#:asdf-install)))
     42    (when (and show-version (fboundp show-version))
     43      (funcall show-version)))
    4144  (provide 'asdf-install))
    4245
     46(defmethod operation-done-p
     47    ((o test-op) (c (eql (find-system :asdf-install))))
     48  nil)
     49
     50#+(or)
    4351(defmethod perform ((o test-op) (c (eql (find-system :asdf-install))))
    4452  t)
  • release/1.2/source/tools/asdf-install/defpackage.lisp

    r2590 r9219  
    11(cl:in-package :cl-user)
    22
    3 (defpackage :asdf-install
    4   (:use "CL")
     3(defpackage #:asdf-install
     4  (:use #:common-lisp)
     5 
     6  #+asdf
     7  (:import-from #:asdf #:*defined-systems*)
    58  (:export
    69
    710   ;; Customizable variables.
     11   #:*shell-path*
    812   #:*proxy*
    913   #:*cclan-mirror*
    10    #:*sbcl-home* ; Deprecated.
    1114   #:asdf-install-dirs
    1215   #:private-asdf-install-dirs
     16   #:*tar-extractors*
    1317
     18   #:*shell-search-paths*
    1419   #:*verify-gpg-signatures*
    1520   #:*locations*
    1621   #:*safe-url-prefixes*
    1722   #:*preferred-location*
    18 
    19    #+(or :win32 :mswindows)
    20    #:*cygwin-bin-directory*
    21 
    22    #+(or :win32 :mswindows)
    23    #:*cygwin-bash-command*
    24 
     23   #:*temporary-directory*
     24   
    2525   ;; External entry points.   
    2626   #:add-locations
    27    #+(and asdf (or :win32 :mswindows))
    28    #:sysdef-source-dir-search
     27   #:add-registry-location
    2928   #:uninstall
    3029   #:install
     30   #:asdf-install-version
     31
     32   #+(and asdf (or :win32 :mswindows))
     33   #:sysdef-source-dir-search   
     34   
    3135   ;; proxy authentication
    3236   #:*proxy-user*
    33    #:*proxy-passwd*))
     37   #:*proxy-passwd*
     38   
     39   ;; conditions
     40   #:download-error
     41   #:signature-error
     42   #:gpg-error
     43   #:gpg-shell-error
     44   #:key-not-found
     45   #:key-not-trusted
     46   #:author-not-trusted
     47   #:installation-abort
    3448
    35 (defpackage :asdf-install-customize
    36   (:use "CL" "ASDF-INSTALL"))
     49   ;; restarts
     50   #:install-anyways
     51   )
     52 
     53  #+(or :win32 :mswindows)
     54  (:export
     55   #:*cygwin-bin-directory*
     56   #:*cygwin-bash-command*))
     57
     58(defpackage #:asdf-install-customize
     59  (:use #:common-lisp #:asdf-install))
  • release/1.2/source/tools/asdf-install/digitool.lisp

    r503 r9219  
    66;;; 2008-01-22 added exit-code checks to call-system
    77
    8 (in-package :asdf-install)
     8(in-package #:asdf-install)
    99
    1010#+:digitool
  • release/1.2/source/tools/asdf-install/installer.lisp

    r2590 r9219  
    1 (in-package :asdf-install)
     1(in-package #:asdf-install)
    22
    33(pushnew :asdf-install *features*)
    44
    55(defun installer-msg (stream format-control &rest format-arguments)
    6   (apply #'format stream ";;; ASDF-INSTALL: ~@?~%" format-control format-arguments))
    7 
    8 
    9 #+:digitool
    10 (defparameter *home-volume-name*
    11   (second (pathname-directory (truename (user-homedir-pathname))))
    12   "Digitool MCL retains the OS 9 convention that ALL volumes have a
    13 name which includes the startup volume. OS X doesn't know about this.
    14 This figures in the home path and in the normalization for system
    15 namestrings.")
    16 
    17 (defvar *proxy* (get-env-var "http_proxy"))
    18 
    19 (defvar *cclan-mirror*
    20   (or (get-env-var "CCLAN_MIRROR")
    21       "http://ftp.linux.org.uk/pub/lisp/cclan/"))
    22 
    23 #+(or :win32 :mswindows)
    24 (defvar *cygwin-bin-directory*
    25   (pathname "C:\\PROGRA~1\\Cygwin\\bin\\"))
    26 
    27 #+(or :win32 :mswindows)
    28 (defvar *cygwin-bash-program*
    29   "C:\\PROGRA~1\\Cygwin\\bin\\bash.exe")
    30 
    31 (defvar *gnu-tar-program*
    32   "tar"
    33   "Path to the GNU tar program")
    34 
    35 (eval-when (:compile-toplevel :load-toplevel :execute)
    36   (defparameter *supported-defsystems*
    37     (list :mk-defsystem
    38           :asdf
    39 
    40           ;; Add others.
    41           ;; #+lispworks :common-defsystem
    42           ))
    43          
    44 
    45   (unless (some (lambda (defsys-tag)
    46                   (member defsys-tag *features*))
    47                 *features*)
    48     (error "ASDF-INSTALL requires one of the following \"defsystem\" utilities to work."
    49            *supported-defsystems*)))
    50 
    51 
    52 
    53 (defun directorify (name)
    54   ;; input name may or may not have a trailing #\/, but we know we
    55   ;; want a directory
    56   (let ((path (pathname name)))
    57     (if (pathname-name path)
    58         (merge-pathnames
    59          (make-pathname :directory `(:relative ,(pathname-name path))
    60                         :name "")
    61          path)
    62         path)))
    63 
    64 (defvar *asdf-install-dirs*
    65   (directorify (or #+sbcl (get-env-var "SBCL_HOME")
    66                    (get-env-var "ASDF_INSTALL_DIR")
    67                    (make-pathname :directory
    68                                   `(:absolute
    69                                     #+digitool ,*home-volume-name*
    70                                     "usr" "local" "asdf-install")))))
    71 
    72 #+sbcl ; Deprecated.
    73 (define-symbol-macro *sbcl-home* *asdf-install-dirs*)
    74 
    75 
    76 (defvar *private-asdf-install-dirs*
    77   #+:sbcl
    78   (merge-pathnames (make-pathname :directory '(:relative ".sbcl"))
    79                    (truename (user-homedir-pathname)))
    80   #-:sbcl
    81   (cond ((get-env-var "PRIVATE_ASDF_INSTALL_DIR")
    82           (directorify (get-env-var "PRIVATE_ASDF_INSTALL_DIR")))
    83         (t
    84           (merge-pathnames (make-pathname :directory '(:relative ".asdf-install-dir"))
    85                            (truename (user-homedir-pathname))))))
    86 
    87 #+sbcl ; Deprecated.
    88 (define-symbol-macro *dot-sbcl* *private-asdf-install-dirs*)
    89 
    90 
    91 (defvar *trusted-uids* nil)
    92 
    93 (defvar *verify-gpg-signatures* t)
    94 
    95 (defvar *safe-url-prefixes* nil)
    96 
    97 (defvar *preferred-location* nil)
     6  (apply #'format stream "~&;;; ASDF-INSTALL: ~@?~%"
     7         format-control format-arguments))
    988
    999(defun verify-gpg-signatures-p (url)
     
    10919      (t t))))
    11020         
    111 (defparameter *locations*
    112   `((,(merge-pathnames (make-pathname :directory '(:relative "site"))
    113                        *asdf-install-dirs*)
    114      ,(merge-pathnames (make-pathname :directory '(:relative "site-systems"))
    115                        *asdf-install-dirs*)
    116      "System-wide install")
    117     (,(merge-pathnames (make-pathname :directory '(:relative "site"))
    118                        *private-asdf-install-dirs*)
    119      ,(merge-pathnames (make-pathname :directory '(:relative "systems"))
    120                        *private-asdf-install-dirs*)
    121      "Personal installation")))
    122 
    123 
    124 #+(and (not :sbcl) :asdf)
    125 (pushnew `(merge-pathnames ,(make-pathname :directory '(:relative "site-systems"))
    126                            ,*asdf-install-dirs*)
    127          asdf:*central-registry*
    128          :test #'equal)
    129 
    130 #+(and (not :sbcl) :asdf)
    131 (pushnew `(merge-pathnames ,(make-pathname :directory '(:relative "systems"))
    132                            ,*private-asdf-install-dirs*)
    133          asdf:*central-registry*
    134          :test #'equal)
    135 
    136 #+mk-defsystem
    137 (mk:add-registry-location
    138  (merge-pathnames (make-pathname :directory '(:relative "site-systems"))
    139                   *private-asdf-install-dirs*))
    140 
    141 #+mk-defsystem
    142 (mk:add-registry-location
    143  (merge-pathnames (make-pathname :directory '(:relative "systems"))
    144                   *private-asdf-install-dirs*))
    145 
     21(defun same-central-registry-entry-p (a b)
     22  (flet ((ensure-string (x)
     23           (typecase x
     24             (string x)
     25             (pathname (namestring (translate-logical-pathname x)))
     26             (t nil))))
     27    (and (setf a (ensure-string a))
     28         (setf b (ensure-string b))
     29         a b (string-equal a b))))
     30
     31(defun add-registry-location (location)
     32  (let ((location-directory (pathname-sans-name+type location)))
     33    #+asdf
     34    (pushnew location-directory
     35             asdf:*central-registry*
     36             :test #'same-central-registry-entry-p)
     37 
     38    #+mk-defsystem
     39    (mk:add-registry-location location-directory)))
    14640
    14741;;; Fixing the handling of *LOCATIONS*
     
    16256        (append *locations* (list (list site system-site loc-name)))))
    16357
    164 
    165 
    166 (eval-when (:load-toplevel :execute)
    167   (let* ((*package* (find-package :asdf-install-customize))
    168          (file (probe-file (merge-pathnames
    169                             (make-pathname :name ".asdf-install")
    170                             (truename (user-homedir-pathname)))))
    171          )
    172     (when file (load file))))
    173 
    174 
    175 ;;;---------------------------------------------------------------------------
    176 ;;; Conditions.
    177 
    178 (define-condition download-error (error)
    179   ((url :initarg :url :reader download-url)
    180    (response :initarg :response :reader download-response))
    181   (:report (lambda (c s)
    182              (format s "Server responded ~A for GET ~A"
    183                      (download-response c) (download-url c)))))
    184 
    185 (define-condition signature-error (error)
    186   ((cause :initarg :cause :reader signature-error-cause))
    187   (:report (lambda (c s)
    188              (format s "Cannot verify package signature:  ~A"
    189                      (signature-error-cause c)))))
    190 
    191 (define-condition gpg-error (error)
    192   ((message :initarg :message :reader gpg-error-message))
    193   (:report (lambda (c s)
    194              (format s "GPG failed with error status:~%~S"
    195                      (gpg-error-message c)))))
    196 
    197 (define-condition no-signature (gpg-error) ())
    198 
    199 (define-condition key-not-found (gpg-error)
    200   ((key-id :initarg :key-id :reader key-id))
    201   (:report (lambda (c s)
    202              (format s "No key found for key id 0x~A. ~
    203                         Try some command like ~%  gpg  --recv-keys 0x~A"
    204                      (key-id c) (key-id c)))))
    205 
    206 (define-condition key-not-trusted (gpg-error)
    207   ((key-id :initarg :key-id :reader key-id)
    208    (key-user-name :initarg :key-user-name :reader key-user-name))
    209   (:report (lambda (c s)
    210              (format s "GPG warns that the key id 0x~A (~A) is not fully trusted"
    211                      (key-id c) (key-user-name c)))))
    212 
    213 (define-condition author-not-trusted (gpg-error)
    214   ((key-id :initarg :key-id :reader key-id)
    215    (key-user-name :initarg :key-user-name :reader key-user-name))
    216   (:report (lambda (c s)
    217              (format s "~A (key id ~A) is not on your package supplier list"
    218                      (key-user-name c) (key-id c)))))
    219  
    220 
    22158;;;---------------------------------------------------------------------------
    22259;;; URL handling.
     
    23269  (assert (string-equal url "http://" :end1 7))
    23370  (let ((port-start (position #\: url :start 7)))
    234     (if port-start (parse-integer url :start (1+ port-start) :junk-allowed t) 80)))
     71    (if port-start
     72        (parse-integer url :start (1+ port-start) :junk-allowed t) 80)))
    23573
    23674; This is from Juri Pakaste's <juri@iki.fi> base64.lisp
     
    269107    result))
    270108
    271 (defvar *proxy-user* nil)
    272 (defvar *proxy-passwd* nil)
     109(defun request-uri (url)
     110  (assert (string-equal url "http://" :end1 7))
     111  (if *proxy*
     112      url
     113      (let ((path-start (position #\/ url :start 7)))
     114        (assert (and path-start) nil "url does not specify a file.")
     115        (subseq url path-start))))
    273116
    274117(defun url-connection (url)
     
    276119        (host (url-host url)))
    277120    (format stream "GET ~A HTTP/1.0~C~CHost: ~A~C~CCookie: CCLAN-SITE=~A~C~C"
    278             url #\Return #\Linefeed
     121            (request-uri url) #\Return #\Linefeed
    279122            host #\Return #\Linefeed
    280123            *cclan-mirror* #\Return #\Linefeed)
     
    285128    (format stream "~C~C" #\Return #\Linefeed)
    286129    (force-output stream)
    287     (flet (#-:digitool
    288            (read-header-line ()
    289              (read-line stream))
    290            #+:digitool
    291            (read-header-line (&aux (line (make-array 16
    292                                                      :element-type 'character
    293                                                      :adjustable t
    294                                                      :fill-pointer 0))
    295                                    (byte nil))
    296              (print (multiple-value-bind (reader arg)
    297                         (ccl::stream-reader stream)
    298                       (loop (setf byte (funcall reader arg))
    299                             (case byte
    300                               ((nil)
    301                                 (return))
    302                               ((#.(char-code #\Return)
    303                                   #.(char-code #\Linefeed))
    304                                 (case (setf byte (funcall reader arg))
    305                                   ((nil #.(char-code #\Return) #.(char-code #\Linefeed)))
    306                                   (t (ccl:stream-untyi stream byte)))
    307                                 (return))
    308                               (t
    309                                 (vector-push-extend (code-char byte) line))))
    310                       (when (or byte (plusp (length line)))
    311                         line)))))
    312       (list
    313        (let* ((l (read-header-line))
    314               (space (position #\Space l)))
    315          (parse-integer l :start (1+ space) :junk-allowed t))
    316        (loop for line = (read-header-line)
    317              until (or (null line)
    318                        (zerop (length line))
    319                        (eql (elt line 0) (code-char 13)))
    320              collect
    321              (let ((colon (position #\: line)))
    322                (cons (intern (string-upcase (subseq line 0 colon)) :keyword)
    323                      (string-trim (list #\Space (code-char 13))
    324                                   (subseq line (1+ colon))))))
    325        stream))))
    326 
    327 
    328 (defun download-files-for-package (package-name-or-url file-name)
    329   (let ((url (if (= (mismatch package-name-or-url "http://") 7)
    330                  package-name-or-url
    331                  (format nil "http://www.cliki.net/~A?download"
    332                          package-name-or-url)))
    333         )
    334     (destructuring-bind (response headers stream)
    335         (block got
    336           (loop
    337            (destructuring-bind (response headers stream) (url-connection url)
    338              (unless (member response '(301 302))             
    339                (return-from got (list response headers stream)))
    340              (close stream)
    341              (setf url (cdr (assoc :location headers))))))
    342       (when (>= response 400)
    343         (error 'download-error :url url :response response))
    344       (let ((length (parse-integer (or (cdr (assoc :content-length headers)) "")
    345                                    :junk-allowed t)))
    346         (installer-msg t "Downloading ~A bytes from ~A to ~A ..."
    347                        (or length "some unknown number of")
    348                        url
    349                        file-name)
    350         (force-output)
    351         #+:clisp (setf (stream-element-type stream)
    352                        '(unsigned-byte 8))
    353         (with-open-file (o file-name :direction :output
    354                            #+(or :clisp :digitool (and :lispworks :win32))
    355                            :element-type
    356                            #+(or :clisp :digitool (and :lispworks :win32))
    357                            '(unsigned-byte 8)
    358                            :if-exists :supersede)
    359           #+(or :cmu :digitool)
    360           (copy-stream stream o)
    361           #-(or :cmu :digitool)
    362           (if length
    363               (let ((buf (make-array length
    364                                      :element-type
    365                                      (stream-element-type stream))))
    366                 #-:clisp (read-sequence buf stream)
    367                 #+:clisp (ext:read-byte-sequence buf stream :no-hang nil)
    368                 (write-sequence buf o))
    369               (copy-stream stream o))))
    370       (close stream)
    371       (terpri)
    372       (restart-case
    373           (verify-gpg-signature/url url file-name)
    374         (skip-gpg-check (&rest rest)
    375                         :report "Don't ckeck GPG signature for this package"
    376                         (declare (ignore rest))
    377                         nil)))))
    378 
    379 
    380 (defun read-until-eof (stream)
    381   (with-output-to-string (o)
    382     (copy-stream stream o)))
    383 
     130    (list
     131     (let* ((l (read-header-line stream))
     132            (space (position #\Space l)))
     133       (parse-integer l :start (1+ space) :junk-allowed t))
     134     (loop for line = (read-header-line stream)
     135           until (or (null line)
     136                     (zerop (length line))
     137                     (eql (elt line 0) (code-char 13)))
     138           collect
     139           (let ((colon (position #\: line)))
     140             (cons (intern (string-upcase (subseq line 0 colon)) :keyword)
     141                   (string-trim (list #\Space (code-char 13))
     142                                (subseq line (1+ colon))))))
     143     stream)))
     144
     145(defun download-link-for-package (package-name-or-url)
     146  (if (= (mismatch package-name-or-url "http://") 7)
     147    package-name-or-url
     148    (format nil "http://www.cliki.net/~A?download"
     149            package-name-or-url)))
     150
     151(defun download-link-for-signature (url)
     152  (concatenate 'string url ".asc"))
     153
     154(defun download-files-for-package (package-name-or-url)
     155  (multiple-value-bind (package-url package-file)
     156      (download-url-to-temporary-file
     157       (download-link-for-package package-name-or-url))
     158    (if (verify-gpg-signatures-p package-name-or-url)
     159        (multiple-value-bind (signature-url signature-file)
     160            (download-url-to-temporary-file
     161             (download-link-for-signature package-url))
     162          (declare (ignore signature-url))
     163          (values package-file signature-file))
     164        (values package-file nil))))
    384165 
    385 (defun verify-gpg-signature/string (string file-name)
    386   (let ((gpg-stream (make-stream-from-gpg-command string file-name))
    387         tags)
    388     (unwind-protect
    389       (loop for l = (read-line gpg-stream nil nil)
    390             while l
    391             do (print l)
    392             when (> (mismatch l "[GNUPG:]") 6)
    393             do (destructuring-bind (_ tag &rest data)
    394                    (split-sequence:split-sequence-if (lambda (x)
    395                                                        (find x '(#\Space #\Tab)))
    396                                                      l)
    397                (declare (ignore _))
    398                (pushnew (cons (intern tag :keyword)
    399                               data) tags)))
    400       (ignore-errors
    401         (close gpg-stream)))
    402     ;; test for obvious key/sig problems
    403     (let ((errsig (assoc :errsig tags)))
    404       (and errsig (error 'key-not-found :key-id (second errsig))))
    405     (let ((badsig (assoc :badsig tags)))
    406       (and badsig (error 'key-not-found :key-id (second badsig))))
    407     (let* ((good (assoc :goodsig tags))
    408            (id (second good))
    409            (name (format nil "~{~A~^ ~}" (nthcdr 2 good))))
    410       ;; good signature, but perhaps not trusted
    411       (unless (or (assoc :trust_ultimate tags)
    412                   (assoc :trust_fully tags))
    413         (cerror "Install the package anyway"
    414                 'key-not-trusted
    415                 :key-user-name name
    416                 :key-id id))
    417       (loop
    418        (when
    419            (restart-case
    420                (or (assoc id *trusted-uids* :test #'equal)
    421                    (error 'author-not-trusted
    422                           :key-user-name name
    423                           :key-id id))
    424              (add-key (&rest rest)
    425                :report "Add to package supplier list"
    426                (declare (ignore rest))
    427                (pushnew (list id name) *trusted-uids*)))
    428          (return))))))
    429 
    430 
    431 (defun verify-gpg-signature/url (url file-name)
    432   (when (verify-gpg-signatures-p url)
    433     (destructuring-bind (response headers stream)
    434         (url-connection (concatenate 'string url ".asc"))
    435       (unwind-protect
    436         (flet (#-:digitool
    437                (read-signature (data stream)
    438                  (read-sequence data stream))
    439                #+:digitool
    440                (read-signature (data stream)
    441                  (multiple-value-bind (reader arg)
    442                      (ccl:stream-reader stream)
    443                    (let ((byte 0))
    444                      (dotimes (i (length data))
    445                        (unless (setf byte (funcall reader arg))
    446                          (error 'download-error :url  (concatenate 'string url ".asc")
    447                                 :response 200))
    448                        (setf (char data i) (code-char byte)))))))
    449           (if (= response 200)
    450             (let ((data (make-string (parse-integer
    451                                       (cdr (assoc :content-length headers))
    452                                       :junk-allowed t))))
    453               (read-signature data stream)
    454               (verify-gpg-signature/string data file-name))
    455             (error 'download-error :url  (concatenate 'string url ".asc")
    456                    :response response)))
    457         (close stream)))))
    458 
    459 
    460 (define-condition installation-abort (condition)
    461   ()
    462   (:report (lambda (c s)
    463              (declare (ignore c))
    464              (installer-msg s "Installation aborted."))))
    465 
    466 
    467 (defun where ()
     166(defun verify-gpg-signature (file-name signature-name)
     167  (block verify
     168    (loop
     169      (restart-case
     170          (let ((tags (gpg-results file-name signature-name)))
     171            ;; test that command returned something
     172            (unless tags
     173              (error 'gpg-shell-error))
     174            ;; test for obvious key/sig problems
     175            (let ((errsig (header-value :errsig tags)))
     176              (and errsig (error 'key-not-found :key-id errsig)))
     177            (let ((badsig (header-value :badsig tags)))
     178              (and badsig (error 'key-not-found :key-id badsig)))
     179            (let* ((good (header-value :goodsig tags))
     180                   (id (first good))
     181                   (name (format nil "~{~A~^ ~}" (rest good))))
     182              ;; good signature, but perhaps not trusted
     183              (restart-case
     184                  (let ((trusted? (or (header-pair :trust_ultimate tags)
     185                                      (header-pair :trust_fully tags)))
     186                        (in-list? (assoc id *trusted-uids* :test #'equal)))
     187                    (cond ((or trusted? in-list?)
     188                           ;; ok
     189                           )
     190                          ((not trusted?)
     191                           (error 'key-not-trusted
     192                                  :key-user-name name :key-id id))
     193                          ((not in-list?)
     194                           (error 'author-not-trusted
     195                                  :key-user-name name :key-id id))))
     196                (add-key (&rest rest)
     197                  :report "Add to package supplier list"
     198                  (declare (ignore rest))
     199                  (pushnew (list id name) *trusted-uids*))))
     200            (return-from verify t))
     201        (install-anyways
     202            (&rest rest)
     203          :report "Don't check GPG signature for this package"
     204          (declare (ignore rest))
     205          (return-from verify t))
     206        (retry-gpg-check
     207            (&rest args)
     208          :report "Retry GPG check \(e.g., after downloading the key\)"
     209          (declare (ignore args))
     210          nil)))))
     211
     212(defun header-value (name headers)
     213  "Searchers headers for name _without_ case sensitivity. Headers should be an alist mapping symbols to values; name a symbol. Returns the value if name is found or nil if it is not."
     214  (cdr (header-pair name headers)))
     215
     216(defun header-pair (name headers)
     217  "Searchers headers for name _without_ case sensitivity. Headers should be an alist mapping symbols to values; name a symbol. Returns the \(name value\) pair if name is found or nil if it is not."
     218  (assoc name headers
     219         :test (lambda (a b)
     220                 (string-equal (symbol-name a) (symbol-name b)))))
     221
     222(defun validate-preferred-location ()
     223  (typecase *preferred-location*
     224    (null t)
     225    ((integer 0)
     226     (assert (<= 1 *preferred-location* (length *locations*))
     227             (*preferred-location*)
     228             'invalid-preferred-location-number-error
     229             :preferred-location *preferred-location*))
     230    ((or symbol string)
     231     (assert (find *preferred-location* *locations*
     232                   :test (if (typep *preferred-location* 'symbol)
     233                             #'eq #'string-equal) :key #'third)
     234             (*preferred-location*)
     235             'invalid-preferred-location-name-error
     236             :preferred-location *preferred-location*))
     237    (t
     238     (assert nil
     239             (*preferred-location*)
     240             'invalid-preferred-location-error
     241             :preferred-location *preferred-location*)))
     242  *preferred-location*)
     243
     244(defun select-location ()
    468245  (loop with n-locations = (length *locations*)
    469         for response = (or *preferred-location*             
    470                            (progn
    471                              (format t "Install where?~%")
    472                              (loop for (source system name) in *locations*
    473                                    for i from 0
    474                                    do (format t "~A) ~A: ~%   System in ~A~%   Files in ~A ~%"
    475                                               i name system source))
    476                              (format t "~D) Abort installation.~% --> " n-locations)
    477                              (force-output)
    478                              (read)))
    479         when (and (numberp response)
    480                   (<= 0 response (1- n-locations)))
    481            return (elt *locations* response)
    482         when (and (numberp response)
    483                   (= response n-locations))
    484            do (abort (make-condition 'installation-abort))))
     246     for response = (progn
     247                      (format t "Install where?~%")
     248                      (loop for (source system name) in *locations*
     249                         for i from 1
     250                         do (format t "~A) ~A: ~%   System in ~A~%   Files in ~A ~%"
     251                                    i name system source))
     252                      (format t "0) Abort installation.~% --> ")
     253                      (force-output)
     254                      (read))
     255     when (and (numberp response)
     256               (<= 1 response n-locations))
     257     return response
     258     when (and (numberp response)
     259               (zerop response))
     260     do (abort (make-condition 'installation-abort))))
     261
     262(defun install-location ()
     263  (validate-preferred-location)
     264  (let ((location-selection (or *preferred-location*
     265                                (select-location))))
     266    (etypecase location-selection
     267      (integer
     268       (elt *locations* (1- location-selection)))
     269      ((or symbol string)
     270       (find location-selection *locations* :key #'third
     271             :test (if (typep location-selection 'string)
     272                      #'string-equal #'eq))))))
    485273
    486274
    487275;;; install-package --
     276
     277(defun find-shell-command (command)
     278  (loop for directory in *shell-search-paths* do
     279       (let ((target (make-pathname :name command :type nil
     280                                    :directory directory)))
     281         (when (probe-file target)
     282           (return-from find-shell-command (namestring target)))))
     283  (values nil))
     284
     285(defun tar-command ()
     286  #-(or :win32 :mswindows)
     287  (find-shell-command *gnu-tar-program*)
     288  #+(or :win32 :mswindows)
     289  *cygwin-bash-program*)
     290
     291(defun tar-arguments (source packagename)
     292  #-(or :win32 :mswindows :scl)
     293  (list "-C" (namestring (truename source))
     294        "-xzvf" (namestring (truename packagename)))
     295  #+(or :win32 :mswindows)
     296  (list "-l"
     297        "-c"
     298        (format nil "\"tar -C \\\"`cygpath '~A'`\\\" -xzvf \\\"`cygpath '~A'`\\\"\""
     299                (namestring (truename source))
     300                (namestring (truename packagename))))
     301  #+scl
     302  (list "-C" (ext:unix-namestring (truename source))
     303        "-xzvf" (ext:unix-namestring (truename packagename))))
     304
     305(defun extract-using-tar (to-dir tarball)
     306  (let ((tar-command (tar-command)))
     307    (if (and tar-command (probe-file tar-command))
     308        (return-output-from-program tar-command
     309                                    (tar-arguments to-dir tarball))
     310        (warn "Cannot find tar command ~S." tar-command))))
     311
     312(defun extract (to-dir tarball)
     313  (or (some #'(lambda (extractor) (funcall extractor to-dir tarball))
     314            *tar-extractors*)
     315      (error "Unable to extract tarball ~A." tarball)))
    488316
    489317(defun install-package (source system packagename)
     
    491319  (ensure-directories-exist source)
    492320  (ensure-directories-exist system)
    493   (let* ((tar
    494           (or #-(or :win32 :mswindows)
    495               (return-output-from-program *gnu-tar-program*
    496                                           (list "-C" (namestring (truename source))
    497                                                 "-xzvf" (namestring (truename packagename))))
    498               #+(or :win32 :mswindows)
    499               (return-output-from-program *cygwin-bash-program*
    500                                           (list "-l"
    501                                                 "-c"
    502                                                 (format nil "\"tar -C \\\"`cygpath '~A'`\\\" -xzvf \\\"`cygpath '~A'`\\\"\""
    503                                                         (namestring (truename source))
    504                                                         (namestring (truename packagename)))))
    505               (error "ASDF-INSTALL: can't untar ~S." packagename)))
     321  (let* ((tar (extract source packagename))
    506322         (pos-slash (or (position #\/ tar)
    507323                        (position #\Return tar)
     
    511327           (make-pathname :directory
    512328                          `(:relative ,(subseq tar 0 pos-slash)))
    513            source))
    514          )
    515     (princ tar)
     329           source)))
     330    ;(princ tar)
    516331    (loop for sysfile in (append
    517332                          (directory
    518                            (make-pathname :defaults (print *default-pathname-defaults*)
     333                           (make-pathname :defaults *default-pathname-defaults*
    519334                                          :name :wild
    520335                                          :type "asd"))
    521336                          (directory
    522                            (make-pathname :defaults (print *default-pathname-defaults*)
     337                           (make-pathname :defaults *default-pathname-defaults*
    523338                                          :name :wild
    524339                                          :type "system")))
    525           #-(or :win32 :mswindows)
    526           do
    527           #-(or :win32 :mswindows)
    528           (let ((target (merge-pathnames
    529                          (make-pathname :name (pathname-name sysfile)
    530                                         :type (pathname-type sysfile))
    531                          system)))
    532             (when (probe-file target)
    533               (unlink-file target))
    534             (symlink-files sysfile target))
    535           collect sysfile)))
    536 
    537 
    538 #| Original
    539 (defun install-package (source system packagename)
    540   "Returns a list of asdf system names for installed asdf systems"
    541   (ensure-directories-exist source)
    542   (ensure-directories-exist system)
    543   (let* ((tar
    544            (or
    545              #-(or :win32 :mswindows)
    546              (return-output-from-program "tar"
    547                                          (list "-C" (system-namestring source)
    548                                                "-xzvf" (system-namestring packagename)))
    549              #+(or :win32 :mswindows)
    550              (return-output-from-program "sh"
    551                                          (list "-c"
    552                                                (format nil "\"tar -C \\\"`cygpath '~A'`\\\" -xzvf \\\"`cygpath '~A'`\\\"\""
    553                                                        (namestring (truename source))
    554                                                        (namestring (truename packagename)))))
    555              (error "can't untar")))
    556          (pos-slash (position-if #'(lambda (c)
    557                                      (find c #(#\/ #\Return #\Linefeed)))
    558                                  tar))
    559          (*default-pathname-defaults*
    560           (merge-pathnames
    561            (make-pathname :directory
    562                           `(:relative ,(subseq tar 0 pos-slash)))
    563            source)))
    564     (princ tar)
    565     (loop for asd in (directory
    566                       (make-pathname :defaults (print *default-pathname-defaults*)
    567                                      :name :wild
    568                                      :type "asd"))
    569           #-(or :win32 :mswindows)
    570           do
    571           #-(or :win32 :mswindows)
    572           (let ((target (merge-pathnames
    573                          (make-pathname :name (pathname-name asd)
    574                                         :type (pathname-type asd))
    575                          system)))
    576             (when (probe-file target)
    577               (unlink-file target))
    578             (symlink-files asd target))
    579           collect (pathname-name asd))))
    580 |#
    581 
     340       do (maybe-symlink-sysfile system sysfile)
     341       do (installer-msg t "Found system definition: ~A" sysfile)
     342       do (maybe-update-central-registry sysfile)
     343       collect sysfile)))
     344
     345(defun maybe-update-central-registry (sysfile)
     346  ;; make sure that the systems we install are accessible in case
     347  ;; asdf-install:*locations* and asdf:*central-registry* are out
     348  ;; of sync
     349  (add-registry-location sysfile))
    582350
    583351(defun temp-file-name (p)
    584   (let* ((pos-slash (position #\/ p :from-end t))
    585          (pos-dot (position #\. p :start (or pos-slash 0))))
    586     (merge-pathnames
    587      (make-pathname
    588       :name (subseq p (if pos-slash (1+ pos-slash) 0) pos-dot)
    589       :type "asdf-install-tmp")
    590      #+:clisp (user-homedir-pathname))))
     352  (declare (ignore p))
     353  (let ((pathname nil))
     354    (loop for i = 0 then (1+ i) do
     355         (setf pathname
     356               (merge-pathnames
     357                (make-pathname
     358                 :name (format nil "asdf-install-~d" i)
     359                 :type "asdf-install-tmp")
     360                *temporary-directory*))
     361         (unless (probe-file pathname)
     362           (return-from temp-file-name pathname)))))
    591363
    592364
     
    594366;;; This is the external entry point.
    595367
    596 (defun install (&rest packages)
    597   (let ((*temporary-files* nil)
    598         (*trusted-uids*
    599          (let ((p (merge-pathnames "trusted-uids.lisp" *private-asdf-install-dirs*)))
    600            (when (probe-file p)
    601              (with-open-file (f p) (read f)))))
    602         ;; (installed-packages nil)
    603         )
     368(defun install (packages &key (propagate nil) (where *preferred-location*))
     369  (let* ((*preferred-location* where)
     370         (*temporary-files* nil)
     371         (trusted-uid-file
     372          (merge-pathnames "trusted-uids.lisp" *private-asdf-install-dirs*))
     373         (*trusted-uids*
     374          (when (probe-file trusted-uid-file)
     375            (with-open-file (f trusted-uid-file) (read f))))
     376         (old-uids (copy-list *trusted-uids*))
     377         #+asdf
     378         (*defined-systems* (if propagate
     379                              (make-hash-table :test 'equal)
     380                              *defined-systems*))
     381         (packages (if (atom packages) (list packages) packages))
     382         (*propagate-installation* propagate)
     383         (*systems-installed-this-time* nil))
    604384    (unwind-protect
    605         (destructuring-bind (source system name) (where)
    606           (declare (ignore name))
    607           (labels ((one-iter (packages)
    608                      (let ((installed-package-sysfiles
    609                             (loop for p in (mapcar #'string packages)
    610                                   unless
    611                                   #+(or :sbcl :alisp) (probe-file p)
    612                                   #-(or :sbcl :alisp) (and (/= (mismatch p "http://") 7)
    613                                                            (probe-file p))
    614                                   do (let ((tmp (temp-file-name p)))
    615                                        (pushnew tmp *temporary-files*)
    616                                        (download-files-for-package p tmp)
    617                                        (setf p tmp))
    618                                   end
    619                                   do (installer-msg t "Installing ~A in ~A, ~A"
    620                                                     p
    621                                                     source
    622                                                     system)
    623                                   append (install-package source
    624                                                           system
    625                                                           p)))
    626                            )
    627                      (dolist (sysfile installed-package-sysfiles)
    628                        (handler-bind
    629                            (
    630                            #+asdf
    631                            (asdf:missing-dependency
    632                             (lambda (c)
    633                               (installer-msg t
    634                                              "Downloading package ~A, required by ~A~%"
    635                                              (asdf::missing-requires c)
    636                                              (asdf:component-name
    637                                               (asdf::missing-required-by c)))
    638                               (one-iter (list
    639                                          (symbol-name
    640                                           (asdf::missing-requires c))))
    641                               (invoke-restart 'retry)))
    642 
    643                            #+mk-defsystem
    644                            (make:missing-component
    645                             (lambda (c)
    646                               (installer-msg t
    647                                              "Downloading package ~A, required by ~A~%"
    648                                            (make:missing-component-name c)
    649                                            (pathname-name sysfile) ; This should work.
    650                                            )
    651                               (one-iter (list (make:missing-component-name c)))
    652                               (invoke-restart 'retry)))
    653                             )
    654 
    655                          (loop (multiple-value-bind (ret restart-p)
    656                                    (with-simple-restart
    657                                        (retry "Retry installation")
    658                                      (load-system-definition sysfile))
    659                                  (declare (ignore ret))
    660                                  (unless restart-p (return))))
    661                          ))))
    662                    )
    663             (one-iter packages)))
    664       (let ((p (merge-pathnames "trusted-uids.lisp" *private-asdf-install-dirs*)))
    665         (when (probe-file p)
    666           (with-open-file (out p
    667                                :direction :output
    668                                :if-exists :supersede)
    669             (with-standard-io-syntax
    670               (prin1 *trusted-uids* out)))))
     385      (destructuring-bind (source system name) (install-location)
     386        (declare (ignore name))
     387        (labels
     388            ((one-iter (packages)
     389               (let ((packages-to-install nil))
     390                 (loop for p in (mapcar #'string packages) do
     391                      (cond ((local-archive-p p)
     392                             (setf packages-to-install
     393                                   (append packages-to-install
     394                                           (install-package source system p))))
     395                            (t
     396                             (multiple-value-bind (package signature)
     397                                 (download-files-for-package p)
     398                               (when (verify-gpg-signatures-p p)
     399                                 (verify-gpg-signature package signature))
     400                               (installer-msg t "Installing ~A in ~A, ~A"
     401                                              p source system)
     402                               (install-package source system package))
     403                             (setf packages-to-install
     404                                   (append packages-to-install
     405                                           (list p))))))
     406                 (dolist (package packages-to-install)
     407                   (setf package
     408                         (etypecase package
     409                           (symbol package)
     410                           (string (intern package :asdf-install))
     411                           (pathname (intern
     412                                      (namestring (pathname-name package))
     413                                      :asdf-install))))
     414                   (handler-bind
     415                       (
     416                        #+asdf
     417                        (asdf:missing-dependency
     418                         (lambda (c)
     419                           (installer-msg
     420                            t
     421                            "Downloading package ~A, required by ~A~%"
     422                            (asdf::missing-requires c)
     423                            (asdf:component-name
     424                             (asdf::missing-required-by c)))
     425                           (one-iter
     426                            (list (asdf::coerce-name
     427                                   (asdf::missing-requires c))))
     428                           (invoke-restart 'retry)))
     429                        #+mk-defsystem
     430                        (make:missing-component
     431                         (lambda (c)
     432                           (installer-msg
     433                            t
     434                            "Downloading package ~A, required by ~A~%"
     435                            (make:missing-component-name c)
     436                            package)
     437                           (one-iter (list (make:missing-component-name c)))
     438                           (invoke-restart 'retry))))
     439                     (loop (multiple-value-bind (ret restart-p)
     440                               (with-simple-restart
     441                                   (retry "Retry installation")
     442                                 (push package *systems-installed-this-time*)
     443                                 (load-package package))
     444                             (declare (ignore ret))
     445                             (unless restart-p (return)))))))))
     446          (one-iter packages)))
     447      ;;; cleanup
     448      (unless (equal old-uids *trusted-uids*)
     449        (let ((create-file-p nil))
     450          (unless (probe-file trusted-uid-file)
     451            (installer-msg t "Trusted UID file ~A does not exist"
     452                           (namestring trusted-uid-file))
     453            (setf create-file-p
     454                  (y-or-n-p "Do you want to create the file?")))
     455          (when (or create-file-p (probe-file trusted-uid-file))
     456            (ensure-directories-exist trusted-uid-file)
     457            (with-open-file (out trusted-uid-file
     458                                 :direction :output
     459                                 :if-exists :supersede)
     460              (with-standard-io-syntax
     461                (prin1 *trusted-uids* out))))))
    671462      (dolist (l *temporary-files* t)
    672         (when (probe-file l) (delete-file l))))))
    673 
    674 
    675 (defun load-system-definition (sysfile)
    676   (declare (type pathname sysfile))
     463        (when (probe-file l) (delete-file l))))
     464    (nreverse *systems-installed-this-time*)))
     465
     466(defun local-archive-p (package)
     467  #+(or :sbcl :allegro) (probe-file package)
     468  #-(or :sbcl :allegro) (and (/= (mismatch package "http://") 7)
     469                           (probe-file package)))
     470
     471(defun load-package (package)
    677472  #+asdf
    678   (when (or (string-equal "asd" (pathname-type sysfile))
    679             (string-equal "asdf" (pathname-type sysfile)))
    680     (installer-msg t "Loading system ~S via ASDF." (pathname-name sysfile))
    681     (asdf:operate 'asdf:load-op (pathname-name sysfile)))
    682 
     473  (progn
     474    (installer-msg t "Loading system ~S via ASDF." package)
     475    (asdf:operate 'asdf:load-op package))
    683476  #+mk-defsystem
    684   (when (string-equal "system" (pathname-type sysfile))
    685     (installer-msg t "Loading system ~S via MK:DEFSYSTEM." (pathname-name sysfile))
    686     (mk:load-system (pathname-name sysfile))))
    687 
    688 
    689 #| Original.
    690 (defun install (&rest packages)
    691   (let ((*temporary-files* nil)
    692         (*trusted-uids*
    693          (let ((p (merge-pathnames "trusted-uids.lisp" *private-asdf-install-dirs*)))
    694            (when (probe-file p)
    695              (with-open-file (f p) (read f))))))
    696     (unwind-protect
    697         (destructuring-bind (source system name) (where)
    698           (declare (ignore name))
    699           (labels ((one-iter (packages)
    700                      (dolist (asd
    701                               (loop for p in (mapcar 'string packages)
    702                                     unless #+(or :sbcl :alisp)
    703                                     (probe-file p)
    704                                     #-(or :sbcl :alisp)
    705                                     (and (/= (mismatch p "http://") 7)
    706                                          (probe-file p))
    707                                     do (let ((tmp (temp-file-name p)))
    708                                          (pushnew tmp *temporary-files*)
    709                                          (download-files-for-package p tmp)
    710                                          (setf p tmp))
    711                                     end
    712                                     do (format t "Installing ~A in ~A,~A~%"
    713                                                p source system)
    714                                     append (install-package source system p)))
    715                        (handler-bind
    716                            ((asdf:missing-dependency
    717                              (lambda (c)
    718                                (format t
    719                                        "Downloading package ~A, required by ~A~%"
    720                                        (asdf::missing-requires c)
    721                                        (asdf:component-name
    722                                         (asdf::missing-required-by c)))
    723                                (one-iter (list
    724                                           (symbol-name
    725                                            (asdf::missing-requires c))))
    726                                (invoke-restart 'retry))))
    727                          (loop
    728                           (multiple-value-bind (ret restart-p)
    729                               (with-simple-restart
    730                                   (retry "Retry installation")
    731                                 (asdf:operate 'asdf:load-op asd))
    732                             (declare (ignore ret))
    733                             (unless restart-p (return))))))))
    734             (one-iter packages)))
    735       (let ((p (merge-pathnames "trusted-uids.lisp" *private-asdf-install-dirs*)))
    736         (with-open-file (out p :direction :output
    737                              :if-exists :supersede)
    738           (with-standard-io-syntax
    739             (prin1 *trusted-uids* out))))
    740       (dolist (l *temporary-files*)
    741         (when (probe-file l) (delete-file l))))))
    742 |#
    743 
     477  (progn
     478    (installer-msg t "Loading system ~S via MK:DEFSYSTEM." package)
     479    (mk:load-system package)))
    744480
    745481;;; uninstall --
     
    749485  (let* ((asd (asdf:system-definition-pathname system))
    750486         (system (asdf:find-system system))
    751          (dir (asdf::pathname-sans-name+type
     487         (dir (pathname-sans-name+type
    752488               (asdf::resolve-symlinks asd))))
    753489    (when (or (not prompt)
     
    757493      #-(or :win32 :mswindows)
    758494      (delete-file asd)
    759       (asdf:run-shell-command "rm -r '~A'" (namestring (truename dir)))))
     495      (let ((dir (#-scl namestring #+scl ext:unix-namestring (truename dir))))
     496        (when dir
     497          (asdf:run-shell-command "rm -r '~A'" dir)))))
    760498
    761499  #+mk-defsystem
     
    777515      )))
    778516
    779 
    780 #| Original
    781 (defun uninstall (system &optional (prompt t))
    782   (let* ((asd (asdf:system-definition-pathname system))
    783          (system (asdf:find-system system))
    784          (dir (asdf::pathname-sans-name+type
    785                (asdf::resolve-symlinks asd))))
    786     (when (or (not prompt)
    787               (y-or-n-p
    788                "Delete system ~A~%asd file: ~A~%sources: ~A~%Are you sure?"
    789                system asd dir))
    790       #-(or :win32 :mswindows)
    791       (delete-file asd)
    792       (asdf:run-shell-command "rm -r '~A'" (namestring (truename dir))))))
    793 |#
    794 
    795517     
    796518;;; some day we will also do UPGRADE, but we need to sort out version
     
    814536            (return-from sysdef-source-dir-search file)))))))
    815537
     538(defmethod asdf:find-component :around
     539    ((module (eql nil)) name &optional version)
     540  (declare (ignore version))
     541  (when (or (not *propagate-installation*)
     542            (member name *systems-installed-this-time*
     543                    :test (lambda (a b)
     544                            (flet ((ensure-string (x)
     545                                     (etypecase x
     546                                       (symbol (symbol-name x))
     547                                       (string x))))
     548                              (string-equal (ensure-string a) (ensure-string b))))))
     549    (call-next-method)))
     550
     551(defun show-version-information ()
     552  (let ((version (asdf-install-version)))
     553    (if version
     554      (format *standard-output* "~&;;; ASDF-Install version ~A"
     555              version)
     556      (format *standard-output* "~&;;; ASDF-Install version unknown; unable to find ASDF system definition."))
     557  (values)))
     558
     559(defun asdf-install-version ()
     560  "Returns the ASDf-Install version information as a string or nil if it cannot be determined."
     561  (let ((system (asdf:find-system 'asdf-install)))
     562    (when system (asdf:component-version system))))
     563
     564;; load customizations if any
     565(eval-when (:load-toplevel :execute)
     566  (let* ((*package* (find-package :asdf-install-customize))
     567         (file (probe-file (merge-pathnames
     568                            (make-pathname :name ".asdf-install")
     569                            (truename (user-homedir-pathname))))))
     570    (when file (load file))))
     571
    816572;;; end of file -- install.lisp --
  • release/1.2/source/tools/asdf-install/load-asdf-install.lisp

    r928 r9219  
    55
    66(eval-when (:load-toplevel :execute)
    7   (unless (find-package "ASDF-INSTALL-LOADER")
    8     (make-package "ASDF-INSTALL-LOADER" :use '("COMMON-LISP"))))
     7  (unless (find-package '#:asdf-install-loader)
     8    (make-package '#:asdf-install-loader :use '(#:common-lisp))))
    99
    10 (in-package "ASDF-INSTALL-LOADER")
     10(in-package :asdf-install-loader)
    1111
    1212(eval-when (:compile-toplevel :load-toplevel :execute)
     
    6767      (load-and-or-compile "ASDF-INSTALL-LIBRARY:port.lisp")
    6868
    69       (unless (find-package "SPLIT-SEQUENCE")
     69      (unless (find-package '#:split-sequence)
    7070        (load-and-or-compile "ASDF-INSTALL-LIBRARY:split-sequence.lisp"))
    7171
    72       #|
    73       ;; Implementation dependencies (in alphabetical order).
    74       #+allegro
    75       (load-and-or-compile "ASDF-INSTALL-LIBRARY:impl-dependent;allegro.lisp")
     72      (load-and-or-compile "ASDF-INSTALL-LIBRARY:installer.lisp")
    7673
    77       #+clisp
    78       (load-and-or-compile "ASDF-INSTALL-LIBRARY:impl-dependent;clisp.lisp")
    79 
    80       #+(or cmu sbcl) ; They are still very similar.
    81       (load-and-or-compile "ASDF-INSTALL-LIBRARY:impl-dependent;cmucl.lisp")
    82 
    83       #+digitool
    84       (load-and-or-compile "ASDF-INSTALL-LIBRARY:digitool.lisp")
    85 
    86       #+lcl
    87       (load-and-or-compile "ASDF-INSTALL-LIBRARY:impl-dependent;lcl.lisp")
    88 
    89       #+lispworks
    90       (load-and-or-compile "ASDF-INSTALL-LIBRARY:impl-dependent;lispworks.lisp")
    91       |#
    92 
    93 
    94       (load-and-or-compile "ASDF-INSTALL-LIBRARY:installer.lisp")
    9574      ;; (load-and-or-compile "ASDF-INSTALL-LIBRARY:loader.lisp")
    9675
     
    10079
    10180  ;; To clean a minimum (and to make things difficult to debug)...
    102   ;; (delete-package "ASDF-INSTALL-LOADER")
     81  ;; (delete-package '#:asdf-install-loader)
    10382  )
    10483
  • release/1.2/source/tools/asdf-install/loader.lisp

    r503 r9219  
    33(eval-when (:load-toplevel)
    44  (unless (find-package 'asdf)
    5     (require 'asdf))
     5    (require 'asdf)))
     6
     7(eval-when (:load-toplevel)
     8  (unless (find-package 'asdf)
     9    (error "ASDF-Install requires ASDF to load"))   
    610  (let ((asdf::*verbose-out* nil))
    711    (require 'asdf-install)))
    812
     13#+sbcl
    914(defun run ()
    1015  (handler-case
  • release/1.2/source/tools/asdf-install/port.lisp

    r2590 r9219  
    1 (in-package :asdf-install)
     1(in-package #:asdf-install)
    22
    33(defvar *temporary-files*)
    44
     5(defparameter *shell-path* "/bin/sh"
     6  "The path to a Bourne compatible command shell in physical pathname notation.")
     7
    58(eval-when (:load-toplevel :compile-toplevel :execute)
    6   #+:lispworks
    7   (require "comm")
    89  #+:allegro
    910  (require :osi)
     
    1112  (require :socket)
    1213  #+:digitool
    13   (require :opentransport))
     14  (require :opentransport)
     15  #+:ecl
     16  (require :sockets)
     17  #+:lispworks
     18  (require "comm")
     19  )
    1420
    1521(defun get-env-var (name)
     22  #+:allegro (sys:getenv name)
     23  #+:clisp (ext:getenv name)
     24  #+:cmu (cdr (assoc (intern (substitute #\_ #\- name)
     25                             :keyword)
     26                     ext:*environment-list*))
     27  #+:ecl (ext:getenv name)
     28  #+:lispworks (lw:environment-variable name)
     29  #+(or :mcl :openmcl) (ccl::getenv name)
    1630  #+:sbcl (sb-ext:posix-getenv name)
    17   #+:cmu (cdr (assoc (intern (substitute #\_ #\- name)
    18                             :keyword)
    19                     ext:*environment-list*))
    20   #+:allegro (sys:getenv name)
    21   #+:lispworks (lw:environment-variable name)
    22   #+:clisp (ext:getenv name)
    23   #+(or :mcl :openmcl) (ccl::getenv name))
     31  #+:scl (cdr (assoc name ext:*environment-list* :test #'string=))
     32  )
    2433
    2534#-:digitool
     
    3948    (unless truename
    4049      (setf truename
    41               (translate-logical-pathname
    42                (merge-pathnames pathname *default-pathname-defaults*))))
     50            (translate-logical-pathname
     51             (merge-pathnames pathname *default-pathname-defaults*))))
    4352    (let ((directory (pathname-directory truename)))
    4453      (flet ((string-or-nil (value) (when (stringp value) value))
     
    6574
    6675;; for non-SBCL we just steal this from SB-EXECUTABLE
    67 #-(or :sbcl :digitool)
     76#-(or :digitool)
    6877(defvar *stream-buffer-size* 8192)
    69 #-(or :sbcl :digitool)
     78#-(or :digitool)
    7079(defun copy-stream (from to)
    7180  "Copy into TO from FROM until end of the input stream, in blocks of
     
    7685                         :element-type (stream-element-type from))))
    7786    (loop
    78      (let ((pos #-(or :clisp :cmu) (read-sequence buf from)
    79                 #+:clisp (ext:read-byte-sequence buf from :no-hang nil)
    80                 #+:cmu (sys:read-n-bytes from buf 0 *stream-buffer-size* nil)))
    81        (when (zerop pos) (return))
    82        (write-sequence buf to :end pos)))))
     87      (let ((pos #-(or :clisp :cmu) (read-sequence buf from)
     88                 #+:clisp (ext:read-byte-sequence buf from :no-hang nil)
     89                 #+:cmu (sys:read-n-bytes from buf 0 *stream-buffer-size* nil)))
     90        (when (zerop pos) (return))
     91        (write-sequence buf to :end pos)))))
    8392
    8493#+:digitool
     
    92101              (funcall writer writer-arg datum))))))
    93102
    94 #+:sbcl
    95 (declaim (inline copy-stream))
    96 #+:sbcl
    97 (defun copy-stream (from to)
    98   (sb-executable:copy-stream from to))
    99 
    100103(defun make-stream-from-url (url)
    101   #+:sbcl
     104  #+(or :sbcl :ecl)
    102105  (let ((s (make-instance 'sb-bsd-sockets:inet-socket
    103                           :type :stream
    104                           :protocol :tcp)))
     106             :type :stream
     107             :protocol :tcp)))
    105108    (sb-bsd-sockets:socket-connect
    106109     s (car (sb-bsd-sockets:host-ent-addresses
    107110             (sb-bsd-sockets:get-host-by-name (url-host url))))
    108111     (url-port url))
    109     (sb-bsd-sockets:socket-make-stream s :input t :output t :buffering :full))
     112    (sb-bsd-sockets:socket-make-stream
     113     s
     114     :input t
     115     :output t
     116     :buffering :full
     117     :external-format :iso-8859-1))
    110118  #+:cmu
    111119  (sys:make-fd-stream (ext:connect-to-inet-socket (url-host url) (url-port url))
    112120                      :input t :output t :buffering :full)
     121  #+:scl
     122  (sys:make-fd-stream (ext:connect-to-inet-socket (url-host url) (url-port url))
     123                      :input t :output t :buffering :full
     124                      :external-format :iso-8859-1)
    113125  #+:lispworks
    114126  (comm:open-tcp-stream (url-host url) (url-port url)
     
    129141                        :element-type 'unsigned-byte))
    130142
    131 #+(or :sbcl :cmu)
    132 (defun make-stream-from-gpg-command (string file-name)
    133   (#+:sbcl sb-ext:process-output
    134    #+:cmu ext:process-output
    135    (#+:sbcl sb-ext:run-program
    136     #+:cmu ext:run-program
    137     "gpg"
    138     (list
    139      "--status-fd" "1" "--verify" "-"
    140      (namestring file-name))
    141     :output :stream
    142     :error nil
    143     #+sbcl :search #+sbcl t
    144     :input (make-string-input-stream string)
    145     :wait t)))
    146 
    147 #+(and :lispworks (not :win32))
    148 (defun make-stream-from-gpg-command (string file-name)
    149   ;; kludge - we can't separate the in and out streams
    150   (let ((stream (sys:open-pipe (format nil "echo '~A' | gpg --status-fd 1 --verify - ~A"
    151                                        string
    152                                        (namestring file-name)))))
    153     stream))
    154 
    155 (defun make-temp-sig (file-name content)
    156   (let ((name (format nil "~A.asc" (namestring (truename file-name)))))
    157     (with-open-file (out name
    158                          :direction :output
    159                          :if-exists :supersede)
    160       (write-string content out))
    161     (pushnew name *temporary-files*)
    162     name))
    163 
    164 #+(and :lispworks :win32)
    165 (defun make-stream-from-gpg-command (string file-name)
    166   (sys:open-pipe (format nil "gpg --status-fd 1 --verify \"~A\" \"~A\""
    167                          (make-temp-sig file-name string)
    168                          (namestring file-name))))
    169 
    170 #+(and :clisp (not (or :win32 :cygwin)))
    171 (defun make-stream-from-gpg-command (string file-name)
    172   (let ((stream
    173           (ext:run-shell-command (format nil "echo '~A' | gpg --status-fd 1 --verify - ~A"
    174                                          string
    175                                          (namestring file-name))
    176                            :output :stream
    177                            :wait nil)))
    178     stream))
    179 
    180 #+(and :clisp (or :win32 :cygwin))
    181 (defun make-stream-from-gpg-command (string file-name)
    182   (ext:run-shell-command (format nil "gpg --status-fd 1 --verify \"~A\" \"~A\""
    183                                  (make-temp-sig file-name string)
    184                                  (namestring file-name))
    185                          :output :stream
    186                          :wait nil))
    187 
    188 #+:allegro
    189 (defun make-stream-from-gpg-command (string file-name)
    190   (multiple-value-bind (in-stream out-stream)
    191       (excl:run-shell-command
    192        #-:mswindows
    193        (concatenate 'vector
    194                     #("gpg" "gpg" "--status-fd" "1" "--verify" "-")
    195                     (make-sequence 'vector 1
    196                                    :initial-element (namestring file-name)))
    197        #+:mswindows
    198        (format nil "gpg --status-fd 1 --verify - \"~A\"" (namestring file-name))
    199        :input :stream
    200        :output :stream
    201        :separate-streams t
    202        :wait nil)
    203     (write-string string in-stream)
    204     (finish-output in-stream)
    205     (close in-stream)
    206     out-stream))
    207 
    208 #+:openmcl
    209 (defun make-stream-from-gpg-command (string file-name)
    210   (let ((proc (ccl:run-program "gpg" (list "--status-fd" "1" "--verify" "-" (namestring file-name))
    211                                :input :stream
    212                                :output :stream
    213                                :wait nil)))
    214     (write-string string (ccl:external-process-input-stream proc))
    215     (close (ccl:external-process-input-stream proc))
    216     (ccl:external-process-output-stream proc)))
    217 
    218 #+:digitool
    219 (defun make-stream-from-gpg-command (string file-name)
    220   (make-instance 'popen-input-stream
    221                  :command (format nil "echo '~A' | gpg --status-fd 1 --verify - '~A'"
    222                                   string
    223                                   (system-namestring file-name))))
    224143
    225144#+:sbcl
     
    230149                 args
    231150                 :output out-stream
     151                 :search t
    232152                 :wait t)))
    233153      (when (or (null proc)
     
    236156        (return-from return-output-from-program nil)))))
    237157
    238 #+:cmu
     158#+(or :cmu :scl)
    239159(defun return-output-from-program (program args)
    240160  (with-output-to-string (out-stream)
     
    254174    (unless (zerop (sys:call-system-showing-output
    255175                    (format nil #-:win32 "~A~{ '~A'~}"
    256                                 #+:win32 "~A~{ ~A~}"
    257                                 program args)
     176                            #+:win32 "~A~{ ~A~}"
     177                            program args)
    258178                    :prefix ""
    259179                    :show-cmd nil
     
    265185  (with-output-to-string (out-stream)
    266186    (let ((stream
    267             (ext:run-program program
    268                              :arguments args
    269                              :output :stream
    270                              :wait nil)))
     187           (ext:run-program program
     188                            :arguments args
     189                            :output :stream
     190                            :wait nil)))
    271191      (loop for line = (read-line stream nil)
    272192            while line
     
    277197  (with-output-to-string (out-stream)
    278198    (let ((stream
    279             (ext:run-shell-command
    280              (format nil "~A~{ ~A~}" program args
    281                      :output :stream
    282                      :wait nil))))
     199           (ext:run-shell-command
     200            (format nil "~A~{ ~A~}" program args
     201                    :output :stream
     202                    :wait nil))))
    283203      (loop for line = (ignore-errors (read-line stream nil))
    284204            while line
     
    289209  (with-output-to-string (out-stream)
    290210    (let ((stream
    291             (excl:run-shell-command
    292              #-:mswindows
    293              (concatenate 'vector
    294                           (list program)
    295                           (cons program args))
    296              #+:mswindows
    297              (format nil "~A~{ ~A~}" program args)
    298              :output :stream
    299              :wait nil)))
     211           (excl:run-shell-command
     212            #-:mswindows
     213            (concatenate 'vector
     214                         (list program)
     215                         (cons program args))
     216            #+:mswindows
     217            (format nil "~A~{ ~A~}" program args)
     218            :output :stream
     219            :wait nil)))
    300220      (loop for line = (read-line stream nil)
    301221            while line
    302222            do (write-line line out-stream)))))
     223
     224#+:ecl
     225(defun return-output-from-program (program args)
     226  (with-output-to-string (out-stream)
     227    (let ((stream (ext:run-program program args :output :stream)))
     228      (when stream
     229        (loop for line = (ignore-errors (read-line stream nil))
     230              while line
     231              do (write-line line out-stream))))))
    303232
    304233#+:openmcl
     
    309238                                 :output :stream
    310239                                 :wait nil)))
    311       (loop for line = (read-line (ccl:external-process-output-stream proc) nil nil nil)
     240      (loop for line = (read-line
     241                        (ccl:external-process-output-stream proc) nil nil nil)
    312242            while line
    313243            do (write-line line out-stream)))))
     
    317247  (ccl::call-system (format nil "~A~{ '~A'~} 2>&1" program args)))
    318248
    319 ;; why not just use DELETE-FILE?
    320249(defun unlink-file (pathname)
    321   #+:sbcl
    322   (sb-posix:unlink pathname)
    323   #+:cmu
    324   (unix:unix-unlink (namestring pathname))
    325   #+:allegro
    326   (excl.osi:unlink pathname)
    327   #+(or :lispwork :clisp :openmcl :digitool)
     250  ;; 20070208 gwking@metabang.com - removed lisp-specific os-level calls
     251  ;; in favor of a simple delete
    328252  (delete-file pathname))
    329253
    330254(defun symlink-files (old new)
    331   #+:sbcl
    332   (sb-posix:symlink old new)
    333   #+:cmu
    334   (unix:unix-symlink (namestring old)
    335                      (namestring new))
    336   #+:allegro
    337   (excl.osi:symlink old new)
    338   #+:lispworks
    339   ;; we loose if the pathnames contain apostrophes...
    340   (sys:call-system (format nil "ln -s '~A' '~A'"
    341                            (namestring old)
    342                            (namestring new)))
    343   #+:clisp
    344   (ext:run-program "ln"
    345                    :arguments (append '("-s")
    346                                       (list (format nil "~A" (namestring old))
    347                                             (format nil "~A" (namestring new)))))
    348   #+:openmcl
    349   (ccl:run-program "ln" (list "-s" (namestring old) (namestring new)))
    350   #+:digitool
    351   (ccl::call-system (format nil "ln -s '~A' '~A'"
    352                             (system-namestring old)
    353                             (system-namestring new))))
     255  (let* ((old (#-scl namestring #+scl ext:unix-namestring old))
     256         (new (#-scl namestring #+scl ext:unix-namestring new #+scl nil))
     257         ;; 20070811 - thanks to Juan Jose Garcia-Ripoll for pointing
     258         ;; that ~a would wreck havoc if the working directory had a space
     259         ;; in the pathname
     260         (command (format nil "ln -s ~s ~s" old new)))
     261    (format t "~S~%" command)
     262    (shell-command command)))
     263
     264(defun maybe-symlink-sysfile (system sysfile)
     265  (declare (ignorable system sysfile))
     266  #-(or :win32 :mswindows)
     267  (let ((target (merge-pathnames
     268                 (make-pathname :name (pathname-name sysfile)
     269                                :type (pathname-type sysfile))
     270                 system)))
     271    (when (probe-file target)
     272      (unlink-file target))
     273    (symlink-files sysfile target)))
     274
     275;;; ---------------------------------------------------------------------------
     276;;; read-header-line
     277;;; ---------------------------------------------------------------------------
     278
     279#-:digitool
     280(defun read-header-line (stream)
     281  (read-line stream))
     282
     283#+:digitool
     284(defun read-header-line (stream &aux (line (make-array 16
     285                                                       :element-type 'character
     286                                                       :adjustable t
     287                                                       :fill-pointer 0))
     288                                (byte nil))
     289  (print (multiple-value-bind (reader arg)
     290                              (ccl::stream-reader stream)
     291           (loop (setf byte (funcall reader arg))
     292                 (case byte
     293                   ((nil)
     294                    (return))
     295                   ((#.(char-code #\Return)
     296                     #.(char-code #\Linefeed))
     297                    (case (setf byte (funcall reader arg))
     298                      ((nil #.(char-code #\Return) #.(char-code #\Linefeed)))
     299                      (t (ccl:stream-untyi stream byte)))
     300                    (return))
     301                   (t
     302                    (vector-push-extend (code-char byte) line))))
     303           (when (or byte (plusp (length line)))
     304             line))))
     305
     306(defun open-file-arguments ()
     307  (append
     308   #+sbcl
     309   '(:external-format :latin1)
     310   #+:scl
     311   '(:external-format :iso-8859-1)
     312   #+(or :clisp :digitool (and :lispworks :win32))
     313   '(:element-type (unsigned-byte 8))))
     314
     315(defun download-url-to-file (url file-name)
     316  "Resolves url and then downloads it to file-name; returns the url actually used."
     317  (multiple-value-bind (response headers stream)
     318      (loop
     319       (destructuring-bind (response headers stream)
     320           (url-connection url)
     321         (unless (member response '(301 302))
     322           (return (values response headers stream)))
     323         (close stream)
     324         (setf url (header-value :location headers))))
     325    (when (>= response 400)
     326      (error 'download-error :url url :response response))
     327    (let ((length (parse-integer (or (header-value :content-length headers) "")
     328                                 :junk-allowed t)))
     329      (installer-msg t "Downloading ~A bytes from ~A to ~A ..."
     330                     (or length "some unknown number of")
     331                     url
     332                     file-name)
     333      (force-output)
     334      #+:clisp (setf (stream-element-type stream)
     335                     '(unsigned-byte 8))
     336      (let ((ok? nil) (o nil))
     337        (unwind-protect
     338             (progn
     339               (setf o (apply #'open file-name
     340                              :direction :output :if-exists :supersede
     341                              (open-file-arguments)))
     342               #+(or :cmu :digitool)
     343               (copy-stream stream o)
     344               #-(or :cmu :digitool)
     345               (if length
     346                   (let ((buf (make-array length
     347                                          :element-type
     348                                          (stream-element-type stream))))
     349                     #-:clisp (read-sequence buf stream)
     350                     #+:clisp (ext:read-byte-sequence buf stream :no-hang nil)
     351                     (write-sequence buf o))
     352                   (copy-stream stream o))
     353               (setf ok? t))
     354          (when o (close o :abort (null ok?))))))
     355    (close stream))
     356  (values url))
     357
     358(defun download-url-to-temporary-file (url)
     359  "Attempts to download url to a new, temporary file. Returns the resolved url and the file name \(as multiple values\)."
     360  (let ((tmp (temp-file-name url)))
     361    (pushnew tmp *temporary-files*)
     362    (values (download-url-to-file url tmp) tmp)))
     363
     364(defun gpg-results (package signature)
     365  (let ((tags nil))
     366    (with-input-from-string
     367        (gpg-stream
     368         (shell-command (format nil "gpg --status-fd 1 --verify ~s ~s"
     369                                (namestring signature) (namestring package))))
     370      (loop for l = (read-line gpg-stream nil nil)
     371         while l
     372         do (print l)
     373         when (> (mismatch l "[GNUPG:]") 6)
     374         do (destructuring-bind (_ tag &rest data)
     375                (split-sequence-if (lambda (x)
     376                                     (find x '(#\Space #\Tab)))
     377                                   l)
     378              (declare (ignore _))
     379              (pushnew (cons (intern (string-upcase tag) :keyword)
     380                             data) tags)))
     381      tags)))
     382
     383#+allegro
     384(defun shell-command (command)
     385  (multiple-value-bind (output error status)
     386                       (excl.osi:command-output command :whole t)
     387    (values output error status)))
     388
     389#+clisp
     390(defun shell-command (command)
     391  ;; BUG: CLisp doesn't allow output to user-specified stream
     392  (values
     393   nil
     394   nil
     395   (ext:run-shell-command  command :output :terminal :wait t)))
     396
     397#+(or :cmu :scl)
     398(defun shell-command (command)
     399  (let* ((process (ext:run-program
     400                   *shell-path*
     401                   (list "-c" command)
     402                   :input nil :output :stream :error :stream))
     403         (output (file-to-string-as-lines (ext::process-output process)))
     404         (error (file-to-string-as-lines (ext::process-error process))))
     405    (close (ext::process-output process))
     406    (close (ext::process-error process))
     407    (values
     408     output
     409     error
     410     (ext::process-exit-code process))))
     411
     412#+ecl
     413(defun shell-command (command)
     414  ;; If we use run-program, we do not get exit codes
     415  (values nil nil (ext:system command)))
     416
     417#+lispworks
     418(defun shell-command (command)
     419  ;; BUG: Lispworks combines output and error streams
     420  (let ((output (make-string-output-stream)))
     421    (unwind-protect
     422      (let ((status
     423             (system:call-system-showing-output
     424              command
     425              :prefix ""
     426              :show-cmd nil
     427              :output-stream output)))
     428        (values (get-output-stream-string output) nil status))
     429      (close output))))
     430
     431#+openmcl
     432(defun shell-command (command)
     433  (let* ((process (create-shell-process command t))
     434         (output (file-to-string-as-lines
     435                  (ccl::external-process-output-stream process)))
     436         (error (file-to-string-as-lines
     437                 (ccl::external-process-error-stream process))))
     438    (close (ccl::external-process-output-stream process))
     439    (close (ccl::external-process-error-stream process))
     440    (values output
     441            error
     442            (process-exit-code process))))
     443
     444#+openmcl
     445(defun create-shell-process (command wait)
     446  (ccl:run-program
     447   *shell-path*
     448   (list "-c" command)
     449   :input nil :output :stream :error :stream
     450   :wait wait))
     451
     452#+openmcl
     453(defun process-exit-code (process)
     454  (nth-value 1 (ccl:external-process-status process)))
     455
     456#+digitool
     457(defun shell-command (command)
     458  ;; BUG: I have no idea what this returns
     459  (ccl::call-system command))
     460
     461#+sbcl
     462(defun shell-command (command)
     463  (let* ((process (sb-ext:run-program
     464                   *shell-path*
     465                   (list "-c" command)
     466                   :input nil :output :stream :error :stream))
     467         (output (file-to-string-as-lines (sb-impl::process-output process)))
     468         (error (file-to-string-as-lines (sb-impl::process-error process))))
     469    (close (sb-impl::process-output process))
     470    (close (sb-impl::process-error process))
     471    (values
     472     output
     473     error
     474     (sb-impl::process-exit-code process))))
     475
     476(defgeneric file-to-string-as-lines (pathname)
     477  (:documentation ""))
     478
     479(defmethod file-to-string-as-lines ((pathname pathname))
     480  (with-open-file (stream pathname :direction :input)
     481    (file-to-string-as-lines stream)))
     482
     483(defmethod file-to-string-as-lines ((stream stream))
     484  (with-output-to-string (s)
     485    (loop for line = (read-line stream nil :eof nil)
     486         until (eq line :eof) do
     487         (princ line s)
     488         (terpri s))))
     489
     490;; copied from ASDF
     491(defun pathname-sans-name+type (pathname)
     492  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
     493and NIL NAME and TYPE components"
     494  (make-pathname :name nil :type nil :defaults pathname))
     495
  • release/1.2/source/tools/asdf-install/split-sequence.lisp

    r928 r9219  
    44;;; <URL:http://groups.google.com/groups?as_umsgid=39F36F1A.B8F19D20%40simplex.nl>;
    55;;;
    6 ;;; changes include:
    7 ;;;
    8 ;;; * altering the behaviour of the :from-end keyword argument to
    9 ;;; return the subsequences in original order, for consistency with
    10 ;;; CL:REMOVE, CL:SUBSTITUTE et al. (:from-end being non-NIL only
    11 ;;; affects the answer if :count is less than the number of
    12 ;;; subsequences, by analogy with the above-referenced functions).
    13 ;;;   
    14 ;;; * changing the :maximum keyword argument to :count, by analogy
    15 ;;; with CL:REMOVE, CL:SUBSTITUTE, and so on.
    16 ;;;
    17 ;;; * naming the function SPLIT-SEQUENCE rather than PARTITION rather
    18 ;;; than SPLIT.
    19 ;;;
    20 ;;; * adding SPLIT-SEQUENCE-IF and SPLIT-SEQUENCE-IF-NOT.
    21 ;;;
    22 ;;; * The second return value is now an index rather than a copy of a
    23 ;;; portion of the sequence; this index is the `right' one to feed to
    24 ;;; CL:SUBSEQ for continued processing.
    256
    26 ;;; There's a certain amount of code duplication here, which is kept
    27 ;;; to illustrate the relationship between the SPLIT-SEQUENCE
    28 ;;; functions and the CL:POSITION functions.
    29 
    30 ;;; Examples:
    31 ;;;
    32 ;;; * (split-sequence #\; "a;;b;c")
    33 ;;; -> ("a" "" "b" "c"), 6
    34 ;;;
    35 ;;; * (split-sequence #\; "a;;b;c" :from-end t)
    36 ;;; -> ("a" "" "b" "c"), 0
    37 ;;;
    38 ;;; * (split-sequence #\; "a;;b;c" :from-end t :count 1)
    39 ;;; -> ("c"), 4
    40 ;;;
    41 ;;; * (split-sequence #\; "a;;b;c" :remove-empty-subseqs t)
    42 ;;; -> ("a" "b" "c"), 6
    43 ;;;
    44 ;;; * (split-sequence-if (lambda (x) (member x '(#\a #\b))) "abracadabra")
    45 ;;; -> ("" "" "r" "c" "d" "" "r" ""), 11
    46 ;;;
    47 ;;; * (split-sequence-if-not (lambda (x) (member x '(#\a #\b))) "abracadabra")
    48 ;;; -> ("ab" "a" "a" "ab" "a"), 11
    49 ;;;
    50 ;;; * (split-sequence #\; ";oo;bar;ba;" :start 1 :end 9)
    51 ;;; -> ("oo" "bar" "b"), 9
    52 
    53 (defpackage "SPLIT-SEQUENCE"
    54   (:use "CL")
    55   (:nicknames "PARTITION")
    56   (:export "SPLIT-SEQUENCE" "SPLIT-SEQUENCE-IF" "SPLIT-SEQUENCE-IF-NOT"
    57            "PARTITION" "PARTITION-IF" "PARTITION-IF-NOT")
    58   (:documentation "The SPLIT-SEQUENCE package provides functionality for Common Lisp sequences analagous to Perl's split operator."))
    59 
    60 (in-package "SPLIT-SEQUENCE")
    61 
    62 (defun split-sequence (delimiter seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (test nil test-supplied) (test-not nil test-not-supplied) (key nil key-supplied))
    63   "Return a list of subsequences in seq delimited by delimiter.
    64 
    65 If :remove-empty-subseqs is NIL, empty subsequences will be included
    66 in the result; otherwise they will be discarded.  All other keywords
    67 work analogously to those for CL:SUBSTITUTE.  In particular, the
    68 behaviour of :from-end is possibly different from other versions of
    69 this function; :from-end values of NIL and T are equivalent unless
    70 :count is supplied. The second return value is an index suitable as an
    71 argument to CL:SUBSEQ into the sequence indicating where processing
    72 stopped."
    73   (let ((len (length seq))
    74         (other-keys (nconc (when test-supplied
    75                              (list :test test))
    76                            (when test-not-supplied
    77                              (list :test-not test-not))
    78                            (when key-supplied
    79                              (list :key key)))))
    80     (unless end (setq end len))
    81     (if from-end
    82         (loop for right = end then left
    83               for left = (max (or (apply #'position delimiter seq
    84                                          :end right
    85                                          :from-end t
    86                                          other-keys)
    87                                   -1)
    88                               (1- start))
    89               unless (and (= right (1+ left))
    90                           remove-empty-subseqs) ; empty subseq we don't want
    91               if (and count (>= nr-elts count))
    92               ;; We can't take any more. Return now.
    93               return (values (nreverse subseqs) right)
    94               else
    95               collect (subseq seq (1+ left) right) into subseqs
    96               and sum 1 into nr-elts
    97               until (< left start)
    98               finally (return (values (nreverse subseqs) (1+ left))))
    99       (loop for left = start then (+ right 1)
    100             for right = (min (or (apply #'position delimiter seq
    101                                         :start left
    102                                         other-keys)
    103                                  len)
    104                              end)
    105             unless (and (= right left)
    106                         remove-empty-subseqs) ; empty subseq we don't want
    107             if (and count (>= nr-elts count))
    108             ;; We can't take any more. Return now.
    109             return (values subseqs left)
    110             else
    111             collect (subseq seq left right) into subseqs
    112             and sum 1 into nr-elts
    113             until (>= right end)
    114             finally (return (values subseqs right))))))
     7(in-package #:asdf-install)
    1158
    1169(defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied))
     
    16558            finally (return (values subseqs right))))))
    16659
    167 (defun split-sequence-if-not (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied))
    168   "Return a list of subsequences in seq delimited by items satisfying
    169 (CL:COMPLEMENT predicate).
    170 
    171 If :remove-empty-subseqs is NIL, empty subsequences will be included
    172 in the result; otherwise they will be discarded.  All other keywords
    173 work analogously to those for CL:SUBSTITUTE-IF-NOT.  In particular,
    174 the behaviour of :from-end is possibly different from other versions
    175 of this function; :from-end values of NIL and T are equivalent unless
    176 :count is supplied. The second return value is an index suitable as an
    177 argument to CL:SUBSEQ into the sequence indicating where processing
    178 stopped."
    179   (let ((len (length seq))
    180         (other-keys (when key-supplied
    181                       (list :key key))))
    182     (unless end (setq end len))
    183     (if from-end
    184         (loop for right = end then left
    185               for left = (max (or (apply #'position-if-not predicate seq
    186                                          :end right
    187                                          :from-end t
    188                                          other-keys)
    189                                   -1)
    190                               (1- start))
    191               unless (and (= right (1+ left))
    192                           remove-empty-subseqs) ; empty subseq we don't want
    193               if (and count (>= nr-elts count))
    194               ;; We can't take any more. Return now.
    195               return (values (nreverse subseqs) right)
    196               else
    197               collect (subseq seq (1+ left) right) into subseqs
    198               and sum 1 into nr-elts
    199               until (< left start)
    200               finally (return (values (nreverse subseqs) (1+ left))))
    201       (loop for left = start then (+ right 1)
    202             for right = (min (or (apply #'position-if-not predicate seq
    203                                         :start left
    204                                         other-keys)
    205                                  len)
    206                              end)
    207             unless (and (= right left)
    208                         remove-empty-subseqs) ; empty subseq we don't want
    209             if (and count (>= nr-elts count))
    210             ;; We can't take any more. Return now.
    211             return (values subseqs left)
    212             else
    213             collect (subseq seq left right) into subseqs
    214             and sum 1 into nr-elts
    215             until (>= right end)
    216             finally (return (values subseqs right))))))
    217 
    218 ;;; clean deprecation
    219 
    220 (defun partition (&rest args)
    221   "PARTITION is deprecated; use SPLIT-SEQUENCE instead."
    222   (apply #'split-sequence args))
    223 
    224 (defun partition-if (&rest args)
    225   "PARTITION-IF is deprecated; use SPLIT-SEQUENCE-IF instead."
    226   (apply #'split-sequence-if args))
    227 
    228 (defun partition-if-not (&rest args)
    229   "PARTITION-IF-NOT is deprecated; use SPLIT-SEQUENCE-IF-NOT instead."
    230   (apply #'split-sequence-if-not args))
    231 
    232 (define-compiler-macro partition (&whole form &rest args)
    233   (declare (ignore args))
    234   (warn "PARTITION is deprecated; use SPLIT-SEQUENCE instead.")
    235   form)
    236 
    237 (define-compiler-macro partition-if (&whole form &rest args)
    238   (declare (ignore args))
    239   (warn "PARTITION-IF is deprecated; use SPLIT-SEQUENCE-IF instead.")
    240   form)
    241 
    242 (define-compiler-macro partition-if-not (&whole form &rest args)
    243   (declare (ignore args))
    244   (warn "PARTITION-IF-NOT is deprecated; use SPLIT-SEQUENCE-IF-NOT instead")
    245   form)
    246 
    247 (pushnew :split-sequence *features*)
  • release/1.2/source/tools/asdf.lisp

    r9202 r9219  
    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/
    9 by 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 
    28 asdf</a>
    29 /
    30 
    31 <a href="/cclan/asdf/asdf.lisp?view=log">
    32 
    33 asdf.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">
    59 Revision <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)
    66 by <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 />
    1415 Powered 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 
     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-2007 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           #:system-licence
     82           #:system-source-file
     83           #:system-relative-pathname
     84
     85           #:operation-on-warnings
     86           #:operation-on-failure
     87
     88           ;#:*component-parent-pathname*
     89           #:*system-definition-search-functions*
     90           #:*central-registry*         ; variables
     91           #:*compile-file-warnings-behaviour*
     92           #:*compile-file-failure-behaviour*
     93           #:*asdf-revision*
     94
     95           #:operation-error #:compile-failed #:compile-warned #:compile-error
     96           #:error-component #:error-operation
     97           #:system-definition-error
     98           #:missing-component
     99           #:missing-dependency
     100           #:circular-dependency        ; errors
     101           #:duplicate-names
     102
     103           #:retry
     104           #:accept                     ; restarts
     105
     106           #:preference-file-for-system/operation
     107           #:load-preferences
     108           )
     109  (:use :cl))
     110
     111
     112#+nil
     113(error "The author of this file habitually uses #+nil to comment out ~
     114        forms. But don't worry, it was unlikely to work in the New ~
     115        Implementation of Lisp anyway")
     116
     117(in-package #:asdf)
     118
     119(defvar *asdf-revision* (let* ((v "$Revision$")
     120                               (colon (or (position #\: v) -1))
     121                               (dot (position #\. v)))
     122                          (and v colon dot
     123                               (list (parse-integer v :start (1+ colon)
     124                                                      :junk-allowed t)
     125                                     (parse-integer v :start (1+ dot)
     126                                                      :junk-allowed t)))))
     127
     128(defvar *compile-file-warnings-behaviour* :warn)
     129
     130(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn)
     131
     132(defvar *verbose-out* nil)
     133
     134(defparameter +asdf-methods+
     135  '(perform explain output-files operation-done-p))
     136
     137;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     138;; utility stuff
     139
     140(defmacro aif (test then &optional else)
     141  `(let ((it ,test)) (if it ,then ,else)))
     142
     143(defun pathname-sans-name+type (pathname)
     144  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
     145and NIL NAME and TYPE components"
     146  (make-pathname :name nil :type nil :defaults pathname))
     147
     148(define-modify-macro appendf (&rest args)
     149  append "Append onto list")
     150
     151;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     152;; classes, condiitons
     153
     154(define-condition system-definition-error (error) ()
     155  ;; [this use of :report should be redundant, but unfortunately it's not.
     156  ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
     157  ;; over print-object; this is always conditions::%print-condition for
     158  ;; condition objects, which in turn does inheritance of :report options at
     159  ;; run-time.  fortunately, inheritance means we only need this kludge here in
     160  ;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]
     161  #+cmu (:report print-object))
     162
     163(define-condition formatted-system-definition-error (system-definition-error)
     164  ((format-control :initarg :format-control :reader format-control)
     165   (format-arguments :initarg :format-arguments :reader format-arguments))
     166  (:report (lambda (c s)
     167             (apply #'format s (format-control c) (format-arguments c)))))
     168
     169(define-condition circular-dependency (system-definition-error)
     170  ((components :initarg :components :reader circular-dependency-components)))
     171
     172(define-condition duplicate-names (system-definition-error)
     173  ((name :initarg :name :reader duplicate-names-name)))
     174
     175(define-condition missing-component (system-definition-error)
     176  ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
     177   (version :initform nil :reader missing-version :initarg :version)
     178   (parent :initform nil :reader missing-parent :initarg :parent)))
     179
     180(define-condition missing-dependency (missing-component)
     181  ((required-by :initarg :required-by :reader missing-required-by)))
     182
     183(define-condition operation-error (error)
     184  ((component :reader error-component :initarg :component)
     185   (operation :reader error-operation :initarg :operation))
     186  (:report (lambda (c s)
     187             (format s "~@<erred while invoking ~A on ~A~@:>"
     188                     (error-operation c) (error-component c)))))
     189(define-condition compile-error (operation-error) ())
     190(define-condition compile-failed (compile-error) ())
     191(define-condition compile-warned (compile-error) ())
     192
     193(defclass component ()
     194  ((name :accessor component-name :initarg :name :documentation
     195         "Component name: designator for a string composed of portable pathname characters")
     196   (version :accessor component-version :initarg :version)
     197   (in-order-to :initform nil :initarg :in-order-to)
     198   ;; XXX crap name
     199   (do-first :initform nil :initarg :do-first)
     200   ;; methods defined using the "inline" style inside a defsystem form:
     201   ;; need to store them somewhere so we can delete them when the system
     202   ;; is re-evaluated
     203   (inline-methods :accessor component-inline-methods :initform nil)
     204   (parent :initarg :parent :initform nil :reader component-parent)
     205   ;; no direct accessor for pathname, we do this as a method to allow
     206   ;; it to default in funky ways if not supplied
     207   (relative-pathname :initarg :pathname)
     208   (operation-times :initform (make-hash-table )
     209                    :accessor component-operation-times)
     210   ;; XXX we should provide some atomic interface for updating the
     211   ;; component properties
     212   (properties :accessor component-properties :initarg :properties
     213               :initform nil)))
     214
     215;;;; methods: conditions
     216
     217(defmethod print-object ((c missing-dependency) s)
     218  (format s "~@<~A, required by ~A~@:>"
     219          (call-next-method c nil) (missing-required-by c)))
     220
     221(defun sysdef-error (format &rest arguments)
     222  (error 'formatted-system-definition-error :format-control format :format-arguments arguments))
     223
     224;;;; methods: components
     225
     226(defmethod print-object ((c missing-component) s)
     227  (format s "~@<component ~S not found~
     228             ~@[ or does not match version ~A~]~
     229             ~@[ in ~A~]~@:>"
     230          (missing-requires c)
     231          (missing-version c)
     232          (when (missing-parent c)
     233            (component-name (missing-parent c)))))
     234
     235(defgeneric component-system (component)
     236  (:documentation "Find the top-level system containing COMPONENT"))
     237
     238(defmethod component-system ((component component))
     239  (aif (component-parent component)
     240       (component-system it)
     241       component))
     242
     243(defmethod print-object ((c component) stream)
     244  (print-unreadable-object (c stream :type t :identity t)
     245    (ignore-errors
     246      (prin1 (component-name c) stream))))
     247
     248(defclass module (component)
     249  ((components :initform nil :accessor module-components :initarg :components)
     250   ;; what to do if we can't satisfy a dependency of one of this module's
     251   ;; components.  This allows a limited form of conditional processing
     252   (if-component-dep-fails :initform :fail
     253                           :accessor module-if-component-dep-fails
     254                           :initarg :if-component-dep-fails)
     255   (default-component-class :accessor module-default-component-class
     256     :initform 'cl-source-file :initarg :default-component-class)))
     257
     258(defgeneric component-pathname (component)
     259  (:documentation "Extracts the pathname applicable for a particular component."))
     260
     261(defun component-parent-pathname (component)
     262  (aif (component-parent component)
     263       (component-pathname it)
     264       *default-pathname-defaults*))
     265
     266(defgeneric component-relative-pathname (component)
     267  (:documentation "Extracts the relative pathname applicable for a particular component."))
     268
     269(defmethod component-relative-pathname ((component module))
     270  (or (slot-value component 'relative-pathname)
     271      (make-pathname
     272       :directory `(:relative ,(component-name component))
     273       :host (pathname-host (component-parent-pathname component)))))
     274
     275(defmethod component-pathname ((component component))
     276  (let ((*default-pathname-defaults* (component-parent-pathname component)))
     277    (merge-pathnames (component-relative-pathname component))))
     278
     279(defgeneric component-property (component property))
     280
     281(defmethod component-property ((c component) property)
     282  (cdr (assoc property (slot-value c 'properties) :test #'equal)))
     283
     284(defgeneric (setf component-property) (new-value component property))
     285
     286(defmethod (setf component-property) (new-value (c component) property)
     287  (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
     288    (if a
     289        (setf (cdr a) new-value)
     290        (setf (slot-value c 'properties)
     291              (acons property new-value (slot-value c 'properties))))))
     292
     293(defclass system (module)
     294  ((description :accessor system-description :initarg :description)
     295   (long-description
     296    :accessor system-long-description :initarg :long-description)
     297   (author :accessor system-author :initarg :author)
     298   (maintainer :accessor system-maintainer :initarg :maintainer)
     299   (licence :accessor system-licence :initarg :licence
     300            :accessor system-license :initarg :license)))
     301
     302;;; version-satisfies
     303
     304;;; with apologies to christophe rhodes ...
     305(defun split (string &optional max (ws '(#\Space #\Tab)))
     306  (flet ((is-ws (char) (find char ws)))
     307    (nreverse
     308     (let ((list nil) (start 0) (words 0) end)
     309       (loop
     310         (when (and max (>= words (1- max)))
     311           (return (cons (subseq string start) list)))
     312         (setf end (position-if #'is-ws string :start start))
     313         (push (subseq string start end) list)
     314         (incf words)
     315         (unless end (return list))
     316         (setf start (1+ end)))))))
     317
     318(defgeneric version-satisfies (component version))
     319
     320(defmethod version-satisfies ((c component) version)
     321  (unless (and version (slot-boundp c 'version))
     322    (return-from version-satisfies t))
     323  (let ((x (mapcar #'parse-integer
     324                   (split (component-version c) nil '(#\.))))
     325        (y (mapcar #'parse-integer
     326                   (split version nil '(#\.)))))
     327    (labels ((bigger (x y)
     328               (cond ((not y) t)
     329                     ((not x) nil)
     330                     ((> (car x) (car y)) t)
     331                     ((= (car x) (car y))
     332                      (bigger (cdr x) (cdr y))))))
     333      (and (= (car x) (car y))
     334           (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
     335
     336;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     337;;; finding systems
     338
     339(defvar *defined-systems* (make-hash-table :test 'equal))
     340(defun coerce-name (name)
     341  (typecase name
     342    (component (component-name name))
     343    (symbol (string-downcase (symbol-name name)))
     344    (string name)
     345    (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
     346
     347;;; for the sake of keeping things reasonably neat, we adopt a
     348;;; convention that functions in this list are prefixed SYSDEF-
     349
     350(defvar *system-definition-search-functions*
     351  '(sysdef-central-registry-search))
     352
     353(defun system-definition-pathname (system)
     354  (some (lambda (x) (funcall x system))
     355        *system-definition-search-functions*))
     356
     357(defvar *central-registry*
     358  '(*default-pathname-defaults*
     359    #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/"
     360    #+nil "telent:asdf;systems;"))
     361
     362(defun sysdef-central-registry-search (system)
     363  (let ((name (coerce-name system)))
     364    (block nil
     365      (dolist (dir *central-registry*)
     366        (let* ((defaults (eval dir))
     367               (file (and defaults
     368                          (make-pathname
     369                           :defaults defaults :version :newest
     370                           :name name :type "asd" :case :local))))
     371          (if (and file (probe-file file))
     372              (return file)))))))
     373
     374(defun make-temporary-package ()
     375  (flet ((try (counter)
     376           (ignore-errors
     377             (make-package (format nil "ASDF~D" counter)
     378                           :use '(:cl :asdf)))))
     379    (do* ((counter 0 (+ counter 1))
     380          (package (try counter) (try counter)))
     381         (package package))))
     382
     383(defun find-system (name &optional (error-p t))
     384  (let* ((name (coerce-name name))
     385         (in-memory (gethash name *defined-systems*))
     386         (on-disk (system-definition-pathname name)))
     387    (when (and on-disk
     388               (or (not in-memory)
     389                   (< (car in-memory) (file-write-date on-disk))))
     390      (let ((package (make-temporary-package)))
     391        (unwind-protect
     392             (let ((*package* package))
     393               (format
     394                *verbose-out*
     395                "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
     396                ;; FIXME: This wants to be (ENOUGH-NAMESTRING
     397                ;; ON-DISK), but CMUCL barfs on that.
     398                on-disk
     399                *package*)
     400               (load on-disk))
     401          (delete-package package))))
     402    (let ((in-memory (gethash name *defined-systems*)))
     403      (if in-memory
     404          (progn (if on-disk (setf (car in-memory) (file-write-date on-disk)))
     405                 (cdr in-memory))
     406          (if error-p (error 'missing-component :requires name))))))
     407
     408(defun register-system (name system)
     409  (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
     410  (setf (gethash (coerce-name  name) *defined-systems*)
     411        (cons (get-universal-time) system)))
     412
     413(defun system-registered-p (name)
     414  (gethash (coerce-name name) *defined-systems*))
     415
     416;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     417;;; finding components
     418
     419(defgeneric find-component (module name &optional version)
     420  (:documentation "Finds the component with name NAME present in the
     421MODULE module; if MODULE is nil, then the component is assumed to be a
     422system."))
     423
     424(defmethod find-component ((module module) name &optional version)
     425  (if (slot-boundp module 'components)
     426      (let ((m (find name (module-components module)
     427                     :test #'equal :key #'component-name)))
     428        (if (and m (version-satisfies m version)) m))))
     429
     430
     431;;; a component with no parent is a system
     432(defmethod find-component ((module (eql nil)) name &optional version)
     433  (let ((m (find-system name nil)))
     434    (if (and m (version-satisfies m version)) m)))
     435
     436;;; component subclasses
     437
     438(defclass source-file (component) ())
     439
     440(defclass cl-source-file (source-file) ())
     441(defclass c-source-file (source-file) ())
     442(defclass java-source-file (source-file) ())
     443(defclass static-file (source-file) ())
     444(defclass doc-file (static-file) ())
     445(defclass html-file (doc-file) ())
     446
     447(defgeneric source-file-type (component system))
     448(defmethod source-file-type ((c cl-source-file) (s module)) "lisp")
     449(defmethod source-file-type ((c c-source-file) (s module)) "c")
     450(defmethod source-file-type ((c java-source-file) (s module)) "java")
     451(defmethod source-file-type ((c html-file) (s module)) "html")
     452(defmethod source-file-type ((c static-file) (s module)) nil)
     453
     454(defmethod component-relative-pathname ((component source-file))
     455  (let ((relative-pathname (slot-value component 'relative-pathname)))
     456    (if relative-pathname
     457        (merge-pathnames
     458         relative-pathname
     459         (make-pathname
     460          :type (source-file-type component (component-system component))))
     461        (let* ((*default-pathname-defaults*
     462                (component-parent-pathname component))
     463               (name-type
     464                (make-pathname
     465                 :name (component-name component)
     466                 :type (source-file-type component
     467                                         (component-system component)))))
     468          name-type))))
     469
     470;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     471;;; operations
     472
     473;;; one of these is instantiated whenever (operate ) is called
     474
     475(defclass operation ()
     476  ((forced :initform nil :initarg :force :accessor operation-forced)
     477   (original-initargs :initform nil :initarg :original-initargs
     478                      :accessor operation-original-initargs)
     479   (visited-nodes :initform nil :accessor operation-visited-nodes)
     480   (visiting-nodes :initform nil :accessor operation-visiting-nodes)
     481   (parent :initform nil :initarg :parent :accessor operation-parent)))
     482
     483(defmethod print-object ((o operation) stream)
     484  (print-unreadable-object (o stream :type t :identity t)
     485    (ignore-errors
     486      (prin1 (operation-original-initargs o) stream))))
     487
     488(defmethod shared-initialize :after ((operation operation) slot-names
     489                                     &key force
     490                                     &allow-other-keys)
     491  (declare (ignore slot-names force))
     492  ;; empty method to disable initarg validity checking
     493  )
     494
     495(defgeneric perform (operation component))
     496(defgeneric operation-done-p (operation component))
     497(defgeneric explain (operation component))
     498(defgeneric output-files (operation component))
     499(defgeneric input-files (operation component))
     500
     501(defun node-for (o c)
     502  (cons (class-name (class-of o)) c))
     503
     504(defgeneric operation-ancestor (operation)
     505  (:documentation
     506   "Recursively chase the operation's parent pointer until we get to
     507the head of the tree"))
     508
     509(defmethod operation-ancestor ((operation operation))
     510  (aif (operation-parent operation)
     511       (operation-ancestor it)
     512       operation))
     513
     514
     515(defun make-sub-operation (c o dep-c dep-o)
     516  (let* ((args (copy-list (operation-original-initargs o)))
     517         (force-p (getf args :force)))
     518    ;; note explicit comparison with T: any other non-NIL force value
     519    ;; (e.g. :recursive) will pass through
     520    (cond ((and (null (component-parent c))
     521                (null (component-parent dep-c))
     522                (not (eql c dep-c)))
     523           (when (eql force-p t)
     524             (setf (getf args :force) nil))
     525           (apply #'make-instance dep-o
     526                  :parent o
     527                  :original-initargs args args))
     528          ((subtypep (type-of o) dep-o)
     529           o)
     530          (t
     531           (apply #'make-instance dep-o
     532                  :parent o :original-initargs args args)))))
     533
     534
     535(defgeneric visit-component (operation component data))
     536
     537(defmethod visit-component ((o operation) (c component) data)
     538  (unless (component-visited-p o c)
     539    (push (cons (node-for o c) data)
     540          (operation-visited-nodes (operation-ancestor o)))))
     541
     542(defgeneric component-visited-p (operation component))
     543
     544(defmethod component-visited-p ((o operation) (c component))
     545  (assoc (node-for o c)
     546         (operation-visited-nodes (operation-ancestor o))
     547         :test 'equal))
     548
     549(defgeneric (setf visiting-component) (new-value operation component))
     550
     551(defmethod (setf visiting-component) (new-value operation component)
     552  ;; MCL complains about unused lexical variables
     553  (declare (ignorable new-value operation component)))
     554
     555(defmethod (setf visiting-component) (new-value (o operation) (c component))
     556  (let ((node (node-for o c))
     557        (a (operation-ancestor o)))
     558    (if new-value
     559        (pushnew node (operation-visiting-nodes a) :test 'equal)
     560        (setf (operation-visiting-nodes a)
     561              (remove node  (operation-visiting-nodes a) :test 'equal)))))
     562
     563(defgeneric component-visiting-p (operation component))
     564
     565(defmethod component-visiting-p ((o operation) (c component))
     566  (let ((node (cons o c)))
     567    (member node (operation-visiting-nodes (operation-ancestor o))
     568            :test 'equal)))
     569
     570(defgeneric component-depends-on (operation component)
     571  (:documentation
     572   "Returns a list of dependencies needed by the component to perform
     573    the operation.  A dependency has one of the following forms:
     574
     575      (<operation> <component>*), where <operation> is a class
     576        designator and each <component> is a component
     577        designator, which means that the component depends on
     578        <operation> having been performed on each <component>; or
     579
     580      (FEATURE <feature>), which means that the component depends
     581        on <feature>'s presence in *FEATURES*.
     582
     583    Methods specialized on subclasses of existing component types
     584    should usually append the results of CALL-NEXT-METHOD to the
     585    list."))
     586
     587(defmethod component-depends-on ((op-spec symbol) (c component))
     588  (component-depends-on (make-instance op-spec) c))
     589
     590(defmethod component-depends-on ((o operation) (c component))
     591  (cdr (assoc (class-name (class-of o))
     592              (slot-value c 'in-order-to))))
     593
     594(defgeneric component-self-dependencies (operation component))
     595
     596(defmethod component-self-dependencies ((o operation) (c component))
     597  (let ((all-deps (component-depends-on o c)))
     598    (remove-if-not (lambda (x)
     599                     (member (component-name c) (cdr x) :test #'string=))
     600                   all-deps)))
     601
     602(defmethod input-files ((operation operation) (c component))
     603  (let ((parent (component-parent c))
     604        (self-deps (component-self-dependencies operation c)))
     605    (if self-deps
     606        (mapcan (lambda (dep)
     607                  (destructuring-bind (op name) dep
     608                    (output-files (make-instance op)
     609                                  (find-component parent name))))
     610                self-deps)
     611        ;; no previous operations needed?  I guess we work with the
     612        ;; original source file, then
     613        (list (component-pathname c)))))
     614
     615(defmethod input-files ((operation operation) (c module)) nil)
     616
     617(defmethod operation-done-p ((o operation) (c component))
     618  (flet ((fwd-or-return-t (file)
     619           ;; if FILE-WRITE-DATE returns NIL, it's possible that the
     620           ;; user or some other agent has deleted an input file.  If
     621           ;; that's the case, well, that's not good, but as long as
     622           ;; the operation is otherwise considered to be done we
     623           ;; could continue and survive.
     624           (let ((date (file-write-date file)))
     625             (cond
     626               (date)
     627               (t
     628                (warn "~@<Missing FILE-WRITE-DATE for ~S: treating ~
     629                       operation ~S on component ~S as done.~@:>"
     630                      file o c)
     631                (return-from operation-done-p t))))))
     632    (let ((out-files (output-files o c))
     633          (in-files (input-files o c)))
     634      (cond ((and (not in-files) (not out-files))
     635             ;; arbitrary decision: an operation that uses nothing to
     636             ;; produce nothing probably isn't doing much
     637             t)
     638            ((not out-files)
     639             (let ((op-done
     640                    (gethash (type-of o)
     641                             (component-operation-times c))))
     642               (and op-done
     643                    (>= op-done
     644                        (apply #'max
     645                               (mapcar #'fwd-or-return-t in-files))))))
     646            ((not in-files) nil)
     647            (t
     648             (and
     649              (every #'probe-file out-files)
     650              (> (apply #'min (mapcar #'file-write-date out-files))
     651                 (apply #'max (mapcar #'fwd-or-return-t in-files)))))))))
     652
     653;;; So you look at this code and think "why isn't it a bunch of
     654;;; methods".  And the answer is, because standard method combination
     655;;; runs :before methods most->least-specific, which is back to front
     656;;; for our purposes.  And CLISP doesn't have non-standard method
     657;;; combinations, so let's keep it simple and aspire to portability
     658
     659(defgeneric traverse (operation component))
     660(defmethod traverse ((operation operation) (c component))
     661  (let ((forced nil))
     662    (labels ((do-one-dep (required-op required-c required-v)
     663               (let* ((dep-c (or (find-component
     664                                  (component-parent c)
     665                                  ;; XXX tacky.  really we should build the
     666                                  ;; in-order-to slot with canonicalized
     667                                  ;; names instead of coercing this late
     668                                  (coerce-name required-c) required-v)
     669                                 (error 'missing-dependency
     670                                        :required-by c
     671                                        :version required-v
     672                                        :requires required-c)))
     673                      (op (make-sub-operation c operation dep-c required-op)))
     674                 (traverse op dep-c)))
     675             (do-dep (op dep)
     676               (cond ((eq op 'feature)
     677                      (or (member (car dep) *features*)
     678                          (error 'missing-dependency
     679                                 :required-by c
     680                                 :requires (car dep)
     681                                 :version nil)))
     682                     (t
     683                      (dolist (d dep)
     684                        (cond ((consp d)
     685                               (assert (string-equal
     686                                        (symbol-name (first d))
     687                                        "VERSION"))
     688                               (appendf forced
     689                                        (do-one-dep op (second d) (third d))))
     690                              (t
     691                               (appendf forced (do-one-dep op d nil)))))))))
     692      (aif (component-visited-p operation c)
     693           (return-from traverse
     694             (if (cdr it) (list (cons 'pruned-op c)) nil)))
     695      ;; dependencies
     696      (if (component-visiting-p operation c)
     697          (error 'circular-dependency :components (list c)))
     698      (setf (visiting-component operation c) t)
     699      (loop for (required-op . deps) in (component-depends-on operation c)
     700            do (do-dep required-op deps))
     701      ;; constituent bits
     702      (let ((module-ops
     703             (when (typep c 'module)
     704               (let ((at-least-one nil)
     705                     (forced nil)
     706                     (error nil))
     707                 (loop for kid in (module-components c)
     708                       do (handler-case
     709                              (appendf forced (traverse operation kid ))
     710                            (missing-dependency (condition)
     711                              (if (eq (module-if-component-dep-fails c) :fail)
     712                                  (error condition))
     713                              (setf error condition))
     714                            (:no-error (c)
     715                              (declare (ignore c))
     716                              (setf at-least-one t))))
     717                 (when (and (eq (module-if-component-dep-fails c) :try-next)
     718                            (not at-least-one))
     719                   (error error))
     720                 forced))))
     721        ;; now the thing itself
     722        (when (or forced module-ops
     723                  (not (operation-done-p operation c))
     724                  (let ((f (operation-forced (operation-ancestor operation))))
     725                    (and f (or (not (consp f))
     726                               (member (component-name
     727                                        (operation-ancestor operation))
     728                                       (mapcar #'coerce-name f)
     729                                       :test #'string=)))))
     730          (let ((do-first (cdr (assoc (class-name (class-of operation))
     731                                      (slot-value c 'do-first)))))
     732            (loop for (required-op . deps) in do-first
     733                  do (do-dep required-op deps)))
     734          (setf forced (append (delete 'pruned-op forced :key #'car)
     735                               (delete 'pruned-op module-ops :key #'car)
     736                               (list (cons operation c))))))
     737      (setf (visiting-component operation c) nil)
     738      (visit-component operation c (and forced t))
     739      forced)))
     740
     741
     742(defmethod perform ((operation operation) (c source-file))
     743  (sysdef-error
     744   "~@<required method PERFORM not implemented ~
     745    for operation ~A, component ~A~@:>"
     746   (class-of operation) (class-of c)))
     747
     748(defmethod perform ((operation operation) (c module))
     749  nil)
     750
     751(defmethod explain ((operation operation) (component component))
     752  (format *verbose-out* "~&;;; ~A on ~A~%" operation component))
     753
     754;;; compile-op
     755
     756(defclass compile-op (operation)
     757  ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
     758   (on-warnings :initarg :on-warnings :accessor operation-on-warnings
     759                :initform *compile-file-warnings-behaviour*)
     760   (on-failure :initarg :on-failure :accessor operation-on-failure
     761               :initform *compile-file-failure-behaviour*)))
     762
     763(defmethod perform :before ((operation compile-op) (c source-file))
     764  (map nil #'ensure-directories-exist (output-files operation c)))
     765
     766(defmethod perform :after ((operation operation) (c component))
     767  (setf (gethash (type-of operation) (component-operation-times c))
     768        (get-universal-time))
     769  (load-preferences c operation))
     770
     771;;; perform is required to check output-files to find out where to put
     772;;; its answers, in case it has been overridden for site policy
     773(defmethod perform ((operation compile-op) (c cl-source-file))
     774  #-:broken-fasl-loader
     775  (let ((source-file (component-pathname c))
     776        (output-file (car (output-files operation c))))
     777    (multiple-value-bind (output warnings-p failure-p)
     778        (compile-file source-file :output-file output-file)
     779      (when warnings-p
     780        (case (operation-on-warnings operation)
     781          (:warn (warn
     782                  "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
     783                  operation c))
     784          (:error (error 'compile-warned :component c :operation operation))
     785          (:ignore nil)))
     786      (when failure-p
     787        (case (operation-on-failure operation)
     788          (:warn (warn
     789                  "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
     790                  operation c))
     791          (:error (error 'compile-failed :component c :operation operation))
     792          (:ignore nil)))
     793      (unless output
     794        (error 'compile-error :component c :operation operation)))))
     795
     796(defmethod output-files ((operation compile-op) (c cl-source-file))
     797  #-:broken-fasl-loader (list (compile-file-pathname (component-pathname c)))
     798  #+:broken-fasl-loader (list (component-pathname c)))
     799
     800(defmethod perform ((operation compile-op) (c static-file))
     801  nil)
     802
     803(