contrib/asdf/asdf.lisp

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