1 ;;; This is asdf: Another System Definition Facility. $Revision: 1.102 $
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/>
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'
16 ;;; Copyright (c) 2001-2003 Daniel Barlow and contributors
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:
26 ;;; The above copyright notice and this permission notice shall be
27 ;;; included in all copies or substantial portions of the Software.
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.
37 ;;; the problem with writing a defsystem replacement is bootstrapping:
38 ;;; we can't use defsystem to compile it. Hence, all in one file
41 (:export
#:defsystem
#:oos
#:operate
#:find-system
#:run-shell-command
42 #:system-definition-pathname
#:find-component
; miscellaneous
43 #:hyperdocumentation
#:hyperdoc
45 #:compile-op
#:load-op
#:load-source-op
#:test-system-version
47 #:operation
; operations
48 #:feature
; sort-of operation
49 #:version
; metaphorically sort-of an operation
51 #:input-files
#:output-files
#:perform
; operation methods
52 #:operation-done-p
#:explain
54 #:component
#:source-file
55 #:c-source-file
#:cl-source-file
#:java-source-file
65 #:module-components
; component accessors
67 #:component-relative-pathname
74 #:component-depends-on
77 #:system-long-description
83 #:operation-on-warnings
84 #:operation-on-failure
86 ;#:*component-parent-pathname*
87 #:*system-definition-search-functions
*
88 #:*central-registry
* ; variables
89 #:*compile-file-warnings-behaviour
*
90 #:*compile-file-failure-behaviour
*
93 #:operation-error
#:compile-failed
#:compile-warned
#:compile-error
94 #:error-component
#:error-operation
95 #:system-definition-error
98 #:circular-dependency
; errors
104 #:preference-file-for-system
/operation
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")
115 (defvar *asdf-revision
* (let* ((v "$Revision: 1.102 $")
116 (colon (or (position #\
: v
) -
1))
117 (dot (position #\. v
)))
119 (list (parse-integer v
:start
(1+ colon
)
121 (parse-integer v
:start
(1+ dot
)
124 (defvar *compile-file-warnings-behaviour
* :warn
)
125 (defvar *compile-file-failure-behaviour
* #+sbcl
:error
#-sbcl
:warn
)
127 (defvar *verbose-out
* nil
)
129 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
132 (defmacro aif
(test then
&optional else
)
133 `(let ((it ,test
)) (if it
,then
,else
)))
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
))
140 (define-modify-macro appendf
(&rest args
)
141 append
"Append onto list")
143 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
144 ;; classes, condiitons
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
))
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
)))))
161 (define-condition circular-dependency
(system-definition-error)
162 ((components :initarg
:components
:reader circular-dependency-components
)))
164 (define-condition duplicate-names
(system-definition-error)
165 ((name :initarg
:name
:reader duplicate-names-name
)))
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
)))
172 (define-condition missing-dependency
(missing-component)
173 ((required-by :initarg
:required-by
:reader missing-required-by
)))
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) ())
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
)
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
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
207 ;;;; methods: conditions
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
)))
213 (defun sysdef-error (format &rest arguments
)
214 (error 'formatted-system-definition-error
:format-control format
:format-arguments arguments
))
216 ;;;; methods: components
218 (defmethod print-object ((c missing-component
) s
)
219 (format s
"~@<component ~S not found~
220 ~@[ or does not match version ~A~]~
224 (when (missing-parent c
)
225 (component-name (missing-parent c
)))))
227 (defgeneric component-system
(component)
228 (:documentation
"Find the top-level system containing COMPONENT"))
230 (defmethod component-system ((component component
))
231 (aif (component-parent component
)
232 (component-system it
)
235 (defmethod print-object ((c component
) stream
)
236 (print-unreadable-object (c stream
:type t
:identity t
)
238 (prin1 (component-name c
) stream
))))
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
)))
250 (defgeneric component-pathname
(component)
251 (:documentation
"Extracts the pathname applicable for a particular component."))
253 (defun component-parent-pathname (component)
254 (aif (component-parent component
)
255 (component-pathname it
)
256 *default-pathname-defaults
*))
258 (defgeneric component-relative-pathname
(component)
259 (:documentation
"Extracts the relative pathname applicable for a particular component."))
261 (defmethod component-relative-pathname ((component module
))
262 (or (slot-value component
'relative-pathname
)
264 :directory
`(:relative
,(component-name component
))
265 :host
(pathname-host (component-parent-pathname component
)))))
267 (defmethod component-pathname ((component component
))
268 (let ((*default-pathname-defaults
* (component-parent-pathname component
)))
269 (merge-pathnames (component-relative-pathname component
))))
271 (defgeneric component-property
(component property
))
273 (defmethod component-property ((c component
) property
)
274 (cdr (assoc property
(slot-value c
'properties
) :test
#'equal
)))
276 (defgeneric (setf component-property
) (new-value component property
))
278 (defmethod (setf component-property
) (new-value (c component
) property
)
279 (let ((a (assoc property
(slot-value c
'properties
) :test
#'equal
)))
281 (setf (cdr a
) new-value
)
282 (setf (slot-value c
'properties
)
283 (acons property new-value
(slot-value c
'properties
))))))
285 (defclass system
(module)
286 ((description :accessor system-description
:initarg
: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
)))
294 ;;; version-satisfies
296 ;;; with apologies to christophe rhodes ...
297 (defun split (string &optional max
(ws '(#\Space
#\Tab
)))
298 (flet ((is-ws (char) (find char ws
)))
300 (let ((list nil
) (start 0) (words 0) end
)
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
)
307 (unless end
(return list
))
308 (setf start
(1+ end
)))))))
310 (defgeneric version-satisfies
(component version
))
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
)
322 ((> (car x
) (car y
)) t
)
324 (bigger (cdr x
) (cdr y
))))))
325 (and (= (car x
) (car y
))
326 (or (not (cdr y
)) (bigger (cdr x
) (cdr y
)))))))
328 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
331 (defvar *defined-systems
* (make-hash-table :test
'equal
))
332 (defun coerce-name (name)
334 (component (component-name name
))
335 (symbol (string-downcase (symbol-name name
)))
337 (t (sysdef-error "~@<invalid component designator ~A~@:>" name
))))
339 ;;; for the sake of keeping things reasonably neat, we adopt a
340 ;;; convention that functions in this list are prefixed SYSDEF-
342 (defvar *system-definition-search-functions
*
343 '(sysdef-central-registry-search))
345 (defun system-definition-pathname (system)
346 (some (lambda (x) (funcall x system
))
347 *system-definition-search-functions
*))
349 (defvar *central-registry
*
350 '(*default-pathname-defaults
*
351 #+nil
"/home/dan/src/sourceforge/cclan/asdf/systems/"
352 #+nil
"telent:asdf;systems;"))
354 (defun sysdef-central-registry-search (system)
355 (let ((name (coerce-name system
)))
357 (dolist (dir *central-registry
*)
358 (let* ((defaults (eval dir
))
361 :defaults defaults
:version
:newest
362 :name name
:type
"asd" :case
:local
))))
363 (if (and file
(probe-file file
))
366 (defun make-temporary-package ()
367 (flet ((try (counter)
369 (make-package (format nil
"ASDF~D" counter
)
370 :use
'(:cl
:asdf
)))))
371 (do* ((counter 0 (+ counter
1))
372 (package (try counter
) (try counter
)))
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
)))
381 (< (car in-memory
) (file-write-date on-disk
))))
382 (let ((package (make-temporary-package)))
384 (let ((*package
* package
))
387 "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
388 ;; FIXME: This wants to be (ENOUGH-NAMESTRING
389 ;; ON-DISK), but CMUCL barfs on that.
393 (delete-package package
))))
394 (let ((in-memory (gethash name
*defined-systems
*)))
396 (progn (if on-disk
(setf (car in-memory
) (file-write-date on-disk
)))
398 (if error-p
(error 'missing-component
:requires name
))))))
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
)))
405 (defun system-registered-p (name)
406 (gethash (coerce-name name
) *defined-systems
*))
408 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
409 ;;; finding components
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
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
))))
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
)))
428 ;;; component subclasses
430 (defclass source-file
(component) ())
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) ())
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
)
446 (defmethod component-relative-pathname ((component source-file
))
447 (let ((relative-pathname (slot-value component
'relative-pathname
)))
448 (if relative-pathname
452 :type
(source-file-type component
(component-system component
))))
453 (let* ((*default-pathname-defaults
*
454 (component-parent-pathname component
))
457 :name
(component-name component
)
458 :type
(source-file-type component
459 (component-system component
)))))
462 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
465 ;;; one of these is instantiated whenever (operate ) is called
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
)))
475 (defmethod print-object ((o operation
) stream
)
476 (print-unreadable-object (o stream
:type t
:identity t
)
478 (prin1 (operation-original-initargs o
) stream
))))
480 (defmethod shared-initialize :after
((operation operation
) slot-names
483 (declare (ignore slot-names force
))
484 ;; empty method to disable initarg validity checking
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
))
493 (defun node-for (o c
)
494 (cons (class-name (class-of o
)) c
))
496 (defgeneric operation-ancestor
(operation)
497 (:documentation
"Recursively chase the operation's parent pointer until we get to the head of the tree"))
499 (defmethod operation-ancestor ((operation operation
))
500 (aif (operation-parent operation
)
501 (operation-ancestor it
)
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
))
513 (when (eql force-p t
)
514 (setf (getf args
:force
) nil
))
515 (apply #'make-instance dep-o
517 :original-initargs args args
))
518 ((subtypep (type-of o
) dep-o
)
521 (apply #'make-instance dep-o
522 :parent o
:original-initargs args args
)))))
525 (defgeneric visit-component
(operation component data
))
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
)))))
532 (defgeneric component-visited-p
(operation component
))
534 (defmethod component-visited-p ((o operation
) (c component
))
535 (assoc (node-for o c
)
536 (operation-visited-nodes (operation-ancestor o
))
539 (defgeneric (setf visiting-component
) (new-value operation component
))
541 (defmethod (setf visiting-component
) (new-value operation component
)
542 ;; MCL complains about unused lexical variables
543 (declare (ignorable new-value operation component
)))
545 (defmethod (setf visiting-component
) (new-value (o operation
) (c component
))
546 (let ((node (node-for o c
))
547 (a (operation-ancestor o
)))
549 (pushnew node
(operation-visiting-nodes a
) :test
'equal
)
550 (setf (operation-visiting-nodes a
)
551 (remove node
(operation-visiting-nodes a
) :test
'equal
)))))
553 (defgeneric component-visiting-p
(operation component
))
555 (defmethod component-visiting-p ((o operation
) (c component
))
556 (let ((node (cons o c
)))
557 (member node
(operation-visiting-nodes (operation-ancestor o
))
560 (defgeneric component-depends-on
(operation component
))
562 (defmethod component-depends-on ((o operation
) (c component
))
563 (cdr (assoc (class-name (class-of o
))
564 (slot-value c
'in-order-to
))))
566 (defgeneric component-self-dependencies
(operation component
))
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
=))
574 (defmethod input-files ((operation operation
) (c component
))
575 (let ((parent (component-parent c
))
576 (self-deps (component-self-dependencies operation c
)))
578 (mapcan (lambda (dep)
579 (destructuring-bind (op name
) dep
580 (output-files (make-instance op
)
581 (find-component parent name
))))
583 ;; no previous operations needed? I guess we work with the
584 ;; original source file, then
585 (list (component-pathname c
)))))
587 (defmethod input-files ((operation operation
) (c module
)) nil
)
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
)))
600 (warn "~@<Missing FILE-WRITE-DATE for ~S: treating ~
601 operation ~S on component ~S as done.~@:>"
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
613 (component-operation-times c
))))
617 (mapcar #'fwd-or-return-t in-files
))))))
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
)))))))))
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
631 (defgeneric traverse
(operation component
))
632 (defmethod traverse ((operation operation
) (c component
))
634 (labels ((do-one-dep (required-op required-c required-v
)
635 (let* ((dep-c (or (find-component
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
643 :requires required-c
)))
644 (op (make-sub-operation c operation dep-c required-op
)))
645 (traverse op dep-c
)))
647 (cond ((eq op
'feature
)
648 (or (member (car dep
) *features
*)
649 (error 'missing-dependency
:required-by c
650 :requires
(car dep
) :version nil
)))
654 (assert (string-equal
655 (symbol-name (first d
))
658 (do-one-dep op
(second d
) (third d
))))
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
)))
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
))
672 (when (typep c
'module
)
673 (let ((at-least-one nil
)
676 (loop for kid in
(module-components c
)
678 (appendf forced
(traverse operation kid
))
679 (missing-dependency (condition)
680 (if (eq (module-if-component-dep-fails c
) :fail
)
682 (setf error condition
))
685 (setf at-least-one t
))))
686 (when (and (eq (module-if-component-dep-fails c
) :try-next
)
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
)
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
))
711 (defmethod perform ((operation operation
) (c source-file
))
713 "~@<required method PERFORM not implemented ~
714 for operation ~A, component ~A~@:>"
715 (class-of operation
) (class-of c
)))
717 (defmethod perform ((operation operation
) (c module
))
720 (defmethod explain ((operation operation
) (component component
))
721 (format *verbose-out
* "~&;;; ~A on ~A~%" operation component
))
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
*)))
732 (defmethod perform :before
((operation compile-op
) (c source-file
))
733 (map nil
#'ensure-directories-exist
(output-files operation c
)))
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
))
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))
751 (case (operation-on-warnings operation
)
753 "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
755 (:error
(error 'compile-warned
:component c
:operation operation
))
758 (case (operation-on-failure operation
)
760 "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
762 (:error
(error 'compile-failed
:component c
:operation operation
))
765 (error 'compile-error
:component c
:operation operation
)))))
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
)))
771 (defmethod perform ((operation compile-op
) (c static-file
))
774 (defmethod output-files ((operation compile-op
) (c static-file
))
779 (defclass basic-load-op
(operation) ())
781 (defclass load-op
(basic-load-op) ())
783 (defmethod perform ((o load-op
) (c cl-source-file
))
784 (mapcar #'load
(input-files o c
)))
786 (defmethod perform ((operation load-op
) (c static-file
))
788 (defmethod operation-done-p ((operation load-op
) (c static-file
))
791 (defmethod output-files ((o operation
) (c component
))
794 (defmethod component-depends-on ((operation load-op
) (c component
))
795 (cons (list 'compile-op
(component-name c
))
800 (defclass load-source-op
(basic-load-op) ())
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
)
806 (get-universal-time)))))
808 (defmethod perform ((operation load-source-op
) (c static-file
))
811 (defmethod output-files ((operation load-source-op
) (c component
))
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
))
822 what-would-load-op-do
)))
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
)))
830 (defclass test-op
(operation) ())
832 (defmethod perform ((operation test-op
) (c component
))
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."))
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."))
841 (defmethod load-preferences ((s t
) (operation t
))
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
))))
850 (format *verbose-out
*
851 "~&~@<; ~@;loading preferences for ~A/~(~A~) from ~A~@:>~%"
853 (type-of operation
) file
))
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
))
860 (defmethod preference-file-for-system/operation
((s system
) (operation t
))
862 (make-pathname :name
(component-name s
)
864 :directory
'(:relative
".asdf"))
865 (truename (user-homedir-pathname))))
867 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
868 ;;; invoking operations
870 (defun operate (operation-class system
&rest args
&key
(verbose t
) version
872 (let* ((op (apply #'make-instance operation-class
873 :original-initargs 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
884 (progn (perform op component
)
889 (format s
"~@<Retry performing ~S on ~S.~@:>"
895 "~@<Continue, treating ~S on ~S as ~
896 having been successful.~@:>"
898 (setf (gethash (type-of op
)
899 (component-operation-times component
))
900 (get-universal-time))
903 (defun oos (&rest args
)
904 "Alias of OPERATE function"
905 (apply #'operate args
))
907 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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
)
916 key
(cddr arglist
))))))))
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
)))
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)))
931 (sysdef-error "Cannot redefine the existing system ~A with a different class" s
)
933 (change-class (cdr s
) ',class
))
935 (register-system (quote ,name
)
936 (make-instance ',class
:name
',name
)))))
937 (parse-component-form nil
(apply
939 :module
(coerce-name ',name
)
942 (pathname-sans-name+type
943 (resolve-symlinks *load-truename
*))
944 *default-pathname-defaults
*)
945 ',component-options
))))))
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
)
954 (cons type extra-symbols
)))
956 (find-class symbol nil
)
957 (subtypep symbol
'component
))
958 (return (find-class symbol
))))))
961 (or (module-default-component-class parent
)
962 (find-class 'cl-source-file
)))
963 (sysdef-error "~@<don't recognize component type ~A~@:>" type
))))
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
)))
971 (aif (assoc op2
(cdr first-op-tree
))
972 (if (find c
(cdr it
))
974 (setf (cdr it
) (cons c
(cdr it
))))
975 (setf (cdr first-op-tree
)
976 (acons op2
(list c
) (cdr first-op-tree
))))
978 (acons op1
(list (list op2 c
)) tree
))))
980 (defun union-of-dependencies (&rest deps
)
981 (let ((new-tree nil
))
983 (dolist (op-tree dep
)
984 (dolist (op (cdr op-tree
))
987 (maybe-add-tree new-tree
(car op-tree
) (car op
) c
))))))
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
)))
997 (defvar *serial-depends-on
*)
999 (defun parse-component-form (parent options
)
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
1007 depends-on serial in-order-to
1009 &allow-other-keys
) options
1010 (check-component-input type name weakly-depends-on depends-on components in-order-to
)
1013 (find-component parent name
)
1014 ;; ignore the same object when rereading the defsystem
1016 (typep (find-component parent name
)
1017 (class-for-type parent type
))))
1018 (error 'duplicate-names
:name name
))
1020 (let* ((other-args (remove-keys
1021 '(components pathname default-component-class
1022 perform explain output-files operation-done-p
1024 depends-on serial in-order-to
)
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
*)
1033 (concatenate 'list
*serial-depends-on
* depends-on
)))
1034 (apply #'reinitialize-instance
1036 :name
(coerce-name name
)
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
)
1051 do
(push (component-name c
) *serial-depends-on
*))))
1053 ;; check for duplicate names
1054 (let ((name-hash (make-hash-table :test
#'equal
)))
1055 (loop for c in
(module-components ret
)
1057 (if (gethash (component-name c
)
1059 (error 'duplicate-names
1060 :name
(component-name c
))
1061 (setf (gethash (component-name c
)
1065 (setf (slot-value ret
'in-order-to
)
1066 (union-of-dependencies
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
))))
1072 (loop for
(n v
) in
`((perform ,perform
) (explain ,explain
)
1073 (output-files ,output-files
)
1074 (operation-done-p ,operation-done-p
))
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
))
1082 do
(destructuring-bind (op qual
(o c
) &body body
) v
1084 (eval `(defmethod ,n
,qual
((,o
,op
) (,c
(eql ,ret
)))
1086 (component-inline-methods ret
))))
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
)))
1105 (defun sysdef-error-component (msg type name value
)
1106 (sysdef-error (concatenate 'string msg
1107 "~&The value specified for ~(~A~) ~A is ~W")
1110 (defun resolve-symlinks (path)
1111 #-allegro
(truename path
)
1112 #+allegro
(excl:pathname-resolve-symbolic-links path
)
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
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
)
1128 (sb-ext:process-exit-code
1130 #+win32
"sh" #-win32
"/bin/sh"
1132 #+win32
#+win32
:search t
1133 :input nil
:output
*verbose-out
*))
1136 (ext:process-exit-code
1140 :input nil
:output
*verbose-out
*))
1143 (excl:run-shell-command command
:input nil
:output
*verbose-out
*)
1146 (system:call-system-showing-output
1148 :shell-type
"/bin/sh"
1149 :output-stream
*verbose-out
*)
1151 #+clisp
;XXX not exactly *verbose-out*, I know
1152 (ext:run-shell-command command
:output
:terminal
:wait t
)
1156 (ccl:external-process-status
1157 (ccl:run-program
"/bin/sh" (list "-c" command
)
1158 :input nil
:output
*verbose-out
*
1160 #+ecl
;; courtesy of Juan Jose Garcia Ripoll
1162 #-
(or openmcl clisp lispworks allegro scl cmu sbcl ecl
)
1163 (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
1167 (defgeneric hyperdocumentation
(package name doc-type
))
1168 (defmethod hyperdocumentation ((package symbol
) name doc-type
)
1169 (hyperdocumentation (find-package package
) name doc-type
))
1171 (defun hyperdoc (name doc-type
)
1172 (hyperdocumentation (symbol-package name
) name doc-type
))
1175 (pushnew :asdf
*features
*)
1178 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
1179 (when (sb-ext:posix-getenv
"SBCL_BUILDING_CONTRIB")
1180 (pushnew :sbcl-hooks-require
*features
*)))
1182 #+(and sbcl sbcl-hooks-require
)
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
)))
1189 (asdf:operate
'asdf
:load-op name
)
1192 (defun contrib-sysdef-search (system)
1193 (let ((home (sb-ext:posix-getenv
"SBCL_HOME")))
1195 (let* ((name (coerce-name system
))
1196 (home (truename home
))
1197 (contrib (merge-pathnames
1198 (make-pathname :directory
`(:relative
,name
)
1204 (probe-file contrib
)))))
1207 '(let ((home (sb-ext:posix-getenv
"SBCL_HOME")))
1209 (merge-pathnames "site-systems/" (truename home
))))
1213 '(merge-pathnames ".sbcl/systems/"
1214 (user-homedir-pathname))
1217 (pushnew 'module-provide-asdf sb-ext
:*module-provider-functions
*)
1218 (pushnew 'contrib-sysdef-search
*system-definition-search-functions
*))
