/[cells]/cells-gtk3/asdf.lisp
ViewVC logotype

Contents of /cells-gtk3/asdf.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Sun Apr 13 10:59:16 2008 UTC (6 years ago) by phildebrandt
Branch: MAIN
CVS Tags: HEAD
cells-gtk3 initial.
1 ;;; This is asdf: Another System Definition Facility. $Revision: 1.1 $
2 ;;;
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/>
7 ;;;
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'
15
16 ;;; Copyright (c) 2001-2003 Daniel Barlow and contributors
17 ;;;
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:
25 ;;;
26 ;;; The above copyright notice and this permission notice shall be
27 ;;; included in all copies or substantial portions of the Software.
28 ;;;
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.
36
37 ;;; the problem with writing a defsystem replacement is bootstrapping:
38 ;;; we can't use defsystem to compile it. Hence, all in one file
39
40 (defpackage #:asdf
41 (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command
42 #:system-definition-pathname #:find-component ; miscellaneous
43 #:hyperdocumentation #:hyperdoc
44
45 #:compile-op #:load-op #:load-source-op #:test-system-version
46 #:test-op
47 #:operation ; operations
48 #:feature ; sort-of operation
49 #:version ; metaphorically sort-of an operation
50
51 #:input-files #:output-files #:perform ; operation methods
52 #:operation-done-p #:explain
53
54 #:component #:source-file
55 #:c-source-file #:cl-source-file #:java-source-file
56 #:static-file
57 #:doc-file
58 #:html-file
59 #:text-file
60 #:source-file-type
61 #:module ; components
62 #:system
63 #:unix-dso
64
65 #:module-components ; component accessors
66 #:component-pathname
67 #:component-relative-pathname
68 #:component-name
69 #:component-version
70 #:component-parent
71 #:component-property
72 #:component-system
73
74 #:component-depends-on
75
76 #:system-description
77 #:system-long-description
78 #:system-author
79 #:system-maintainer
80 #:system-license
81
82 #:operation-on-warnings
83 #:operation-on-failure
84
85 ;#:*component-parent-pathname*
86 #:*system-definition-search-functions*
87 #:*central-registry* ; variables
88 #:*compile-file-warnings-behaviour*
89 #:*compile-file-failure-behaviour*
90 #:*asdf-revision*
91
92 #:operation-error #:compile-failed #:compile-warned #:compile-error
93 #:system-definition-error
94 #:missing-component
95 #:missing-dependency
96 #:circular-dependency ; errors
97
98 #:retry
99 #:accept ; restarts
100
101 )
102 (:use :cl))
103
104 #+nil
105 (error "The author of this file habitually uses #+nil to comment out forms. But don't worry, it was unlikely to work in the New Implementation of Lisp anyway")
106
107
108 (in-package #:asdf)
109
110 (defvar *asdf-revision* (let* ((v "$Revision: 1.1 $")
111 (colon (or (position #\: v) -1))
112 (dot (position #\. v)))
113 (and v colon dot
114 (list (parse-integer v :start (1+ colon)
115 :junk-allowed t)
116 (parse-integer v :start (1+ dot)
117 :junk-allowed t)))))
118
119 (defvar *compile-file-warnings-behaviour* :warn)
120 (defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn)
121
122 (defvar *verbose-out* nil)
123
124 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
125 ;; utility stuff
126
127 (defmacro aif (test then &optional else)
128 `(let ((it ,test)) (if it ,then ,else)))
129
130 (defun pathname-sans-name+type (pathname)
131 "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
132 and NIL NAME and TYPE components"
133 (make-pathname :name nil :type nil :defaults pathname))
134
135 (define-modify-macro appendf (&rest args)
136 append "Append onto list")
137
138 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
139 ;; classes, condiitons
140
141 (define-condition system-definition-error (error) ()
142 ;; [this use of :report should be redundant, but unfortunately it's not.
143 ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
144 ;; over print-object; this is always conditions::%print-condition for
145 ;; condition objects, which in turn does inheritance of :report options at
146 ;; run-time. fortunately, inheritance means we only need this kludge here in
147 ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.]
148 #+cmu (:report print-object))
149
150 (define-condition formatted-system-definition-error (system-definition-error)
151 ((format-control :initarg :format-control :reader format-control)
152 (format-arguments :initarg :format-arguments :reader format-arguments))
153 (:report (lambda (c s)
154 (apply #'format s (format-control c) (format-arguments c)))))
155
156 (define-condition circular-dependency (system-definition-error)
157 ((components :initarg :components :reader circular-dependency-components)))
158
159 (define-condition missing-component (system-definition-error)
160 ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
161 (version :initform nil :reader missing-version :initarg :version)
162 (parent :initform nil :reader missing-parent :initarg :parent)))
163
164 (define-condition missing-dependency (missing-component)
165 ((required-by :initarg :required-by :reader missing-required-by)))
166
167 (define-condition operation-error (error)
168 ((component :reader error-component :initarg :component)
169 (operation :reader error-operation :initarg :operation))
170 (:report (lambda (c s)
171 (format s "~@<erred while invoking ~A on ~A~@:>"
172 (error-operation c) (error-component c)))))
173 (define-condition compile-error (operation-error) ())
174 (define-condition compile-failed (compile-error) ())
175 (define-condition compile-warned (compile-error) ())
176
177 (defclass component ()
178 ((name :accessor component-name :initarg :name :documentation
179 "Component name: designator for a string composed of portable pathname characters")
180 (version :accessor component-version :initarg :version)
181 (in-order-to :initform nil :initarg :in-order-to)
182 ;;; XXX crap name
183 (do-first :initform nil :initarg :do-first)
184 ;; methods defined using the "inline" style inside a defsystem form:
185 ;; need to store them somewhere so we can delete them when the system
186 ;; is re-evaluated
187 (inline-methods :accessor component-inline-methods :initform nil)
188 (parent :initarg :parent :initform nil :reader component-parent)
189 ;; no direct accessor for pathname, we do this as a method to allow
190 ;; it to default in funky ways if not supplied
191 (relative-pathname :initarg :pathname)
192 (operation-times :initform (make-hash-table )
193 :accessor component-operation-times)
194 ;; XXX we should provide some atomic interface for updating the
195 ;; component properties
196 (properties :accessor component-properties :initarg :properties
197 :initform nil)))
198
199 ;;;; methods: conditions
200
201 (defmethod print-object ((c missing-dependency) s)
202 (format s "~@<~A, required by ~A~@:>"
203 (call-next-method c nil) (missing-required-by c)))
204
205 (defun sysdef-error (format &rest arguments)
206 (error 'formatted-system-definition-error :format-control format :format-arguments arguments))
207
208 ;;;; methods: components
209
210 (defmethod print-object ((c missing-component) s)
211 (format s "~@<component ~S not found~
212 ~@[ or does not match version ~A~]~
213 ~@[ in ~A~]~@:>"
214 (missing-requires c)
215 (missing-version c)
216 (when (missing-parent c)
217 (component-name (missing-parent c)))))
218
219 (defgeneric component-system (component)
220 (:documentation "Find the top-level system containing COMPONENT"))
221
222 (defmethod component-system ((component component))
223 (aif (component-parent component)
224 (component-system it)
225 component))
226
227 (defmethod print-object ((c component) stream)
228 (print-unreadable-object (c stream :type t :identity t)
229 (ignore-errors
230 (prin1 (component-name c) stream))))
231
232 (defclass module (component)
233 ((components :initform nil :accessor module-components :initarg :components)
234 ;; what to do if we can't satisfy a dependency of one of this module's
235 ;; components. This allows a limited form of conditional processing
236 (if-component-dep-fails :initform :fail
237 :accessor module-if-component-dep-fails
238 :initarg :if-component-dep-fails)
239 (default-component-class :accessor module-default-component-class
240 :initform 'cl-source-file :initarg :default-component-class)))
241
242 (defgeneric component-pathname (component)
243 (:documentation "Extracts the pathname applicable for a particular component."))
244
245 (defun component-parent-pathname (component)
246 (aif (component-parent component)
247 (component-pathname it)
248 *default-pathname-defaults*))
249
250 (defgeneric component-relative-pathname (component)
251 (:documentation "Extracts the relative pathname applicable for a particular component."))
252
253 (defmethod component-relative-pathname ((component module))
254 (or (slot-value component 'relative-pathname)
255 (make-pathname
256 :directory `(:relative ,(component-name component))
257 :host (pathname-host (component-parent-pathname component)))))
258
259 (defmethod component-pathname ((component component))
260 (let ((*default-pathname-defaults* (component-parent-pathname component)))
261 (merge-pathnames (component-relative-pathname component))))
262
263 (defgeneric component-property (component property))
264
265 (defmethod component-property ((c component) property)
266 (cdr (assoc property (slot-value c 'properties) :test #'equal)))
267
268 (defgeneric (setf component-property) (new-value component property))
269
270 (defmethod (setf component-property) (new-value (c component) property)
271 (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
272 (if a
273 (setf (cdr a) new-value)
274 (setf (slot-value c 'properties)
275 (acons property new-value (slot-value c 'properties))))))
276
277 (defclass system (module)
278 ((description :accessor system-description :initarg :description)
279 (long-description
280 :accessor system-long-description :initarg :long-description)
281 (author :accessor system-author :initarg :author)
282 (maintainer :accessor system-maintainer :initarg :maintainer)
283 (licence :accessor system-licence :initarg :licence)))
284
285 ;;; version-satisfies
286
287 ;;; with apologies to christophe rhodes ...
288 (defun split (string &optional max (ws '(#\Space #\Tab)))
289 (flet ((is-ws (char) (find char ws)))
290 (nreverse
291 (let ((list nil) (start 0) (words 0) end)
292 (loop
293 (when (and max (>= words (1- max)))
294 (return (cons (subseq string start) list)))
295 (setf end (position-if #'is-ws string :start start))
296 (push (subseq string start end) list)
297 (incf words)
298 (unless end (return list))
299 (setf start (1+ end)))))))
300
301 (defgeneric version-satisfies (component version))
302
303 (defmethod version-satisfies ((c component) version)
304 (unless (and version (slot-boundp c 'version))
305 (return-from version-satisfies t))
306 (let ((x (mapcar #'parse-integer
307 (split (component-version c) nil '(#\.))))
308 (y (mapcar #'parse-integer
309 (split version nil '(#\.)))))
310 (labels ((bigger (x y)
311 (cond ((not y) t)
312 ((not x) nil)
313 ((> (car x) (car y)) t)
314 ((= (car x) (car y))
315 (bigger (cdr x) (cdr y))))))
316 (and (= (car x) (car y))
317 (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
318
319 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
320 ;;; finding systems
321
322 (defvar *defined-systems* (make-hash-table :test 'equal))
323 (defun coerce-name (name)
324 (typecase name
325 (component (component-name name))
326 (symbol (string-downcase (symbol-name name)))
327 (string name)
328 (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
329
330 ;;; for the sake of keeping things reasonably neat, we adopt a
331 ;;; convention that functions in this list are prefixed SYSDEF-
332
333 (defvar *system-definition-search-functions*
334 '(sysdef-central-registry-search))
335
336 (defun system-definition-pathname (system)
337 (some (lambda (x) (funcall x system))
338 *system-definition-search-functions*))
339
340 (defvar *central-registry*
341 '(*default-pathname-defaults*
342 #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/"
343 #+nil "telent:asdf;systems;"))
344
345 (defun sysdef-central-registry-search (system)
346 (let ((name (coerce-name system)))
347 (block nil
348 (dolist (dir *central-registry*)
349 (let* ((defaults (eval dir))
350 (file (and defaults
351 (make-pathname
352 :defaults defaults :version :newest
353 :name name :type "asd" :case :local))))
354 (if (and file (probe-file file))
355 (return file)))))))
356
357
358 (defun find-system (name &optional (error-p t))
359 (let* ((name (coerce-name name))
360 (in-memory (gethash name *defined-systems*))
361 (on-disk (system-definition-pathname name)))
362 (when (and on-disk
363 (or (not in-memory)
364 (< (car in-memory) (file-write-date on-disk))))
365 (let ((*package* (make-package (gensym (package-name #.*package*))
366 :use '(:cl :asdf))))
367 (format *verbose-out*
368 "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
369 ;; FIXME: This wants to be (ENOUGH-NAMESTRING
370 ;; ON-DISK), but CMUCL barfs on that.
371 on-disk
372 *package*)
373 (load on-disk)))
374 (let ((in-memory (gethash name *defined-systems*)))
375 (if in-memory
376 (progn (if on-disk (setf (car in-memory) (file-write-date on-disk)))
377 (cdr in-memory))
378 (if error-p (error 'missing-component :requires name))))))
379
380 (defun register-system (name system)
381 (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
382 (setf (gethash (coerce-name name) *defined-systems*)
383 (cons (get-universal-time) system)))
384
385 (defun system-registered-p (name)
386 (gethash (coerce-name name) *defined-systems*))
387
388 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
389 ;;; finding components
390
391 (defgeneric find-component (module name &optional version)
392 (:documentation "Finds the component with name NAME present in the
393 MODULE module; if MODULE is nil, then the component is assumed to be a
394 system."))
395
396 (defmethod find-component ((module module) name &optional version)
397 (if (slot-boundp module 'components)
398 (let ((m (find name (module-components module)
399 :test #'equal :key #'component-name)))
400 (if (and m (version-satisfies m version)) m))))
401
402
403 ;;; a component with no parent is a system
404 (defmethod find-component ((module (eql nil)) name &optional version)
405 (let ((m (find-system name nil)))
406 (if (and m (version-satisfies m version)) m)))
407
408 ;;; component subclasses
409
410 (defclass source-file (component) ())
411
412 (defclass cl-source-file (source-file) ())
413 (defclass c-source-file (source-file) ())
414 (defclass java-source-file (source-file) ())
415 (defclass static-file (source-file) ())
416 (defclass doc-file (static-file) ())
417 (defclass html-file (doc-file) ())
418
419 (defgeneric source-file-type (component system))
420 (defmethod source-file-type ((c cl-source-file) (s module)) "lisp")
421 (defmethod source-file-type ((c c-source-file) (s module)) "c")
422 (defmethod source-file-type ((c java-source-file) (s module)) "java")
423 (defmethod source-file-type ((c html-file) (s module)) "html")
424 (defmethod source-file-type ((c static-file) (s module)) nil)
425
426 (defmethod component-relative-pathname ((component source-file))
427 (let* ((*default-pathname-defaults* (component-parent-pathname component))
428 (name-type
429 (make-pathname
430 :name (component-name component)
431 :type (source-file-type component
432 (component-system component)))))
433 (if (slot-value component 'relative-pathname)
434 (merge-pathnames
435 (slot-value component 'relative-pathname)
436 name-type)
437 name-type)))
438
439 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
440 ;;; operations
441
442 ;;; one of these is instantiated whenever (operate ) is called
443
444 (defclass operation ()
445 ((forced :initform nil :initarg :force :accessor operation-forced)
446 (original-initargs :initform nil :initarg :original-initargs
447 :accessor operation-original-initargs)
448 (visited-nodes :initform nil :accessor operation-visited-nodes)
449 (visiting-nodes :initform nil :accessor operation-visiting-nodes)
450 (parent :initform nil :initarg :parent :accessor operation-parent)))
451
452 (defmethod print-object ((o operation) stream)
453 (print-unreadable-object (o stream :type t :identity t)
454 (ignore-errors
455 (prin1 (operation-original-initargs o) stream))))
456
457 (defmethod shared-initialize :after ((operation operation) slot-names
458 &key force
459 &allow-other-keys)
460 (declare (ignore slot-names force))
461 ;; empty method to disable initarg validity checking
462 )
463
464 (defgeneric perform (operation component))
465 (defgeneric operation-done-p (operation component))
466 (defgeneric explain (operation component))
467 (defgeneric output-files (operation component))
468 (defgeneric input-files (operation component))
469
470 (defun node-for (o c)
471 (cons (class-name (class-of o)) c))
472
473 (defgeneric operation-ancestor (operation)
474 (:documentation "Recursively chase the operation's parent pointer until we get to the head of the tree"))
475
476 (defmethod operation-ancestor ((operation operation))
477 (aif (operation-parent operation)
478 (operation-ancestor it)
479 operation))
480
481
482 (defun make-sub-operation (c o dep-c dep-o)
483 (let* ((args (copy-list (operation-original-initargs o)))
484 (force-p (getf args :force)))
485 ;; note explicit comparison with T: any other non-NIL force value
486 ;; (e.g. :recursive) will pass through
487 (cond ((and (null (component-parent c))
488 (null (component-parent dep-c))
489 (not (eql c dep-c)))
490 (when (eql force-p t)
491 (setf (getf args :force) nil))
492 (apply #'make-instance dep-o
493 :parent o
494 :original-initargs args args))
495 ((subtypep (type-of o) dep-o)
496 o)
497 (t
498 (apply #'make-instance dep-o
499 :parent o :original-initargs args args)))))
500
501
502 (defgeneric visit-component (operation component data))
503
504 (defmethod visit-component ((o operation) (c component) data)
505 (unless (component-visited-p o c)
506 (push (cons (node-for o c) data)
507 (operation-visited-nodes (operation-ancestor o)))))
508
509 (defgeneric component-visited-p (operation component))
510
511 (defmethod component-visited-p ((o operation) (c component))
512 (assoc (node-for o c)
513 (operation-visited-nodes (operation-ancestor o))
514 :test 'equal))
515
516 (defgeneric (setf visiting-component) (new-value operation component))
517
518 (defmethod (setf visiting-component) (new-value operation component)
519 ;; MCL complains about unused lexical variables
520 (declare (ignorable new-value operation component)))
521
522 (defmethod (setf visiting-component) (new-value (o operation) (c component))
523 (let ((node (node-for o c))
524 (a (operation-ancestor o)))
525 (if new-value
526 (pushnew node (operation-visiting-nodes a) :test 'equal)
527 (setf (operation-visiting-nodes a)
528 (remove node (operation-visiting-nodes a) :test 'equal)))))
529
530 (defgeneric component-visiting-p (operation component))
531
532 (defmethod component-visiting-p ((o operation) (c component))
533 (let ((node (cons o c)))
534 (member node (operation-visiting-nodes (operation-ancestor o))
535 :test 'equal)))
536
537 (defgeneric component-depends-on (operation component))
538
539 (defmethod component-depends-on ((o operation) (c component))
540 (cdr (assoc (class-name (class-of o))
541 (slot-value c 'in-order-to))))
542
543 (defgeneric component-self-dependencies (operation component))
544
545 (defmethod component-self-dependencies ((o operation) (c component))
546 (let ((all-deps (component-depends-on o c)))
547 (remove-if-not (lambda (x)
548 (member (component-name c) (cdr x) :test #'string=))
549 all-deps)))
550
551 (defmethod input-files ((operation operation) (c component))
552 (let ((parent (component-parent c))
553 (self-deps (component-self-dependencies operation c)))
554 (if self-deps
555 (mapcan (lambda (dep)
556 (destructuring-bind (op name) dep
557 (output-files (make-instance op)
558 (find-component parent name))))
559 self-deps)
560 ;; no previous operations needed? I guess we work with the
561 ;; original source file, then
562 (list (component-pathname c)))))
563
564 (defmethod input-files ((operation operation) (c module)) nil)
565
566 (defmethod operation-done-p ((o operation) (c component))
567 (let ((out-files (output-files o c))
568 (in-files (input-files o c)))
569 (cond ((and (not in-files) (not out-files))
570 ;; arbitrary decision: an operation that uses nothing to
571 ;; produce nothing probably isn't doing much
572 t)
573 ((not out-files)
574 (let ((op-done
575 (gethash (type-of o)
576 (component-operation-times c))))
577 (and op-done
578 (>= op-done
579 (or (apply #'max
580 (mapcar #'file-write-date in-files)) 0)))))
581 ((not in-files) nil)
582 (t
583 (and
584 (every #'probe-file out-files)
585 (> (apply #'min (mapcar #'file-write-date out-files))
586 (apply #'max (mapcar #'file-write-date in-files)) ))))))
587
588 ;;; So you look at this code and think "why isn't it a bunch of
589 ;;; methods". And the answer is, because standard method combination
590 ;;; runs :before methods most->least-specific, which is back to front
591 ;;; for our purposes. And CLISP doesn't have non-standard method
592 ;;; combinations, so let's keep it simple and aspire to portability
593
594 (defgeneric traverse (operation component))
595 (defmethod traverse ((operation operation) (c component))
596 (let ((forced nil))
597 (labels ((do-one-dep (required-op required-c required-v)
598 (let* ((dep-c (or (find-component
599 (component-parent c)
600 ;; XXX tacky. really we should build the
601 ;; in-order-to slot with canonicalized
602 ;; names instead of coercing this late
603 (coerce-name required-c) required-v)
604 (error 'missing-dependency :required-by c
605 :version required-v
606 :requires required-c)))
607 (op (make-sub-operation c operation dep-c required-op)))
608 (traverse op dep-c)))
609 (do-dep (op dep)
610 (cond ((eq op 'feature)
611 (or (member (car dep) *features*)
612 (error 'missing-dependency :required-by c
613 :requires (car dep) :version nil)))
614 (t
615 (dolist (d dep)
616 (cond ((consp d)
617 (assert (string-equal
618 (symbol-name (first d))
619 "VERSION"))
620 (appendf forced
621 (do-one-dep op (second d) (third d))))
622 (t
623 (appendf forced (do-one-dep op d nil)))))))))
624 (aif (component-visited-p operation c)
625 (return-from traverse
626 (if (cdr it) (list (cons 'pruned-op c)) nil)))
627 ;; dependencies
628 (if (component-visiting-p operation c)
629 (error 'circular-dependency :components (list c)))
630 (setf (visiting-component operation c) t)
631 (loop for (required-op . deps) in (component-depends-on operation c)
632 do (do-dep required-op deps))
633 ;; constituent bits
634 (let ((module-ops
635 (when (typep c 'module)
636 (let ((at-least-one nil)
637 (forced nil)
638 (error nil))
639 (loop for kid in (module-components c)
640 do (handler-case
641 (appendf forced (traverse operation kid ))
642 (missing-dependency (condition)
643 (if (eq (module-if-component-dep-fails c) :fail)
644 (error condition))
645 (setf error condition))
646 (:no-error (c)
647 (declare (ignore c))
648 (setf at-least-one t))))
649 (when (and (eq (module-if-component-dep-fails c) :try-next)
650 (not at-least-one))
651 (error error))
652 forced))))
653 ;; now the thing itself
654 (when (or forced module-ops
655 (not (operation-done-p operation c))
656 (let ((f (operation-forced (operation-ancestor operation))))
657 (and f (or (not (consp f))
658 (member (component-name
659 (operation-ancestor operation))
660 (mapcar #'coerce-name f)
661 :test #'string=)))))
662 (let ((do-first (cdr (assoc (class-name (class-of operation))
663 (slot-value c 'do-first)))))
664 (loop for (required-op . deps) in do-first
665 do (do-dep required-op deps)))
666 (setf forced (append (delete 'pruned-op forced :key #'car)
667 (delete 'pruned-op module-ops :key #'car)
668 (list (cons operation c))))))
669 (setf (visiting-component operation c) nil)
670 (visit-component operation c (and forced t))
671 forced)))
672
673
674 (defmethod perform ((operation operation) (c source-file))
675 (sysdef-error
676 "~@<required method PERFORM not implemented ~
677 for operation ~A, component ~A~@:>"
678 (class-of operation) (class-of c)))
679
680 (defmethod perform ((operation operation) (c module))
681 nil)
682
683 (defmethod explain ((operation operation) (component component))
684 (format *verbose-out* "~&;;; ~A on ~A~%" operation component))
685
686 ;;; compile-op
687
688 (defclass compile-op (operation)
689 ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
690 (on-warnings :initarg :on-warnings :accessor operation-on-warnings
691 :initform *compile-file-warnings-behaviour*)
692 (on-failure :initarg :on-failure :accessor operation-on-failure
693 :initform *compile-file-failure-behaviour*)))
694
695 (defmethod perform :before ((operation compile-op) (c source-file))
696 (map nil #'ensure-directories-exist (output-files operation c)))
697
698 (defmethod perform :after ((operation operation) (c component))
699 (setf (gethash (type-of operation) (component-operation-times c))
700 (get-universal-time)))
701
702 ;;; perform is required to check output-files to find out where to put
703 ;;; its answers, in case it has been overridden for site policy
704 (defmethod perform ((operation compile-op) (c cl-source-file))
705 #-:cormanlisp
706 (let ((source-file (component-pathname c))
707 (output-file (car (output-files operation c))))
708 (multiple-value-bind (output warnings-p failure-p)
709 (compile-file source-file
710 :output-file output-file)
711 ;(declare (ignore output))
712 (when warnings-p
713 (case (operation-on-warnings operation)
714 (:warn (warn
715 "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
716 operation c))
717 (:error (error 'compile-warned :component c :operation operation))
718 (:ignore nil)))
719 (when failure-p
720 (case (operation-on-failure operation)
721 (:warn (warn
722 "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
723 operation c))
724 (:error (error 'compile-failed :component c :operation operation))
725 (:ignore nil)))
726 (unless output
727 (error 'compile-error :component c :operation operation)))))
728
729 (defmethod output-files ((operation compile-op) (c cl-source-file))
730 #-:cormanlisp (list (compile-file-pathname (component-pathname c)))
731 #+:cormanlisp (list (component-pathname c)))
732
733 (defmethod perform ((operation compile-op) (c static-file))
734 nil)
735
736 (defmethod output-files ((operation compile-op) (c static-file))
737 nil)
738
739 ;;; load-op
740
741 (defclass load-op (operation) ())
742
743 (defmethod perform ((o load-op) (c cl-source-file))
744 (mapcar #'load (input-files o c)))
745
746 (defmethod perform ((operation load-op) (c static-file))
747 nil)
748 (defmethod operation-done-p ((operation load-op) (c static-file))
749 t)
750
751 (defmethod output-files ((o operation) (c component))
752 nil)
753
754 (defmethod component-depends-on ((operation load-op) (c component))
755 (cons (list 'compile-op (component-name c))
756 (call-next-method)))
757
758 ;;; load-source-op
759
760 (defclass load-source-op (operation) ())
761
762 (defmethod perform ((o load-source-op) (c cl-source-file))
763 (let ((source (component-pathname c)))
764 (setf (component-property c 'last-loaded-as-source)
765 (and (load source)
766 (get-universal-time)))))
767
768 (defmethod perform ((operation load-source-op) (c static-file))
769 nil)
770
771 (defmethod output-files ((operation load-source-op) (c component))
772 nil)
773
774 ;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right.
775 (defmethod component-depends-on ((o load-source-op) (c component))
776 (let ((what-would-load-op-do (cdr (assoc 'load-op
777 (slot-value c 'in-order-to)))))
778 (mapcar (lambda (dep)
779 (if (eq (car dep) 'load-op)
780 (cons 'load-source-op (cdr dep))
781 dep))
782 what-would-load-op-do)))
783
784 (defmethod operation-done-p ((o load-source-op) (c source-file))
785 (if (or (not (component-property c 'last-loaded-as-source))
786 (> (file-write-date (component-pathname c))
787 (component-property c 'last-loaded-as-source)))
788 nil t))
789
790 (defclass test-op (operation) ())
791
792 (defmethod perform ((operation test-op) (c component))
793 nil)
794
795 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
796 ;;; invoking operations
797
798 (defun opxx (operation-class system &rest args)
799 (let* ((op (apply #'make-instance operation-class
800 :original-initargs args args))
801 (*verbose-out*
802 (if (getf args :verbose t)
803 *trace-output*
804 (make-broadcast-stream)))
805 (system (if (typep system 'component) system (find-system system)))
806 (steps (traverse op system)))
807 (print steps)))
808
809 (defun operate (operation-class system &rest args)
810 (let* ((op (apply #'make-instance operation-class
811 :original-initargs args args))
812 (*verbose-out*
813 (if (getf args :verbose t)
814 *trace-output*
815 (make-broadcast-stream)))
816 (system (if (typep system 'component) system (find-system system)))
817 (steps (traverse op system)))
818 (with-compilation-unit ()
819 (loop for (op . component) in steps do
820 (loop
821 (restart-case
822 (progn (perform op component)
823 (return))
824 (retry ()
825 :report
826 (lambda (s)
827 (format s "~@<Retry performing ~S on ~S.~@:>"
828 op component)))
829 (accept ()
830 :report
831 (lambda (s)
832 (format s
833 "~@<Continue, treating ~S on ~S as ~
834 having been successful.~@:>"
835 op component))
836 (setf (gethash (type-of op)
837 (component-operation-times component))
838 (get-universal-time))
839 (return))))))))
840
841 (defun oos (&rest args)
842 "Alias of OPERATE function"
843 (apply #'operate args))
844
845 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
846 ;;; syntax
847
848 (defun remove-keyword (key arglist)
849 (labels ((aux (key arglist)
850 (cond ((null arglist) nil)
851 ((eq key (car arglist)) (cddr arglist))
852 (t (cons (car arglist) (cons (cadr arglist)
853 (remove-keyword
854 key (cddr arglist))))))))
855 (aux key arglist)))
856
857 (defmacro defsystem (name &body options)
858 (destructuring-bind (&key pathname (class 'system) &allow-other-keys) options
859 (let ((component-options (remove-keyword :class options)))
860 `(progn
861 ;; system must be registered before we parse the body, otherwise
862 ;; we recur when trying to find an existing system of the same name
863 ;; to reuse options (e.g. pathname) from
864 (let ((s (system-registered-p ',name)))
865 (cond ((and s (eq (type-of (cdr s)) ',class))
866 (setf (car s) (get-universal-time)))
867 (s
868 #+clisp
869 (sysdef-error "Cannot redefine the existing system ~A with a different class" s)
870 #-clisp
871 (change-class (cdr s) ',class))
872 (t
873 (register-system (quote ,name)
874 (make-instance ',class :name ',name)))))
875 (parse-component-form nil (apply
876 #'list
877 :module (coerce-name ',name)
878 :pathname
879 (or ,pathname
880 (pathname-sans-name+type
881 (resolve-symlinks *load-truename*))
882 *default-pathname-defaults*)
883 ',component-options))))))
884
885
886 (defun class-for-type (parent type)
887 (let ((class (find-class
888 (or (find-symbol (symbol-name type) *package*)
889 (find-symbol (symbol-name type) #.*package*)) nil)))
890 (or class
891 (and (eq type :file)
892 (or (module-default-component-class parent)
893 (find-class 'cl-source-file)))
894 (sysdef-error "~@<don't recognize component type ~A~@:>" type))))
895
896 (defun maybe-add-tree (tree op1 op2 c)
897 "Add the node C at /OP1/OP2 in TREE, unless it's there already.
898 Returns the new tree (which probably shares structure with the old one)"
899 (let ((first-op-tree (assoc op1 tree)))
900 (if first-op-tree
901 (progn
902 (aif (assoc op2 (cdr first-op-tree))
903 (if (find c (cdr it))
904 nil
905 (setf (cdr it) (cons c (cdr it))))
906 (setf (cdr first-op-tree)
907 (acons op2 (list c) (cdr first-op-tree))))
908 tree)
909 (acons op1 (list (list op2 c)) tree))))
910
911 (defun union-of-dependencies (&rest deps)
912 (let ((new-tree nil))
913 (dolist (dep deps)
914 (dolist (op-tree dep)
915 (dolist (op (cdr op-tree))
916 (dolist (c (cdr op))
917 (setf new-tree
918 (maybe-add-tree new-tree (car op-tree) (car op) c))))))
919 new-tree))
920
921
922 (defun remove-keys (key-names args)
923 (loop for ( name val ) on args by #'cddr
924 unless (member (symbol-name name) key-names
925 :key #'symbol-name :test 'equal)
926 append (list name val)))
927
928 (defvar *serial-depends-on*)
929
930 (defun parse-component-form (parent options)
931 (destructuring-bind
932 (type name &rest rest &key
933 ;; the following list of keywords is reproduced below in the
934 ;; remove-keys form. important to keep them in sync
935 components pathname default-component-class
936 perform explain output-files operation-done-p
937 depends-on serial in-order-to
938 ;; list ends
939 &allow-other-keys) options
940 (check-component-input type name depends-on components in-order-to)
941 (let* ((other-args (remove-keys
942 '(components pathname default-component-class
943 perform explain output-files operation-done-p
944 depends-on serial in-order-to)
945 rest))
946 (ret
947 (or (find-component parent name)
948 (make-instance (class-for-type parent type)))))
949 (when (boundp '*serial-depends-on*)
950 (setf depends-on
951 (concatenate 'list *serial-depends-on* depends-on)))
952 (apply #'reinitialize-instance
953 ret
954 :name (coerce-name name)
955 :pathname pathname
956 :parent parent
957 other-args)
958 (when (typep ret 'module)
959 (setf (module-default-component-class ret)
960 (or default-component-class
961 (and (typep parent 'module)
962 (module-default-component-class parent))))
963 (let ((*serial-depends-on* nil))
964 (setf (module-components ret)
965 (loop for c-form in components
966 for c = (parse-component-form ret c-form)
967 collect c
968 if serial
969 do (push (component-name c) *serial-depends-on*)))))
970
971 (setf (slot-value ret 'in-order-to)
972 (union-of-dependencies
973 in-order-to
974 `((compile-op (compile-op ,@depends-on))
975 (load-op (load-op ,@depends-on))))
976 (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on))))
977
978 (loop for (n v) in `((perform ,perform) (explain ,explain)
979 (output-files ,output-files)
980 (operation-done-p ,operation-done-p))
981 do (map 'nil
982 ;; this is inefficient as most of the stored
983 ;; methods will not be for this particular gf n
984 ;; But this is hardly performance-critical
985 (lambda (m) (remove-method (symbol-function n) m))
986 (component-inline-methods ret))
987 when v
988 do (destructuring-bind (op qual (o c) &body body) v
989 (pushnew
990 (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret)))
991 ,@body))
992 (component-inline-methods ret))))
993 ret)))
994
995 (defun check-component-input (type name depends-on components in-order-to)
996 "A partial test of the values of a component."
997 (unless (listp depends-on)
998 (sysdef-error-component ":depends-on must be a list."
999 type name depends-on))
1000 (unless (listp components)
1001 (sysdef-error-component ":components must be NIL or a list of components."
1002 type name components))
1003 (unless (and (listp in-order-to) (listp (car in-order-to)))
1004 (sysdef-error-component ":in-order-to must be NIL or a list of components."
1005 type name in-order-to)))
1006
1007 (defun sysdef-error-component (msg type name value)
1008 (sysdef-error (concatenate 'string msg
1009 "~&The value specified for ~(~A~) ~A is ~W")
1010 type name value))
1011
1012 (defun resolve-symlinks (path)
1013 #-allegro (truename path)
1014 #+allegro (excl:pathname-resolve-symbolic-links path)
1015 )
1016
1017 ;;; optional extras
1018
1019 ;;; run-shell-command functions for other lisp implementations will be
1020 ;;; gratefully accepted, if they do the same thing. If the docstring
1021 ;;; is ambiguous, send a bug report
1022
1023 (defun run-shell-command (control-string &rest args)
1024 "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
1025 synchronously execute the result using a Bourne-compatible shell, with
1026 output to *verbose-out*. Returns the shell's exit code."
1027 (let ((command (apply #'format nil control-string args)))
1028 (format *verbose-out* "; $ ~A~%" command)
1029 #+sbcl
1030 (sb-impl::process-exit-code
1031 (sb-ext:run-program
1032 "/bin/sh"
1033 (list "-c" command)
1034 :input nil :output *verbose-out*))
1035
1036 #+(or cmu scl)
1037 (ext:process-exit-code
1038 (ext:run-program
1039 "/bin/sh"
1040 (list "-c" command)
1041 :input nil :output *verbose-out*))
1042
1043 #+allegro
1044 (excl:run-shell-command command :input nil :output *verbose-out*)
1045
1046 #+lispworks
1047 (system:call-system-showing-output
1048 command
1049 :shell-type "/bin/sh"
1050 :output-stream *verbose-out*)
1051
1052 #+clisp ;XXX not exactly *verbose-out*, I know
1053 (ext:run-shell-command command :output :terminal :wait t)
1054
1055 #+openmcl
1056 (nth-value 1
1057 (ccl:external-process-status
1058 (ccl:run-program "/bin/sh" (list "-c" command)
1059 :input nil :output *verbose-out*
1060 :wait t)))
1061
1062 #-(or openmcl clisp lispworks allegro scl cmu sbcl)
1063 (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
1064 ))
1065
1066
1067 (defgeneric hyperdocumentation (package name doc-type))
1068 (defmethod hyperdocumentation ((package symbol) name doc-type)
1069 (hyperdocumentation (find-package package) name doc-type))
1070
1071 (defun hyperdoc (name doc-type)
1072 (hyperdocumentation (symbol-package name) name doc-type))
1073
1074
1075 (pushnew :asdf *features*)
1076
1077 #+sbcl
1078 (eval-when (:compile-toplevel :load-toplevel :execute)
1079 (when (sb-ext:posix-getenv "SBCL_BUILDING_CONTRIB")
1080 (pushnew :sbcl-hooks-require *features*)))
1081
1082 #+(and sbcl sbcl-hooks-require)
1083 (progn
1084 (defun module-provide-asdf (name)
1085 (handler-bind ((style-warning #'muffle-warning))
1086 (let* ((*verbose-out* (make-broadcast-stream))
1087 (system (asdf:find-system name nil)))
1088 (when system
1089 (asdf:operate 'asdf:load-op name)
1090 t))))
1091
1092 (pushnew
1093 '(merge-pathnames "systems/"
1094 (truename (sb-ext:posix-getenv "SBCL_HOME")))
1095 *central-registry*)
1096
1097 (pushnew
1098 '(merge-pathnames "site-systems/"
1099 (truename (sb-ext:posix-getenv "SBCL_HOME")))
1100 *central-registry*)
1101
1102 (pushnew
1103 '(merge-pathnames ".sbcl/systems/"
1104 (user-homedir-pathname))
1105 *central-registry*)
1106
1107 (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*))
1108
1109 (provide 'asdf)

  ViewVC Help
Powered by ViewVC 1.1.5