/[meta-cvs]/meta-cvs/F-F8FB346C85583F5BA0474148BA2A0E28.lisp
ViewVC logotype

Contents of /meta-cvs/F-F8FB346C85583F5BA0474148BA2A0E28.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5