1 ;;; This is asdf: Another System Definition Facility. 1.130
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-2008 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
44 #:compile-op
#:load-op
#:load-source-op
46 #:operation
; operations
47 #:feature
; sort-of operation
48 #:version
; metaphorically sort-of an operation
50 #:input-files
#:output-files
#:perform
; operation methods
51 #:operation-done-p
#:explain
53 #:component
#:source-file
54 #:c-source-file
#:cl-source-file
#:java-source-file
64 #:module-components
; component accessors
66 #:component-relative-pathname
73 #:component-depends-on
76 #:system-long-description
82 #:system-relative-pathname
84 #:operation-on-warnings
85 #:operation-on-failure
87 ;#:*component-parent-pathname*
88 #:*system-definition-search-functions
*
89 #:*central-registry
* ; variables
90 #:*compile-file-warnings-behaviour
*
91 #:*compile-file-failure-behaviour
*
94 #:operation-error
#:compile-failed
#:compile-warned
#:compile-error
95 #:error-component
#:error-operation
96 #:system-definition-error
98 #:missing-component-of-version
100 #:missing-dependency-of-version
101 #:circular-dependency
; errors
108 #:standard-asdf-method-combination
109 #:around
; protocol assistants
115 (error "The author of this file habitually uses #+nil to comment out ~
116 forms. But don't worry, it was unlikely to work in the New ~
117 Implementation of Lisp anyway")
121 (defvar *asdf-revision
* (let* ((v "1.130")
122 (colon (or (position #\
: v
) -
1))
123 (dot (position #\. v
)))
125 (list (parse-integer v
:start
(1+ colon
)
127 (parse-integer v
:start
(1+ dot
)
130 (defvar *compile-file-warnings-behaviour
* :warn
)
132 (defvar *compile-file-failure-behaviour
* #+sbcl
:error
#-sbcl
:warn
)
134 (defvar *verbose-out
* nil
)
136 (defparameter +asdf-methods
+
137 '(perform explain output-files operation-done-p
))
139 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
142 (defmacro aif
(test then
&optional else
)
143 `(let ((it ,test
)) (if it
,then
,else
)))
145 (defun pathname-sans-name+type
(pathname)
146 "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
147 and NIL NAME and TYPE components"
148 (make-pathname :name nil
:type nil
:defaults pathname
))
150 (define-modify-macro appendf
(&rest args
)
151 append
"Append onto list")
153 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
154 ;; classes, condiitons
156 (define-condition system-definition-error
(error) ()
157 ;; [this use of :report should be redundant, but unfortunately it's not.
158 ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
159 ;; over print-object; this is always conditions::%print-condition for
160 ;; condition objects, which in turn does inheritance of :report options at
161 ;; run-time. fortunately, inheritance means we only need this kludge here in
162 ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.]
163 #+cmu
(:report print-object
))
165 (define-condition formatted-system-definition-error
(system-definition-error)
166 ((format-control :initarg
:format-control
:reader format-control
)
167 (format-arguments :initarg
:format-arguments
:reader format-arguments
))
168 (:report
(lambda (c s
)
169 (apply #'format s
(format-control c
) (format-arguments c
)))))
171 (define-condition circular-dependency
(system-definition-error)
172 ((components :initarg
:components
:reader circular-dependency-components
)))
174 (define-condition duplicate-names
(system-definition-error)
175 ((name :initarg
:name
:reader duplicate-names-name
)))
177 (define-condition missing-component
(system-definition-error)
178 ((requires :initform
"(unnamed)" :reader missing-requires
:initarg
:requires
)
179 (parent :initform nil
:reader missing-parent
:initarg
:parent
)))
181 (define-condition missing-component-of-version
(missing-component)
182 ((version :initform nil
:reader missing-version
:initarg
:version
)))
184 (define-condition missing-dependency
(missing-component)
185 ((required-by :initarg
:required-by
:reader missing-required-by
)))
187 (define-condition missing-dependency-of-version
(missing-dependency
188 missing-component-of-version
)
191 (define-condition operation-error
(error)
192 ((component :reader error-component
:initarg
:component
)
193 (operation :reader error-operation
:initarg
:operation
))
194 (:report
(lambda (c s
)
195 (format s
"~@<erred while invoking ~A on ~A~@:>"
196 (error-operation c
) (error-component c
)))))
197 (define-condition compile-error
(operation-error) ())
198 (define-condition compile-failed
(compile-error) ())
199 (define-condition compile-warned
(compile-error) ())
201 (defclass component
()
202 ((name :accessor component-name
:initarg
:name
:documentation
203 "Component name: designator for a string composed of portable pathname characters")
204 (version :accessor component-version
:initarg
:version
)
205 (in-order-to :initform nil
:initarg
:in-order-to
)
207 (do-first :initform nil
:initarg
:do-first
)
208 ;; methods defined using the "inline" style inside a defsystem form:
209 ;; need to store them somewhere so we can delete them when the system
211 (inline-methods :accessor component-inline-methods
:initform nil
)
212 (parent :initarg
:parent
:initform nil
:reader component-parent
)
213 ;; no direct accessor for pathname, we do this as a method to allow
214 ;; it to default in funky ways if not supplied
215 (relative-pathname :initarg
:pathname
)
216 (operation-times :initform
(make-hash-table )
217 :accessor component-operation-times
)
218 ;; XXX we should provide some atomic interface for updating the
219 ;; component properties
220 (properties :accessor component-properties
:initarg
:properties
223 ;;;; methods: conditions
225 (defmethod print-object ((c missing-dependency
) s
)
226 (format s
"~@<~A, required by ~A~@:>"
227 (call-next-method c nil
) (missing-required-by c
)))
229 (defun sysdef-error (format &rest arguments
)
230 (error 'formatted-system-definition-error
:format-control format
:format-arguments arguments
))
232 ;;;; methods: components
234 (defmethod print-object ((c missing-component
) s
)
235 (format s
"~@<component ~S not found~
238 (when (missing-parent c
)
239 (component-name (missing-parent c
)))))
241 (defmethod print-object ((c missing-component-of-version
) s
)
242 (format s
"~@<component ~S does not match version ~A~
246 (when (missing-parent c
)
247 (component-name (missing-parent c
)))))
249 (defgeneric component-system
(component)
250 (:documentation
"Find the top-level system containing COMPONENT"))
252 (defmethod component-system ((component component
))
253 (aif (component-parent component
)
254 (component-system it
)
257 (defmethod print-object ((c component
) stream
)
258 (print-unreadable-object (c stream
:type t
:identity t
)
260 (prin1 (component-name c
) stream
))))
262 (defclass module
(component)
263 ((components :initform nil
:accessor module-components
:initarg
:components
)
264 ;; what to do if we can't satisfy a dependency of one of this module's
265 ;; components. This allows a limited form of conditional processing
266 (if-component-dep-fails :initform
:fail
267 :accessor module-if-component-dep-fails
268 :initarg
:if-component-dep-fails
)
269 (default-component-class :accessor module-default-component-class
270 :initform
'cl-source-file
:initarg
:default-component-class
)))
272 (defgeneric component-pathname
(component)
273 (:documentation
"Extracts the pathname applicable for a particular component."))
275 (defun component-parent-pathname (component)
276 (aif (component-parent component
)
277 (component-pathname it
)
278 *default-pathname-defaults
*))
280 (defgeneric component-relative-pathname
(component)
281 (:documentation
"Extracts the relative pathname applicable for a particular component."))
283 (defmethod component-relative-pathname ((component module
))
284 (or (slot-value component
'relative-pathname
)
286 :directory
`(:relative
,(component-name component
))
287 :host
(pathname-host (component-parent-pathname component
)))))
289 (defmethod component-pathname ((component component
))
290 (let ((*default-pathname-defaults
* (component-parent-pathname component
)))
291 (merge-pathnames (component-relative-pathname component
))))
293 (defgeneric component-property
(component property
))
295 (defmethod component-property ((c component
) property
)
296 (cdr (assoc property
(slot-value c
'properties
) :test
#'equal
)))
298 (defgeneric (setf component-property
) (new-value component property
))
300 (defmethod (setf component-property
) (new-value (c component
) property
)
301 (let ((a (assoc property
(slot-value c
'properties
) :test
#'equal
)))
303 (setf (cdr a
) new-value
)
304 (setf (slot-value c
'properties
)
305 (acons property new-value
(slot-value c
'properties
))))))
307 (defclass system
(module)
308 ((description :accessor system-description
:initarg
:description
)
310 :accessor system-long-description
:initarg
:long-description
)
311 (author :accessor system-author
:initarg
:author
)
312 (maintainer :accessor system-maintainer
:initarg
:maintainer
)
313 (licence :accessor system-licence
:initarg
:licence
314 :accessor system-license
:initarg
:license
)))
316 ;;; version-satisfies
318 ;;; with apologies to christophe rhodes ...
319 (defun split (string &optional max
(ws '(#\Space
#\Tab
)))
320 (flet ((is-ws (char) (find char ws
)))
322 (let ((list nil
) (start 0) (words 0) end
)
324 (when (and max
(>= words
(1- max
)))
325 (return (cons (subseq string start
) list
)))
326 (setf end
(position-if #'is-ws string
:start start
))
327 (push (subseq string start end
) list
)
329 (unless end
(return list
))
330 (setf start
(1+ end
)))))))
332 (defgeneric version-satisfies
(component version
))
334 (defmethod version-satisfies ((c component
) version
)
335 (unless (and version
(slot-boundp c
'version
))
336 (return-from version-satisfies t
))
337 (let ((x (mapcar #'parse-integer
338 (split (component-version c
) nil
'(#\.
))))
339 (y (mapcar #'parse-integer
340 (split version nil
'(#\.
)))))
341 (labels ((bigger (x y
)
344 ((> (car x
) (car y
)) t
)
346 (bigger (cdr x
) (cdr y
))))))
347 (and (= (car x
) (car y
))
348 (or (not (cdr y
)) (bigger (cdr x
) (cdr y
)))))))
350 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
353 (defvar *defined-systems
* (make-hash-table :test
'equal
))
354 (defun coerce-name (name)
356 (component (component-name name
))
357 (symbol (string-downcase (symbol-name name
)))
359 (t (sysdef-error "~@<invalid component designator ~A~@:>" name
))))
361 ;;; for the sake of keeping things reasonably neat, we adopt a
362 ;;; convention that functions in this list are prefixed SYSDEF-
364 (defvar *system-definition-search-functions
*
365 '(sysdef-central-registry-search))
367 (defun system-definition-pathname (system)
368 (let ((system-name (coerce-name system
)))
370 (some (lambda (x) (funcall x system-name
))
371 *system-definition-search-functions
*)
372 (let ((system-pair (system-registered-p system-name
)))
374 (system-source-file (cdr system-pair
)))))))
376 (defvar *central-registry
*
377 '(*default-pathname-defaults
*
378 #+nil
"/home/dan/src/sourceforge/cclan/asdf/systems/"
379 #+nil
"telent:asdf;systems;"))
381 (defun sysdef-central-registry-search (system)
382 (let ((name (coerce-name system
)))
384 (dolist (dir *central-registry
*)
385 (let* ((defaults (eval dir
))
388 :defaults defaults
:version
:newest
389 :name name
:type
"asd" :case
:local
))))
390 (if (and file
(probe-file file
))
393 (defun make-temporary-package ()
394 (flet ((try (counter)
396 (make-package (format nil
"ASDF~D" counter
)
397 :use
'(:cl
:asdf
)))))
398 (do* ((counter 0 (+ counter
1))
399 (package (try counter
) (try counter
)))
402 (defun find-system (name &optional
(error-p t
))
403 (let* ((name (coerce-name name
))
404 (in-memory (system-registered-p name
))
405 (on-disk (system-definition-pathname name
)))
408 (< (car in-memory
) (file-write-date on-disk
))))
409 (let ((package (make-temporary-package)))
411 (let ((*package
* package
))
414 "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
415 ;; FIXME: This wants to be (ENOUGH-NAMESTRING
416 ;; ON-DISK), but CMUCL barfs on that.
420 (delete-package package
))))
421 (let ((in-memory (system-registered-p name
)))
423 (progn (if on-disk
(setf (car in-memory
) (file-write-date on-disk
)))
425 (if error-p
(error 'missing-component
:requires name
))))))
427 (defun register-system (name system
)
428 (format *verbose-out
* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name
)
429 (setf (gethash (coerce-name name
) *defined-systems
*)
430 (cons (get-universal-time) system
)))
432 (defun system-registered-p (name)
433 (gethash (coerce-name name
) *defined-systems
*))
436 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
437 ;;; finding components
439 (defgeneric find-component
(module name
&optional version
)
440 (:documentation
"Finds the component with name NAME present in the
441 MODULE module; if MODULE is nil, then the component is assumed to be a
444 (defmethod find-component ((module module
) name
&optional version
)
445 (if (slot-boundp module
'components
)
446 (let ((m (find name
(module-components module
)
447 :test
#'equal
:key
#'component-name
)))
448 (if (and m
(version-satisfies m version
)) m
))))
451 ;;; a component with no parent is a system
452 (defmethod find-component ((module (eql nil
)) name
&optional version
)
453 (let ((m (find-system name nil
)))
454 (if (and m
(version-satisfies m version
)) m
)))
456 ;;; component subclasses
458 (defclass source-file
(component) ())
460 (defclass cl-source-file
(source-file) ())
461 (defclass c-source-file
(source-file) ())
462 (defclass java-source-file
(source-file) ())
463 (defclass static-file
(source-file) ())
464 (defclass doc-file
(static-file) ())
465 (defclass html-file
(doc-file) ())
467 (defgeneric source-file-type
(component system
))
468 (defmethod source-file-type ((c cl-source-file
) (s module
)) "lisp")
469 (defmethod source-file-type ((c c-source-file
) (s module
)) "c")
470 (defmethod source-file-type ((c java-source-file
) (s module
)) "java")
471 (defmethod source-file-type ((c html-file
) (s module
)) "html")
472 (defmethod source-file-type ((c static-file
) (s module
)) nil
)
474 (defmethod component-relative-pathname ((component source-file
))
475 (let ((relative-pathname (slot-value component
'relative-pathname
)))
476 (if relative-pathname
480 :type
(source-file-type component
(component-system component
))))
481 (let* ((*default-pathname-defaults
*
482 (component-parent-pathname component
))
485 :name
(component-name component
)
486 :type
(source-file-type component
487 (component-system component
)))))
490 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
493 ;;; one of these is instantiated whenever (operate ) is called
495 (defclass operation
()
496 ((forced :initform nil
:initarg
:force
:accessor operation-forced
)
497 (original-initargs :initform nil
:initarg
:original-initargs
498 :accessor operation-original-initargs
)
499 (visited-nodes :initform nil
:accessor operation-visited-nodes
)
500 (visiting-nodes :initform nil
:accessor operation-visiting-nodes
)
501 (parent :initform nil
:initarg
:parent
:accessor operation-parent
)))
503 (defmethod print-object ((o operation
) stream
)
504 (print-unreadable-object (o stream
:type t
:identity t
)
506 (prin1 (operation-original-initargs o
) stream
))))
508 (defmethod shared-initialize :after
((operation operation
) slot-names
511 (declare (ignore slot-names force
))
512 ;; empty method to disable initarg validity checking
515 (define-method-combination standard-asdf-method-combination
()
516 ((around-asdf (around))
519 (primary () :required t
)
521 (flet ((call-methods (methods)
522 (mapcar #'(lambda (method)
523 `(call-method ,method
))
525 (let* ((form (if (or before after
(rest primary
))
526 `(multiple-value-prog1
527 (progn ,@(call-methods before
)
528 (call-method ,(first primary
)
530 ,@(call-methods (reverse after
)))
531 `(call-method ,(first primary
))))
532 (standard-form (if around
533 `(call-method ,(first around
)
535 (make-method ,form
)))
538 `(call-method ,(first around-asdf
)
539 (,@(rest around-asdf
) (make-method ,standard-form
)))
542 (defgeneric perform
(operation component
)
543 (:method-combination standard-asdf-method-combination
))
544 (defgeneric operation-done-p
(operation component
)
545 (:method-combination standard-asdf-method-combination
))
546 (defgeneric explain
(operation component
)
547 (:method-combination standard-asdf-method-combination
))
548 (defgeneric output-files
(operation component
)
549 (:method-combination standard-asdf-method-combination
))
550 (defgeneric input-files
(operation component
)
551 (:method-combination standard-asdf-method-combination
))
553 (defun node-for (o c
)
554 (cons (class-name (class-of o
)) c
))
556 (defgeneric operation-ancestor
(operation)
558 "Recursively chase the operation's parent pointer until we get to
559 the head of the tree"))
561 (defmethod operation-ancestor ((operation operation
))
562 (aif (operation-parent operation
)
563 (operation-ancestor it
)
567 (defun make-sub-operation (c o dep-c dep-o
)
568 (let* ((args (copy-list (operation-original-initargs o
)))
569 (force-p (getf args
:force
)))
570 ;; note explicit comparison with T: any other non-NIL force value
571 ;; (e.g. :recursive) will pass through
572 (cond ((and (null (component-parent c
))
573 (null (component-parent dep-c
))
575 (when (eql force-p t
)
576 (setf (getf args
:force
) nil
))
577 (apply #'make-instance dep-o
579 :original-initargs args args
))
580 ((subtypep (type-of o
) dep-o
)
583 (apply #'make-instance dep-o
584 :parent o
:original-initargs args args
)))))
587 (defgeneric component-visited-p
(operation component
))
589 (defgeneric visit-component
(operation component data
))
591 (defmethod visit-component ((o operation
) (c component
) data
)
592 (unless (component-visited-p o c
)
593 (push (cons (node-for o c
) data
)
594 (operation-visited-nodes (operation-ancestor o
)))))
596 (defmethod component-visited-p ((o operation
) (c component
))
597 (assoc (node-for o c
)
598 (operation-visited-nodes (operation-ancestor o
))
601 (defgeneric (setf visiting-component
) (new-value operation component
))
603 (defmethod (setf visiting-component
) (new-value operation component
)
604 ;; MCL complains about unused lexical variables
605 (declare (ignorable new-value operation component
)))
607 (defmethod (setf visiting-component
) (new-value (o operation
) (c component
))
608 (let ((node (node-for o c
))
609 (a (operation-ancestor o
)))
611 (pushnew node
(operation-visiting-nodes a
) :test
'equal
)
612 (setf (operation-visiting-nodes a
)
613 (remove node
(operation-visiting-nodes a
) :test
'equal
)))))
615 (defgeneric component-visiting-p
(operation component
))
617 (defmethod component-visiting-p ((o operation
) (c component
))
618 (let ((node (node-for o c
)))
619 (member node
(operation-visiting-nodes (operation-ancestor o
))
622 (defgeneric component-depends-on
(operation component
)
624 "Returns a list of dependencies needed by the component to perform
625 the operation. A dependency has one of the following forms:
627 (<operation> <component>*), where <operation> is a class
628 designator and each <component> is a component
629 designator, which means that the component depends on
630 <operation> having been performed on each <component>; or
632 (FEATURE <feature>), which means that the component depends
633 on <feature>'s presence in *FEATURES*.
635 Methods specialized on subclasses of existing component types
636 should usually append the results of CALL-NEXT-METHOD to the
639 (defmethod component-depends-on ((op-spec symbol
) (c component
))
640 (component-depends-on (make-instance op-spec
) c
))
642 (defmethod component-depends-on ((o operation
) (c component
))
643 (cdr (assoc (class-name (class-of o
))
644 (slot-value c
'in-order-to
))))
646 (defgeneric component-self-dependencies
(operation component
))
648 (defmethod component-self-dependencies ((o operation
) (c component
))
649 (let ((all-deps (component-depends-on o c
)))
650 (remove-if-not (lambda (x)
651 (member (component-name c
) (cdr x
) :test
#'string
=))
654 (defmethod input-files ((operation operation
) (c component
))
655 (let ((parent (component-parent c
))
656 (self-deps (component-self-dependencies operation c
)))
658 (mapcan (lambda (dep)
659 (destructuring-bind (op name
) dep
660 (output-files (make-instance op
)
661 (find-component parent name
))))
663 ;; no previous operations needed? I guess we work with the
664 ;; original source file, then
665 (list (component-pathname c
)))))
667 (defmethod input-files ((operation operation
) (c module
)) nil
)
669 (defmethod operation-done-p ((o operation
) (c component
))
670 (flet ((fwd-or-return-t (file)
671 ;; if FILE-WRITE-DATE returns NIL, it's possible that the
672 ;; user or some other agent has deleted an input file. If
673 ;; that's the case, well, that's not good, but as long as
674 ;; the operation is otherwise considered to be done we
675 ;; could continue and survive.
676 (let ((date (file-write-date file
)))
680 (warn "~@<Missing FILE-WRITE-DATE for ~S: treating ~
681 operation ~S on component ~S as done.~@:>"
683 (return-from operation-done-p t
))))))
684 (let ((out-files (output-files o c
))
685 (in-files (input-files o c
)))
686 (cond ((and (not in-files
) (not out-files
))
687 ;; arbitrary decision: an operation that uses nothing to
688 ;; produce nothing probably isn't doing much
693 (component-operation-times c
))))
697 (mapcar #'fwd-or-return-t in-files
))))))
701 (every #'probe-file out-files
)
702 (> (apply #'min
(mapcar #'file-write-date out-files
))
703 (apply #'max
(mapcar #'fwd-or-return-t in-files
)))))))))
705 ;;; So you look at this code and think "why isn't it a bunch of
706 ;;; methods". And the answer is, because standard method combination
707 ;;; runs :before methods most->least-specific, which is back to front
708 ;;; for our purposes. And CLISP doesn't have non-standard method
709 ;;; combinations, so let's keep it simple and aspire to portability
711 (defgeneric traverse
(operation component
))
712 (defmethod traverse ((operation operation
) (c component
))
714 (labels ((do-one-dep (required-op required-c required-v
)
715 (let* ((dep-c (or (find-component
717 ;; XXX tacky. really we should build the
718 ;; in-order-to slot with canonicalized
719 ;; names instead of coercing this late
720 (coerce-name required-c
) required-v
)
722 (error 'missing-dependency-of-version
725 :requires required-c
)
726 (error 'missing-dependency
728 :requires required-c
))))
729 (op (make-sub-operation c operation dep-c required-op
)))
730 (traverse op dep-c
)))
732 (cond ((eq op
'feature
)
733 (or (member (car dep
) *features
*)
734 (error 'missing-dependency
736 :requires
(car dep
))))
740 (assert (string-equal
741 (symbol-name (first d
))
744 (do-one-dep op
(second d
) (third d
))))
746 (appendf forced
(do-one-dep op d nil
)))))))))
747 (aif (component-visited-p operation c
)
748 (return-from traverse
749 (if (cdr it
) (list (cons 'pruned-op c
)) nil
)))
751 (if (component-visiting-p operation c
)
752 (error 'circular-dependency
:components
(list c
)))
753 (setf (visiting-component operation c
) t
)
756 (loop for
(required-op . deps
) in
757 (component-depends-on operation c
)
758 do
(do-dep required-op deps
))
761 (when (typep c
'module
)
762 (let ((at-least-one nil
)
765 (loop for kid in
(module-components c
)
767 (appendf forced
(traverse operation kid
))
768 (missing-dependency (condition)
769 (if (eq (module-if-component-dep-fails c
)
772 (setf error condition
))
775 (setf at-least-one t
))))
776 (when (and (eq (module-if-component-dep-fails c
)
781 ;; now the thing itself
782 (when (or forced module-ops
783 (not (operation-done-p operation c
))
784 (let ((f (operation-forced
785 (operation-ancestor operation
))))
786 (and f
(or (not (consp f
))
787 (member (component-name
788 (operation-ancestor operation
))
789 (mapcar #'coerce-name f
)
791 (let ((do-first (cdr (assoc (class-name (class-of operation
))
792 (slot-value c
'do-first
)))))
793 (loop for
(required-op . deps
) in do-first
794 do
(do-dep required-op deps
)))
795 (setf forced
(append (delete 'pruned-op forced
:key
#'car
)
796 (delete 'pruned-op module-ops
:key
#'car
)
797 (list (cons operation c
)))))))
798 (setf (visiting-component operation c
) nil
))
799 (visit-component operation c
(and forced t
))
803 (defmethod perform ((operation operation
) (c source-file
))
805 "~@<required method PERFORM not implemented ~
806 for operation ~A, component ~A~@:>"
807 (class-of operation
) (class-of c
)))
809 (defmethod perform ((operation operation
) (c module
))
812 (defmethod explain ((operation operation
) (component component
))
813 (format *verbose-out
* "~&;;; ~A on ~A~%" operation component
))
817 (defclass compile-op
(operation)
818 ((proclamations :initarg
:proclamations
:accessor compile-op-proclamations
:initform nil
)
819 (on-warnings :initarg
:on-warnings
:accessor operation-on-warnings
820 :initform
*compile-file-warnings-behaviour
*)
821 (on-failure :initarg
:on-failure
:accessor operation-on-failure
822 :initform
*compile-file-failure-behaviour
*)))
824 (defmethod perform :before
((operation compile-op
) (c source-file
))
825 (map nil
#'ensure-directories-exist
(output-files operation c
)))
827 (defmethod perform :after
((operation operation
) (c component
))
828 (setf (gethash (type-of operation
) (component-operation-times c
))
829 (get-universal-time)))
831 ;;; perform is required to check output-files to find out where to put
832 ;;; its answers, in case it has been overridden for site policy
833 (defmethod perform ((operation compile-op
) (c cl-source-file
))
834 #-
:broken-fasl-loader
835 (let ((source-file (component-pathname c
))
836 (output-file (car (output-files operation c
))))
837 (multiple-value-bind (output warnings-p failure-p
)
838 (compile-file source-file
:output-file output-file
)
840 (case (operation-on-warnings operation
)
842 "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
844 (:error
(error 'compile-warned
:component c
:operation operation
))
847 (case (operation-on-failure operation
)
849 "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
851 (:error
(error 'compile-failed
:component c
:operation operation
))
854 (error 'compile-error
:component c
:operation operation
)))))
856 (defmethod output-files ((operation compile-op
) (c cl-source-file
))
857 #-
:broken-fasl-loader
(list (compile-file-pathname (component-pathname c
)))
858 #+:broken-fasl-loader
(list (component-pathname c
)))
860 (defmethod perform ((operation compile-op
) (c static-file
))
863 (defmethod output-files ((operation compile-op
) (c static-file
))
866 (defmethod input-files ((op compile-op
) (c static-file
))
872 (defclass basic-load-op
(operation) ())
874 (defclass load-op
(basic-load-op) ())
876 (defmethod perform ((o load-op
) (c cl-source-file
))
877 (mapcar #'load
(input-files o c
)))
879 (defmethod perform around
((o load-op
) (c cl-source-file
))
880 (let ((state :initial
))
881 (loop until
(or (eq state
:success
)
882 (eq state
:failure
)) do
885 (setf state
:failure
)
887 (setf state
:success
))
889 (setf state
:recompiled
)
890 (perform (make-instance 'asdf
:compile-op
) c
))
893 (try-recompiling "Recompile ~a and try loading it again"
895 (setf state
:failed-load
)
897 (setf state
:success
)))))))
899 (defmethod perform around
((o compile-op
) (c cl-source-file
))
900 (let ((state :initial
))
901 (loop until
(or (eq state
:success
)
902 (eq state
:failure
)) do
905 (setf state
:failure
)
907 (setf state
:success
))
909 (setf state
:recompiled
)
910 (perform (make-instance 'asdf
:compile-op
) c
))
913 (try-recompiling "Try recompiling ~a"
915 (setf state
:failed-compile
)
917 (setf state
:success
)))))))
919 (defmethod perform ((operation load-op
) (c static-file
))
922 (defmethod operation-done-p ((operation load-op
) (c static-file
))
925 (defmethod output-files ((o operation
) (c component
))
928 (defmethod component-depends-on ((operation load-op
) (c component
))
929 (cons (list 'compile-op
(component-name c
))
934 (defclass load-source-op
(basic-load-op) ())
936 (defmethod perform ((o load-source-op
) (c cl-source-file
))
937 (let ((source (component-pathname c
)))
938 (setf (component-property c
'last-loaded-as-source
)
940 (get-universal-time)))))
942 (defmethod perform ((operation load-source-op
) (c static-file
))
945 (defmethod output-files ((operation load-source-op
) (c component
))
948 ;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right.
949 (defmethod component-depends-on ((o load-source-op
) (c component
))
950 (let ((what-would-load-op-do (cdr (assoc 'load-op
951 (slot-value c
'in-order-to
)))))
952 (mapcar (lambda (dep)
953 (if (eq (car dep
) 'load-op
)
954 (cons 'load-source-op
(cdr dep
))
956 what-would-load-op-do
)))
958 (defmethod operation-done-p ((o load-source-op
) (c source-file
))
959 (if (or (not (component-property c
'last-loaded-as-source
))
960 (> (file-write-date (component-pathname c
))
961 (component-property c
'last-loaded-as-source
)))
964 (defclass test-op
(operation) ())
966 (defmethod perform ((operation test-op
) (c component
))
969 (defmethod operation-done-p ((operation test-op
) (c system
))
970 "Testing a system is _never_ done."
973 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
974 ;;; invoking operations
976 (defvar *operate-docstring
*
977 "Operate does three things:
979 1. It creates an instance of `operation-class` using any keyword parameters
981 2. It finds the asdf-system specified by `system` (possibly loading
983 3. It then calls `traverse` with the operation and system as arguments
985 The traverse operation is wrapped in `with-compilation-unit` and error
986 handling code. If a `version` argument is supplied, then operate also
987 ensures that the system found satisfies it using the `version-satisfies`
990 (defun operate (operation-class system
&rest args
&key
(verbose t
) version
992 (let* ((op (apply #'make-instance operation-class
993 :original-initargs args
995 (*verbose-out
* (if verbose
*standard-output
* (make-broadcast-stream)))
996 (system (if (typep system
'component
) system
(find-system system
))))
997 (unless (version-satisfies system version
)
998 (error 'missing-component-of-version
:requires system
:version version
))
999 (let ((steps (traverse op system
)))
1000 (with-compilation-unit ()
1001 (loop for
(op . component
) in steps do
1004 (progn (perform op component
)
1009 (format s
"~@<Retry performing ~S on ~S.~@:>"
1014 (format s
"~@<Continue, treating ~S on ~S as ~
1015 having been successful.~@:>"
1017 (setf (gethash (type-of op
)
1018 (component-operation-times component
))
1019 (get-universal-time))
1022 (setf (documentation 'operate
'function
)
1023 *operate-docstring
*)
1025 (defun oos (operation-class system
&rest args
&key force
(verbose t
) version
)
1026 (declare (ignore force verbose version
))
1027 (apply #'operate operation-class system args
))
1029 (setf (documentation 'oos
'function
)
1031 "Short for _operate on system_ and an alias for the `operate` function. ~&~&~a"
1032 *operate-docstring
*))
1034 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1037 (defun remove-keyword (key arglist
)
1038 (labels ((aux (key arglist
)
1039 (cond ((null arglist
) nil
)
1040 ((eq key
(car arglist
)) (cddr arglist
))
1041 (t (cons (car arglist
) (cons (cadr arglist
)
1043 key
(cddr arglist
))))))))
1046 (defmacro defsystem
(name &body options
)
1047 (destructuring-bind (&key
(pathname nil pathname-arg-p
) (class 'system
)
1050 (let ((component-options (remove-keyword :class options
)))
1052 ;; system must be registered before we parse the body, otherwise
1053 ;; we recur when trying to find an existing system of the same name
1054 ;; to reuse options (e.g. pathname) from
1055 (let ((s (system-registered-p ',name
)))
1056 (cond ((and s
(eq (type-of (cdr s
)) ',class
))
1057 (setf (car s
) (get-universal-time)))
1060 (sysdef-error "Cannot redefine the existing system ~A with a different class" s
)
1062 (change-class (cdr s
) ',class
))
1064 (register-system (quote ,name
)
1065 (make-instance ',class
:name
',name
)))))
1066 (parse-component-form nil
(apply
1068 :module
(coerce-name ',name
)
1070 ;; to avoid a note about unreachable code
1073 `(or (when *load-truename
*
1074 (pathname-sans-name+type
1077 *default-pathname-defaults
*))
1078 ',component-options
))))))
1081 (defun class-for-type (parent type
)
1082 (let* ((extra-symbols (list (find-symbol (symbol-name type
) *package
*)
1083 (find-symbol (symbol-name type
)
1085 (package-name :asdf
)))))
1086 (class (dolist (symbol (if (keywordp type
)
1088 (cons type extra-symbols
)))
1090 (find-class symbol nil
)
1091 (subtypep symbol
'component
))
1092 (return (find-class symbol
))))))
1094 (and (eq type
:file
)
1095 (or (module-default-component-class parent
)
1096 (find-class 'cl-source-file
)))
1097 (sysdef-error "~@<don't recognize component type ~A~@:>" type
))))
1099 (defun maybe-add-tree (tree op1 op2 c
)
1100 "Add the node C at /OP1/OP2 in TREE, unless it's there already.
1101 Returns the new tree (which probably shares structure with the old one)"
1102 (let ((first-op-tree (assoc op1 tree
)))
1105 (aif (assoc op2
(cdr first-op-tree
))
1106 (if (find c
(cdr it
))
1108 (setf (cdr it
) (cons c
(cdr it
))))
1109 (setf (cdr first-op-tree
)
1110 (acons op2
(list c
) (cdr first-op-tree
))))
1112 (acons op1
(list (list op2 c
)) tree
))))
1114 (defun union-of-dependencies (&rest deps
)
1115 (let ((new-tree nil
))
1117 (dolist (op-tree dep
)
1118 (dolist (op (cdr op-tree
))
1119 (dolist (c (cdr op
))
1121 (maybe-add-tree new-tree
(car op-tree
) (car op
) c
))))))
1125 (defun remove-keys (key-names args
)
1126 (loop for
( name val
) on args by
#'cddr
1127 unless
(member (symbol-name name
) key-names
1128 :key
#'symbol-name
:test
'equal
)
1129 append
(list name val
)))
1131 (defvar *serial-depends-on
*)
1133 (defun parse-component-form (parent options
)
1136 (type name
&rest rest
&key
1137 ;; the following list of keywords is reproduced below in the
1138 ;; remove-keys form. important to keep them in sync
1139 components pathname default-component-class
1140 perform explain output-files operation-done-p
1142 depends-on serial in-order-to
1144 &allow-other-keys
) options
1145 (declare (ignorable perform explain output-files operation-done-p
))
1146 (check-component-input type name weakly-depends-on depends-on components in-order-to
)
1149 (find-component parent name
)
1150 ;; ignore the same object when rereading the defsystem
1152 (typep (find-component parent name
)
1153 (class-for-type parent type
))))
1154 (error 'duplicate-names
:name name
))
1156 (let* ((other-args (remove-keys
1157 '(components pathname default-component-class
1158 perform explain output-files operation-done-p
1160 depends-on serial in-order-to
)
1163 (or (find-component parent name
)
1164 (make-instance (class-for-type parent type
)))))
1165 (when weakly-depends-on
1166 (setf depends-on
(append depends-on
(remove-if (complement #'find-system
) weakly-depends-on
))))
1167 (when (boundp '*serial-depends-on
*)
1169 (concatenate 'list
*serial-depends-on
* depends-on
)))
1170 (apply #'reinitialize-instance ret
1171 :name
(coerce-name name
)
1175 (when (typep ret
'module
)
1176 (setf (module-default-component-class ret
)
1177 (or default-component-class
1178 (and (typep parent
'module
)
1179 (module-default-component-class parent
))))
1180 (let ((*serial-depends-on
* nil
))
1181 (setf (module-components ret
)
1182 (loop for c-form in components
1183 for c
= (parse-component-form ret c-form
)
1186 do
(push (component-name c
) *serial-depends-on
*))))
1188 ;; check for duplicate names
1189 (let ((name-hash (make-hash-table :test
#'equal
)))
1190 (loop for c in
(module-components ret
)
1192 (if (gethash (component-name c
)
1194 (error 'duplicate-names
1195 :name
(component-name c
))
1196 (setf (gethash (component-name c
)
1200 (setf (slot-value ret
'in-order-to
)
1201 (union-of-dependencies
1203 `((compile-op (compile-op ,@depends-on
))
1204 (load-op (load-op ,@depends-on
))))
1205 (slot-value ret
'do-first
) `((compile-op (load-op ,@depends-on
))))
1207 (%remove-component-inline-methods ret rest
)
1211 (defun %remove-component-inline-methods
(ret rest
)
1212 (loop for name in
+asdf-methods
+
1214 ;; this is inefficient as most of the stored
1215 ;; methods will not be for this particular gf n
1216 ;; But this is hardly performance-critical
1218 (remove-method (symbol-function name
) m
))
1219 (component-inline-methods ret
)))
1220 ;; clear methods, then add the new ones
1221 (setf (component-inline-methods ret
) nil
)
1222 (loop for name in
+asdf-methods
+
1223 for v
= (getf rest
(intern (symbol-name name
) :keyword
))
1225 (destructuring-bind (op qual
(o c
) &body body
) v
1227 (eval `(defmethod ,name
,qual
((,o
,op
) (,c
(eql ,ret
)))
1229 (component-inline-methods ret
)))))
1231 (defun check-component-input (type name weakly-depends-on depends-on components in-order-to
)
1232 "A partial test of the values of a component."
1233 (when weakly-depends-on
(warn "We got one! XXXXX"))
1234 (unless (listp depends-on
)
1235 (sysdef-error-component ":depends-on must be a list."
1236 type name depends-on
))
1237 (unless (listp weakly-depends-on
)
1238 (sysdef-error-component ":weakly-depends-on must be a list."
1239 type name weakly-depends-on
))
1240 (unless (listp components
)
1241 (sysdef-error-component ":components must be NIL or a list of components."
1242 type name components
))
1243 (unless (and (listp in-order-to
) (listp (car in-order-to
)))
1244 (sysdef-error-component ":in-order-to must be NIL or a list of components."
1245 type name in-order-to
)))
1247 (defun sysdef-error-component (msg type name value
)
1248 (sysdef-error (concatenate 'string msg
1249 "~&The value specified for ~(~A~) ~A is ~W")
1252 (defun resolve-symlinks (path)
1253 #-allegro
(truename path
)
1254 #+allegro
(excl:pathname-resolve-symbolic-links path
)
1259 ;;; run-shell-command functions for other lisp implementations will be
1260 ;;; gratefully accepted, if they do the same thing. If the docstring
1261 ;;; is ambiguous, send a bug report
1263 (defun run-shell-command (control-string &rest args
)
1264 "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
1265 synchronously execute the result using a Bourne-compatible shell, with
1266 output to *VERBOSE-OUT*. Returns the shell's exit code."
1267 (let ((command (apply #'format nil control-string args
)))
1268 (format *verbose-out
* "; $ ~A~%" command
)
1270 (sb-ext:process-exit-code
1272 #+win32
"sh" #-win32
"/bin/sh"
1274 #+win32
#+win32
:search t
1275 :input nil
:output
*verbose-out
*))
1278 (ext:process-exit-code
1282 :input nil
:output
*verbose-out
*))
1285 (excl:run-shell-command command
:input nil
:output
*verbose-out
*)
1288 (system:call-system-showing-output
1290 :shell-type
"/bin/sh"
1291 :output-stream
*verbose-out
*)
1293 #+clisp
;XXX not exactly *verbose-out*, I know
1294 (ext:run-shell-command command
:output
:terminal
:wait t
)
1298 (ccl:external-process-status
1299 (ccl:run-program
"/bin/sh" (list "-c" command
)
1300 :input nil
:output
*verbose-out
*
1302 #+ecl
;; courtesy of Juan Jose Garcia Ripoll
1304 #-
(or openmcl clisp lispworks allegro scl cmu sbcl ecl
)
1305 (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
1308 (defgeneric system-source-file
(system)
1309 (:documentation
"Return the source file in which system is defined."))
1311 (defmethod system-source-file ((system-name t
))
1312 (system-source-file (find-system system-name
)))
1314 (defmethod system-source-file ((system system
))
1315 (let ((pn (and (slot-boundp system
'relative-pathname
)
1318 :name
(asdf:component-name system
)
1319 :defaults
(asdf:component-relative-pathname system
)))))
1323 (defun system-source-directory (system-name)
1324 (make-pathname :name nil
1326 :defaults
(system-source-file system-name
)))
1328 (defun system-relative-pathname (system pathname
&key name type
)
1329 ;; you're not allowed to muck with the return value of pathname-X
1330 (let ((directory (copy-list (pathname-directory pathname
))))
1331 (when (eq (car directory
) :absolute
)
1332 (setf (car directory
) :relative
))
1334 (make-pathname :name
(or name
(pathname-name pathname
))
1335 :type
(or type
(pathname-type pathname
))
1336 :directory directory
)
1337 (system-source-directory system
))))
1339 (pushnew :asdf
*features
*)
1342 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
1343 (when (sb-ext:posix-getenv
"SBCL_BUILDING_CONTRIB")
1344 (pushnew :sbcl-hooks-require
*features
*)))
1346 #+(and sbcl sbcl-hooks-require
)
1348 (defun module-provide-asdf (name)
1349 (handler-bind ((style-warning #'muffle-warning
))
1350 (let* ((*verbose-out
* (make-broadcast-stream))
1351 (system (asdf:find-system name nil
)))
1353 (asdf:operate
'asdf
:load-op name
)
1356 (defun contrib-sysdef-search (system)
1357 (let ((home (sb-ext:posix-getenv
"SBCL_HOME")))
1358 (when (and home
(not (string= home
"")))
1359 (let* ((name (coerce-name system
))
1360 (home (truename home
))
1361 (contrib (merge-pathnames
1362 (make-pathname :directory
`(:relative
,name
)
1368 (probe-file contrib
)))))
1371 '(let ((home (sb-ext:posix-getenv
"SBCL_HOME")))
1372 (when (and home
(not (string= home
"")))
1373 (merge-pathnames "site-systems/" (truename home
))))
1377 '(merge-pathnames ".sbcl/systems/"
1378 (user-homedir-pathname))
1381 (pushnew 'module-provide-asdf sb-ext
:*module-provider-functions
*)
1382 (pushnew 'contrib-sysdef-search
*system-definition-search-functions
*))