contrib/asdf/asdf.lisp

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