1 ;;; This is asdf: Another System Definition Facility. 1.117
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 loading - to be expunged
108 #:preference-file-for-system
/operation
114 (error "The author of this file habitually uses #+nil to comment out ~
115 forms. But don't worry, it was unlikely to work in the New ~
116 Implementation of Lisp anyway")
120 (defvar *asdf-revision
* (let* ((v "1.117")
121 (colon (or (position #\
: v
) -
1))
122 (dot (position #\. v
)))
124 (list (parse-integer v
:start
(1+ colon
)
126 (parse-integer v
:start
(1+ dot
)
129 (defvar *load-preference-files
* nil
130 "If true, then preference files will be loaded.
132 This variable will be removed August 2008.")
134 (defvar *compile-file-warnings-behaviour
* :warn
)
136 (defvar *compile-file-failure-behaviour
* #+sbcl
:error
#-sbcl
:warn
)
138 (defvar *verbose-out
* nil
)
140 (defparameter +asdf-methods
+
141 '(perform explain output-files operation-done-p
))
143 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
146 (defmacro aif
(test then
&optional else
)
147 `(let ((it ,test
)) (if it
,then
,else
)))
149 (defun pathname-sans-name+type
(pathname)
150 "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
151 and NIL NAME and TYPE components"
152 (make-pathname :name nil
:type nil
:defaults pathname
))
154 (define-modify-macro appendf
(&rest args
)
155 append
"Append onto list")
157 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
158 ;; classes, condiitons
160 (define-condition system-definition-error
(error) ()
161 ;; [this use of :report should be redundant, but unfortunately it's not.
162 ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
163 ;; over print-object; this is always conditions::%print-condition for
164 ;; condition objects, which in turn does inheritance of :report options at
165 ;; run-time. fortunately, inheritance means we only need this kludge here in
166 ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.]
167 #+cmu
(:report print-object
))
169 (define-condition formatted-system-definition-error
(system-definition-error)
170 ((format-control :initarg
:format-control
:reader format-control
)
171 (format-arguments :initarg
:format-arguments
:reader format-arguments
))
172 (:report
(lambda (c s
)
173 (apply #'format s
(format-control c
) (format-arguments c
)))))
175 (define-condition circular-dependency
(system-definition-error)
176 ((components :initarg
:components
:reader circular-dependency-components
)))
178 (define-condition duplicate-names
(system-definition-error)
179 ((name :initarg
:name
:reader duplicate-names-name
)))
181 (define-condition missing-component
(system-definition-error)
182 ((requires :initform
"(unnamed)" :reader missing-requires
:initarg
:requires
)
183 (version :initform nil
:reader missing-version
:initarg
:version
)
184 (parent :initform nil
:reader missing-parent
:initarg
:parent
)))
186 (define-condition missing-dependency
(missing-component)
187 ((required-by :initarg
:required-by
:reader missing-required-by
)))
189 (define-condition operation-error
(error)
190 ((component :reader error-component
:initarg
:component
)
191 (operation :reader error-operation
:initarg
:operation
))
192 (:report
(lambda (c s
)
193 (format s
"~@<erred while invoking ~A on ~A~@:>"
194 (error-operation c
) (error-component c
)))))
195 (define-condition compile-error
(operation-error) ())
196 (define-condition compile-failed
(compile-error) ())
197 (define-condition compile-warned
(compile-error) ())
199 (defclass component
()
200 ((name :accessor component-name
:initarg
:name
:documentation
201 "Component name: designator for a string composed of portable pathname characters")
202 (version :accessor component-version
:initarg
:version
)
203 (in-order-to :initform nil
:initarg
:in-order-to
)
205 (do-first :initform nil
:initarg
:do-first
)
206 ;; methods defined using the "inline" style inside a defsystem form:
207 ;; need to store them somewhere so we can delete them when the system
209 (inline-methods :accessor component-inline-methods
:initform nil
)
210 (parent :initarg
:parent
:initform nil
:reader component-parent
)
211 ;; no direct accessor for pathname, we do this as a method to allow
212 ;; it to default in funky ways if not supplied
213 (relative-pathname :initarg
:pathname
)
214 (operation-times :initform
(make-hash-table )
215 :accessor component-operation-times
)
216 ;; XXX we should provide some atomic interface for updating the
217 ;; component properties
218 (properties :accessor component-properties
:initarg
:properties
221 ;;;; methods: conditions
223 (defmethod print-object ((c missing-dependency
) s
)
224 (format s
"~@<~A, required by ~A~@:>"
225 (call-next-method c nil
) (missing-required-by c
)))
227 (defun sysdef-error (format &rest arguments
)
228 (error 'formatted-system-definition-error
:format-control format
:format-arguments arguments
))
230 ;;;; methods: components
232 (defmethod print-object ((c missing-component
) s
)
233 (format s
"~@<component ~S not found~
234 ~@[ or does not match version ~A~]~
238 (when (missing-parent c
)
239 (component-name (missing-parent c
)))))
241 (defgeneric component-system
(component)
242 (:documentation
"Find the top-level system containing COMPONENT"))
244 (defmethod component-system ((component component
))
245 (aif (component-parent component
)
246 (component-system it
)
249 (defmethod print-object ((c component
) stream
)
250 (print-unreadable-object (c stream
:type t
:identity t
)
252 (prin1 (component-name c
) stream
))))
254 (defclass module
(component)
255 ((components :initform nil
:accessor module-components
:initarg
:components
)
256 ;; what to do if we can't satisfy a dependency of one of this module's
257 ;; components. This allows a limited form of conditional processing
258 (if-component-dep-fails :initform
:fail
259 :accessor module-if-component-dep-fails
260 :initarg
:if-component-dep-fails
)
261 (default-component-class :accessor module-default-component-class
262 :initform
'cl-source-file
:initarg
:default-component-class
)))
264 (defgeneric component-pathname
(component)
265 (:documentation
"Extracts the pathname applicable for a particular component."))
267 (defun component-parent-pathname (component)
268 (aif (component-parent component
)
269 (component-pathname it
)
270 *default-pathname-defaults
*))
272 (defgeneric component-relative-pathname
(component)
273 (:documentation
"Extracts the relative pathname applicable for a particular component."))
275 (defmethod component-relative-pathname ((component module
))
276 (or (slot-value component
'relative-pathname
)
278 :directory
`(:relative
,(component-name component
))
279 :host
(pathname-host (component-parent-pathname component
)))))
281 (defmethod component-pathname ((component component
))
282 (let ((*default-pathname-defaults
* (component-parent-pathname component
)))
283 (merge-pathnames (component-relative-pathname component
))))
285 (defgeneric component-property
(component property
))
287 (defmethod component-property ((c component
) property
)
288 (cdr (assoc property
(slot-value c
'properties
) :test
#'equal
)))
290 (defgeneric (setf component-property
) (new-value component property
))
292 (defmethod (setf component-property
) (new-value (c component
) property
)
293 (let ((a (assoc property
(slot-value c
'properties
) :test
#'equal
)))
295 (setf (cdr a
) new-value
)
296 (setf (slot-value c
'properties
)
297 (acons property new-value
(slot-value c
'properties
))))))
299 (defclass system
(module)
300 ((description :accessor system-description
:initarg
:description
)
302 :accessor system-long-description
:initarg
:long-description
)
303 (author :accessor system-author
:initarg
:author
)
304 (maintainer :accessor system-maintainer
:initarg
:maintainer
)
305 (licence :accessor system-licence
:initarg
:licence
306 :accessor system-license
:initarg
:license
)))
308 ;;; version-satisfies
310 ;;; with apologies to christophe rhodes ...
311 (defun split (string &optional max
(ws '(#\Space
#\Tab
)))
312 (flet ((is-ws (char) (find char ws
)))
314 (let ((list nil
) (start 0) (words 0) end
)
316 (when (and max
(>= words
(1- max
)))
317 (return (cons (subseq string start
) list
)))
318 (setf end
(position-if #'is-ws string
:start start
))
319 (push (subseq string start end
) list
)
321 (unless end
(return list
))
322 (setf start
(1+ end
)))))))
324 (defgeneric version-satisfies
(component version
))
326 (defmethod version-satisfies ((c component
) version
)
327 (unless (and version
(slot-boundp c
'version
))
328 (return-from version-satisfies t
))
329 (let ((x (mapcar #'parse-integer
330 (split (component-version c
) nil
'(#\.
))))
331 (y (mapcar #'parse-integer
332 (split version nil
'(#\.
)))))
333 (labels ((bigger (x y
)
336 ((> (car x
) (car y
)) t
)
338 (bigger (cdr x
) (cdr y
))))))
339 (and (= (car x
) (car y
))
340 (or (not (cdr y
)) (bigger (cdr x
) (cdr y
)))))))
342 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
345 (defvar *defined-systems
* (make-hash-table :test
'equal
))
346 (defun coerce-name (name)
348 (component (component-name name
))
349 (symbol (string-downcase (symbol-name name
)))
351 (t (sysdef-error "~@<invalid component designator ~A~@:>" name
))))
353 ;;; for the sake of keeping things reasonably neat, we adopt a
354 ;;; convention that functions in this list are prefixed SYSDEF-
356 (defvar *system-definition-search-functions
*
357 '(sysdef-central-registry-search))
359 (defun system-definition-pathname (system)
360 (some (lambda (x) (funcall x system
))
361 *system-definition-search-functions
*))
363 (defvar *central-registry
*
364 '(*default-pathname-defaults
*
365 #+nil
"/home/dan/src/sourceforge/cclan/asdf/systems/"
366 #+nil
"telent:asdf;systems;"))
368 (defun sysdef-central-registry-search (system)
369 (let ((name (coerce-name system
)))
371 (dolist (dir *central-registry
*)
372 (let* ((defaults (eval dir
))
375 :defaults defaults
:version
:newest
376 :name name
:type
"asd" :case
:local
))))
377 (if (and file
(probe-file file
))
380 (defun make-temporary-package ()
381 (flet ((try (counter)
383 (make-package (format nil
"ASDF~D" counter
)
384 :use
'(:cl
:asdf
)))))
385 (do* ((counter 0 (+ counter
1))
386 (package (try counter
) (try counter
)))
389 (defun find-system (name &optional
(error-p t
))
390 (let* ((name (coerce-name name
))
391 (in-memory (gethash name
*defined-systems
*))
392 (on-disk (system-definition-pathname name
)))
395 (< (car in-memory
) (file-write-date on-disk
))))
396 (let ((package (make-temporary-package)))
398 (let ((*package
* package
))
401 "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
402 ;; FIXME: This wants to be (ENOUGH-NAMESTRING
403 ;; ON-DISK), but CMUCL barfs on that.
407 (delete-package package
))))
408 (let ((in-memory (gethash name
*defined-systems
*)))
410 (progn (if on-disk
(setf (car in-memory
) (file-write-date on-disk
)))
412 (if error-p
(error 'missing-component
:requires name
))))))
414 (defun register-system (name system
)
415 (format *verbose-out
* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name
)
416 (setf (gethash (coerce-name name
) *defined-systems
*)
417 (cons (get-universal-time) system
)))
419 (defun system-registered-p (name)
420 (gethash (coerce-name name
) *defined-systems
*))
422 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
423 ;;; finding components
425 (defgeneric find-component
(module name
&optional version
)
426 (:documentation
"Finds the component with name NAME present in the
427 MODULE module; if MODULE is nil, then the component is assumed to be a
430 (defmethod find-component ((module module
) name
&optional version
)
431 (if (slot-boundp module
'components
)
432 (let ((m (find name
(module-components module
)
433 :test
#'equal
:key
#'component-name
)))
434 (if (and m
(version-satisfies m version
)) m
))))
437 ;;; a component with no parent is a system
438 (defmethod find-component ((module (eql nil
)) name
&optional version
)
439 (let ((m (find-system name nil
)))
440 (if (and m
(version-satisfies m version
)) m
)))
442 ;;; component subclasses
444 (defclass source-file
(component) ())
446 (defclass cl-source-file
(source-file) ())
447 (defclass c-source-file
(source-file) ())
448 (defclass java-source-file
(source-file) ())
449 (defclass static-file
(source-file) ())
450 (defclass doc-file
(static-file) ())
451 (defclass html-file
(doc-file) ())
453 (defgeneric source-file-type
(component system
))
454 (defmethod source-file-type ((c cl-source-file
) (s module
)) "lisp")
455 (defmethod source-file-type ((c c-source-file
) (s module
)) "c")
456 (defmethod source-file-type ((c java-source-file
) (s module
)) "java")
457 (defmethod source-file-type ((c html-file
) (s module
)) "html")
458 (defmethod source-file-type ((c static-file
) (s module
)) nil
)
460 (defmethod component-relative-pathname ((component source-file
))
461 (let ((relative-pathname (slot-value component
'relative-pathname
)))
462 (if relative-pathname
466 :type
(source-file-type component
(component-system component
))))
467 (let* ((*default-pathname-defaults
*
468 (component-parent-pathname component
))
471 :name
(component-name component
)
472 :type
(source-file-type component
473 (component-system component
)))))
476 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
479 ;;; one of these is instantiated whenever (operate ) is called
481 (defclass operation
()
482 ((forced :initform nil
:initarg
:force
:accessor operation-forced
)
483 (original-initargs :initform nil
:initarg
:original-initargs
484 :accessor operation-original-initargs
)
485 (visited-nodes :initform nil
:accessor operation-visited-nodes
)
486 (visiting-nodes :initform nil
:accessor operation-visiting-nodes
)
487 (parent :initform nil
:initarg
:parent
:accessor operation-parent
)))
489 (defmethod print-object ((o operation
) stream
)
490 (print-unreadable-object (o stream
:type t
:identity t
)
492 (prin1 (operation-original-initargs o
) stream
))))
494 (defmethod shared-initialize :after
((operation operation
) slot-names
497 (declare (ignore slot-names force
))
498 ;; empty method to disable initarg validity checking
501 (defgeneric perform
(operation component
))
502 (defgeneric operation-done-p
(operation component
))
503 (defgeneric explain
(operation component
))
504 (defgeneric output-files
(operation component
))
505 (defgeneric input-files
(operation component
))
507 (defun node-for (o c
)
508 (cons (class-name (class-of o
)) c
))
510 (defgeneric operation-ancestor
(operation)
512 "Recursively chase the operation's parent pointer until we get to
513 the head of the tree"))
515 (defmethod operation-ancestor ((operation operation
))
516 (aif (operation-parent operation
)
517 (operation-ancestor it
)
521 (defun make-sub-operation (c o dep-c dep-o
)
522 (let* ((args (copy-list (operation-original-initargs o
)))
523 (force-p (getf args
:force
)))
524 ;; note explicit comparison with T: any other non-NIL force value
525 ;; (e.g. :recursive) will pass through
526 (cond ((and (null (component-parent c
))
527 (null (component-parent dep-c
))
529 (when (eql force-p t
)
530 (setf (getf args
:force
) nil
))
531 (apply #'make-instance dep-o
533 :original-initargs args args
))
534 ((subtypep (type-of o
) dep-o
)
537 (apply #'make-instance dep-o
538 :parent o
:original-initargs args args
)))))
541 (defgeneric visit-component
(operation component data
))
543 (defmethod visit-component ((o operation
) (c component
) data
)
544 (unless (component-visited-p o c
)
545 (push (cons (node-for o c
) data
)
546 (operation-visited-nodes (operation-ancestor o
)))))
548 (defgeneric component-visited-p
(operation component
))
550 (defmethod component-visited-p ((o operation
) (c component
))
551 (assoc (node-for o c
)
552 (operation-visited-nodes (operation-ancestor o
))
555 (defgeneric (setf visiting-component
) (new-value operation component
))
557 (defmethod (setf visiting-component
) (new-value operation component
)
558 ;; MCL complains about unused lexical variables
559 (declare (ignorable new-value operation component
)))
561 (defmethod (setf visiting-component
) (new-value (o operation
) (c component
))
562 (let ((node (node-for o c
))
563 (a (operation-ancestor o
)))
565 (pushnew node
(operation-visiting-nodes a
) :test
'equal
)
566 (setf (operation-visiting-nodes a
)
567 (remove node
(operation-visiting-nodes a
) :test
'equal
)))))
569 (defgeneric component-visiting-p
(operation component
))
571 (defmethod component-visiting-p ((o operation
) (c component
))
572 (let ((node (cons o c
)))
573 (member node
(operation-visiting-nodes (operation-ancestor o
))
576 (defgeneric component-depends-on
(operation component
)
578 "Returns a list of dependencies needed by the component to perform
579 the operation. A dependency has one of the following forms:
581 (<operation> <component>*), where <operation> is a class
582 designator and each <component> is a component
583 designator, which means that the component depends on
584 <operation> having been performed on each <component>; or
586 (FEATURE <feature>), which means that the component depends
587 on <feature>'s presence in *FEATURES*.
589 Methods specialized on subclasses of existing component types
590 should usually append the results of CALL-NEXT-METHOD to the
593 (defmethod component-depends-on ((op-spec symbol
) (c component
))
594 (component-depends-on (make-instance op-spec
) c
))
596 (defmethod component-depends-on ((o operation
) (c component
))
597 (cdr (assoc (class-name (class-of o
))
598 (slot-value c
'in-order-to
))))
600 (defgeneric component-self-dependencies
(operation component
))
602 (defmethod component-self-dependencies ((o operation
) (c component
))
603 (let ((all-deps (component-depends-on o c
)))
604 (remove-if-not (lambda (x)
605 (member (component-name c
) (cdr x
) :test
#'string
=))
608 (defmethod input-files ((operation operation
) (c component
))
609 (let ((parent (component-parent c
))
610 (self-deps (component-self-dependencies operation c
)))
612 (mapcan (lambda (dep)
613 (destructuring-bind (op name
) dep
614 (output-files (make-instance op
)
615 (find-component parent name
))))
617 ;; no previous operations needed? I guess we work with the
618 ;; original source file, then
619 (list (component-pathname c
)))))
621 (defmethod input-files ((operation operation
) (c module
)) nil
)
623 (defmethod operation-done-p ((o operation
) (c component
))
624 (flet ((fwd-or-return-t (file)
625 ;; if FILE-WRITE-DATE returns NIL, it's possible that the
626 ;; user or some other agent has deleted an input file. If
627 ;; that's the case, well, that's not good, but as long as
628 ;; the operation is otherwise considered to be done we
629 ;; could continue and survive.
630 (let ((date (file-write-date file
)))
634 (warn "~@<Missing FILE-WRITE-DATE for ~S: treating ~
635 operation ~S on component ~S as done.~@:>"
637 (return-from operation-done-p t
))))))
638 (let ((out-files (output-files o c
))
639 (in-files (input-files o c
)))
640 (cond ((and (not in-files
) (not out-files
))
641 ;; arbitrary decision: an operation that uses nothing to
642 ;; produce nothing probably isn't doing much
647 (component-operation-times c
))))
651 (mapcar #'fwd-or-return-t in-files
))))))
655 (every #'probe-file out-files
)
656 (> (apply #'min
(mapcar #'file-write-date out-files
))
657 (apply #'max
(mapcar #'fwd-or-return-t in-files
)))))))))
659 ;;; So you look at this code and think "why isn't it a bunch of
660 ;;; methods". And the answer is, because standard method combination
661 ;;; runs :before methods most->least-specific, which is back to front
662 ;;; for our purposes. And CLISP doesn't have non-standard method
663 ;;; combinations, so let's keep it simple and aspire to portability
665 (defgeneric traverse
(operation component
))
666 (defmethod traverse ((operation operation
) (c component
))
668 (labels ((do-one-dep (required-op required-c required-v
)
669 (let* ((dep-c (or (find-component
671 ;; XXX tacky. really we should build the
672 ;; in-order-to slot with canonicalized
673 ;; names instead of coercing this late
674 (coerce-name required-c
) required-v
)
675 (error 'missing-dependency
678 :requires required-c
)))
679 (op (make-sub-operation c operation dep-c required-op
)))
680 (traverse op dep-c
)))
682 (cond ((eq op
'feature
)
683 (or (member (car dep
) *features
*)
684 (error 'missing-dependency
691 (assert (string-equal
692 (symbol-name (first d
))
695 (do-one-dep op
(second d
) (third d
))))
697 (appendf forced
(do-one-dep op d nil
)))))))))
698 (aif (component-visited-p operation c
)
699 (return-from traverse
700 (if (cdr it
) (list (cons 'pruned-op c
)) nil
)))
702 (if (component-visiting-p operation c
)
703 (error 'circular-dependency
:components
(list c
)))
704 (setf (visiting-component operation c
) t
)
705 (loop for
(required-op . deps
) in
(component-depends-on operation c
)
706 do
(do-dep required-op deps
))
709 (when (typep c
'module
)
710 (let ((at-least-one nil
)
713 (loop for kid in
(module-components c
)
715 (appendf forced
(traverse operation kid
))
716 (missing-dependency (condition)
717 (if (eq (module-if-component-dep-fails c
) :fail
)
719 (setf error condition
))
722 (setf at-least-one t
))))
723 (when (and (eq (module-if-component-dep-fails c
) :try-next
)
727 ;; now the thing itself
728 (when (or forced module-ops
729 (not (operation-done-p operation c
))
730 (let ((f (operation-forced (operation-ancestor operation
))))
731 (and f
(or (not (consp f
))
732 (member (component-name
733 (operation-ancestor operation
))
734 (mapcar #'coerce-name f
)
736 (let ((do-first (cdr (assoc (class-name (class-of operation
))
737 (slot-value c
'do-first
)))))
738 (loop for
(required-op . deps
) in do-first
739 do
(do-dep required-op deps
)))
740 (setf forced
(append (delete 'pruned-op forced
:key
#'car
)
741 (delete 'pruned-op module-ops
:key
#'car
)
742 (list (cons operation c
))))))
743 (setf (visiting-component operation c
) nil
)
744 (visit-component operation c
(and forced t
))
748 (defmethod perform ((operation operation
) (c source-file
))
750 "~@<required method PERFORM not implemented ~
751 for operation ~A, component ~A~@:>"
752 (class-of operation
) (class-of c
)))
754 (defmethod perform ((operation operation
) (c module
))
757 (defmethod explain ((operation operation
) (component component
))
758 (format *verbose-out
* "~&;;; ~A on ~A~%" operation component
))
762 (defclass compile-op
(operation)
763 ((proclamations :initarg
:proclamations
:accessor compile-op-proclamations
:initform nil
)
764 (on-warnings :initarg
:on-warnings
:accessor operation-on-warnings
765 :initform
*compile-file-warnings-behaviour
*)
766 (on-failure :initarg
:on-failure
:accessor operation-on-failure
767 :initform
*compile-file-failure-behaviour
*)))
769 (defmethod perform :before
((operation compile-op
) (c source-file
))
770 (map nil
#'ensure-directories-exist
(output-files operation c
)))
772 (defmethod perform :after
((operation operation
) (c component
))
773 (setf (gethash (type-of operation
) (component-operation-times c
))
774 (get-universal-time))
775 (when *load-preference-files
*
776 (load-preferences c operation
)))
778 ;;; perform is required to check output-files to find out where to put
779 ;;; its answers, in case it has been overridden for site policy
780 (defmethod perform ((operation compile-op
) (c cl-source-file
))
781 #-
:broken-fasl-loader
782 (let ((source-file (component-pathname c
))
783 (output-file (car (output-files operation c
))))
784 (multiple-value-bind (output warnings-p failure-p
)
785 (compile-file source-file
:output-file output-file
)
787 (case (operation-on-warnings operation
)
789 "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
791 (:error
(error 'compile-warned
:component c
:operation operation
))
794 (case (operation-on-failure operation
)
796 "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
798 (:error
(error 'compile-failed
:component c
:operation operation
))
801 (error 'compile-error
:component c
:operation operation
)))))
803 (defmethod output-files ((operation compile-op
) (c cl-source-file
))
804 #-
:broken-fasl-loader
(list (compile-file-pathname (component-pathname c
)))
805 #+:broken-fasl-loader
(list (component-pathname c
)))
807 (defmethod perform ((operation compile-op
) (c static-file
))
810 (defmethod output-files ((operation compile-op
) (c static-file
))
813 (defmethod input-files ((op compile-op
) (c static-file
))
819 (defclass basic-load-op
(operation) ())
821 (defclass load-op
(basic-load-op) ())
823 (defmethod perform ((o load-op
) (c cl-source-file
))
824 (mapcar #'load
(input-files o c
)))
826 (defmethod perform :around
((o load-op
) (c cl-source-file
))
827 (let ((state :initial
))
828 (loop until
(or (eq state
:success
)
829 (eq state
:failure
)) do
832 (setf state
:failure
)
834 (setf state
:success
))
836 (setf state
:recompiled
)
837 (perform (make-instance 'asdf
:compile-op
) c
))
840 (:try-recompiling
"Recompile ~a and try loading it again"
842 (setf state
:failed-load
)
844 (setf state
:success
)))))))
846 (defmethod perform :around
((o compile-op
) (c cl-source-file
))
847 (let ((state :initial
))
848 (loop until
(or (eq state
:success
)
849 (eq state
:failure
)) do
852 (setf state
:failure
)
854 (setf state
:success
))
856 (setf state
:recompiled
)
857 (perform (make-instance 'asdf
:compile-op
) c
))
860 (:try-recompiling
"Try recompiling ~a"
862 (setf state
:failed-compile
)
864 (setf state
:success
)))))))
866 (defmethod perform ((operation load-op
) (c static-file
))
869 (defmethod operation-done-p ((operation load-op
) (c static-file
))
872 (defmethod output-files ((o operation
) (c component
))
875 (defmethod component-depends-on ((operation load-op
) (c component
))
876 (cons (list 'compile-op
(component-name c
))
881 (defclass load-source-op
(basic-load-op) ())
883 (defmethod perform ((o load-source-op
) (c cl-source-file
))
884 (let ((source (component-pathname c
)))
885 (setf (component-property c
'last-loaded-as-source
)
887 (get-universal-time)))))
889 (defmethod perform ((operation load-source-op
) (c static-file
))
892 (defmethod output-files ((operation load-source-op
) (c component
))
895 ;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right.
896 (defmethod component-depends-on ((o load-source-op
) (c component
))
897 (let ((what-would-load-op-do (cdr (assoc 'load-op
898 (slot-value c
'in-order-to
)))))
899 (mapcar (lambda (dep)
900 (if (eq (car dep
) 'load-op
)
901 (cons 'load-source-op
(cdr dep
))
903 what-would-load-op-do
)))
905 (defmethod operation-done-p ((o load-source-op
) (c source-file
))
906 (if (or (not (component-property c
'last-loaded-as-source
))
907 (> (file-write-date (component-pathname c
))
908 (component-property c
'last-loaded-as-source
)))
911 (defclass test-op
(operation) ())
913 (defmethod perform ((operation test-op
) (c component
))
916 (defgeneric load-preferences
(system operation
)
918 "Deprecated - will be removed August 2008
920 Called to load system preferences after <perform operation
921 system>. Typical uses are to set parameters that don't exist until
922 after the system has been loaded."))
924 (defgeneric preference-file-for-system
/operation
(system operation
)
926 "Deprecated - will be removed August 2008
928 Returns the pathname of the preference file for this system.
929 Called by 'load-preferences to determine what file to load."))
931 (defmethod load-preferences ((s t
) (operation t
))
935 (defmethod load-preferences ((s system
) (operation basic-load-op
))
936 (let* ((*package
* (find-package :common-lisp
))
937 (file (probe-file (preference-file-for-system/operation s operation
))))
940 (format *verbose-out
*
941 "~&~@<; ~@;loading preferences for ~A/~(~A~) from ~A~@:>~%"
943 (type-of operation
) file
))
946 (defmethod preference-file-for-system/operation
((system t
) (operation t
))
947 ;; cope with anything other than systems
948 (preference-file-for-system/operation
(find-system system t
) operation
))
950 (defmethod preference-file-for-system/operation
((s system
) (operation t
))
951 (let ((*default-pathname-defaults
*
952 (make-pathname :name nil
:type nil
953 :defaults
*default-pathname-defaults
*)))
955 (make-pathname :name
(component-name s
)
957 :directory
'(:relative
".asdf"))
958 (truename (user-homedir-pathname)))))
960 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
961 ;;; invoking operations
963 (defvar *operate-docstring
*
964 "Operate does three things:
966 1. It creates an instance of `operation-class` using any keyword parameters
968 2. It finds the asdf-system specified by `system` (possibly loading
970 3. It then calls `traverse` with the operation and system as arguments
972 The traverse operation is wrapped in `with-compilation-unit` and error
973 handling code. If a `version` argument is supplied, then operate also
974 ensures that the system found satisfies it using the `version-satisfies`
977 (defun operate (operation-class system
&rest args
&key
(verbose t
) version
979 (let* ((op (apply #'make-instance operation-class
980 :original-initargs args
982 (*verbose-out
* (if verbose
*standard-output
* (make-broadcast-stream)))
983 (system (if (typep system
'component
) system
(find-system system
))))
984 (unless (version-satisfies system version
)
985 (error 'missing-component
:requires system
:version version
))
986 (let ((steps (traverse op system
)))
987 (with-compilation-unit ()
988 (loop for
(op . component
) in steps do
991 (progn (perform op component
)
996 (format s
"~@<Retry performing ~S on ~S.~@:>"
1001 (format s
"~@<Continue, treating ~S on ~S as ~
1002 having been successful.~@:>"
1004 (setf (gethash (type-of op
)
1005 (component-operation-times component
))
1006 (get-universal-time))
1009 (setf (documentation 'operate
'function
)
1010 *operate-docstring
*)
1012 (defun oos (operation-class system
&rest args
&key force
(verbose t
) version
)
1013 (declare (ignore force verbose version
))
1014 (apply #'operate operation-class system args
))
1016 (setf (documentation 'oos
'function
)
1018 "Short for _operate on system_ and an alias for the `operate` function. ~&~&~a"
1019 *operate-docstring
*))
1021 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1024 (defun remove-keyword (key arglist
)
1025 (labels ((aux (key arglist
)
1026 (cond ((null arglist
) nil
)
1027 ((eq key
(car arglist
)) (cddr arglist
))
1028 (t (cons (car arglist
) (cons (cadr arglist
)
1030 key
(cddr arglist
))))))))
1033 (defmacro defsystem
(name &body options
)
1034 (destructuring-bind (&key
(pathname nil pathname-arg-p
) (class 'system
)
1037 (let ((component-options (remove-keyword :class options
)))
1039 ;; system must be registered before we parse the body, otherwise
1040 ;; we recur when trying to find an existing system of the same name
1041 ;; to reuse options (e.g. pathname) from
1042 (let ((s (system-registered-p ',name
)))
1043 (cond ((and s
(eq (type-of (cdr s
)) ',class
))
1044 (setf (car s
) (get-universal-time)))
1047 (sysdef-error "Cannot redefine the existing system ~A with a different class" s
)
1049 (change-class (cdr s
) ',class
))
1051 (register-system (quote ,name
)
1052 (make-instance ',class
:name
',name
)))))
1053 (parse-component-form nil
(apply
1055 :module
(coerce-name ',name
)
1057 ;; to avoid a note about unreachable code
1060 `(or (when *load-truename
*
1061 (pathname-sans-name+type
1064 *default-pathname-defaults
*))
1065 ',component-options
))))))
1068 (defun class-for-type (parent type
)
1069 (let* ((extra-symbols (list (find-symbol (symbol-name type
) *package
*)
1070 (find-symbol (symbol-name type
)
1072 (package-name :asdf
)))))
1073 (class (dolist (symbol (if (keywordp type
)
1075 (cons type extra-symbols
)))
1077 (find-class symbol nil
)
1078 (subtypep symbol
'component
))
1079 (return (find-class symbol
))))))
1081 (and (eq type
:file
)
1082 (or (module-default-component-class parent
)
1083 (find-class 'cl-source-file
)))
1084 (sysdef-error "~@<don't recognize component type ~A~@:>" type
))))
1086 (defun maybe-add-tree (tree op1 op2 c
)
1087 "Add the node C at /OP1/OP2 in TREE, unless it's there already.
1088 Returns the new tree (which probably shares structure with the old one)"
1089 (let ((first-op-tree (assoc op1 tree
)))
1092 (aif (assoc op2
(cdr first-op-tree
))
1093 (if (find c
(cdr it
))
1095 (setf (cdr it
) (cons c
(cdr it
))))
1096 (setf (cdr first-op-tree
)
1097 (acons op2
(list c
) (cdr first-op-tree
))))
1099 (acons op1
(list (list op2 c
)) tree
))))
1101 (defun union-of-dependencies (&rest deps
)
1102 (let ((new-tree nil
))
1104 (dolist (op-tree dep
)
1105 (dolist (op (cdr op-tree
))
1106 (dolist (c (cdr op
))
1108 (maybe-add-tree new-tree
(car op-tree
) (car op
) c
))))))
1112 (defun remove-keys (key-names args
)
1113 (loop for
( name val
) on args by
#'cddr
1114 unless
(member (symbol-name name
) key-names
1115 :key
#'symbol-name
:test
'equal
)
1116 append
(list name val
)))
1118 (defvar *serial-depends-on
*)
1120 (defun parse-component-form (parent options
)
1123 (type name
&rest rest
&key
1124 ;; the following list of keywords is reproduced below in the
1125 ;; remove-keys form. important to keep them in sync
1126 components pathname default-component-class
1127 perform explain output-files operation-done-p
1129 depends-on serial in-order-to
1131 &allow-other-keys
) options
1132 (declare (ignorable perform explain output-files operation-done-p
))
1133 (check-component-input type name weakly-depends-on depends-on components in-order-to
)
1136 (find-component parent name
)
1137 ;; ignore the same object when rereading the defsystem
1139 (typep (find-component parent name
)
1140 (class-for-type parent type
))))
1141 (error 'duplicate-names
:name name
))
1143 (let* ((other-args (remove-keys
1144 '(components pathname default-component-class
1145 perform explain output-files operation-done-p
1147 depends-on serial in-order-to
)
1150 (or (find-component parent name
)
1151 (make-instance (class-for-type parent type
)))))
1152 (when weakly-depends-on
1153 (setf depends-on
(append depends-on
(remove-if (complement #'find-system
) weakly-depends-on
))))
1154 (when (boundp '*serial-depends-on
*)
1156 (concatenate 'list
*serial-depends-on
* depends-on
)))
1157 (apply #'reinitialize-instance ret
1158 :name
(coerce-name name
)
1162 (when (typep ret
'module
)
1163 (setf (module-default-component-class ret
)
1164 (or default-component-class
1165 (and (typep parent
'module
)
1166 (module-default-component-class parent
))))
1167 (let ((*serial-depends-on
* nil
))
1168 (setf (module-components ret
)
1169 (loop for c-form in components
1170 for c
= (parse-component-form ret c-form
)
1173 do
(push (component-name c
) *serial-depends-on
*))))
1175 ;; check for duplicate names
1176 (let ((name-hash (make-hash-table :test
#'equal
)))
1177 (loop for c in
(module-components ret
)
1179 (if (gethash (component-name c
)
1181 (error 'duplicate-names
1182 :name
(component-name c
))
1183 (setf (gethash (component-name c
)
1187 (setf (slot-value ret
'in-order-to
)
1188 (union-of-dependencies
1190 `((compile-op (compile-op ,@depends-on
))
1191 (load-op (load-op ,@depends-on
))))
1192 (slot-value ret
'do-first
) `((compile-op (load-op ,@depends-on
))))
1194 (%remove-component-inline-methods ret rest
)
1198 (defun %remove-component-inline-methods
(ret rest
)
1199 (loop for name in
+asdf-methods
+
1201 ;; this is inefficient as most of the stored
1202 ;; methods will not be for this particular gf n
1203 ;; But this is hardly performance-critical
1205 (remove-method (symbol-function name
) m
))
1206 (component-inline-methods ret
)))
1207 ;; clear methods, then add the new ones
1208 (setf (component-inline-methods ret
) nil
)
1209 (loop for name in
+asdf-methods
+
1210 for v
= (getf rest
(intern (symbol-name name
) :keyword
))
1212 (destructuring-bind (op qual
(o c
) &body body
) v
1214 (eval `(defmethod ,name
,qual
((,o
,op
) (,c
(eql ,ret
)))
1216 (component-inline-methods ret
)))))
1218 (defun check-component-input (type name weakly-depends-on depends-on components in-order-to
)
1219 "A partial test of the values of a component."
1220 (when weakly-depends-on
(warn "We got one! XXXXX"))
1221 (unless (listp depends-on
)
1222 (sysdef-error-component ":depends-on must be a list."
1223 type name depends-on
))
1224 (unless (listp weakly-depends-on
)
1225 (sysdef-error-component ":weakly-depends-on must be a list."
1226 type name weakly-depends-on
))
1227 (unless (listp components
)
1228 (sysdef-error-component ":components must be NIL or a list of components."
1229 type name components
))
1230 (unless (and (listp in-order-to
) (listp (car in-order-to
)))
1231 (sysdef-error-component ":in-order-to must be NIL or a list of components."
1232 type name in-order-to
)))
1234 (defun sysdef-error-component (msg type name value
)
1235 (sysdef-error (concatenate 'string msg
1236 "~&The value specified for ~(~A~) ~A is ~W")
1239 (defun resolve-symlinks (path)
1240 #-allegro
(truename path
)
1241 #+allegro
(excl:pathname-resolve-symbolic-links path
)
1246 ;;; run-shell-command functions for other lisp implementations will be
1247 ;;; gratefully accepted, if they do the same thing. If the docstring
1248 ;;; is ambiguous, send a bug report
1250 (defun run-shell-command (control-string &rest args
)
1251 "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
1252 synchronously execute the result using a Bourne-compatible shell, with
1253 output to *VERBOSE-OUT*. Returns the shell's exit code."
1254 (let ((command (apply #'format nil control-string args
)))
1255 (format *verbose-out
* "; $ ~A~%" command
)
1257 (sb-ext:process-exit-code
1259 #+win32
"sh" #-win32
"/bin/sh"
1261 #+win32
#+win32
:search t
1262 :input nil
:output
*verbose-out
*))
1265 (ext:process-exit-code
1269 :input nil
:output
*verbose-out
*))
1272 (excl:run-shell-command command
:input nil
:output
*verbose-out
*)
1275 (system:call-system-showing-output
1277 :shell-type
"/bin/sh"
1278 :output-stream
*verbose-out
*)
1280 #+clisp
;XXX not exactly *verbose-out*, I know
1281 (ext:run-shell-command command
:output
:terminal
:wait t
)
1285 (ccl:external-process-status
1286 (ccl:run-program
"/bin/sh" (list "-c" command
)
1287 :input nil
:output
*verbose-out
*
1289 #+ecl
;; courtesy of Juan Jose Garcia Ripoll
1291 #-
(or openmcl clisp lispworks allegro scl cmu sbcl ecl
)
1292 (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
1296 (defgeneric hyperdocumentation
(package name doc-type
))
1297 (defmethod hyperdocumentation ((package symbol
) name doc-type
)
1298 (hyperdocumentation (find-package package
) name doc-type
))
1300 (defun hyperdoc (name doc-type
)
1301 (hyperdocumentation (symbol-package name
) name doc-type
))
1303 (defun system-source-file (system-name)
1304 (let ((system (asdf:find-system system-name
)))
1307 :name
(asdf:component-name system
)
1308 :defaults
(asdf:component-relative-pathname system
))))
1310 (defun system-source-directory (system-name)
1311 (make-pathname :name nil
1313 :defaults
(system-source-file system-name
)))
1315 (defun system-relative-pathname (system pathname
&key name type
)
1316 (let ((directory (pathname-directory pathname
)))
1317 (when (eq (car directory
) :absolute
)
1318 (setf (car directory
) :relative
))
1320 (make-pathname :name
(or name
(pathname-name pathname
))
1321 :type
(or type
(pathname-type pathname
))
1322 :directory directory
)
1323 (system-source-directory system
))))
1326 (pushnew :asdf
*features
*)
1329 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
1330 (when (sb-ext:posix-getenv
"SBCL_BUILDING_CONTRIB")
1331 (pushnew :sbcl-hooks-require
*features
*)))
1333 #+(and sbcl sbcl-hooks-require
)
1335 (defun module-provide-asdf (name)
1336 (handler-bind ((style-warning #'muffle-warning
))
1337 (let* ((*verbose-out
* (make-broadcast-stream))
1338 (system (asdf:find-system name nil
)))
1340 (asdf:operate
'asdf
:load-op name
)
1343 (defun contrib-sysdef-search (system)
1344 (let ((home (sb-ext:posix-getenv
"SBCL_HOME")))
1345 (when (and home
(not (string= home
"")))
1346 (let* ((name (coerce-name system
))
1347 (home (truename home
))
1348 (contrib (merge-pathnames
1349 (make-pathname :directory
`(:relative
,name
)
1355 (probe-file contrib
)))))
1358 '(let ((home (sb-ext:posix-getenv
"SBCL_HOME")))
1359 (when (and home
(not (string= home
"")))
1360 (merge-pathnames "site-systems/" (truename home
))))
1364 '(merge-pathnames ".sbcl/systems/"
1365 (user-homedir-pathname))
1368 (pushnew 'module-provide-asdf sb-ext
:*module-provider-functions
*)
1369 (pushnew 'contrib-sysdef-search
*system-definition-search-functions
*))