Changeset 9202 for release/1.2
- Timestamp:
- Apr 20, 2008, 8:03:39 AM (13 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
release/1.2/source/tools/asdf.lisp
r4703 r9202 1 ;;; This is asdf: Another System Definition Facility. $Revision$ 2 ;;; 3 ;;; Feedback, bug reports, and patches are all welcome: please mail to 4 ;;; <cclan-list@lists.sf.net>. But note first that the canonical 5 ;;; source for asdf is presently the cCLan CVS repository at 6 ;;; <URL:http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/> 7 ;;; 8 ;;; If you obtained this copy from anywhere else, and you experience 9 ;;; trouble using it, or find bugs, you may want to check at the 10 ;;; location above for a more recent version (and for documentation 11 ;;; and test files, if your copy came without them) before reporting 12 ;;; bugs. There are usually two "supported" revisions - the CVS HEAD 13 ;;; is the latest development version, whereas the revision tagged 14 ;;; RELEASE may be slightly older but is considered `stable' 15 16 ;;; Copyright (c) 2001-2003 Daniel Barlow and contributors 17 ;;; 18 ;;; Permission is hereby granted, free of charge, to any person obtaining 19 ;;; a copy of this software and associated documentation files (the 20 ;;; "Software"), to deal in the Software without restriction, including 21 ;;; without limitation the rights to use, copy, modify, merge, publish, 22 ;;; distribute, sublicense, and/or sell copies of the Software, and to 23 ;;; permit persons to whom the Software is furnished to do so, subject to 24 ;;; the following conditions: 25 ;;; 26 ;;; The above copyright notice and this permission notice shall be 27 ;;; included in all copies or substantial portions of the Software. 28 ;;; 29 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 30 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 31 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 32 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 33 ;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 34 ;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 35 ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 36 37 ;;; the problem with writing a defsystem replacement is bootstrapping: 38 ;;; we can't use defsystem to compile it. Hence, all in one file 39 40 (defpackage #:asdf 41 (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command 42 #:system-definition-pathname #:find-component ; miscellaneous 43 #:hyperdocumentation #:hyperdoc 44 45 #:compile-op #:load-op #:load-source-op #:test-system-version 46 #:test-op 47 #:operation ; operations 48 #:feature ; sort-of operation 49 #:version ; metaphorically sort-of an operation 50 51 #:input-files #:output-files #:perform ; operation methods 52 #:operation-done-p #:explain 53 54 #:component #:source-file 55 #:c-source-file #:cl-source-file #:java-source-file 56 #:static-file 57 #:doc-file 58 #:html-file 59 #:text-file 60 #:source-file-type 61 #:module ; components 62 #:system 63 #:unix-dso 64 65 #:module-components ; component accessors 66 #:component-pathname 67 #:component-relative-pathname 68 #:component-name 69 #:component-version 70 #:component-parent 71 #:component-property 72 #:component-system 73 74 #:component-depends-on 75 76 #:system-description 77 #:system-long-description 78 #:system-author 79 #:system-maintainer 80 #:system-license 81 82 #:operation-on-warnings 83 #:operation-on-failure 84 85 ;#:*component-parent-pathname* 86 #:*system-definition-search-functions* 87 #:*central-registry* ; variables 88 #:*compile-file-warnings-behaviour* 89 #:*compile-file-failure-behaviour* 90 #:*asdf-revision* 91 92 #:operation-error #:compile-failed #:compile-warned #:compile-error 93 #:error-component #:error-operation 94 #:system-definition-error 95 #:missing-component 96 #:missing-dependency 97 #:circular-dependency ; errors 98 #:duplicate-names 99 100 #:retry 101 #:accept ; restarts 102 103 ) 104 (:use :cl)) 105 106 #+nil 107 (error "The author of this file habitually uses #+nil to comment out forms. But don't worry, it was unlikely to work in the New Implementation of Lisp anyway") 108 109 110 (in-package #:asdf) 111 112 (defvar *asdf-revision* (let* ((v "$Revision$") 113 (colon (or (position #\: v) -1)) 114 (dot (position #\. v))) 115 (and v colon dot 116 (list (parse-integer v :start (1+ colon) 117 :junk-allowed t) 118 (parse-integer v :start (1+ dot) 119 :junk-allowed t))))) 120 121 (defvar *compile-file-warnings-behaviour* :warn) 122 (defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn) 123 124 (defvar *verbose-out* nil) 125 126 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 127 ;; utility stuff 128 129 (defmacro aif (test then &optional else) 130 `(let ((it ,test)) (if it ,then ,else))) 131 132 (defun pathname-sans-name+type (pathname) 133 "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, 134 and NIL NAME and TYPE components" 135 (make-pathname :name nil :type nil :defaults pathname)) 136 137 (define-modify-macro appendf (&rest args) 138 append "Append onto list") 139 140 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 141 ;; classes, condiitons 142 143 (define-condition system-definition-error (error) () 144 ;; [this use of :report should be redundant, but unfortunately it's not. 145 ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function 146 ;; over print-object; this is always conditions::%print-condition for 147 ;; condition objects, which in turn does inheritance of :report options at 148 ;; run-time. fortunately, inheritance means we only need this kludge here in 149 ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] 150 #+cmu (:report print-object)) 151 152 (define-condition formatted-system-definition-error (system-definition-error) 153 ((format-control :initarg :format-control :reader format-control) 154 (format-arguments :initarg :format-arguments :reader format-arguments)) 155 (:report (lambda (c s) 156 (apply #'format s (format-control c) (format-arguments c))))) 157 158 (define-condition circular-dependency (system-definition-error) 159 ((components :initarg :components :reader circular-dependency-components))) 160 161 (define-condition duplicate-names (system-definition-error) 162 ((name :initarg :name :reader duplicate-names-name))) 163 164 (define-condition missing-component (system-definition-error) 165 ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) 166 (version :initform nil :reader missing-version :initarg :version) 167 (parent :initform nil :reader missing-parent :initarg :parent))) 168 169 (define-condition missing-dependency (missing-component) 170 ((required-by :initarg :required-by :reader missing-required-by))) 171 172 (define-condition operation-error (error) 173 ((component :reader error-component :initarg :component) 174 (operation :reader error-operation :initarg :operation)) 175 (:report (lambda (c s) 176 (format s "~@<erred while invoking ~A on ~A~@:>" 177 (error-operation c) (error-component c))))) 178 (define-condition compile-error (operation-error) ()) 179 (define-condition compile-failed (compile-error) ()) 180 (define-condition compile-warned (compile-error) ()) 181 182 (defclass component () 183 ((name :accessor component-name :initarg :name :documentation 184 "Component name: designator for a string composed of portable pathname characters") 185 (version :accessor component-version :initarg :version) 186 (in-order-to :initform nil :initarg :in-order-to) 187 ;;; XXX crap name 188 (do-first :initform nil :initarg :do-first) 189 ;; methods defined using the "inline" style inside a defsystem form: 190 ;; need to store them somewhere so we can delete them when the system 191 ;; is re-evaluated 192 (inline-methods :accessor component-inline-methods :initform nil) 193 (parent :initarg :parent :initform nil :reader component-parent) 194 ;; no direct accessor for pathname, we do this as a method to allow 195 ;; it to default in funky ways if not supplied 196 (relative-pathname :initarg :pathname) 197 (operation-times :initform (make-hash-table ) 198 :accessor component-operation-times) 199 ;; XXX we should provide some atomic interface for updating the 200 ;; component properties 201 (properties :accessor component-properties :initarg :properties 202 :initform nil))) 203 204 ;;;; methods: conditions 205 206 (defmethod print-object ((c missing-dependency) s) 207 (format s "~@<~A, required by ~A~@:>" 208 (call-next-method c nil) (missing-required-by c))) 209 210 (defun sysdef-error (format &rest arguments) 211 (error 'formatted-system-definition-error :format-control format :format-arguments arguments)) 212 213 ;;;; methods: components 214 215 (defmethod print-object ((c missing-component) s) 216 (format s "~@<component ~S not found~ 217 ~@[ or does not match version ~A~]~ 218 ~@[ in ~A~]~@:>" 219 (missing-requires c) 220 (missing-version c) 221 (when (missing-parent c) 222 (component-name (missing-parent c))))) 223 224 (defgeneric component-system (component) 225 (:documentation "Find the top-level system containing COMPONENT")) 226 227 (defmethod component-system ((component component)) 228 (aif (component-parent component) 229 (component-system it) 230 component)) 231 232 (defmethod print-object ((c component) stream) 233 (print-unreadable-object (c stream :type t :identity t) 234 (ignore-errors 235 (prin1 (component-name c) stream)))) 236 237 (defclass module (component) 238 ((components :initform nil :accessor module-components :initarg :components) 239 ;; what to do if we can't satisfy a dependency of one of this module's 240 ;; components. This allows a limited form of conditional processing 241 (if-component-dep-fails :initform :fail 242 :accessor module-if-component-dep-fails 243 :initarg :if-component-dep-fails) 244 (default-component-class :accessor module-default-component-class 245 :initform 'cl-source-file :initarg :default-component-class))) 246 247 (defgeneric component-pathname (component) 248 (:documentation "Extracts the pathname applicable for a particular component.")) 249 250 (defun component-parent-pathname (component) 251 (aif (component-parent component) 252 (component-pathname it) 253 *default-pathname-defaults*)) 254 255 (defgeneric component-relative-pathname (component) 256 (:documentation "Extracts the relative pathname applicable for a particular component.")) 257 258 (defmethod component-relative-pathname ((component module)) 259 (or (slot-value component 'relative-pathname) 260 (make-pathname 261 :directory `(:relative ,(component-name component)) 262 :host (pathname-host (component-parent-pathname component))))) 263 264 (defmethod component-pathname ((component component)) 265 (let ((*default-pathname-defaults* (component-parent-pathname component))) 266 (merge-pathnames (component-relative-pathname component)))) 267 268 (defgeneric component-property (component property)) 269 270 (defmethod component-property ((c component) property) 271 (cdr (assoc property (slot-value c 'properties) :test #'equal))) 272 273 (defgeneric (setf component-property) (new-value component property)) 274 275 (defmethod (setf component-property) (new-value (c component) property) 276 (let ((a (assoc property (slot-value c 'properties) :test #'equal))) 277 (if a 278 (setf (cdr a) new-value) 279 (setf (slot-value c 'properties) 280 (acons property new-value (slot-value c 'properties)))))) 281 282 (defclass system (module) 283 ((description :accessor system-description :initarg :description) 284 (long-description 285 :accessor system-long-description :initarg :long-description) 286 (author :accessor system-author :initarg :author) 287 (maintainer :accessor system-maintainer :initarg :maintainer) 288 (licence :accessor system-licence :initarg :licence))) 289 290 ;;; version-satisfies 291 292 ;;; with apologies to christophe rhodes ... 293 (defun split (string &optional max (ws '(#\Space #\Tab))) 294 (flet ((is-ws (char) (find char ws))) 295 (nreverse 296 (let ((list nil) (start 0) (words 0) end) 297 (loop 298 (when (and max (>= words (1- max))) 299 (return (cons (subseq string start) list))) 300 (setf end (position-if #'is-ws string :start start)) 301 (push (subseq string start end) list) 302 (incf words) 303 (unless end (return list)) 304 (setf start (1+ end))))))) 305 306 (defgeneric version-satisfies (component version)) 307 308 (defmethod version-satisfies ((c component) version) 309 (unless (and version (slot-boundp c 'version)) 310 (return-from version-satisfies t)) 311 (let ((x (mapcar #'parse-integer 312 (split (component-version c) nil '(#\.)))) 313 (y (mapcar #'parse-integer 314 (split version nil '(#\.))))) 315 (labels ((bigger (x y) 316 (cond ((not y) t) 317 ((not x) nil) 318 ((> (car x) (car y)) t) 319 ((= (car x) (car y)) 320 (bigger (cdr x) (cdr y)))))) 321 (and (= (car x) (car y)) 322 (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) 323 324 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 325 ;;; finding systems 326 327 (defvar *defined-systems* (make-hash-table :test 'equal)) 328 (defun coerce-name (name) 329 (typecase name 330 (component (component-name name)) 331 (symbol (string-downcase (symbol-name name))) 332 (string name) 333 (t (sysdef-error "~@<invalid component designator ~A~@:>" name)))) 334 335 ;;; for the sake of keeping things reasonably neat, we adopt a 336 ;;; convention that functions in this list are prefixed SYSDEF- 337 338 (defvar *system-definition-search-functions* 339 '(sysdef-central-registry-search)) 340 341 (defun system-definition-pathname (system) 342 (some (lambda (x) (funcall x system)) 343 *system-definition-search-functions*)) 344 345 (defvar *central-registry* 346 '(*default-pathname-defaults* 347 #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/" 348 #+nil "telent:asdf;systems;")) 349 350 (defun sysdef-central-registry-search (system) 351 (let ((name (coerce-name system))) 352 (block nil 353 (dolist (dir *central-registry*) 354 (let* ((defaults (eval dir)) 355 (file (and defaults 356 (make-pathname 357 :defaults defaults :version :newest 358 :name name :type "asd" :case :local)))) 359 (if (and file (probe-file file)) 360 (return file))))))) 361 362 (defun make-temporary-package () 363 (flet ((try (counter) 364 (ignore-errors 365 (make-package (format nil "ASDF~D" counter) 366 :use '(:cl :asdf))))) 367 (do* ((counter 0 (+ counter 1)) 368 (package (try counter) (try counter))) 369 (package package)))) 370 371 (defun find-system (name &optional (error-p t)) 372 (let* ((name (coerce-name name)) 373 (in-memory (gethash name *defined-systems*)) 374 (on-disk (system-definition-pathname name))) 375 (when (and on-disk 376 (or (not in-memory) 377 (< (car in-memory) (file-write-date on-disk)))) 378 (let ((package (make-temporary-package))) 379 (unwind-protect 380 (let ((*package* package)) 381 (format 382 *verbose-out* 383 "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%" 384 ;; FIXME: This wants to be (ENOUGH-NAMESTRING 385 ;; ON-DISK), but CMUCL barfs on that. 386 on-disk 387 *package*) 388 (load on-disk)) 389 (delete-package package)))) 390 (let ((in-memory (gethash name *defined-systems*))) 391 (if in-memory 392 (progn (if on-disk (setf (car in-memory) (file-write-date on-disk))) 393 (cdr in-memory)) 394 (if error-p (error 'missing-component :requires name)))))) 395 396 (defun register-system (name system) 397 (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name) 398 (setf (gethash (coerce-name name) *defined-systems*) 399 (cons (get-universal-time) system))) 400 401 (defun system-registered-p (name) 402 (gethash (coerce-name name) *defined-systems*)) 403 404 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 405 ;;; finding components 406 407 (defgeneric find-component (module name &optional version) 408 (:documentation "Finds the component with name NAME present in the 409 MODULE module; if MODULE is nil, then the component is assumed to be a 410 system.")) 411 412 (defmethod find-component ((module module) name &optional version) 413 (if (slot-boundp module 'components) 414 (let ((m (find name (module-components module) 415 :test #'equal :key #'component-name))) 416 (if (and m (version-satisfies m version)) m)))) 417 418 419 ;;; a component with no parent is a system 420 (defmethod find-component ((module (eql nil)) name &optional version) 421 (let ((m (find-system name nil))) 422 (if (and m (version-satisfies m version)) m))) 423 424 ;;; component subclasses 425 426 (defclass source-file (component) ()) 427 428 (defclass cl-source-file (source-file) ()) 429 (defclass c-source-file (source-file) ()) 430 (defclass java-source-file (source-file) ()) 431 (defclass static-file (source-file) ()) 432 (defclass doc-file (static-file) ()) 433 (defclass html-file (doc-file) ()) 434 435 (defgeneric source-file-type (component system)) 436 (defmethod source-file-type ((c cl-source-file) (s module)) "lisp") 437 (defmethod source-file-type ((c c-source-file) (s module)) "c") 438 (defmethod source-file-type ((c java-source-file) (s module)) "java") 439 (defmethod source-file-type ((c html-file) (s module)) "html") 440 (defmethod source-file-type ((c static-file) (s module)) nil) 441 442 (defmethod component-relative-pathname ((component source-file)) 443 (let ((relative-pathname (slot-value component 'relative-pathname))) 444 (if relative-pathname 445 (merge-pathnames 446 relative-pathname 447 (make-pathname 448 :type (source-file-type component (component-system component)))) 449 (let* ((*default-pathname-defaults* 450 (component-parent-pathname component)) 451 (name-type 452 (make-pathname 453 :name (component-name component) 454 :type (source-file-type component 455 (component-system component))))) 456 name-type)))) 457 458 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 459 ;;; operations 460 461 ;;; one of these is instantiated whenever (operate ) is called 462 463 (defclass operation () 464 ((forced :initform nil :initarg :force :accessor operation-forced) 465 (original-initargs :initform nil :initarg :original-initargs 466 :accessor operation-original-initargs) 467 (visited-nodes :initform nil :accessor operation-visited-nodes) 468 (visiting-nodes :initform nil :accessor operation-visiting-nodes) 469 (parent :initform nil :initarg :parent :accessor operation-parent))) 470 471 (defmethod print-object ((o operation) stream) 472 (print-unreadable-object (o stream :type t :identity t) 473 (ignore-errors 474 (prin1 (operation-original-initargs o) stream)))) 475 476 (defmethod shared-initialize :after ((operation operation) slot-names 477 &key force 478 &allow-other-keys) 479 (declare (ignore slot-names force)) 480 ;; empty method to disable initarg validity checking 481 ) 482 483 (defgeneric perform (operation component)) 484 (defgeneric operation-done-p (operation component)) 485 (defgeneric explain (operation component)) 486 (defgeneric output-files (operation component)) 487 (defgeneric input-files (operation component)) 488 489 (defun node-for (o c) 490 (cons (class-name (class-of o)) c)) 491 492 (defgeneric operation-ancestor (operation) 493 (:documentation "Recursively chase the operation's parent pointer until we get to the head of the tree")) 494 495 (defmethod operation-ancestor ((operation operation)) 496 (aif (operation-parent operation) 497 (operation-ancestor it) 498 operation)) 499 500 501 (defun make-sub-operation (c o dep-c dep-o) 502 (let* ((args (copy-list (operation-original-initargs o))) 503 (force-p (getf args :force))) 504 ;; note explicit comparison with T: any other non-NIL force value 505 ;; (e.g. :recursive) will pass through 506 (cond ((and (null (component-parent c)) 507 (null (component-parent dep-c)) 508 (not (eql c dep-c))) 509 (when (eql force-p t) 510 (setf (getf args :force) nil)) 511 (apply #'make-instance dep-o 512 :parent o 513 :original-initargs args args)) 514 ((subtypep (type-of o) dep-o) 515 o) 516 (t 517 (apply #'make-instance dep-o 518 :parent o :original-initargs args args))))) 519 520 521 (defgeneric visit-component (operation component data)) 522 523 (defmethod visit-component ((o operation) (c component) data) 524 (unless (component-visited-p o c) 525 (push (cons (node-for o c) data) 526 (operation-visited-nodes (operation-ancestor o))))) 527 528 (defgeneric component-visited-p (operation component)) 529 530 (defmethod component-visited-p ((o operation) (c component)) 531 (assoc (node-for o c) 532 (operation-visited-nodes (operation-ancestor o)) 533 :test 'equal)) 534 535 (defgeneric (setf visiting-component) (new-value operation component)) 536 537 (defmethod (setf visiting-component) (new-value operation component) 538 ;; MCL complains about unused lexical variables 539 (declare (ignorable new-value operation component))) 540 541 (defmethod (setf visiting-component) (new-value (o operation) (c component)) 542 (let ((node (node-for o c)) 543 (a (operation-ancestor o))) 544 (if new-value 545 (pushnew node (operation-visiting-nodes a) :test 'equal) 546 (setf (operation-visiting-nodes a) 547 (remove node (operation-visiting-nodes a) :test 'equal))))) 548 549 (defgeneric component-visiting-p (operation component)) 550 551 (defmethod component-visiting-p ((o operation) (c component)) 552 (let ((node (cons o c))) 553 (member node (operation-visiting-nodes (operation-ancestor o)) 554 :test 'equal))) 555 556 (defgeneric component-depends-on (operation component)) 557 558 (defmethod component-depends-on ((o operation) (c component)) 559 (cdr (assoc (class-name (class-of o)) 560 (slot-value c 'in-order-to)))) 561 562 (defgeneric component-self-dependencies (operation component)) 563 564 (defmethod component-self-dependencies ((o operation) (c component)) 565 (let ((all-deps (component-depends-on o c))) 566 (remove-if-not (lambda (x) 567 (member (component-name c) (cdr x) :test #'string=)) 568 all-deps))) 569 570 (defmethod input-files ((operation operation) (c component)) 571 (let ((parent (component-parent c)) 572 (self-deps (component-self-dependencies operation c))) 573 (if self-deps 574 (mapcan (lambda (dep) 575 (destructuring-bind (op name) dep 576 (output-files (make-instance op) 577 (find-component parent name)))) 578 self-deps) 579 ;; no previous operations needed? I guess we work with the 580 ;; original source file, then 581 (list (component-pathname c))))) 582 583 (defmethod input-files ((operation operation) (c module)) nil) 584 585 (defmethod operation-done-p ((o operation) (c component)) 586 (flet ((fwd-or-return-t (file) 587 ;; if FILE-WRITE-DATE returns NIL, it's possible that the 588 ;; user or some other agent has deleted an input file. If 589 ;; that's the case, well, that's not good, but as long as 590 ;; the operation is otherwise considered to be done we 591 ;; could continue and survive. 592 (let ((date (file-write-date file))) 593 (cond 594 (date) 595 (t 596 (warn "~@<Missing FILE-WRITE-DATE for ~S: treating ~ 597 operation ~S on component ~S as done.~@:>" 598 file o c) 599 (return-from operation-done-p t)))))) 600 (let ((out-files (output-files o c)) 601 (in-files (input-files o c))) 602 (cond ((and (not in-files) (not out-files)) 603 ;; arbitrary decision: an operation that uses nothing to 604 ;; produce nothing probably isn't doing much 605 t) 606 ((not out-files) 607 (let ((op-done 608 (gethash (type-of o) 609 (component-operation-times c)))) 610 (and op-done 611 (>= op-done 612 (apply #'max 613 (mapcar #'fwd-or-return-t in-files)))))) 614 ((not in-files) nil) 615 (t 616 (and 617 (every #'probe-file out-files) 618 (> (apply #'min (mapcar #'file-write-date out-files)) 619 (apply #'max (mapcar #'fwd-or-return-t in-files))))))))) 620 621 ;;; So you look at this code and think "why isn't it a bunch of 622 ;;; methods". And the answer is, because standard method combination 623 ;;; runs :before methods most->least-specific, which is back to front 624 ;;; for our purposes. And CLISP doesn't have non-standard method 625 ;;; combinations, so let's keep it simple and aspire to portability 626 627 (defgeneric traverse (operation component)) 628 (defmethod traverse ((operation operation) (c component)) 629 (let ((forced nil)) 630 (labels ((do-one-dep (required-op required-c required-v) 631 (let* ((dep-c (or (find-component 632 (component-parent c) 633 ;; XXX tacky. really we should build the 634 ;; in-order-to slot with canonicalized 635 ;; names instead of coercing this late 636 (coerce-name required-c) required-v) 637 (error 'missing-dependency :required-by c 638 :version required-v 639 :requires required-c))) 640 (op (make-sub-operation c operation dep-c required-op))) 641 (traverse op dep-c))) 642 (do-dep (op dep) 643 (cond ((eq op 'feature) 644 (or (member (car dep) *features*) 645 (error 'missing-dependency :required-by c 646 :requires (car dep) :version nil))) 647 (t 648 (dolist (d dep) 649 (cond ((consp d) 650 (assert (string-equal 651 (symbol-name (first d)) 652 "VERSION")) 653 (appendf forced 654 (do-one-dep op (second d) (third d)))) 655 (t 656 (appendf forced (do-one-dep op d nil))))))))) 657 (aif (component-visited-p operation c) 658 (return-from traverse 659 (if (cdr it) (list (cons 'pruned-op c)) nil))) 660 ;; dependencies 661 (if (component-visiting-p operation c) 662 (error 'circular-dependency :components (list c))) 663 (setf (visiting-component operation c) t) 664 (loop for (required-op . deps) in (component-depends-on operation c) 665 do (do-dep required-op deps)) 666 ;; constituent bits 667 (let ((module-ops 668 (when (typep c 'module) 669 (let ((at-least-one nil) 670 (forced nil) 671 (error nil)) 672 (loop for kid in (module-components c) 673 do (handler-case 674 (appendf forced (traverse operation kid )) 675 (missing-dependency (condition) 676 (if (eq (module-if-component-dep-fails c) :fail) 677 (error condition)) 678 (setf error condition)) 679 (:no-error (c) 680 (declare (ignore c)) 681 (setf at-least-one t)))) 682 (when (and (eq (module-if-component-dep-fails c) :try-next) 683 (not at-least-one)) 684 (error error)) 685 forced)))) 686 ;; now the thing itself 687 (when (or forced module-ops 688 (not (operation-done-p operation c)) 689 (let ((f (operation-forced (operation-ancestor operation)))) 690 (and f (or (not (consp f)) 691 (member (component-name 692 (operation-ancestor operation)) 693 (mapcar #'coerce-name f) 694 :test #'string=))))) 695 (let ((do-first (cdr (assoc (class-name (class-of operation)) 696 (slot-value c 'do-first))))) 697 (loop for (required-op . deps) in do-first 698 do (do-dep required-op deps))) 699 (setf forced (append (delete 'pruned-op forced :key #'car) 700 (delete 'pruned-op module-ops :key #'car) 701 (list (cons operation c)))))) 702 (setf (visiting-component operation c) nil) 703 (visit-component operation c (and forced t)) 704 forced))) 705 706 707 (defmethod perform ((operation operation) (c source-file)) 708 (sysdef-error 709 "~@<required method PERFORM not implemented ~ 710 for operation ~A, component ~A~@:>" 711 (class-of operation) (class-of c))) 712 713 (defmethod perform ((operation operation) (c module)) 714 nil) 715 716 (defmethod explain ((operation operation) (component component)) 717 (format *verbose-out* "~&;;; ~A on ~A~%" operation component)) 718 719 ;;; compile-op 720 721 (defclass compile-op (operation) 722 ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil) 723 (on-warnings :initarg :on-warnings :accessor operation-on-warnings 724 :initform *compile-file-warnings-behaviour*) 725 (on-failure :initarg :on-failure :accessor operation-on-failure 726 :initform *compile-file-failure-behaviour*))) 727 728 (defmethod perform :before ((operation compile-op) (c source-file)) 729 (map nil #'ensure-directories-exist (output-files operation c))) 730 731 (defmethod perform :after ((operation operation) (c component)) 732 (setf (gethash (type-of operation) (component-operation-times c)) 733 (get-universal-time))) 734 735 ;;; perform is required to check output-files to find out where to put 736 ;;; its answers, in case it has been overridden for site policy 737 (defmethod perform ((operation compile-op) (c cl-source-file)) 738 #-:broken-fasl-loader 739 (let ((source-file (component-pathname c)) 740 (output-file (car (output-files operation c)))) 741 (multiple-value-bind (output warnings-p failure-p) 742 (compile-file source-file 743 :output-file output-file) 744 ;(declare (ignore output)) 745 (when warnings-p 746 (case (operation-on-warnings operation) 747 (:warn (warn 748 "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>" 749 operation c)) 750 (:error (error 'compile-warned :component c :operation operation)) 751 (:ignore nil))) 752 (when failure-p 753 (case (operation-on-failure operation) 754 (:warn (warn 755 "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>" 756 operation c)) 757 (:error (error 'compile-failed :component c :operation operation)) 758 (:ignore nil))) 759 (unless output 760 (error 'compile-error :component c :operation operation))))) 761 762 (defmethod output-files ((operation compile-op) (c cl-source-file)) 763 #-:broken-fasl-loader (list (compile-file-pathname (component-pathname c))) 764 #+:broken-fasl-loader (list (component-pathname c))) 765 766 (defmethod perform ((operation compile-op) (c static-file)) 767 nil) 768 769 (defmethod output-files ((operation compile-op) (c static-file)) 770 nil) 771 772 ;;; load-op 773 774 (defclass load-op (operation) ()) 775 776 (defmethod perform ((o load-op) (c cl-source-file)) 777 (mapcar #'load (input-files o c))) 778 779 (defmethod perform ((operation load-op) (c static-file)) 780 nil) 781 (defmethod operation-done-p ((operation load-op) (c static-file)) 782 t) 783 784 (defmethod output-files ((o operation) (c component)) 785 nil) 786 787 (defmethod component-depends-on ((operation load-op) (c component)) 788 (cons (list 'compile-op (component-name c)) 789 (call-next-method))) 790 791 ;;; load-source-op 792 793 (defclass load-source-op (operation) ()) 794 795 (defmethod perform ((o load-source-op) (c cl-source-file)) 796 (let ((source (component-pathname c))) 797 (setf (component-property c 'last-loaded-as-source) 798 (and (load source) 799 (get-universal-time))))) 800 801 (defmethod perform ((operation load-source-op) (c static-file)) 802 nil) 803 804 (defmethod output-files ((operation load-source-op) (c component)) 805 nil) 806 807 ;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right. 808 (defmethod component-depends-on ((o load-source-op) (c component)) 809 (let ((what-would-load-op-do (cdr (assoc 'load-op 810 (slot-value c 'in-order-to))))) 811 (mapcar (lambda (dep) 812 (if (eq (car dep) 'load-op) 813 (cons 'load-source-op (cdr dep)) 814 dep)) 815 what-would-load-op-do))) 816 817 (defmethod operation-done-p ((o load-source-op) (c source-file)) 818 (if (or (not (component-property c 'last-loaded-as-source)) 819 (> (file-write-date (component-pathname c)) 820 (component-property c 'last-loaded-as-source))) 821 nil t)) 822 823 (defclass test-op (operation) ()) 824 825 (defmethod perform ((operation test-op) (c component)) 826 nil) 827 828 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 829 ;;; invoking operations 830 831 (defun operate (operation-class system &rest args &key (verbose t) version 832 &allow-other-keys) 833 (let* ((op (apply #'make-instance operation-class 834 :original-initargs args 835 args)) 836 (*verbose-out* (if verbose *trace-output* (make-broadcast-stream))) 837 (system (if (typep system 'component) system (find-system system)))) 838 (unless (version-satisfies system version) 839 (error 'missing-component :requires system :version version)) 840 (let ((steps (traverse op system))) 841 (with-compilation-unit () 842 (loop for (op . component) in steps do 843 (loop 844 (restart-case 845 (progn (perform op component) 846 (return)) 847 (retry () 848 :report 849 (lambda (s) 850 (format s "~@<Retry performing ~S on ~S.~@:>" 851 op component))) 852 (accept () 853 :report 854 (lambda (s) 855 (format s 856 "~@<Continue, treating ~S on ~S as ~ 857 having been successful.~@:>" 858 op component)) 859 (setf (gethash (type-of op) 860 (component-operation-times component)) 861 (get-universal-time)) 862 (return))))))))) 863 864 (defun oos (&rest args) 865 "Alias of OPERATE function" 866 (apply #'operate args)) 867 868 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 869 ;;; syntax 870 871 (defun remove-keyword (key arglist) 872 (labels ((aux (key arglist) 873 (cond ((null arglist) nil) 874 ((eq key (car arglist)) (cddr arglist)) 875 (t (cons (car arglist) (cons (cadr arglist) 876 (remove-keyword 877 key (cddr arglist)))))))) 878 (aux key arglist))) 879 880 (defmacro defsystem (name &body options) 881 (destructuring-bind (&key pathname (class 'system) &allow-other-keys) options 882 (let ((component-options (remove-keyword :class options))) 883 `(progn 884 ;; system must be registered before we parse the body, otherwise 885 ;; we recur when trying to find an existing system of the same name 886 ;; to reuse options (e.g. pathname) from 887 (let ((s (system-registered-p ',name))) 888 (cond ((and s (eq (type-of (cdr s)) ',class)) 889 (setf (car s) (get-universal-time))) 890 (s 891 #+clisp 892 (sysdef-error "Cannot redefine the existing system ~A with a different class" s) 893 #-clisp 894 (change-class (cdr s) ',class)) 895 (t 896 (register-system (quote ,name) 897 (make-instance ',class :name ',name))))) 898 (parse-component-form nil (apply 899 #'list 900 :module (coerce-name ',name) 901 :pathname 902 (or ,pathname 903 (pathname-sans-name+type 904 (resolve-symlinks *load-truename*)) 905 *default-pathname-defaults*) 906 ',component-options)))))) 907 908 909 (defun class-for-type (parent type) 910 (let ((class 911 (find-class 912 (or (find-symbol (symbol-name type) *package*) 913 (find-symbol (symbol-name type) #.(package-name *package*))) 914 nil))) 915 (or class 916 (and (eq type :file) 917 (or (module-default-component-class parent) 918 (find-class 'cl-source-file))) 919 (sysdef-error "~@<don't recognize component type ~A~@:>" type)))) 920 921 (defun maybe-add-tree (tree op1 op2 c) 922 "Add the node C at /OP1/OP2 in TREE, unless it's there already. 923 Returns the new tree (which probably shares structure with the old one)" 924 (let ((first-op-tree (assoc op1 tree))) 925 (if first-op-tree 926 (progn 927 (aif (assoc op2 (cdr first-op-tree)) 928 (if (find c (cdr it)) 929 nil 930 (setf (cdr it) (cons c (cdr it)))) 931 (setf (cdr first-op-tree) 932 (acons op2 (list c) (cdr first-op-tree)))) 933 tree) 934 (acons op1 (list (list op2 c)) tree)))) 935 936 (defun union-of-dependencies (&rest deps) 937 (let ((new-tree nil)) 938 (dolist (dep deps) 939 (dolist (op-tree dep) 940 (dolist (op (cdr op-tree)) 941 (dolist (c (cdr op)) 942 (setf new-tree 943 (maybe-add-tree new-tree (car op-tree) (car op) c)))))) 944 new-tree)) 945 946 947 (defun remove-keys (key-names args) 948 (loop for ( name val ) on args by #'cddr 949 unless (member (symbol-name name) key-names 950 :key #'symbol-name :test 'equal) 951 append (list name val))) 952 953 (defvar *serial-depends-on*) 954 955 (defun parse-component-form (parent options) 956 (destructuring-bind 957 (type name &rest rest &key 958 ;; the following list of keywords is reproduced below in the 959 ;; remove-keys form. important to keep them in sync 960 components pathname default-component-class 961 perform explain output-files operation-done-p 962 weakly-depends-on 963 depends-on serial in-order-to 964 ;; list ends 965 &allow-other-keys) options 966 (check-component-input type name weakly-depends-on depends-on components in-order-to) 967 968 (when (and parent 969 (find-component parent name) 970 ;; ignore the same object when rereading the defsystem 971 (not 972 (typep (find-component parent name) 973 (class-for-type parent type)))) 974 (error 'duplicate-names :name name)) 975 976 (let* ((other-args (remove-keys 977 '(components pathname default-component-class 978 perform explain output-files operation-done-p 979 weakly-depends-on 980 depends-on serial in-order-to) 981 rest)) 982 (ret 983 (or (find-component parent name) 984 (make-instance (class-for-type parent type))))) 985 (when weakly-depends-on 986 (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on)))) 987 (when (boundp '*serial-depends-on*) 988 (setf depends-on 989 (concatenate 'list *serial-depends-on* depends-on))) 990 (apply #'reinitialize-instance 991 ret 992 :name (coerce-name name) 993 :pathname pathname 994 :parent parent 995 other-args) 996 (when (typep ret 'module) 997 (setf (module-default-component-class ret) 998 (or default-component-class 999 (and (typep parent 'module) 1000 (module-default-component-class parent)))) 1001 (let ((*serial-depends-on* nil)) 1002 (setf (module-components ret) 1003 (loop for c-form in components 1004 for c = (parse-component-form ret c-form) 1005 collect c 1006 if serial 1007 do (push (component-name c) *serial-depends-on*)))) 1008 1009 ;; check for duplicate names 1010 (let ((name-hash (make-hash-table :test #'equal))) 1011 (loop for c in (module-components ret) 1012 do 1013 (if (gethash (component-name c) 1014 name-hash) 1015 (error 'duplicate-names 1016 :name (component-name c)) 1017 (setf (gethash (component-name c) 1018 name-hash) 1019 t))))) 1020 1021 (setf (slot-value ret 'in-order-to) 1022 (union-of-dependencies 1023 in-order-to 1024 `((compile-op (compile-op ,@depends-on)) 1025 (load-op (load-op ,@depends-on)))) 1026 (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on)))) 1027 1028 (loop for (n v) in `((perform ,perform) (explain ,explain) 1029 (output-files ,output-files) 1030 (operation-done-p ,operation-done-p)) 1031 do (map 'nil 1032 ;; this is inefficient as most of the stored 1033 ;; methods will not be for this particular gf n 1034 ;; But this is hardly performance-critical 1035 (lambda (m) (remove-method (symbol-function n) m)) 1036 (component-inline-methods ret)) 1037 when v 1038 do (destructuring-bind (op qual (o c) &body body) v 1039 (pushnew 1040 (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret))) 1041 ,@body)) 1042 (component-inline-methods ret)))) 1043 ret))) 1044 1045 (defun check-component-input (type name weakly-depends-on depends-on components in-order-to) 1046 "A partial test of the values of a component." 1047 (when weakly-depends-on (warn "We got one! XXXXX")) 1048 (unless (listp depends-on) 1049 (sysdef-error-component ":depends-on must be a list." 1050 type name depends-on)) 1051 (unless (listp weakly-depends-on) 1052 (sysdef-error-component ":weakly-depends-on must be a list." 1053 type name weakly-depends-on)) 1054 (unless (listp components) 1055 (sysdef-error-component ":components must be NIL or a list of components." 1056 type name components)) 1057 (unless (and (listp in-order-to) (listp (car in-order-to))) 1058 (sysdef-error-component ":in-order-to must be NIL or a list of components." 1059 type name in-order-to))) 1060 1061 (defun sysdef-error-component (msg type name value) 1062 (sysdef-error (concatenate 'string msg 1063 "~&The value specified for ~(~A~) ~A is ~W") 1064 type name value)) 1065 1066 (defun resolve-symlinks (path) 1067 #-allegro (truename path) 1068 #+allegro (excl:pathname-resolve-symbolic-links path) 1069 ) 1070 1071 ;;; optional extras 1072 1073 ;;; run-shell-command functions for other lisp implementations will be 1074 ;;; gratefully accepted, if they do the same thing. If the docstring 1075 ;;; is ambiguous, send a bug report 1076 1077 (defun run-shell-command (control-string &rest args) 1078 "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and 1079 synchronously execute the result using a Bourne-compatible shell, with 1080 output to *VERBOSE-OUT*. Returns the shell's exit code." 1081 (let ((command (apply #'format nil control-string args))) 1082 (format *verbose-out* "; $ ~A~%" command) 1083 #+sbcl 1084 (sb-ext:process-exit-code 1085 (sb-ext:run-program 1086 #+win32 "sh" #-win32 "/bin/sh" 1087 (list "-c" command) 1088 #+win32 #+win32 :search t 1089 :input nil :output *verbose-out*)) 1090 1091 #+(or cmu scl) 1092 (ext:process-exit-code 1093 (ext:run-program 1094 "/bin/sh" 1095 (list "-c" command) 1096 :input nil :output *verbose-out*)) 1097 1098 #+allegro 1099 (excl:run-shell-command command :input nil :output *verbose-out*) 1100 1101 #+lispworks 1102 (system:call-system-showing-output 1103 command 1104 :shell-type "/bin/sh" 1105 :output-stream *verbose-out*) 1106 1107 #+clisp ;XXX not exactly *verbose-out*, I know 1108 (ext:run-shell-command command :output :terminal :wait t) 1109 1110 #+openmcl 1111 (nth-value 1 1112 (ccl:external-process-status 1113 (ccl:run-program "/bin/sh" (list "-c" command) 1114 :input nil :output *verbose-out* 1115 :wait t))) 1116 #+ecl ;; courtesy of Juan Jose Garcia Ripoll 1117 (si:system command) 1118 #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl) 1119 (error "RUN-SHELL-PROGRAM not implemented for this Lisp") 1120 )) 1121 1122 1123 (defgeneric hyperdocumentation (package name doc-type)) 1124 (defmethod hyperdocumentation ((package symbol) name doc-type) 1125 (hyperdocumentation (find-package package) name doc-type)) 1126 1127 (defun hyperdoc (name doc-type) 1128 (hyperdocumentation (symbol-package name) name doc-type)) 1129 1130 1131 (pushnew :asdf *features*) 1132 1133 #+sbcl 1134 (eval-when (:compile-toplevel :load-toplevel :execute) 1135 (when (sb-ext:posix-getenv "SBCL_BUILDING_CONTRIB") 1136 (pushnew :sbcl-hooks-require *features*))) 1137 1138 #+(and sbcl sbcl-hooks-require) 1139 (progn 1140 (defun module-provide-asdf (name) 1141 (handler-bind ((style-warning #'muffle-warning)) 1142 (let* ((*verbose-out* (make-broadcast-stream)) 1143 (system (asdf:find-system name nil))) 1144 (when system 1145 (asdf:operate 'asdf:load-op name) 1146 t)))) 1147 1148 (defun contrib-sysdef-search (system) 1149 (let* ((name (coerce-name system)) 1150 (home (truename (sb-ext:posix-getenv "SBCL_HOME"))) 1151 (contrib (merge-pathnames 1152 (make-pathname :directory `(:relative ,name) 1153 :name name 1154 :type "asd" 1155 :case :local 1156 :version :newest) 1157 home))) 1158 (probe-file contrib))) 1159 1160 (pushnew 1161 '(merge-pathnames "site-systems/" 1162 (truename (sb-ext:posix-getenv "SBCL_HOME"))) 1163 *central-registry*) 1164 1165 (pushnew 1166 '(merge-pathnames ".sbcl/systems/" 1167 (user-homedir-pathname)) 1168 *central-registry*) 1169 1170 (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*) 1171 (pushnew 'contrib-sysdef-search *system-definition-search-functions*)) 1172 1173 (provide 'asdf) 1 2 3 4 5 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" 6 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> 7 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"> 8 <!-- ViewVC - http://viewvc.org/ 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">;;; <cclan-list@lists.sf.net>. 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">;;; <URL:http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/></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 "supported" 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">;;; "Software"), 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 "AS IS", 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">"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"</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">"$Revision$"</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">&</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">"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"</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">(&</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">"Append onto list"</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">"(unnamed)"</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">"~@<erred while invoking ~A on ~A~@:>"</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">"Component name: designator for a string composed of portable pathname characters"</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 "inline" 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">"~@<~A, required by ~A~@:>"</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">&</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">"~@<component ~S not found~</span> 316 <a id="l_228"></a><span class="hl line"> 228 </span><span class="hl str"> ~@[ or does not match version ~A~]~</span> 317 <a id="l_229"></a><span class="hl line"> 229 </span><span class="hl str"> ~@[ in ~A~]~@:>"</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">"Find the top-level system containing COMPONENT"</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">"Extracts the pathname applicable for a particular component."</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">"Extracts the relative pathname applicable for a particular component."</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">&</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">(>=</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">((> (</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">"~@<invalid component designator ~A~@:>"</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">"/home/dan/src/sourceforge/cclan/asdf/systems/"</span> 448 <a id="l_360"></a><span class="hl line"> 360 </span> #<span class="hl sym">+</span>nil <span class="hl str">"telent:asdf;systems;"</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">"asd"</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">"ASDF~D"</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">&</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">(< (</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">"~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"</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">"~&~@<; ~@;registering ~A as ~A~@:>~%"</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">&</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">"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."</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">&</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">&</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">"lisp"</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">"c"</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">"java"</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">"html"</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">&</span>key force 578 <a id="l_490"></a><span class="hl line"> 490 </span> <span class="hl sym">&</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">"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"</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">"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"> (<operation> <component>*), where <operation> is a class</span> 664 <a id="l_576"></a><span class="hl line"> 576 </span><span class="hl str"> designator and each <component> 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"> <operation> having been performed on each <component>; 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 <feature>), which means that the component depends</span> 669 <a id="l_581"></a><span class="hl line"> 581 </span><span class="hl str"> on <feature>'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."</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">"~@<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.~@:>"</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">(>=</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">(> (</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 "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". 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->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">"VERSION"</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">"~@<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~@:>"</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">"~&;;; ~A on ~A~%"</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">"~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"</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">"~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"</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">(> (</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">"Called to load system preferences after <perform operation</span> 959 <a id="l_871"></a><span class="hl line"> 871 </span><span class="hl str">system>. 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."</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">"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."</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">"~&~@<; ~@;loading preferences for ~A/~(~A~) from ~A~@:>~%"</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">"lisp"</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">".asdf"</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">"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."</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">&</span>rest args <span class="hl sym">&</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">&</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">"~@<Retry performing ~S on ~S.~@:>"</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">"~@<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.~@:>"</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">&</span>rest args <span class="hl sym">&</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">"Short for _operate on system_ and an alias for the `operate` function. ~&~&~a"</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">&</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">(&</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">&</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">"Cannot redefine the existing system ~A with a different class"</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">"~@<don't recognize component type ~A~@:>"</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">"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)"</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">(&</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">&</span>rest rest <span class="hl sym">&</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">&</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>@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>@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>@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">) &</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>@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">"A partial test of the values of a component."</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">"We got one! XXXXX"</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">":depends-on must be a list."</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">":weakly-depends-on must be a list."</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">":components must be NIL or a list of components."</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">":in-order-to must be NIL or a list of components."</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">"~&The value specified for ~(~A~) ~A is ~W"</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">&</span>rest args<span class="hl sym">)</span> 1287 <a id="l_1199"></a><span class="hl line"> 1199 </span> <span class="hl str">"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."</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">"; $ ~A~%"</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">"sh"</span> #-win32 <span class="hl str">"/bin/sh"</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">"-c"</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">"/bin/sh"</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">"-c"</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">"/bin/sh"</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">"/bin/sh"</span> <span class="hl sym">(</span><span class="hl kwa">list</span> <span class="hl str">"-c"</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">"RUN-SHELL-PROGRAM not implemented for this Lisp"</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">"asd"</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">&</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">"SBCL_BUILDING_CONTRIB"</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">"SBCL_HOME"</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">""</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">"asd"</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">"SBCL_HOME"</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">""</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">"site-systems/"</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">".sbcl/systems/"</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
Note: See TracChangeset
for help on using the changeset viewer.