contrib/asdf/asdf.lisp

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