contrib/asdf/asdf.lisp

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