1 ;;; This is asdf: Another System Definition Facility.
4 ;;; Feedback, bug reports, and patches are all welcome: please mail to
5 ;;; <asdf-devel@common-lisp.net>. But note first that the canonical
6 ;;; source for asdf is presently on common-lisp.net at
7 ;;; <URL:http://common-lisp.net/project/asdf/>
9 ;;; If you obtained this copy from anywhere else, and you experience
10 ;;; trouble using it, or find bugs, you may want to check at the
11 ;;; location above for a more recent version (and for documentation
12 ;;; and test files, if your copy came without them) before reporting
13 ;;; bugs. There are usually two "supported" revisions - the git HEAD
14 ;;; is the latest development version, whereas the revision tagged
15 ;;; RELEASE may be slightly older but is considered `stable'
17 ;;; Copyright (c) 2001-2009 Daniel Barlow and contributors
19 ;;; Permission is hereby granted, free of charge, to any person obtaining
20 ;;; a copy of this software and associated documentation files (the
21 ;;; "Software"), to deal in the Software without restriction, including
22 ;;; without limitation the rights to use, copy, modify, merge, publish,
23 ;;; distribute, sublicense, and/or sell copies of the Software, and to
24 ;;; permit persons to whom the Software is furnished to do so, subject to
25 ;;; the following conditions:
27 ;;; The above copyright notice and this permission notice shall be
28 ;;; included in all copies or substantial portions of the Software.
30 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
31 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
32 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
33 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
34 ;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
35 ;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
36 ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
38 ;;; the problem with writing a defsystem replacement is bootstrapping:
39 ;;; we can't use defsystem to compile it. Hence, all in one file
42 (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command
43 #:system-definition-pathname #:find-component ; miscellaneous
44 #:compile-system #:load-system #:test-system
45 #:compile-op #:load-op #:load-source-op
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
99 #:missing-component-of-version
101 #:missing-dependency-of-version
102 #:circular-dependency ; errors
109 #:standard-asdf-method-combination
110 #:around ; protocol assistants
116 (error "The author of this file habitually uses #+nil to comment out ~
117 forms. But don't worry, it was unlikely to work in the New ~
118 Implementation of Lisp anyway")
122 (defvar *asdf-revision*
123 ;; find first tag that looks like /tags/[0-9]*\.[0-9]*. E.g., /tags/1.34
124 ;; return nil or a list of the major and minor version numbers
125 (let* ((v "$Format:%d$")
129 (loop for tag-start = (search to-find v :test #'char= :start2 start)
132 (let ((dot (position #\. v :start tag-start))
133 (space (position #\space v :start tag-start)))
134 (when (and dot (or (not space) (< dot space)))
137 (list (parse-integer v :start (+ tag-start (length to-find))
139 (parse-integer v :start (1+ dot)
141 (setf start (1+ tag-start))))))))
143 (defvar *compile-file-warnings-behaviour* :warn)
145 (defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn)
147 (defvar *verbose-out* nil)
149 (defparameter +asdf-methods+
150 '(perform explain output-files operation-done-p))
152 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
155 (defmacro aif (test then &optional else)
156 `(let ((it ,test)) (if it ,then ,else)))
158 (defun pathname-sans-name+type (pathname)
159 "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
160 and NIL NAME and TYPE components"
161 (make-pathname :name nil :type nil :defaults pathname))
163 (define-modify-macro appendf (&rest args)
164 append "Append onto list")
166 (defun asdf-message (format-string &rest format-args)
167 (declare (dynamic-extent format-args))
168 (apply #'format *verbose-out* format-string format-args))
171 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
172 ;; classes, condiitons
174 (define-condition system-definition-error (error) ()
175 ;; [this use of :report should be redundant, but unfortunately it's not.
176 ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
177 ;; over print-object; this is always conditions::%print-condition for
178 ;; condition objects, which in turn does inheritance of :report options at
179 ;; run-time. fortunately, inheritance means we only need this kludge here in
180 ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.]
181 #+cmu (:report print-object))
183 (define-condition formatted-system-definition-error (system-definition-error)
184 ((format-control :initarg :format-control :reader format-control)
185 (format-arguments :initarg :format-arguments :reader format-arguments))
186 (:report (lambda (c s)
187 (apply #'format s (format-control c) (format-arguments c)))))
189 (define-condition circular-dependency (system-definition-error)
190 ((components :initarg :components :reader circular-dependency-components)))
192 (define-condition duplicate-names (system-definition-error)
193 ((name :initarg :name :reader duplicate-names-name)))
195 (define-condition missing-component (system-definition-error)
196 ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
197 (parent :initform nil :reader missing-parent :initarg :parent)))
199 (define-condition missing-component-of-version (missing-component)
200 ((version :initform nil :reader missing-version :initarg :version)))
202 (define-condition missing-dependency (missing-component)
203 ((required-by :initarg :required-by :reader missing-required-by)))
205 (define-condition missing-dependency-of-version (missing-dependency
206 missing-component-of-version)
209 (define-condition operation-error (error)
210 ((component :reader error-component :initarg :component)
211 (operation :reader error-operation :initarg :operation))
212 (:report (lambda (c s)
213 (format s "~@<erred while invoking ~A on ~A~@:>"
214 (error-operation c) (error-component c)))))
215 (define-condition compile-error (operation-error) ())
216 (define-condition compile-failed (compile-error) ())
217 (define-condition compile-warned (compile-error) ())
219 (defclass component ()
220 ((name :accessor component-name :initarg :name :documentation
221 "Component name: designator for a string composed of portable pathname characters")
222 (version :accessor component-version :initarg :version)
223 (in-order-to :initform nil :initarg :in-order-to)
225 (do-first :initform nil :initarg :do-first)
226 ;; methods defined using the "inline" style inside a defsystem form:
227 ;; need to store them somewhere so we can delete them when the system
229 (inline-methods :accessor component-inline-methods :initform nil)
230 (parent :initarg :parent :initform nil :reader component-parent)
231 ;; no direct accessor for pathname, we do this as a method to allow
232 ;; it to default in funky ways if not supplied
233 (relative-pathname :initarg :pathname)
234 (operation-times :initform (make-hash-table )
235 :accessor component-operation-times)
236 ;; XXX we should provide some atomic interface for updating the
237 ;; component properties
238 (properties :accessor component-properties :initarg :properties
241 ;;;; methods: conditions
243 (defmethod print-object ((c missing-dependency) s)
244 (format s "~@<~A, required by ~A~@:>"
245 (call-next-method c nil) (missing-required-by c)))
247 (defun sysdef-error (format &rest arguments)
248 (error 'formatted-system-definition-error :format-control format :format-arguments arguments))
250 ;;;; methods: components
252 (defmethod print-object ((c missing-component) s)
253 (format s "~@<component ~S not found~
256 (when (missing-parent c)
257 (component-name (missing-parent c)))))
259 (defmethod print-object ((c missing-component-of-version) s)
260 (format s "~@<component ~S does not match version ~A~
264 (when (missing-parent c)
265 (component-name (missing-parent c)))))
267 (defgeneric component-system (component)
268 (:documentation "Find the top-level system containing COMPONENT"))
270 (defmethod component-system ((component component))
271 (aif (component-parent component)
272 (component-system it)
275 (defmethod print-object ((c component) stream)
276 (print-unreadable-object (c stream :type t :identity t)
278 (prin1 (component-name c) stream))))
280 (defclass module (component)
281 ((components :initform nil :accessor module-components :initarg :components)
282 ;; what to do if we can't satisfy a dependency of one of this module's
283 ;; components. This allows a limited form of conditional processing
284 (if-component-dep-fails :initform :fail
285 :accessor module-if-component-dep-fails
286 :initarg :if-component-dep-fails)
287 (default-component-class :accessor module-default-component-class
288 :initform 'cl-source-file :initarg :default-component-class)))
290 (defgeneric component-pathname (component)
291 (:documentation "Extracts the pathname applicable for a particular component."))
293 (defun component-parent-pathname (component)
294 (aif (component-parent component)
295 (component-pathname it)
296 *default-pathname-defaults*))
298 (defgeneric component-relative-pathname (component)
299 (:documentation "Extracts the relative pathname applicable for a particular component."))
301 (defmethod component-relative-pathname ((component module))
302 (or (slot-value component 'relative-pathname)
304 :directory `(:relative ,(component-name component))
305 :host (pathname-host (component-parent-pathname component)))))
307 (defmethod component-pathname ((component component))
308 (let ((*default-pathname-defaults* (component-parent-pathname component)))
309 (merge-pathnames (component-relative-pathname component))))
311 (defgeneric component-property (component property))
313 (defmethod component-property ((c component) property)
314 (cdr (assoc property (slot-value c 'properties) :test #'equal)))
316 (defgeneric (setf component-property) (new-value component property))
318 (defmethod (setf component-property) (new-value (c component) property)
319 (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
321 (setf (cdr a) new-value)
322 (setf (slot-value c 'properties)
323 (acons property new-value (slot-value c 'properties))))))
325 (defclass system (module)
326 ((description :accessor system-description :initarg :description)
328 :accessor system-long-description :initarg :long-description)
329 (author :accessor system-author :initarg :author)
330 (maintainer :accessor system-maintainer :initarg :maintainer)
331 (licence :accessor system-licence :initarg :licence
332 :accessor system-license :initarg :license)))
334 ;;; version-satisfies
336 ;;; with apologies to christophe rhodes ...
337 (defun split (string &optional max (ws '(#\Space #\Tab)))
338 (flet ((is-ws (char) (find char ws)))
340 (let ((list nil) (start 0) (words 0) end)
342 (when (and max (>= words (1- max)))
343 (return (cons (subseq string start) list)))
344 (setf end (position-if #'is-ws string :start start))
345 (push (subseq string start end) list)
347 (unless end (return list))
348 (setf start (1+ end)))))))
350 (defgeneric version-satisfies (component version))
352 (defmethod version-satisfies ((c component) version)
353 (unless (and version (slot-boundp c 'version))
354 (return-from version-satisfies t))
355 (let ((x (mapcar #'parse-integer
356 (split (component-version c) nil '(#\.))))
357 (y (mapcar #'parse-integer
358 (split version nil '(#\.)))))
359 (labels ((bigger (x y)
362 ((> (car x) (car y)) t)
364 (bigger (cdr x) (cdr y))))))
365 (and (= (car x) (car y))
366 (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
368 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
371 (defun make-defined-systems-table ()
372 (make-hash-table :test 'equal))
374 (defvar *defined-systems* (make-defined-systems-table))
376 (defun coerce-name (name)
378 (component (component-name name))
379 (symbol (string-downcase (symbol-name name)))
381 (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
383 (defun system-registered-p (name)
384 (gethash (coerce-name name) *defined-systems*))
387 ;;; for the sake of keeping things reasonably neat, we adopt a
388 ;;; convention that functions in this list are prefixed SYSDEF-
390 (defvar *system-definition-search-functions*
391 '(sysdef-central-registry-search))
393 (defun system-definition-pathname (system)
394 (let ((system-name (coerce-name system)))
396 (some (lambda (x) (funcall x system-name))
397 *system-definition-search-functions*)
398 (let ((system-pair (system-registered-p system-name)))
400 (system-source-file (cdr system-pair)))))))
402 (defvar *central-registry*
403 '(*default-pathname-defaults*)
404 "A list of 'system directory designators' ASDF uses to find systems.
406 A 'system directory designator' is a pathname or a function
407 which evaluates to a pathname. For example:
409 (setf asdf:*central-registry*
410 (list '*default-pathname-defaults*
411 #p\"/home/me/cl/systems/\"
412 #p\"/usr/share/common-lisp/systems/\"))
415 (defun sysdef-central-registry-search (system)
416 (let ((name (coerce-name system)))
418 (dolist (dir *central-registry*)
419 (let* ((defaults (eval dir))
422 :defaults defaults :version :newest
423 :name name :type "asd" :case :local))))
424 (if (and file (probe-file file))
427 (defun make-temporary-package ()
428 (flet ((try (counter)
430 (make-package (format nil "ASDF~D" counter)
431 :use '(:cl :asdf)))))
432 (do* ((counter 0 (+ counter 1))
433 (package (try counter) (try counter)))
436 (defun find-system (name &optional (error-p t))
437 (let* ((name (coerce-name name))
438 (in-memory (system-registered-p name))
439 (on-disk (system-definition-pathname name)))
442 (< (car in-memory) (file-write-date on-disk))))
443 (let ((package (make-temporary-package)))
445 (let ((*package* package))
447 "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
448 ;; FIXME: This wants to be (ENOUGH-NAMESTRING
449 ;; ON-DISK), but CMUCL barfs on that.
453 (delete-package package))))
454 (let ((in-memory (system-registered-p name)))
456 (progn (if on-disk (setf (car in-memory) (file-write-date on-disk)))
458 (if error-p (error 'missing-component :requires name))))))
460 (defun register-system (name system)
461 (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
462 (setf (gethash (coerce-name name) *defined-systems*)
463 (cons (get-universal-time) system)))
466 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
467 ;;; finding components
469 (defgeneric find-component (module name &optional version)
470 (:documentation "Finds the component with name NAME present in the
471 MODULE module; if MODULE is nil, then the component is assumed to be a
474 (defmethod find-component ((module module) name &optional version)
475 (if (slot-boundp module 'components)
476 (let ((m (find name (module-components module)
477 :test #'equal :key #'component-name)))
478 (if (and m (version-satisfies m version)) m))))
481 ;;; a component with no parent is a system
482 (defmethod find-component ((module (eql nil)) name &optional version)
483 (let ((m (find-system name nil)))
484 (if (and m (version-satisfies m version)) m)))
486 ;;; component subclasses
488 (defclass source-file (component) ())
490 (defclass cl-source-file (source-file) ())
491 (defclass c-source-file (source-file) ())
492 (defclass java-source-file (source-file) ())
493 (defclass static-file (source-file) ())
494 (defclass doc-file (static-file) ())
495 (defclass html-file (doc-file) ())
497 (defgeneric source-file-type (component system))
498 (defmethod source-file-type ((c cl-source-file) (s module)) "lisp")
499 (defmethod source-file-type ((c c-source-file) (s module)) "c")
500 (defmethod source-file-type ((c java-source-file) (s module)) "java")
501 (defmethod source-file-type ((c html-file) (s module)) "html")
502 (defmethod source-file-type ((c static-file) (s module)) nil)
504 (defmethod component-relative-pathname ((component source-file))
505 (let ((relative-pathname (slot-value component 'relative-pathname)))
506 (if relative-pathname
510 :type (source-file-type component (component-system component))))
511 (let* ((*default-pathname-defaults*
512 (component-parent-pathname component))
515 :name (component-name component)
516 :type (source-file-type component
517 (component-system component)))))
520 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
523 ;;; one of these is instantiated whenever (operate ) is called
525 (defclass operation ()
526 ((forced :initform nil :initarg :force :accessor operation-forced)
527 (original-initargs :initform nil :initarg :original-initargs
528 :accessor operation-original-initargs)
529 (visited-nodes :initform nil :accessor operation-visited-nodes)
530 (visiting-nodes :initform nil :accessor operation-visiting-nodes)
531 (parent :initform nil :initarg :parent :accessor operation-parent)))
533 (defmethod print-object ((o operation) stream)
534 (print-unreadable-object (o stream :type t :identity t)
536 (prin1 (operation-original-initargs o) stream))))
538 (defmethod shared-initialize :after ((operation operation) slot-names
541 (declare (ignore slot-names force))
542 ;; empty method to disable initarg validity checking
545 (define-method-combination standard-asdf-method-combination ()
546 ((around-asdf (around))
549 (primary () :required t)
551 (flet ((call-methods (methods)
552 (mapcar #'(lambda (method)
553 `(call-method ,method))
555 (let* ((form (if (or before after (rest primary))
556 `(multiple-value-prog1
557 (progn ,@(call-methods before)
558 (call-method ,(first primary)
560 ,@(call-methods (reverse after)))
561 `(call-method ,(first primary))))
562 (standard-form (if around
563 `(call-method ,(first around)
565 (make-method ,form)))
568 `(call-method ,(first around-asdf)
569 (,@(rest around-asdf) (make-method ,standard-form)))
572 (defgeneric perform (operation component)
573 (:method-combination standard-asdf-method-combination))
574 (defgeneric operation-done-p (operation component)
575 (:method-combination standard-asdf-method-combination))
576 (defgeneric explain (operation component)
577 (:method-combination standard-asdf-method-combination))
578 (defgeneric output-files (operation component)
579 (:method-combination standard-asdf-method-combination))
580 (defgeneric input-files (operation component)
581 (:method-combination standard-asdf-method-combination))
583 (defun node-for (o c)
584 (cons (class-name (class-of o)) c))
586 (defgeneric operation-ancestor (operation)
588 "Recursively chase the operation's parent pointer until we get to
589 the head of the tree"))
591 (defmethod operation-ancestor ((operation operation))
592 (aif (operation-parent operation)
593 (operation-ancestor it)
597 (defun make-sub-operation (c o dep-c dep-o)
598 (let* ((args (copy-list (operation-original-initargs o)))
599 (force-p (getf args :force)))
600 ;; note explicit comparison with T: any other non-NIL force value
601 ;; (e.g. :recursive) will pass through
602 (cond ((and (null (component-parent c))
603 (null (component-parent dep-c))
605 (when (eql force-p t)
606 (setf (getf args :force) nil))
607 (apply #'make-instance dep-o
609 :original-initargs args args))
610 ((subtypep (type-of o) dep-o)
613 (apply #'make-instance dep-o
614 :parent o :original-initargs args args)))))
617 (defgeneric component-visited-p (operation component))
619 (defgeneric visit-component (operation component data))
621 (defmethod visit-component ((o operation) (c component) data)
622 (unless (component-visited-p o c)
623 (push (cons (node-for o c) data)
624 (operation-visited-nodes (operation-ancestor o)))))
626 (defmethod component-visited-p ((o operation) (c component))
627 (assoc (node-for o c)
628 (operation-visited-nodes (operation-ancestor o))
631 (defgeneric (setf visiting-component) (new-value operation component))
633 (defmethod (setf visiting-component) (new-value operation component)
634 ;; MCL complains about unused lexical variables
635 (declare (ignorable new-value operation component)))
637 (defmethod (setf visiting-component) (new-value (o operation) (c component))
638 (let ((node (node-for o c))
639 (a (operation-ancestor o)))
641 (pushnew node (operation-visiting-nodes a) :test 'equal)
642 (setf (operation-visiting-nodes a)
643 (remove node (operation-visiting-nodes a) :test 'equal)))))
645 (defgeneric component-visiting-p (operation component))
647 (defmethod component-visiting-p ((o operation) (c component))
648 (let ((node (node-for o c)))
649 (member node (operation-visiting-nodes (operation-ancestor o))
652 (defgeneric component-depends-on (operation component)
654 "Returns a list of dependencies needed by the component to perform
655 the operation. A dependency has one of the following forms:
657 (<operation> <component>*), where <operation> is a class
658 designator and each <component> is a component
659 designator, which means that the component depends on
660 <operation> having been performed on each <component>; or
662 (FEATURE <feature>), which means that the component depends
663 on <feature>'s presence in *FEATURES*.
665 Methods specialized on subclasses of existing component types
666 should usually append the results of CALL-NEXT-METHOD to the
669 (defmethod component-depends-on ((op-spec symbol) (c component))
670 (component-depends-on (make-instance op-spec) c))
672 (defmethod component-depends-on ((o operation) (c component))
673 (cdr (assoc (class-name (class-of o))
674 (slot-value c 'in-order-to))))
676 (defgeneric component-self-dependencies (operation component))
678 (defmethod component-self-dependencies ((o operation) (c component))
679 (let ((all-deps (component-depends-on o c)))
680 (remove-if-not (lambda (x)
681 (member (component-name c) (cdr x) :test #'string=))
684 (defmethod input-files ((operation operation) (c component))
685 (let ((parent (component-parent c))
686 (self-deps (component-self-dependencies operation c)))
688 (mapcan (lambda (dep)
689 (destructuring-bind (op name) dep
690 (output-files (make-instance op)
691 (find-component parent name))))
693 ;; no previous operations needed? I guess we work with the
694 ;; original source file, then
695 (list (component-pathname c)))))
697 (defmethod input-files ((operation operation) (c module)) nil)
699 (defmethod operation-done-p ((o operation) (c component))
700 (flet ((fwd-or-return-t (file)
701 ;; if FILE-WRITE-DATE returns NIL, it's possible that the
702 ;; user or some other agent has deleted an input file. If
703 ;; that's the case, well, that's not good, but as long as
704 ;; the operation is otherwise considered to be done we
705 ;; could continue and survive.
706 (let ((date (file-write-date file)))
710 (warn "~@<Missing FILE-WRITE-DATE for ~S: treating ~
711 operation ~S on component ~S as done.~@:>"
713 (return-from operation-done-p t))))))
714 (let ((out-files (output-files o c))
715 (in-files (input-files o c)))
716 (cond ((and (not in-files) (not out-files))
717 ;; arbitrary decision: an operation that uses nothing to
718 ;; produce nothing probably isn't doing much
723 (component-operation-times c))))
727 (mapcar #'fwd-or-return-t in-files))))))
731 (every #'probe-file out-files)
732 (> (apply #'min (mapcar #'file-write-date out-files))
733 (apply #'max (mapcar #'fwd-or-return-t in-files)))))))))
735 ;;; So you look at this code and think "why isn't it a bunch of
736 ;;; methods". And the answer is, because standard method combination
737 ;;; runs :before methods most->least-specific, which is back to front
738 ;;; for our purposes.
740 (defgeneric traverse (operation component))
741 (defmethod traverse ((operation operation) (c component))
743 (labels ((%do-one-dep (required-op required-c required-v)
744 (let* ((dep-c (or (find-component
746 ;; XXX tacky. really we should build the
747 ;; in-order-to slot with canonicalized
748 ;; names instead of coercing this late
749 (coerce-name required-c) required-v)
751 (error 'missing-dependency-of-version
754 :requires required-c)
755 (error 'missing-dependency
757 :requires required-c))))
758 (op (make-sub-operation c operation dep-c required-op)))
759 (traverse op dep-c)))
760 (do-one-dep (required-op required-c required-v)
763 (return (%do-one-dep required-op required-c required-v))
766 (format s "~@<Retry loading component ~S.~@:>"
771 (print (list :c1 c (typep c 'missing-dependency)))
772 (when (typep c 'missing-dependency)
773 (print (list :c2 (missing-requires c) required-c
774 (equalp (missing-requires c)
777 (and (typep c 'missing-dependency)
778 (equalp (missing-requires c)
781 (cond ((eq op 'feature)
782 (or (member (car dep) *features*)
783 (error 'missing-dependency
785 :requires (car dep))))
790 (symbol-name (first d))
794 (do-one-dep op (second d) (third d))))
796 (symbol-name (first d))
798 (find (second d) *features*
799 :test 'string-equal))
802 (do-one-dep op (second d) (third d))))
804 (error "Dependencies must be (:version <version>), (:feature <feature>), or a name"))))
806 (appendf forced (do-one-dep op d nil)))))))))
807 (aif (component-visited-p operation c)
808 (return-from traverse
809 (if (cdr it) (list (cons 'pruned-op c)) nil)))
811 (if (component-visiting-p operation c)
812 (error 'circular-dependency :components (list c)))
813 (setf (visiting-component operation c) t)
816 (loop for (required-op . deps) in
817 (component-depends-on operation c)
818 do (do-dep required-op deps))
821 (when (typep c 'module)
822 (let ((at-least-one nil)
825 (loop for kid in (module-components c)
827 (appendf forced (traverse operation kid ))
828 (missing-dependency (condition)
829 (if (eq (module-if-component-dep-fails c)
832 (setf error condition))
835 (setf at-least-one t))))
836 (when (and (eq (module-if-component-dep-fails c)
841 ;; now the thing itself
842 (when (or forced module-ops
843 (not (operation-done-p operation c))
844 (let ((f (operation-forced
845 (operation-ancestor operation))))
846 (and f (or (not (consp f))
847 (member (component-name
848 (operation-ancestor operation))
849 (mapcar #'coerce-name f)
851 (let ((do-first (cdr (assoc (class-name (class-of operation))
852 (slot-value c 'do-first)))))
853 (loop for (required-op . deps) in do-first
854 do (do-dep required-op deps)))
855 (setf forced (append (delete 'pruned-op forced :key #'car)
856 (delete 'pruned-op module-ops :key #'car)
857 (list (cons operation c)))))))
858 (setf (visiting-component operation c) nil))
859 (visit-component operation c (and forced t))
863 (defmethod perform ((operation operation) (c source-file))
865 "~@<required method PERFORM not implemented ~
866 for operation ~A, component ~A~@:>"
867 (class-of operation) (class-of c)))
869 (defmethod perform ((operation operation) (c module))
872 (defmethod explain ((operation operation) (component component))
873 (asdf-message "~&;;; ~A on ~A~%" operation component))
877 (defclass compile-op (operation)
878 ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
879 (on-warnings :initarg :on-warnings :accessor operation-on-warnings
880 :initform *compile-file-warnings-behaviour*)
881 (on-failure :initarg :on-failure :accessor operation-on-failure
882 :initform *compile-file-failure-behaviour*)))
884 (defmethod perform :before ((operation compile-op) (c source-file))
885 (map nil #'ensure-directories-exist (output-files operation c)))
887 (defmethod perform :after ((operation operation) (c component))
888 (setf (gethash (type-of operation) (component-operation-times c))
889 (get-universal-time)))
891 ;;; perform is required to check output-files to find out where to put
892 ;;; its answers, in case it has been overridden for site policy
893 (defmethod perform ((operation compile-op) (c cl-source-file))
894 #-:broken-fasl-loader
895 (let ((source-file (component-pathname c))
896 (output-file (car (output-files operation c))))
897 (multiple-value-bind (output warnings-p failure-p)
898 (compile-file source-file :output-file output-file)
900 (case (operation-on-warnings operation)
902 "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
904 (:error (error 'compile-warned :component c :operation operation))
907 (case (operation-on-failure operation)
909 "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
911 (:error (error 'compile-failed :component c :operation operation))
914 (error 'compile-error :component c :operation operation)))))
916 (defmethod output-files ((operation compile-op) (c cl-source-file))
917 #-:broken-fasl-loader (list (compile-file-pathname (component-pathname c)))
918 #+:broken-fasl-loader (list (component-pathname c)))
920 (defmethod perform ((operation compile-op) (c static-file))
923 (defmethod output-files ((operation compile-op) (c static-file))
926 (defmethod input-files ((op compile-op) (c static-file))
932 (defclass basic-load-op (operation) ())
934 (defclass load-op (basic-load-op) ())
936 (defmethod perform ((o load-op) (c cl-source-file))
937 (mapcar #'load (input-files o c)))
939 (defmethod perform around ((o load-op) (c cl-source-file))
940 (let ((state :initial))
941 (loop until (or (eq state :success)
942 (eq state :failure)) do
945 (setf state :failure)
947 (setf state :success))
949 (setf state :recompiled)
950 (perform (make-instance 'asdf:compile-op) c))
953 (try-recompiling "Recompile ~a and try loading it again"
955 (setf state :failed-load)
957 (setf state :success)))))))
959 (defmethod perform around ((o compile-op) (c cl-source-file))
960 (let ((state :initial))
961 (loop until (or (eq state :success)
962 (eq state :failure)) do
965 (setf state :failure)
967 (setf state :success))
969 (setf state :recompiled)
970 (perform (make-instance 'asdf:compile-op) c))
973 (try-recompiling "Try recompiling ~a"
975 (setf state :failed-compile)
977 (setf state :success)))))))
979 (defmethod perform ((operation load-op) (c static-file))
982 (defmethod operation-done-p ((operation load-op) (c static-file))
985 (defmethod output-files ((o operation) (c component))
988 (defmethod component-depends-on ((operation load-op) (c component))
989 (cons (list 'compile-op (component-name c))
994 (defclass load-source-op (basic-load-op) ())
996 (defmethod perform ((o load-source-op) (c cl-source-file))
997 (let ((source (component-pathname c)))
998 (setf (component-property c 'last-loaded-as-source)
1000 (get-universal-time)))))
1002 (defmethod perform ((operation load-source-op) (c static-file))
1005 (defmethod output-files ((operation load-source-op) (c component))
1008 ;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right.
1009 (defmethod component-depends-on ((o load-source-op) (c component))
1010 (let ((what-would-load-op-do (cdr (assoc 'load-op
1011 (slot-value c 'in-order-to)))))
1012 (mapcar (lambda (dep)
1013 (if (eq (car dep) 'load-op)
1014 (cons 'load-source-op (cdr dep))
1016 what-would-load-op-do)))
1018 (defmethod operation-done-p ((o load-source-op) (c source-file))
1019 (if (or (not (component-property c 'last-loaded-as-source))
1020 (> (file-write-date (component-pathname c))
1021 (component-property c 'last-loaded-as-source)))
1024 (defclass test-op (operation) ())
1026 (defmethod perform ((operation test-op) (c component))
1029 (defmethod operation-done-p ((operation test-op) (c system))
1030 "Testing a system is _never_ done."
1033 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1034 ;;; invoking operations
1036 (defun operate (operation-class system &rest args &key (verbose t) version force
1038 (declare (ignore force))
1039 (let* ((*package* *package*)
1040 (*readtable* *readtable*)
1041 (op (apply #'make-instance operation-class
1042 :original-initargs args
1044 (*verbose-out* (if verbose *standard-output* (make-broadcast-stream)))
1045 (system (if (typep system 'component) system (find-system system))))
1046 (unless (version-satisfies system version)
1047 (error 'missing-component-of-version :requires system :version version))
1048 (let ((steps (traverse op system)))
1049 (with-compilation-unit ()
1050 (loop for (op . component) in steps do
1053 (progn (perform op component)
1058 (format s "~@<Retry performing ~S on ~S.~@:>"
1063 (format s "~@<Continue, treating ~S on ~S as ~
1064 having been successful.~@:>"
1066 (setf (gethash (type-of op)
1067 (component-operation-times component))
1068 (get-universal-time))
1071 (defun oos (operation-class system &rest args &key force (verbose t) version
1073 (declare (ignore force verbose version))
1074 (apply #'operate operation-class system args))
1076 (let ((operate-docstring
1077 "Operate does three things:
1079 1. It creates an instance of `operation-class` using any keyword parameters
1081 2. It finds the asdf-system specified by `system` (possibly loading
1083 3. It then calls `traverse` with the operation and system as arguments
1085 The traverse operation is wrapped in `with-compilation-unit` and error
1086 handling code. If a `version` argument is supplied, then operate also
1087 ensures that the system found satisfies it using the `version-satisfies`
1089 (setf (documentation 'oos 'function)
1091 "Short for _operate on system_ and an alias for the [operate][] function. ~&~&~a"
1093 (setf (documentation 'operate 'function)
1096 (defun load-system (system &rest args &key force (verbose t) version)
1097 "Shorthand for `(operate 'asdf:load-op system)`. See [operate][] for details."
1098 (declare (ignore force verbose version))
1099 (apply #'operate 'load-op system args))
1101 (defun compile-system (system &rest args &key force (verbose t) version)
1102 "Shorthand for `(operate 'asdf:compile-op system)`. See [operate][] for details."
1103 (declare (ignore force verbose version))
1104 (apply #'operate 'compile-op system args))
1106 (defun test-system (system &rest args &key force (verbose t) version)
1107 "Shorthand for `(operate 'asdf:test-op system)`. See [operate][] for details."
1108 (declare (ignore force verbose version))
1109 (apply #'operate 'test-op system args))
1111 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1114 (defun remove-keyword (key arglist)
1115 (labels ((aux (key arglist)
1116 (cond ((null arglist) nil)
1117 ((eq key (car arglist)) (cddr arglist))
1118 (t (cons (car arglist) (cons (cadr arglist)
1120 key (cddr arglist))))))))
1123 (defmacro defsystem (name &body options)
1124 (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
1127 (let ((component-options (remove-keyword :class options)))
1129 ;; system must be registered before we parse the body, otherwise
1130 ;; we recur when trying to find an existing system of the same name
1131 ;; to reuse options (e.g. pathname) from
1132 (let ((s (system-registered-p ',name)))
1133 (cond ((and s (eq (type-of (cdr s)) ',class))
1134 (setf (car s) (get-universal-time)))
1136 (change-class (cdr s) ',class))
1138 (register-system (quote ,name)
1139 (make-instance ',class :name ',name)))))
1140 (parse-component-form nil (apply
1142 :module (coerce-name ',name)
1144 ;; to avoid a note about unreachable code
1147 `(or (when *load-truename*
1148 (pathname-sans-name+type
1151 *default-pathname-defaults*))
1152 ',component-options))))))
1155 (defun class-for-type (parent type)
1156 (let* ((extra-symbols (list (find-symbol (symbol-name type) *package*)
1157 (find-symbol (symbol-name type)
1159 (package-name :asdf)))))
1160 (class (dolist (symbol (if (keywordp type)
1162 (cons type extra-symbols)))
1164 (find-class symbol nil)
1165 (subtypep symbol 'component))
1166 (return (find-class symbol))))))
1168 (and (eq type :file)
1169 (or (module-default-component-class parent)
1170 (find-class 'cl-source-file)))
1171 (sysdef-error "~@<don't recognize component type ~A~@:>" type))))
1173 (defun maybe-add-tree (tree op1 op2 c)
1174 "Add the node C at /OP1/OP2 in TREE, unless it's there already.
1175 Returns the new tree (which probably shares structure with the old one)"
1176 (let ((first-op-tree (assoc op1 tree)))
1179 (aif (assoc op2 (cdr first-op-tree))
1180 (if (find c (cdr it))
1182 (setf (cdr it) (cons c (cdr it))))
1183 (setf (cdr first-op-tree)
1184 (acons op2 (list c) (cdr first-op-tree))))
1186 (acons op1 (list (list op2 c)) tree))))
1188 (defun union-of-dependencies (&rest deps)
1189 (let ((new-tree nil))
1191 (dolist (op-tree dep)
1192 (dolist (op (cdr op-tree))
1193 (dolist (c (cdr op))
1195 (maybe-add-tree new-tree (car op-tree) (car op) c))))))
1199 (defun remove-keys (key-names args)
1200 (loop for ( name val ) on args by #'cddr
1201 unless (member (symbol-name name) key-names
1202 :key #'symbol-name :test 'equal)
1203 append (list name val)))
1205 (defvar *serial-depends-on*)
1207 (defun sysdef-error-component (msg type name value)
1208 (sysdef-error (concatenate 'string msg
1209 "~&The value specified for ~(~A~) ~A is ~W")
1212 (defun check-component-input (type name weakly-depends-on depends-on components in-order-to)
1213 "A partial test of the values of a component."
1214 (when weakly-depends-on (warn "We got one! XXXXX"))
1215 (unless (listp depends-on)
1216 (sysdef-error-component ":depends-on must be a list."
1217 type name depends-on))
1218 (unless (listp weakly-depends-on)
1219 (sysdef-error-component ":weakly-depends-on must be a list."
1220 type name weakly-depends-on))
1221 (unless (listp components)
1222 (sysdef-error-component ":components must be NIL or a list of components."
1223 type name components))
1224 (unless (and (listp in-order-to) (listp (car in-order-to)))
1225 (sysdef-error-component ":in-order-to must be NIL or a list of components."
1226 type name in-order-to)))
1228 (defun %remove-component-inline-methods (ret rest)
1229 (loop for name in +asdf-methods+
1231 ;; this is inefficient as most of the stored
1232 ;; methods will not be for this particular gf n
1233 ;; But this is hardly performance-critical
1235 (remove-method (symbol-function name) m))
1236 (component-inline-methods ret)))
1237 ;; clear methods, then add the new ones
1238 (setf (component-inline-methods ret) nil)
1239 (loop for name in +asdf-methods+
1240 for v = (getf rest (intern (symbol-name name) :keyword))
1242 (destructuring-bind (op qual (o c) &body body) v
1244 (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
1246 (component-inline-methods ret)))))
1248 (defun parse-component-form (parent options)
1251 (type name &rest rest &key
1252 ;; the following list of keywords is reproduced below in the
1253 ;; remove-keys form. important to keep them in sync
1254 components pathname default-component-class
1255 perform explain output-files operation-done-p
1257 depends-on serial in-order-to
1259 &allow-other-keys) options
1260 (declare (ignorable perform explain output-files operation-done-p))
1261 (check-component-input type name weakly-depends-on depends-on components in-order-to)
1264 (find-component parent name)
1265 ;; ignore the same object when rereading the defsystem
1267 (typep (find-component parent name)
1268 (class-for-type parent type))))
1269 (error 'duplicate-names :name name))
1271 (let* ((other-args (remove-keys
1272 '(components pathname default-component-class
1273 perform explain output-files operation-done-p
1275 depends-on serial in-order-to)
1278 (or (find-component parent name)
1279 (make-instance (class-for-type parent type)))))
1280 (when weakly-depends-on
1281 (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on))))
1282 (when (boundp '*serial-depends-on*)
1284 (concatenate 'list *serial-depends-on* depends-on)))
1285 (apply #'reinitialize-instance ret
1286 :name (coerce-name name)
1290 (when (typep ret 'module)
1291 (setf (module-default-component-class ret)
1292 (or default-component-class
1293 (and (typep parent 'module)
1294 (module-default-component-class parent))))
1295 (let ((*serial-depends-on* nil))
1296 (setf (module-components ret)
1297 (loop for c-form in components
1298 for c = (parse-component-form ret c-form)
1301 do (push (component-name c) *serial-depends-on*))))
1303 ;; check for duplicate names
1304 (let ((name-hash (make-hash-table :test #'equal)))
1305 (loop for c in (module-components ret)
1307 (if (gethash (component-name c)
1309 (error 'duplicate-names
1310 :name (component-name c))
1311 (setf (gethash (component-name c)
1315 (setf (slot-value ret 'in-order-to)
1316 (union-of-dependencies
1318 `((compile-op (compile-op ,@depends-on))
1319 (load-op (load-op ,@depends-on))))
1320 (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on))))
1322 (%remove-component-inline-methods ret rest)
1326 (defun resolve-symlinks (path)
1327 #-allegro (truename path)
1328 #+allegro (excl:pathname-resolve-symbolic-links path)
1333 ;;; run-shell-command functions for other lisp implementations will be
1334 ;;; gratefully accepted, if they do the same thing. If the docstring
1335 ;;; is ambiguous, send a bug report
1337 (defun run-shell-command (control-string &rest args)
1338 "Interpolate `args` into `control-string` as if by `format`, and
1339 synchronously execute the result using a Bourne-compatible shell, with
1340 output to `*verbose-out*`. Returns the shell's exit code."
1341 (let ((command (apply #'format nil control-string args)))
1342 (asdf-message "; $ ~A~%" command)
1344 (sb-ext:process-exit-code
1346 #+win32 "sh" #-win32 "/bin/sh"
1348 #+win32 #+win32 :search t
1349 :input nil :output *verbose-out*))
1352 (ext:process-exit-code
1356 :input nil :output *verbose-out*))
1359 ;; will this fail if command has embedded quotes - it seems to work
1360 (multiple-value-bind (stdout stderr exit-code)
1361 (excl.osi:command-output
1362 (format nil "~a -c \"~a\""
1363 #+mswindows "sh" #-mswindows "/bin/sh" command)
1364 :input nil :whole nil
1365 #+mswindows :show-window #+mswindows :hide)
1366 (format *verbose-out* "~{~&; ~a~%~}~%" stderr)
1367 (format *verbose-out* "~{~&; ~a~%~}~%" stdout)
1371 (system:call-system-showing-output
1373 :shell-type "/bin/sh"
1374 :output-stream *verbose-out*)
1376 #+clisp ;XXX not exactly *verbose-out*, I know
1377 (ext:run-shell-command command :output :terminal :wait t)
1381 (ccl:external-process-status
1382 (ccl:run-program "/bin/sh" (list "-c" command)
1383 :input nil :output *verbose-out*
1386 #+ecl ;; courtesy of Juan Jose Garcia Ripoll
1389 #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl)
1390 (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
1393 (defgeneric system-source-file (system)
1394 (:documentation "Return the source file in which system is defined."))
1396 (defmethod system-source-file ((system-name t))
1397 (system-source-file (find-system system-name)))
1399 (defmethod system-source-file ((system system))
1400 (let ((pn (and (slot-boundp system 'relative-pathname)
1403 :name (asdf:component-name system)
1404 :defaults (asdf:component-relative-pathname system)))))
1408 (defun system-source-directory (system-name)
1409 (make-pathname :name nil
1411 :defaults (system-source-file system-name)))
1413 (defun system-relative-pathname (system pathname &key name type)
1414 ;; you're not allowed to muck with the return value of pathname-X
1415 (let ((directory (copy-list (pathname-directory pathname))))
1416 (when (eq (car directory) :absolute)
1417 (setf (car directory) :relative))
1419 (make-pathname :name (or name (pathname-name pathname))
1420 :type (or type (pathname-type pathname))
1421 :directory directory)
1422 (system-source-directory system))))
1424 (pushnew :asdf *features*)
1427 (eval-when (:compile-toplevel :load-toplevel :execute)
1428 (when (sb-ext:posix-getenv "SBCL_BUILDING_CONTRIB")
1429 (pushnew :sbcl-hooks-require *features*)))
1431 #+(and sbcl sbcl-hooks-require)
1433 (defun module-provide-asdf (name)
1434 (handler-bind ((style-warning #'muffle-warning))
1435 (let* ((*verbose-out* (make-broadcast-stream))
1436 (system (asdf:find-system name nil)))
1438 (asdf:operate 'asdf:load-op name)
1441 (defun contrib-sysdef-search (system)
1442 (let ((home (sb-ext:posix-getenv "SBCL_HOME")))
1443 (when (and home (not (string= home "")))
1444 (let* ((name (coerce-name system))
1445 (home (truename home))
1446 (contrib (merge-pathnames
1447 (make-pathname :directory `(:relative ,name)
1453 (probe-file contrib)))))
1456 '(let ((home (sb-ext:posix-getenv "SBCL_HOME")))
1457 (when (and home (not (string= home "")))
1458 (merge-pathnames "site-systems/" (truename home))))
1462 '(merge-pathnames ".sbcl/systems/"
1463 (user-homedir-pathname))
1466 (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)
1467 (pushnew 'contrib-sysdef-search *system-definition-search-functions*))
1470 (asdf-message ";; ASDF, revision ~a" *asdf-revision*)
1471 (asdf-message ";; ASDF, revision unknown; possibly a development version"))