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*))