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