1 ;;; This is asdf: Another System Definition Facility. 1.115
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-2007 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 #:system-relative-pathname
85 #:operation-on-warnings
86 #:operation-on-failure
88 ;#:*component-parent-pathname*
89 #:*system-definition-search-functions
*
90 #:*central-registry
* ; variables
91 #:*compile-file-warnings-behaviour
*
92 #:*compile-file-failure-behaviour
*
95 #:operation-error
#:compile-failed
#:compile-warned
#:compile-error
96 #:error-component
#:error-operation
97 #:system-definition-error
100 #:circular-dependency
; errors
106 #:preference-file-for-system
/operation
113 (error "The author of this file habitually uses #+nil to comment out ~
114 forms. But don't worry, it was unlikely to work in the New ~
115 Implementation of Lisp anyway")
119 (defvar *asdf-revision
* (let* ((v "1.115")
120 (colon (or (position #\
: v
) -
1))
121 (dot (position #\. v
)))
123 (list (parse-integer v
:start
(1+ colon
)
125 (parse-integer v
:start
(1+ dot
)
128 (defvar *compile-file-warnings-behaviour
* :warn
)
130 (defvar *compile-file-failure-behaviour
* #+sbcl
:error
#-sbcl
:warn
)
132 (defvar *verbose-out
* nil
)
134 (defparameter +asdf-methods
+
135 '(perform explain output-files operation-done-p
))
137 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
140 (defmacro aif
(test then
&optional else
)
141 `(let ((it ,test
)) (if it
,then
,else
)))
143 (defun pathname-sans-name+type
(pathname)
144 "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
145 and NIL NAME and TYPE components"
146 (make-pathname :name nil
:type nil
:defaults pathname
))
148 (define-modify-macro appendf
(&rest args
)
149 append
"Append onto list")
151 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
152 ;; classes, condiitons
154 (define-condition system-definition-error
(error) ()
155 ;; [this use of :report should be redundant, but unfortunately it's not.
156 ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
157 ;; over print-object; this is always conditions::%print-condition for
158 ;; condition objects, which in turn does inheritance of :report options at
159 ;; run-time. fortunately, inheritance means we only need this kludge here in
160 ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.]
161 #+cmu
(:report print-object
))
163 (define-condition formatted-system-definition-error
(system-definition-error)
164 ((format-control :initarg
:format-control
:reader format-control
)
165 (format-arguments :initarg
:format-arguments
:reader format-arguments
))
166 (:report
(lambda (c s
)
167 (apply #'format s
(format-control c
) (format-arguments c
)))))
169 (define-condition circular-dependency
(system-definition-error)
170 ((components :initarg
:components
:reader circular-dependency-components
)))
172 (define-condition duplicate-names
(system-definition-error)
173 ((name :initarg
:name
:reader duplicate-names-name
)))
175 (define-condition missing-component
(system-definition-error)
176 ((requires :initform
"(unnamed)" :reader missing-requires
:initarg
:requires
)
177 (version :initform nil
:reader missing-version
:initarg
:version
)
178 (parent :initform nil
:reader missing-parent
:initarg
:parent
)))
180 (define-condition missing-dependency
(missing-component)
181 ((required-by :initarg
:required-by
:reader missing-required-by
)))
183 (define-condition operation-error
(error)
184 ((component :reader error-component
:initarg
:component
)
185 (operation :reader error-operation
:initarg
:operation
))
186 (:report
(lambda (c s
)
187 (format s
"~@<erred while invoking ~A on ~A~@:>"
188 (error-operation c
) (error-component c
)))))
189 (define-condition compile-error
(operation-error) ())
190 (define-condition compile-failed
(compile-error) ())
191 (define-condition compile-warned
(compile-error) ())
193 (defclass component
()
194 ((name :accessor component-name
:initarg
:name
:documentation
195 "Component name: designator for a string composed of portable pathname characters")
196 (version :accessor component-version
:initarg
:version
)
197 (in-order-to :initform nil
:initarg
:in-order-to
)
199 (do-first :initform nil
:initarg
:do-first
)
200 ;; methods defined using the "inline" style inside a defsystem form:
201 ;; need to store them somewhere so we can delete them when the system
203 (inline-methods :accessor component-inline-methods
:initform nil
)
204 (parent :initarg
:parent
:initform nil
:reader component-parent
)
205 ;; no direct accessor for pathname, we do this as a method to allow
206 ;; it to default in funky ways if not supplied
207 (relative-pathname :initarg
:pathname
)
208 (operation-times :initform
(make-hash-table )
209 :accessor component-operation-times
)
210 ;; XXX we should provide some atomic interface for updating the
211 ;; component properties
212 (properties :accessor component-properties
:initarg
:properties
215 ;;;; methods: conditions
217 (defmethod print-object ((c missing-dependency
) s
)
218 (format s
"~@<~A, required by ~A~@:>"
219 (call-next-method c nil
) (missing-required-by c
)))
221 (defun sysdef-error (format &rest arguments
)
222 (error 'formatted-system-definition-error
:format-control format
:format-arguments arguments
))
224 ;;;; methods: components
226 (defmethod print-object ((c missing-component
) s
)
227 (format s
"~@<component ~S not found~
228 ~@[ or does not match version ~A~]~
232 (when (missing-parent c
)
233 (component-name (missing-parent c
)))))
235 (defgeneric component-system
(component)
236 (:documentation
"Find the top-level system containing COMPONENT"))
238 (defmethod component-system ((component component
))
239 (aif (component-parent component
)
240 (component-system it
)
243 (defmethod print-object ((c component
) stream
)
244 (print-unreadable-object (c stream
:type t
:identity t
)
246 (prin1 (component-name c
) stream
))))
248 (defclass module
(component)
249 ((components :initform nil
:accessor module-components
:initarg
:components
)
250 ;; what to do if we can't satisfy a dependency of one of this module's
251 ;; components. This allows a limited form of conditional processing
252 (if-component-dep-fails :initform
:fail
253 :accessor module-if-component-dep-fails
254 :initarg
:if-component-dep-fails
)
255 (default-component-class :accessor module-default-component-class
256 :initform
'cl-source-file
:initarg
:default-component-class
)))
258 (defgeneric component-pathname
(component)
259 (:documentation
"Extracts the pathname applicable for a particular component."))
261 (defun component-parent-pathname (component)
262 (aif (component-parent component
)
263 (component-pathname it
)
264 *default-pathname-defaults
*))
266 (defgeneric component-relative-pathname
(component)
267 (:documentation
"Extracts the relative pathname applicable for a particular component."))
269 (defmethod component-relative-pathname ((component module
))
270 (or (slot-value component
'relative-pathname
)
272 :directory
`(:relative
,(component-name component
))
273 :host
(pathname-host (component-parent-pathname component
)))))
275 (defmethod component-pathname ((component component
))
276 (let ((*default-pathname-defaults
* (component-parent-pathname component
)))
277 (merge-pathnames (component-relative-pathname component
))))
279 (defgeneric component-property
(component property
))
281 (defmethod component-property ((c component
) property
)
282 (cdr (assoc property
(slot-value c
'properties
) :test
#'equal
)))
284 (defgeneric (setf component-property
) (new-value component property
))
286 (defmethod (setf component-property
) (new-value (c component
) property
)
287 (let ((a (assoc property
(slot-value c
'properties
) :test
#'equal
)))
289 (setf (cdr a
) new-value
)
290 (setf (slot-value c
'properties
)
291 (acons property new-value
(slot-value c
'properties
))))))
293 (defclass system
(module)
294 ((description :accessor system-description
:initarg
:description
)
296 :accessor system-long-description
:initarg
:long-description
)
297 (author :accessor system-author
:initarg
:author
)
298 (maintainer :accessor system-maintainer
:initarg
:maintainer
)
299 (licence :accessor system-licence
:initarg
:licence
300 :accessor system-license
:initarg
:license
)))
302 ;;; version-satisfies
304 ;;; with apologies to christophe rhodes ...
305 (defun split (string &optional max
(ws '(#\Space
#\Tab
)))
306 (flet ((is-ws (char) (find char ws
)))
308 (let ((list nil
) (start 0) (words 0) end
)
310 (when (and max
(>= words
(1- max
)))
311 (return (cons (subseq string start
) list
)))
312 (setf end
(position-if #'is-ws string
:start start
))
313 (push (subseq string start end
) list
)
315 (unless end
(return list
))
316 (setf start
(1+ end
)))))))
318 (defgeneric version-satisfies
(component version
))
320 (defmethod version-satisfies ((c component
) version
)
321 (unless (and version
(slot-boundp c
'version
))
322 (return-from version-satisfies t
))
323 (let ((x (mapcar #'parse-integer
324 (split (component-version c
) nil
'(#\.
))))
325 (y (mapcar #'parse-integer
326 (split version nil
'(#\.
)))))
327 (labels ((bigger (x y
)
330 ((> (car x
) (car y
)) t
)
332 (bigger (cdr x
) (cdr y
))))))
333 (and (= (car x
) (car y
))
334 (or (not (cdr y
)) (bigger (cdr x
) (cdr y
)))))))
336 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
339 (defvar *defined-systems
* (make-hash-table :test
'equal
))
340 (defun coerce-name (name)
342 (component (component-name name
))
343 (symbol (string-downcase (symbol-name name
)))
345 (t (sysdef-error "~@<invalid component designator ~A~@:>" name
))))
347 ;;; for the sake of keeping things reasonably neat, we adopt a
348 ;;; convention that functions in this list are prefixed SYSDEF-
350 (defvar *system-definition-search-functions
*
351 '(sysdef-central-registry-search))
353 (defun system-definition-pathname (system)
354 (some (lambda (x) (funcall x system
))
355 *system-definition-search-functions
*))
357 (defvar *central-registry
*
358 '(*default-pathname-defaults
*
359 #+nil
"/home/dan/src/sourceforge/cclan/asdf/systems/"
360 #+nil
"telent:asdf;systems;"))
362 (defun sysdef-central-registry-search (system)
363 (let ((name (coerce-name system
)))
365 (dolist (dir *central-registry
*)
366 (let* ((defaults (eval dir
))
369 :defaults defaults
:version
:newest
370 :name name
:type
"asd" :case
:local
))))
371 (if (and file
(probe-file file
))
374 (defun make-temporary-package ()
375 (flet ((try (counter)
377 (make-package (format nil
"ASDF~D" counter
)
378 :use
'(:cl
:asdf
)))))
379 (do* ((counter 0 (+ counter
1))
380 (package (try counter
) (try counter
)))
383 (defun find-system (name &optional
(error-p t
))
384 (let* ((name (coerce-name name
))
385 (in-memory (gethash name
*defined-systems
*))
386 (on-disk (system-definition-pathname name
)))
389 (< (car in-memory
) (file-write-date on-disk
))))
390 (let ((package (make-temporary-package)))
392 (let ((*package
* package
))
395 "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
396 ;; FIXME: This wants to be (ENOUGH-NAMESTRING
397 ;; ON-DISK), but CMUCL barfs on that.
401 (delete-package package
))))
402 (let ((in-memory (gethash name
*defined-systems
*)))
404 (progn (if on-disk
(setf (car in-memory
) (file-write-date on-disk
)))
406 (if error-p
(error 'missing-component
:requires name
))))))
408 (defun register-system (name system
)
409 (format *verbose-out
* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name
)
410 (setf (gethash (coerce-name name
) *defined-systems
*)
411 (cons (get-universal-time) system
)))
413 (defun system-registered-p (name)
414 (gethash (coerce-name name
) *defined-systems
*))
416 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
417 ;;; finding components
419 (defgeneric find-component
(module name
&optional version
)
420 (:documentation
"Finds the component with name NAME present in the
421 MODULE module; if MODULE is nil, then the component is assumed to be a
424 (defmethod find-component ((module module
) name
&optional version
)
425 (if (slot-boundp module
'components
)
426 (let ((m (find name
(module-components module
)
427 :test
#'equal
:key
#'component-name
)))
428 (if (and m
(version-satisfies m version
)) m
))))
431 ;;; a component with no parent is a system
432 (defmethod find-component ((module (eql nil
)) name
&optional version
)
433 (let ((m (find-system name nil
)))
434 (if (and m
(version-satisfies m version
)) m
)))
436 ;;; component subclasses
438 (defclass source-file
(component) ())
440 (defclass cl-source-file
(source-file) ())
441 (defclass c-source-file
(source-file) ())
442 (defclass java-source-file
(source-file) ())
443 (defclass static-file
(source-file) ())
444 (defclass doc-file
(static-file) ())
445 (defclass html-file
(doc-file) ())
447 (defgeneric source-file-type
(component system
))
448 (defmethod source-file-type ((c cl-source-file
) (s module
)) "lisp")
449 (defmethod source-file-type ((c c-source-file
) (s module
)) "c")
450 (defmethod source-file-type ((c java-source-file
) (s module
)) "java")
451 (defmethod source-file-type ((c html-file
) (s module
)) "html")
452 (defmethod source-file-type ((c static-file
) (s module
)) nil
)
454 (defmethod component-relative-pathname ((component source-file
))
455 (let ((relative-pathname (slot-value component
'relative-pathname
)))
456 (if relative-pathname
460 :type
(source-file-type component
(component-system component
))))
461 (let* ((*default-pathname-defaults
*
462 (component-parent-pathname component
))
465 :name
(component-name component
)
466 :type
(source-file-type component
467 (component-system component
)))))
470 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
473 ;;; one of these is instantiated whenever (operate ) is called
475 (defclass operation
()
476 ((forced :initform nil
:initarg
:force
:accessor operation-forced
)
477 (original-initargs :initform nil
:initarg
:original-initargs
478 :accessor operation-original-initargs
)
479 (visited-nodes :initform nil
:accessor operation-visited-nodes
)
480 (visiting-nodes :initform nil
:accessor operation-visiting-nodes
)
481 (parent :initform nil
:initarg
:parent
:accessor operation-parent
)))
483 (defmethod print-object ((o operation
) stream
)
484 (print-unreadable-object (o stream
:type t
:identity t
)
486 (prin1 (operation-original-initargs o
) stream
))))
488 (defmethod shared-initialize :after
((operation operation
) slot-names
491 (declare (ignore slot-names force
))
492 ;; empty method to disable initarg validity checking
495 (defgeneric perform
(operation component
))
496 (defgeneric operation-done-p
(operation component
))
497 (defgeneric explain
(operation component
))
498 (defgeneric output-files
(operation component
))
499 (defgeneric input-files
(operation component
))
501 (defun node-for (o c
)
502 (cons (class-name (class-of o
)) c
))
504 (defgeneric operation-ancestor
(operation)
506 "Recursively chase the operation's parent pointer until we get to
507 the head of the tree"))
509 (defmethod operation-ancestor ((operation operation
))
510 (aif (operation-parent operation
)
511 (operation-ancestor it
)
515 (defun make-sub-operation (c o dep-c dep-o
)
516 (let* ((args (copy-list (operation-original-initargs o
)))
517 (force-p (getf args
:force
)))
518 ;; note explicit comparison with T: any other non-NIL force value
519 ;; (e.g. :recursive) will pass through
520 (cond ((and (null (component-parent c
))
521 (null (component-parent dep-c
))
523 (when (eql force-p t
)
524 (setf (getf args
:force
) nil
))
525 (apply #'make-instance dep-o
527 :original-initargs args args
))
528 ((subtypep (type-of o
) dep-o
)
531 (apply #'make-instance dep-o
532 :parent o
:original-initargs args args
)))))
535 (defgeneric visit-component
(operation component data
))
537 (defmethod visit-component ((o operation
) (c component
) data
)
538 (unless (component-visited-p o c
)
539 (push (cons (node-for o c
) data
)
540 (operation-visited-nodes (operation-ancestor o
)))))
542 (defgeneric component-visited-p
(operation component
))
544 (defmethod component-visited-p ((o operation
) (c component
))
545 (assoc (node-for o c
)
546 (operation-visited-nodes (operation-ancestor o
))
549 (defgeneric (setf visiting-component
) (new-value operation component
))
551 (defmethod (setf visiting-component
) (new-value operation component
)
552 ;; MCL complains about unused lexical variables
553 (declare (ignorable new-value operation component
)))
555 (defmethod (setf visiting-component
) (new-value (o operation
) (c component
))
556 (let ((node (node-for o c
))
557 (a (operation-ancestor o
)))
559 (pushnew node
(operation-visiting-nodes a
) :test
'equal
)
560 (setf (operation-visiting-nodes a
)
561 (remove node
(operation-visiting-nodes a
) :test
'equal
)))))
563 (defgeneric component-visiting-p
(operation component
))
565 (defmethod component-visiting-p ((o operation
) (c component
))
566 (let ((node (cons o c
)))
567 (member node
(operation-visiting-nodes (operation-ancestor o
))
570 (defgeneric component-depends-on
(operation component
)
572 "Returns a list of dependencies needed by the component to perform
573 the operation. A dependency has one of the following forms:
575 (<operation> <component>*), where <operation> is a class
576 designator and each <component> is a component
577 designator, which means that the component depends on
578 <operation> having been performed on each <component>; or
580 (FEATURE <feature>), which means that the component depends
581 on <feature>'s presence in *FEATURES*.
583 Methods specialized on subclasses of existing component types
584 should usually append the results of CALL-NEXT-METHOD to the
587 (defmethod component-depends-on ((op-spec symbol
) (c component
))
588 (component-depends-on (make-instance op-spec
) c
))
590 (defmethod component-depends-on ((o operation
) (c component
))
591 (cdr (assoc (class-name (class-of o
))
592 (slot-value c
'in-order-to
))))
594 (defgeneric component-self-dependencies
(operation component
))
596 (defmethod component-self-dependencies ((o operation
) (c component
))
597 (let ((all-deps (component-depends-on o c
)))
598 (remove-if-not (lambda (x)
599 (member (component-name c
) (cdr x
) :test
#'string
=))
602 (defmethod input-files ((operation operation
) (c component
))
603 (let ((parent (component-parent c
))
604 (self-deps (component-self-dependencies operation c
)))
606 (mapcan (lambda (dep)
607 (destructuring-bind (op name
) dep
608 (output-files (make-instance op
)
609 (find-component parent name
))))
611 ;; no previous operations needed? I guess we work with the
612 ;; original source file, then
613 (list (component-pathname c
)))))
615 (defmethod input-files ((operation operation
) (c module
)) nil
)
617 (defmethod operation-done-p ((o operation
) (c component
))
618 (flet ((fwd-or-return-t (file)
619 ;; if FILE-WRITE-DATE returns NIL, it's possible that the
620 ;; user or some other agent has deleted an input file. If
621 ;; that's the case, well, that's not good, but as long as
622 ;; the operation is otherwise considered to be done we
623 ;; could continue and survive.
624 (let ((date (file-write-date file
)))
628 (warn "~@<Missing FILE-WRITE-DATE for ~S: treating ~
629 operation ~S on component ~S as done.~@:>"
631 (return-from operation-done-p t
))))))
632 (let ((out-files (output-files o c
))
633 (in-files (input-files o c
)))
634 (cond ((and (not in-files
) (not out-files
))
635 ;; arbitrary decision: an operation that uses nothing to
636 ;; produce nothing probably isn't doing much
641 (component-operation-times c
))))
645 (mapcar #'fwd-or-return-t in-files
))))))
649 (every #'probe-file out-files
)
650 (> (apply #'min
(mapcar #'file-write-date out-files
))
651 (apply #'max
(mapcar #'fwd-or-return-t in-files
)))))))))
653 ;;; So you look at this code and think "why isn't it a bunch of
654 ;;; methods". And the answer is, because standard method combination
655 ;;; runs :before methods most->least-specific, which is back to front
656 ;;; for our purposes. And CLISP doesn't have non-standard method
657 ;;; combinations, so let's keep it simple and aspire to portability
659 (defgeneric traverse
(operation component
))
660 (defmethod traverse ((operation operation
) (c component
))
662 (labels ((do-one-dep (required-op required-c required-v
)
663 (let* ((dep-c (or (find-component
665 ;; XXX tacky. really we should build the
666 ;; in-order-to slot with canonicalized
667 ;; names instead of coercing this late
668 (coerce-name required-c
) required-v
)
669 (error 'missing-dependency
672 :requires required-c
)))
673 (op (make-sub-operation c operation dep-c required-op
)))
674 (traverse op dep-c
)))
676 (cond ((eq op
'feature
)
677 (or (member (car dep
) *features
*)
678 (error 'missing-dependency
685 (assert (string-equal
686 (symbol-name (first d
))
689 (do-one-dep op
(second d
) (third d
))))
691 (appendf forced
(do-one-dep op d nil
)))))))))
692 (aif (component-visited-p operation c
)
693 (return-from traverse
694 (if (cdr it
) (list (cons 'pruned-op c
)) nil
)))
696 (if (component-visiting-p operation c
)
697 (error 'circular-dependency
:components
(list c
)))
698 (setf (visiting-component operation c
) t
)
699 (loop for
(required-op . deps
) in
(component-depends-on operation c
)
700 do
(do-dep required-op deps
))
703 (when (typep c
'module
)
704 (let ((at-least-one nil
)
707 (loop for kid in
(module-components c
)
709 (appendf forced
(traverse operation kid
))
710 (missing-dependency (condition)
711 (if (eq (module-if-component-dep-fails c
) :fail
)
713 (setf error condition
))
716 (setf at-least-one t
))))
717 (when (and (eq (module-if-component-dep-fails c
) :try-next
)
721 ;; now the thing itself
722 (when (or forced module-ops
723 (not (operation-done-p operation c
))
724 (let ((f (operation-forced (operation-ancestor operation
))))
725 (and f
(or (not (consp f
))
726 (member (component-name
727 (operation-ancestor operation
))
728 (mapcar #'coerce-name f
)
730 (let ((do-first (cdr (assoc (class-name (class-of operation
))
731 (slot-value c
'do-first
)))))
732 (loop for
(required-op . deps
) in do-first
733 do
(do-dep required-op deps
)))
734 (setf forced
(append (delete 'pruned-op forced
:key
#'car
)
735 (delete 'pruned-op module-ops
:key
#'car
)
736 (list (cons operation c
))))))
737 (setf (visiting-component operation c
) nil
)
738 (visit-component operation c
(and forced t
))
742 (defmethod perform ((operation operation
) (c source-file
))
744 "~@<required method PERFORM not implemented ~
745 for operation ~A, component ~A~@:>"
746 (class-of operation
) (class-of c
)))
748 (defmethod perform ((operation operation
) (c module
))
751 (defmethod explain ((operation operation
) (component component
))
752 (format *verbose-out
* "~&;;; ~A on ~A~%" operation component
))
756 (defclass compile-op
(operation)
757 ((proclamations :initarg
:proclamations
:accessor compile-op-proclamations
:initform nil
)
758 (on-warnings :initarg
:on-warnings
:accessor operation-on-warnings
759 :initform
*compile-file-warnings-behaviour
*)
760 (on-failure :initarg
:on-failure
:accessor operation-on-failure
761 :initform
*compile-file-failure-behaviour
*)))
763 (defmethod perform :before
((operation compile-op
) (c source-file
))
764 (map nil
#'ensure-directories-exist
(output-files operation c
)))
766 (defmethod perform :after
((operation operation
) (c component
))
767 (setf (gethash (type-of operation
) (component-operation-times c
))
768 (get-universal-time))
769 (load-preferences c operation
))
771 ;;; perform is required to check output-files to find out where to put
772 ;;; its answers, in case it has been overridden for site policy
773 (defmethod perform ((operation compile-op
) (c cl-source-file
))
774 #-
:broken-fasl-loader
775 (let ((source-file (component-pathname c
))
776 (output-file (car (output-files operation c
))))
777 (multiple-value-bind (output warnings-p failure-p
)
778 (compile-file source-file
:output-file output-file
)
780 (case (operation-on-warnings operation
)
782 "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
784 (:error
(error 'compile-warned
:component c
:operation operation
))
787 (case (operation-on-failure operation
)
789 "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
791 (:error
(error 'compile-failed
:component c
:operation operation
))
794 (error 'compile-error
:component c
:operation operation
)))))
796 (defmethod output-files ((operation compile-op
) (c cl-source-file
))
797 #-
:broken-fasl-loader
(list (compile-file-pathname (component-pathname c
)))
798 #+:broken-fasl-loader
(list (component-pathname c
)))
800 (defmethod perform ((operation compile-op
) (c static-file
))
803 (defmethod output-files ((operation compile-op
) (c static-file
))
806 (defmethod input-files ((op compile-op
) (c static-file
))
812 (defclass basic-load-op
(operation) ())
814 (defclass load-op
(basic-load-op) ())
816 (defmethod perform ((o load-op
) (c cl-source-file
))
817 (mapcar #'load
(input-files o c
)))
819 (defmethod perform ((operation load-op
) (c static-file
))
821 (defmethod operation-done-p ((operation load-op
) (c static-file
))
824 (defmethod output-files ((o operation
) (c component
))
827 (defmethod component-depends-on ((operation load-op
) (c component
))
828 (cons (list 'compile-op
(component-name c
))
833 (defclass load-source-op
(basic-load-op) ())
835 (defmethod perform ((o load-source-op
) (c cl-source-file
))
836 (let ((source (component-pathname c
)))
837 (setf (component-property c
'last-loaded-as-source
)
839 (get-universal-time)))))
841 (defmethod perform ((operation load-source-op
) (c static-file
))
844 (defmethod output-files ((operation load-source-op
) (c component
))
847 ;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right.
848 (defmethod component-depends-on ((o load-source-op
) (c component
))
849 (let ((what-would-load-op-do (cdr (assoc 'load-op
850 (slot-value c
'in-order-to
)))))
851 (mapcar (lambda (dep)
852 (if (eq (car dep
) 'load-op
)
853 (cons 'load-source-op
(cdr dep
))
855 what-would-load-op-do
)))
857 (defmethod operation-done-p ((o load-source-op
) (c source-file
))
858 (if (or (not (component-property c
'last-loaded-as-source
))
859 (> (file-write-date (component-pathname c
))
860 (component-property c
'last-loaded-as-source
)))
863 (defclass test-op
(operation) ())
865 (defmethod perform ((operation test-op
) (c component
))
868 (defgeneric load-preferences
(system operation
)
870 "Called to load system preferences after <perform operation
871 system>. Typical uses are to set parameters that don't exist until
872 after the system has been loaded."))
874 (defgeneric preference-file-for-system
/operation
(system operation
)
876 "Returns the pathname of the preference file for this system.
877 Called by 'load-preferences to determine what file to load."))
879 (defmethod load-preferences ((s t
) (operation t
))
883 (defmethod load-preferences ((s system
) (operation basic-load-op
))
884 (let* ((*package
* (find-package :common-lisp
))
885 (file (probe-file (preference-file-for-system/operation s operation
))))
888 (format *verbose-out
*
889 "~&~@<; ~@;loading preferences for ~A/~(~A~) from ~A~@:>~%"
891 (type-of operation
) file
))
894 (defmethod preference-file-for-system/operation
((system t
) (operation t
))
895 ;; cope with anything other than systems
896 (preference-file-for-system/operation
(find-system system t
) operation
))
898 (defmethod preference-file-for-system/operation
((s system
) (operation t
))
899 (let ((*default-pathname-defaults
*
900 (make-pathname :name nil
:type nil
901 :defaults
*default-pathname-defaults
*)))
903 (make-pathname :name
(component-name s
)
905 :directory
'(:relative
".asdf"))
906 (truename (user-homedir-pathname)))))
908 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
909 ;;; invoking operations
911 (defvar *operate-docstring
*
912 "Operate does three things:
914 1. It creates an instance of `operation-class` using any keyword parameters
916 2. It finds the asdf-system specified by `system` (possibly loading
918 3. It then calls `traverse` with the operation and system as arguments
920 The traverse operation is wrapped in `with-compilation-unit` and error
921 handling code. If a `version` argument is supplied, then operate also
922 ensures that the system found satisfies it using the `version-satisfies`
925 (defun operate (operation-class system
&rest args
&key
(verbose t
) version
927 (let* ((op (apply #'make-instance operation-class
928 :original-initargs args
930 (*verbose-out
* (if verbose
*standard-output
* (make-broadcast-stream)))
931 (system (if (typep system
'component
) system
(find-system system
))))
932 (unless (version-satisfies system version
)
933 (error 'missing-component
:requires system
:version version
))
934 (let ((steps (traverse op system
)))
935 (with-compilation-unit ()
936 (loop for
(op . component
) in steps do
939 (progn (perform op component
)
944 (format s
"~@<Retry performing ~S on ~S.~@:>"
949 (format s
"~@<Continue, treating ~S on ~S as ~
950 having been successful.~@:>"
952 (setf (gethash (type-of op
)
953 (component-operation-times component
))
954 (get-universal-time))
957 (setf (documentation 'operate
'function
)
960 (defun oos (operation-class system
&rest args
&key force
(verbose t
) version
)
961 (declare (ignore force verbose version
))
962 (apply #'operate operation-class system args
))
964 (setf (documentation 'oos
'function
)
966 "Short for _operate on system_ and an alias for the `operate` function. ~&~&~a"
967 *operate-docstring
*))
969 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
972 (defun remove-keyword (key arglist
)
973 (labels ((aux (key arglist
)
974 (cond ((null arglist
) nil
)
975 ((eq key
(car arglist
)) (cddr arglist
))
976 (t (cons (car arglist
) (cons (cadr arglist
)
978 key
(cddr arglist
))))))))
981 (defmacro defsystem
(name &body options
)
982 (destructuring-bind (&key
(pathname nil pathname-arg-p
) (class 'system
)
985 (let ((component-options (remove-keyword :class options
)))
987 ;; system must be registered before we parse the body, otherwise
988 ;; we recur when trying to find an existing system of the same name
989 ;; to reuse options (e.g. pathname) from
990 (let ((s (system-registered-p ',name
)))
991 (cond ((and s
(eq (type-of (cdr s
)) ',class
))
992 (setf (car s
) (get-universal-time)))
995 (sysdef-error "Cannot redefine the existing system ~A with a different class" s
)
997 (change-class (cdr s
) ',class
))
999 (register-system (quote ,name
)
1000 (make-instance ',class
:name
',name
)))))
1001 (parse-component-form nil
(apply
1003 :module
(coerce-name ',name
)
1005 ;; to avoid a note about unreachable code
1008 `(or (when *load-truename
*
1009 (pathname-sans-name+type
1012 *default-pathname-defaults
*))
1013 ',component-options
))))))
1016 (defun class-for-type (parent type
)
1017 (let* ((extra-symbols (list (find-symbol (symbol-name type
) *package
*)
1018 (find-symbol (symbol-name type
)
1020 (package-name :asdf
)))))
1021 (class (dolist (symbol (if (keywordp type
)
1023 (cons type extra-symbols
)))
1025 (find-class symbol nil
)
1026 (subtypep symbol
'component
))
1027 (return (find-class symbol
))))))
1029 (and (eq type
:file
)
1030 (or (module-default-component-class parent
)
1031 (find-class 'cl-source-file
)))
1032 (sysdef-error "~@<don't recognize component type ~A~@:>" type
))))
1034 (defun maybe-add-tree (tree op1 op2 c
)
1035 "Add the node C at /OP1/OP2 in TREE, unless it's there already.
1036 Returns the new tree (which probably shares structure with the old one)"
1037 (let ((first-op-tree (assoc op1 tree
)))
1040 (aif (assoc op2
(cdr first-op-tree
))
1041 (if (find c
(cdr it
))
1043 (setf (cdr it
) (cons c
(cdr it
))))
1044 (setf (cdr first-op-tree
)
1045 (acons op2
(list c
) (cdr first-op-tree
))))
1047 (acons op1
(list (list op2 c
)) tree
))))
1049 (defun union-of-dependencies (&rest deps
)
1050 (let ((new-tree nil
))
1052 (dolist (op-tree dep
)
1053 (dolist (op (cdr op-tree
))
1054 (dolist (c (cdr op
))
1056 (maybe-add-tree new-tree
(car op-tree
) (car op
) c
))))))
1060 (defun remove-keys (key-names args
)
1061 (loop for
( name val
) on args by
#'cddr
1062 unless
(member (symbol-name name
) key-names
1063 :key
#'symbol-name
:test
'equal
)
1064 append
(list name val
)))
1066 (defvar *serial-depends-on
*)
1068 (defun parse-component-form (parent options
)
1071 (type name
&rest rest
&key
1072 ;; the following list of keywords is reproduced below in the
1073 ;; remove-keys form. important to keep them in sync
1074 components pathname default-component-class
1075 perform explain output-files operation-done-p
1077 depends-on serial in-order-to
1079 &allow-other-keys
) options
1080 (declare (ignorable perform explain output-files operation-done-p
))
1081 (check-component-input type name weakly-depends-on depends-on components in-order-to
)
1084 (find-component parent name
)
1085 ;; ignore the same object when rereading the defsystem
1087 (typep (find-component parent name
)
1088 (class-for-type parent type
))))
1089 (error 'duplicate-names
:name name
))
1091 (let* ((other-args (remove-keys
1092 '(components pathname default-component-class
1093 perform explain output-files operation-done-p
1095 depends-on serial in-order-to
)
1098 (or (find-component parent name
)
1099 (make-instance (class-for-type parent type
)))))
1100 (when weakly-depends-on
1101 (setf depends-on
(append depends-on
(remove-if (complement #'find-system
) weakly-depends-on
))))
1102 (when (boundp '*serial-depends-on
*)
1104 (concatenate 'list
*serial-depends-on
* depends-on
)))
1105 (apply #'reinitialize-instance ret
1106 :name
(coerce-name name
)
1110 (when (typep ret
'module
)
1111 (setf (module-default-component-class ret
)
1112 (or default-component-class
1113 (and (typep parent
'module
)
1114 (module-default-component-class parent
))))
1115 (let ((*serial-depends-on
* nil
))
1116 (setf (module-components ret
)
1117 (loop for c-form in components
1118 for c
= (parse-component-form ret c-form
)
1121 do
(push (component-name c
) *serial-depends-on
*))))
1123 ;; check for duplicate names
1124 (let ((name-hash (make-hash-table :test
#'equal
)))
1125 (loop for c in
(module-components ret
)
1127 (if (gethash (component-name c
)
1129 (error 'duplicate-names
1130 :name
(component-name c
))
1131 (setf (gethash (component-name c
)
1135 (setf (slot-value ret
'in-order-to
)
1136 (union-of-dependencies
1138 `((compile-op (compile-op ,@depends-on
))
1139 (load-op (load-op ,@depends-on
))))
1140 (slot-value ret
'do-first
) `((compile-op (load-op ,@depends-on
))))
1142 (%remove-component-inline-methods ret rest
)
1146 (defun %remove-component-inline-methods
(ret rest
)
1147 (loop for name in
+asdf-methods
+
1149 ;; this is inefficient as most of the stored
1150 ;; methods will not be for this particular gf n
1151 ;; But this is hardly performance-critical
1153 (remove-method (symbol-function name
) m
))
1154 (component-inline-methods ret
)))
1155 ;; clear methods, then add the new ones
1156 (setf (component-inline-methods ret
) nil
)
1157 (loop for name in
+asdf-methods
+
1158 for v
= (getf rest
(intern (symbol-name name
) :keyword
))
1160 (destructuring-bind (op qual
(o c
) &body body
) v
1162 (eval `(defmethod ,name
,qual
((,o
,op
) (,c
(eql ,ret
)))
1164 (component-inline-methods ret
)))))
1166 (defun check-component-input (type name weakly-depends-on depends-on components in-order-to
)
1167 "A partial test of the values of a component."
1168 (when weakly-depends-on
(warn "We got one! XXXXX"))
1169 (unless (listp depends-on
)
1170 (sysdef-error-component ":depends-on must be a list."
1171 type name depends-on
))
1172 (unless (listp weakly-depends-on
)
1173 (sysdef-error-component ":weakly-depends-on must be a list."
1174 type name weakly-depends-on
))
1175 (unless (listp components
)
1176 (sysdef-error-component ":components must be NIL or a list of components."
1177 type name components
))
1178 (unless (and (listp in-order-to
) (listp (car in-order-to
)))
1179 (sysdef-error-component ":in-order-to must be NIL or a list of components."
1180 type name in-order-to
)))
1182 (defun sysdef-error-component (msg type name value
)
1183 (sysdef-error (concatenate 'string msg
1184 "~&The value specified for ~(~A~) ~A is ~W")
1187 (defun resolve-symlinks (path)
1188 #-allegro
(truename path
)
1189 #+allegro
(excl:pathname-resolve-symbolic-links path
)
1194 ;;; run-shell-command functions for other lisp implementations will be
1195 ;;; gratefully accepted, if they do the same thing. If the docstring
1196 ;;; is ambiguous, send a bug report
1198 (defun run-shell-command (control-string &rest args
)
1199 "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
1200 synchronously execute the result using a Bourne-compatible shell, with
1201 output to *VERBOSE-OUT*. Returns the shell's exit code."
1202 (let ((command (apply #'format nil control-string args
)))
1203 (format *verbose-out
* "; $ ~A~%" command
)
1205 (sb-ext:process-exit-code
1207 #+win32
"sh" #-win32
"/bin/sh"
1209 #+win32
#+win32
:search t
1210 :input nil
:output
*verbose-out
*))
1213 (ext:process-exit-code
1217 :input nil
:output
*verbose-out
*))
1220 (excl:run-shell-command command
:input nil
:output
*verbose-out
*)
1223 (system:call-system-showing-output
1225 :shell-type
"/bin/sh"
1226 :output-stream
*verbose-out
*)
1228 #+clisp
;XXX not exactly *verbose-out*, I know
1229 (ext:run-shell-command command
:output
:terminal
:wait t
)
1233 (ccl:external-process-status
1234 (ccl:run-program
"/bin/sh" (list "-c" command
)
1235 :input nil
:output
*verbose-out
*
1237 #+ecl
;; courtesy of Juan Jose Garcia Ripoll
1239 #-
(or openmcl clisp lispworks allegro scl cmu sbcl ecl
)
1240 (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
1244 (defgeneric hyperdocumentation
(package name doc-type
))
1245 (defmethod hyperdocumentation ((package symbol
) name doc-type
)
1246 (hyperdocumentation (find-package package
) name doc-type
))
1248 (defun hyperdoc (name doc-type
)
1249 (hyperdocumentation (symbol-package name
) name doc-type
))
1251 (defun system-source-file (system-name)
1252 (let ((system (asdf:find-system system-name
)))
1255 :name
(asdf:component-name system
)
1256 :defaults
(asdf:component-relative-pathname system
))))
1258 (defun system-source-directory (system-name)
1259 (make-pathname :name nil
1261 :defaults
(system-source-file system-name
)))
1263 (defun system-relative-pathname (system pathname
&key name type
)
1264 (let ((directory (pathname-directory pathname
)))
1265 (when (eq (car directory
) :absolute
)
1266 (setf (car directory
) :relative
))
1268 (make-pathname :name
(or name
(pathname-name pathname
))
1269 :type
(or type
(pathname-type pathname
))
1270 :directory directory
)
1271 (system-source-directory system
))))
1274 (pushnew :asdf
*features
*)
1277 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
1278 (when (sb-ext:posix-getenv
"SBCL_BUILDING_CONTRIB")
1279 (pushnew :sbcl-hooks-require
*features
*)))
1281 #+(and sbcl sbcl-hooks-require
)
1283 (defun module-provide-asdf (name)
1284 (handler-bind ((style-warning #'muffle-warning
))
1285 (let* ((*verbose-out
* (make-broadcast-stream))
1286 (system (asdf:find-system name nil
)))
1288 (asdf:operate
'asdf
:load-op name
)
1291 (defun contrib-sysdef-search (system)
1292 (let ((home (sb-ext:posix-getenv
"SBCL_HOME")))
1293 (when (and home
(not (string= home
"")))
1294 (let* ((name (coerce-name system
))
1295 (home (truename home
))
1296 (contrib (merge-pathnames
1297 (make-pathname :directory
`(:relative
,name
)
1303 (probe-file contrib
)))))
1306 '(let ((home (sb-ext:posix-getenv
"SBCL_HOME")))
1307 (when (and home
(not (string= home
"")))
1308 (merge-pathnames "site-systems/" (truename home
))))
1312 '(merge-pathnames ".sbcl/systems/"
1313 (user-homedir-pathname))
1316 (pushnew 'module-provide-asdf sb-ext
:*module-provider-functions
*)
1317 (pushnew 'contrib-sysdef-search
*system-definition-search-functions
*))