contrib/asdf/asdf.lisp

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