asdf.lisp 39.1 KB
Newer Older
1
;;; This is asdf: Another System Definition Facility.  $Revision: 1.91 $
2
;;;
3
4
5
6
;;; Feedback, bug reports, and patches are all welcome: please mail to
;;; <cclan-list@lists.sf.net>.  But note first that the canonical
;;; source for asdf is presently the cCLan CVS repository at
;;; <URL:http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/>
7
8
9
10
11
12
13
14
15
;;;
;;; If you obtained this copy from anywhere else, and you experience
;;; trouble using it, or find bugs, you may want to check at the
;;; location above for a more recent version (and for documentation
;;; and test files, if your copy came without them) before reporting
;;; bugs.  There are usually two "supported" revisions - the CVS HEAD
;;; is the latest development version, whereas the revision tagged
;;; RELEASE may be slightly older but is considered `stable'

16
;;; Copyright (c) 2001-2003 Daniel Barlow and contributors
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining
;;; a copy of this software and associated documentation files (the
;;; "Software"), to deal in the Software without restriction, including
;;; without limitation the rights to use, copy, modify, merge, publish,
;;; distribute, sublicense, and/or sell copies of the Software, and to
;;; permit persons to whom the Software is furnished to do so, subject to
;;; the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

Daniel Barlow's avatar
Daniel Barlow committed
37
38
39
40
;;; the problem with writing a defsystem replacement is bootstrapping:
;;; we can't use defsystem to compile it.  Hence, all in one file

(defpackage #:asdf
Daniel Barlow's avatar
Daniel Barlow committed
41
42
  (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command
	   #: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
53
	   #:operation-done-p #:explain
	   
54
	   #:component #:source-file 
55
	   #:c-source-file #:cl-source-file #:java-source-file
56
	   #:static-file
Daniel Barlow's avatar
   
Daniel Barlow committed
57
58
59
	   #:doc-file
	   #:html-file
	   #:text-file
60
	   #:source-file-type
61
	   #:module			; components
62
	   #:system
63
64
65
66
67
68
69
	   #:unix-dso
	   
	   #:module-components		; component accessors
	   #:component-pathname
	   #:component-relative-pathname
	   #:component-name
	   #:component-version
Daniel Barlow's avatar
Daniel Barlow committed
70
	   #:component-parent
71
	   #:component-property
72
	   #:component-system
Daniel Barlow's avatar
Daniel Barlow committed
73
	   
74
	   #:component-depends-on
75

Daniel Barlow's avatar
Daniel Barlow committed
76
77
78
79
80
81
	   #:system-description
	   #:system-long-description
	   #:system-author
	   #:system-maintainer
	   #:system-license
	   
82
83
	   #:operation-on-warnings
	   #:operation-on-failure
84
	   
Daniel Barlow's avatar
Daniel Barlow committed
85
	   ;#:*component-parent-pathname* 
Daniel Barlow's avatar
Daniel Barlow committed
86
	   #:*system-definition-search-functions*
Daniel Barlow's avatar
Daniel Barlow committed
87
	   #:*central-registry*		; variables
88
89
	   #:*compile-file-warnings-behaviour*
	   #:*compile-file-failure-behaviour*
Daniel Barlow's avatar
Daniel Barlow committed
90
	   #:*asdf-revision*
91
	   
92
	   #:operation-error #:compile-failed #:compile-warned #:compile-error
93
	   #:error-component #:error-operation
94
95
	   #:system-definition-error 
	   #:missing-component
96
	   #:missing-dependency
97
	   #:circular-dependency	; errors
98
99
	   #:duplicate-names
	   
100
101
102
	   #:retry
	   #:accept                     ; restarts
	   
103
	   )
Daniel Barlow's avatar
Daniel Barlow committed
104
  (:use :cl))
105

106
107
108
109
#+nil
(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")


Daniel Barlow's avatar
Daniel Barlow committed
110
111
(in-package #:asdf)

112
(defvar *asdf-revision* (let* ((v "$Revision: 1.91 $")
113
			       (colon (or (position #\: v) -1))
114
115
116
117
118
119
120
			       (dot (position #\. v)))
			  (and v colon dot 
			       (list (parse-integer v :start (1+ colon)
						    :junk-allowed t)
				     (parse-integer v :start (1+ dot)
						    :junk-allowed t)))))

121
122
(defvar *compile-file-warnings-behaviour* :warn)
(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn)
Daniel Barlow's avatar
   
Daniel Barlow committed
123

124
(defvar *verbose-out* nil)
125

126
127
128
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; utility stuff

129
130
131
132
133
134
135
(defmacro aif (test then &optional else)
  `(let ((it ,test)) (if it ,then ,else)))

(defun pathname-sans-name+type (pathname)
  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
and NIL NAME and TYPE components"
  (make-pathname :name nil :type nil :defaults pathname))
136

Daniel Barlow's avatar
   
Daniel Barlow committed
137
138
139
(define-modify-macro appendf (&rest args) 
		     append "Append onto list") 

Daniel Barlow's avatar
Daniel Barlow committed
140
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Daniel Barlow's avatar
   
Daniel Barlow committed
141
;; classes, condiitons
Daniel Barlow's avatar
Daniel Barlow committed
142

143
144
145
146
147
148
149
150
151
(define-condition system-definition-error (error) ()
  ;; [this use of :report should be redundant, but unfortunately it's not.
  ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
  ;; over print-object; this is always conditions::%print-condition for
  ;; condition objects, which in turn does inheritance of :report options at
  ;; run-time.  fortunately, inheritance means we only need this kludge here in
  ;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]
  #+cmu (:report print-object))

Daniel Barlow's avatar
Daniel Barlow committed
152
(define-condition formatted-system-definition-error (system-definition-error)
153
154
155
156
157
  ((format-control :initarg :format-control :reader format-control)
   (format-arguments :initarg :format-arguments :reader format-arguments))
  (:report (lambda (c s)
	     (apply #'format s (format-control c) (format-arguments c)))))

Daniel Barlow's avatar
Daniel Barlow committed
158
(define-condition circular-dependency (system-definition-error)
159
  ((components :initarg :components :reader circular-dependency-components)))
160

161
162
163
(define-condition duplicate-names (system-definition-error)
  ((name :initarg :name :reader duplicate-names-name)))

164
165
166
167
168
169
170
171
(define-condition missing-component (system-definition-error)
  ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
   (version :initform nil :reader missing-version :initarg :version)
   (parent :initform nil :reader missing-parent :initarg :parent)))

(define-condition missing-dependency (missing-component)
  ((required-by :initarg :required-by :reader missing-required-by)))

Daniel Barlow's avatar
Daniel Barlow committed
172
173
174
175
(define-condition operation-error (error)
  ((component :reader error-component :initarg :component)
   (operation :reader error-operation :initarg :operation))
  (:report (lambda (c s)
176
	     (format s "~@<erred while invoking ~A on ~A~@:>"
Daniel Barlow's avatar
Daniel Barlow committed
177
		     (error-operation c) (error-component c)))))
178
179
180
(define-condition compile-error (operation-error) ())
(define-condition compile-failed (compile-error) ())
(define-condition compile-warned (compile-error) ())
Daniel Barlow's avatar
Daniel Barlow committed
181
182

(defclass component ()
183
184
  ((name :accessor component-name :initarg :name :documentation
	 "Component name: designator for a string composed of portable pathname characters")
Daniel Barlow's avatar
Daniel Barlow committed
185
   (version :accessor component-version :initarg :version)
186
   (in-order-to :initform nil :initarg :in-order-to)
187
188
   ;;; XXX crap name
   (do-first :initform nil :initarg :do-first)
189
190
191
192
   ;; methods defined using the "inline" style inside a defsystem form:
   ;; need to store them somewhere so we can delete them when the system
   ;; is re-evaluated
   (inline-methods :accessor component-inline-methods :initform nil)
Daniel Barlow's avatar
Daniel Barlow committed
193
   (parent :initarg :parent :initform nil :reader component-parent)
Daniel Barlow's avatar
Daniel Barlow committed
194
195
   ;; no direct accessor for pathname, we do this as a method to allow
   ;; it to default in funky ways if not supplied
Daniel Barlow's avatar
   
Daniel Barlow committed
196
   (relative-pathname :initarg :pathname)
Daniel Barlow's avatar
   
Daniel Barlow committed
197
198
   (operation-times :initform (make-hash-table )
		    :accessor component-operation-times)
Daniel Barlow's avatar
   
Daniel Barlow committed
199
200
   ;; XXX we should provide some atomic interface for updating the
   ;; component properties
201
202
   (properties :accessor component-properties :initarg :properties
	       :initform nil)))
Daniel Barlow's avatar
   
Daniel Barlow committed
203

Daniel Barlow's avatar
   
Daniel Barlow committed
204
205
206
;;;; methods: conditions

(defmethod print-object ((c missing-dependency) s)
207
208
  (format s "~@<~A, required by ~A~@:>"
	  (call-next-method c nil) (missing-required-by c)))
Daniel Barlow's avatar
   
Daniel Barlow committed
209
210
211

(defun sysdef-error (format &rest arguments)
  (error 'formatted-system-definition-error :format-control format :format-arguments arguments))
Daniel Barlow's avatar
Daniel Barlow committed
212

Daniel Barlow's avatar
   
Daniel Barlow committed
213
214
215
;;;; methods: components

(defmethod print-object ((c missing-component) s)
216
217
218
  (format s "~@<component ~S not found~
             ~@[ or does not match version ~A~]~
             ~@[ in ~A~]~@:>"
219
220
221
222
	  (missing-requires c)
	  (missing-version c)
	  (when (missing-parent c)
	    (component-name (missing-parent c)))))
Daniel Barlow's avatar
   
Daniel Barlow committed
223
224
225
226

(defgeneric component-system (component)
  (:documentation "Find the top-level system containing COMPONENT"))
  
Daniel Barlow's avatar
Daniel Barlow committed
227
228
229
230
231
(defmethod component-system ((component component))
  (aif (component-parent component)
       (component-system it)
       component))

232
(defmethod print-object ((c component) stream)
Daniel Barlow's avatar
Daniel Barlow committed
233
  (print-unreadable-object (c stream :type t :identity t)
Daniel Barlow's avatar
Daniel Barlow committed
234
235
    (ignore-errors
      (prin1 (component-name c) stream))))
Daniel Barlow's avatar
Daniel Barlow committed
236
237

(defclass module (component)
Daniel Barlow's avatar
   
Daniel Barlow committed
238
  ((components :initform nil :accessor module-components :initarg :components)
239
240
241
242
243
   ;; what to do if we can't satisfy a dependency of one of this module's
   ;; components.  This allows a limited form of conditional processing
   (if-component-dep-fails :initform :fail
			   :accessor module-if-component-dep-fails
			   :initarg :if-component-dep-fails)
Daniel Barlow's avatar
Daniel Barlow committed
244
245
246
   (default-component-class :accessor module-default-component-class
     :initform 'cl-source-file :initarg :default-component-class)))

Daniel Barlow's avatar
   
Daniel Barlow committed
247
248
249
250
251
252
253
254
(defgeneric component-pathname (component)
  (:documentation "Extracts the pathname applicable for a particular component."))

(defun component-parent-pathname (component)
  (aif (component-parent component)
       (component-pathname it)
       *default-pathname-defaults*))

255
256
257
(defgeneric component-relative-pathname (component)
  (:documentation "Extracts the relative pathname applicable for a particular component."))
   
Daniel Barlow's avatar
Daniel Barlow committed
258
(defmethod component-relative-pathname ((component module))
Daniel Barlow's avatar
Daniel Barlow committed
259
260
261
262
263
  (or (slot-value component 'relative-pathname)
      (make-pathname
       :directory `(:relative ,(component-name component))
       :host (pathname-host (component-parent-pathname component)))))

Daniel Barlow's avatar
   
Daniel Barlow committed
264
265
266
267
(defmethod component-pathname ((component component))
  (let ((*default-pathname-defaults* (component-parent-pathname component)))
    (merge-pathnames (component-relative-pathname component))))

268
269
(defgeneric component-property (component property))

270
(defmethod component-property ((c component) property)
Daniel Barlow's avatar
Daniel Barlow committed
271
  (cdr (assoc property (slot-value c 'properties) :test #'equal)))
272

273
274
(defgeneric (setf component-property) (new-value component property))

275
(defmethod (setf component-property) (new-value (c component) property)
Daniel Barlow's avatar
Daniel Barlow committed
276
  (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
277
278
279
280
281
    (if a
	(setf (cdr a) new-value)
	(setf (slot-value c 'properties)
	      (acons property new-value (slot-value c 'properties))))))

Daniel Barlow's avatar
   
Daniel Barlow committed
282
283
(defclass system (module)
  ((description :accessor system-description :initarg :description)
Daniel Barlow's avatar
Daniel Barlow committed
284
285
   (long-description
    :accessor system-long-description :initarg :long-description)
Daniel Barlow's avatar
   
Daniel Barlow committed
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
   (author :accessor system-author :initarg :author)
   (maintainer :accessor system-maintainer :initarg :maintainer)
   (licence :accessor system-licence :initarg :licence)))

;;; version-satisfies

;;; with apologies to christophe rhodes ...
(defun split (string &optional max (ws '(#\Space #\Tab)))
  (flet ((is-ws (char) (find char ws)))
    (nreverse
     (let ((list nil) (start 0) (words 0) end)
       (loop
	(when (and max (>= words (1- max)))
	  (return (cons (subseq string start) list)))
	(setf end (position-if #'is-ws string :start start))
	(push (subseq string start end) list)
	(incf words)
	(unless end (return list))
	(setf start (1+ end)))))))

306
307
(defgeneric version-satisfies (component version))

Daniel Barlow's avatar
   
Daniel Barlow committed
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
(defmethod version-satisfies ((c component) version)
  (unless (and version (slot-boundp c 'version))
    (return-from version-satisfies t))
  (let ((x (mapcar #'parse-integer
		   (split (component-version c) nil '(#\.))))
	(y (mapcar #'parse-integer
		   (split version nil '(#\.)))))
    (labels ((bigger (x y)
	       (cond ((not y) t)
		     ((not x) nil)
		     ((> (car x) (car y)) t)
		     ((= (car x) (car y))
		      (bigger (cdr x) (cdr y))))))
      (and (= (car x) (car y))
	   (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; finding systems

(defvar *defined-systems* (make-hash-table :test 'equal))
(defun coerce-name (name)
   (typecase name
     (component (component-name name))
     (symbol (string-downcase (symbol-name name)))
     (string name)
333
     (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
Daniel Barlow's avatar
   
Daniel Barlow committed
334

335
336
337
338
339
340
;;; for the sake of keeping things reasonably neat, we adopt a
;;; convention that functions in this list are prefixed SYSDEF-

(defvar *system-definition-search-functions*
  '(sysdef-central-registry-search))

341
342
343
344
(defun system-definition-pathname (system)
  (some (lambda (x) (funcall x system))
	*system-definition-search-functions*))
	
345
346
347
348
349
(defvar *central-registry*
  '(*default-pathname-defaults*
    #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/"
    #+nil "telent:asdf;systems;"))

350
351
352
353
354
355
356
357
358
359
360
361
362
(defun sysdef-central-registry-search (system)
  (let ((name (coerce-name system)))
    (block nil
      (dolist (dir *central-registry*)
	(let* ((defaults (eval dir))
	       (file (and defaults
			  (make-pathname
			   :defaults defaults :version :newest
			   :name name :type "asd" :case :local))))
	  (if (and file (probe-file file))
	      (return file)))))))


Daniel Barlow's avatar
   
Daniel Barlow committed
363
364
365
366
367
368
369
(defun find-system (name &optional (error-p t))
  (let* ((name (coerce-name name))
	 (in-memory (gethash name *defined-systems*))
	 (on-disk (system-definition-pathname name)))	 
    (when (and on-disk
	       (or (not in-memory)
		   (< (car in-memory) (file-write-date on-disk))))
370
      (let ((*package* (make-package (gensym #.(package-name *package*))
371
				     :use '(:cl :asdf))))
372
	(format *verbose-out*
373
		"~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
374
375
376
377
		;; FIXME: This wants to be (ENOUGH-NAMESTRING
		;; ON-DISK), but CMUCL barfs on that.
		on-disk
		*package*)
Daniel Barlow's avatar
   
Daniel Barlow committed
378
379
380
381
382
383
384
385
	(load on-disk)))
    (let ((in-memory (gethash name *defined-systems*)))
      (if in-memory
	  (progn (if on-disk (setf (car in-memory) (file-write-date on-disk)))
		 (cdr in-memory))
	  (if error-p (error 'missing-component :requires name))))))

(defun register-system (name system)
386
  (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
Daniel Barlow's avatar
   
Daniel Barlow committed
387
388
389
390
391
392
393
394
  (setf (gethash (coerce-name  name) *defined-systems*)
	(cons (get-universal-time) system)))

(defun system-registered-p (name)
  (gethash (coerce-name name) *defined-systems*))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; finding components
Daniel Barlow's avatar
Daniel Barlow committed
395

396
(defgeneric find-component (module name &optional version)
Christophe Rhodes's avatar
Christophe Rhodes committed
397
398
399
400
  (:documentation "Finds the component with name NAME present in the
MODULE module; if MODULE is nil, then the component is assumed to be a
system."))

401
(defmethod find-component ((module module) name &optional version)
Daniel Barlow's avatar
Daniel Barlow committed
402
  (if (slot-boundp module 'components)
403
404
405
406
      (let ((m (find name (module-components module)
		     :test #'equal :key #'component-name)))
	(if (and m (version-satisfies m version)) m))))
	    
Daniel Barlow's avatar
Daniel Barlow committed
407
408

;;; a component with no parent is a system
409
(defmethod find-component ((module (eql nil)) name &optional version)
Daniel Barlow's avatar
   
Daniel Barlow committed
410
  (let ((m (find-system name nil)))
411
    (if (and m (version-satisfies m version)) m)))
Daniel Barlow's avatar
Daniel Barlow committed
412

Daniel Barlow's avatar
   
Daniel Barlow committed
413
414
;;; component subclasses

Daniel Barlow's avatar
Daniel Barlow committed
415
416
417
(defclass source-file (component) ())

(defclass cl-source-file (source-file) ())
Daniel Barlow's avatar
Daniel Barlow committed
418
419
(defclass c-source-file (source-file) ())
(defclass java-source-file (source-file) ())
420
421
422
(defclass static-file (source-file) ())
(defclass doc-file (static-file) ())
(defclass html-file (doc-file) ())
Daniel Barlow's avatar
Daniel Barlow committed
423

Daniel Barlow's avatar
Daniel Barlow committed
424
425
426
427
(defgeneric source-file-type (component system))
(defmethod source-file-type ((c cl-source-file) (s module)) "lisp")
(defmethod source-file-type ((c c-source-file) (s module)) "c")
(defmethod source-file-type ((c java-source-file) (s module)) "java")
Daniel Barlow's avatar
   
Daniel Barlow committed
428
(defmethod source-file-type ((c html-file) (s module)) "html")
429
430
(defmethod source-file-type ((c static-file) (s module)) nil)

Daniel Barlow's avatar
Daniel Barlow committed
431
(defmethod component-relative-pathname ((component source-file))
432
433
434
435
436
437
438
439
440
441
442
  (let* ((*default-pathname-defaults* (component-parent-pathname component))
	 (name-type
	  (make-pathname
	   :name (component-name component)
	   :type (source-file-type component
				   (component-system component)))))
    (if (slot-value component 'relative-pathname)
	(merge-pathnames
	 (slot-value component 'relative-pathname)
	 name-type)
	name-type)))
Daniel Barlow's avatar
Daniel Barlow committed
443
444
445
446
447
448
449

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; operations

;;; one of these is instantiated whenever (operate ) is called

(defclass operation ()
450
  ((forced :initform nil :initarg :force :accessor operation-forced)
451
452
453
454
455
456
   (original-initargs :initform nil :initarg :original-initargs
		      :accessor operation-original-initargs)
   (visited-nodes :initform nil :accessor operation-visited-nodes)
   (visiting-nodes :initform nil :accessor operation-visiting-nodes)
   (parent :initform nil :initarg :parent :accessor operation-parent)))

457
458
459
460
461
(defmethod print-object ((o operation) stream)
  (print-unreadable-object (o stream :type t :identity t)
    (ignore-errors
      (prin1 (operation-original-initargs o) stream))))

462
463
464
465
466
467
(defmethod shared-initialize :after ((operation operation) slot-names
				     &key force 
				     &allow-other-keys)
  (declare (ignore slot-names force))
  ;; empty method to disable initarg validity checking
  )
Daniel Barlow's avatar
Daniel Barlow committed
468

469
470
471
472
(defgeneric perform (operation component))
(defgeneric operation-done-p (operation component))
(defgeneric explain (operation component))
(defgeneric output-files (operation component))
Daniel Barlow's avatar
   
Daniel Barlow committed
473
(defgeneric input-files (operation component))
Daniel Barlow's avatar
Daniel Barlow committed
474

475
476
477
(defun node-for (o c)
  (cons (class-name (class-of o)) c))

Daniel Barlow's avatar
   
Daniel Barlow committed
478
479
480
(defgeneric operation-ancestor (operation)
  (:documentation   "Recursively chase the operation's parent pointer until we get to the head of the tree"))

481
482
483
484
485
(defmethod operation-ancestor ((operation operation))
  (aif (operation-parent operation)
       (operation-ancestor it)
       operation))

486
487
488
489
490
491
492
493
494
495
496
497

(defun make-sub-operation (c o dep-c dep-o)
  (let* ((args (copy-list (operation-original-initargs o)))
	 (force-p (getf args :force)))
    ;; note explicit comparison with T: any other non-NIL force value
    ;; (e.g. :recursive) will pass through
    (cond ((and (null (component-parent c))
		(null (component-parent dep-c))
		(not (eql c dep-c)))
	   (when (eql force-p t)
	     (setf (getf args :force) nil))
	   (apply #'make-instance dep-o
498
		  :parent o
499
500
501
502
503
504
505
		  :original-initargs args args))
	  ((subtypep (type-of o) dep-o)
	   o)
	  (t 
	   (apply #'make-instance dep-o
		  :parent o :original-initargs args args)))))

506

Daniel Barlow's avatar
   
Daniel Barlow committed
507
(defgeneric visit-component (operation component data))
508

Daniel Barlow's avatar
   
Daniel Barlow committed
509
510
511
512
(defmethod visit-component ((o operation) (c component) data)
  (unless (component-visited-p o c)
    (push (cons (node-for o c) data)
	  (operation-visited-nodes (operation-ancestor o)))))
Daniel Barlow's avatar
Daniel Barlow committed
513

514
(defgeneric component-visited-p (operation component))
Daniel Barlow's avatar
   
Daniel Barlow committed
515

Daniel Barlow's avatar
Daniel Barlow committed
516
(defmethod component-visited-p ((o operation) (c component))
Daniel Barlow's avatar
   
Daniel Barlow committed
517
518
519
  (assoc (node-for o c)
	 (operation-visited-nodes (operation-ancestor o))
	 :test 'equal))
Daniel Barlow's avatar
Daniel Barlow committed
520

521
522
(defgeneric (setf visiting-component) (new-value operation component))

523
524
525
(defmethod (setf visiting-component) (new-value operation component)
  ;; MCL complains about unused lexical variables
  (declare (ignorable new-value operation component)))
526

Daniel Barlow's avatar
Daniel Barlow committed
527
(defmethod (setf visiting-component) (new-value (o operation) (c component))
528
529
  (let ((node (node-for o c))
	(a (operation-ancestor o)))
530
    (if new-value
531
532
533
	(pushnew node (operation-visiting-nodes a) :test 'equal)
	(setf (operation-visiting-nodes a)
	      (remove node  (operation-visiting-nodes a) :test 'equal)))))
Daniel Barlow's avatar
Daniel Barlow committed
534

535
536
(defgeneric component-visiting-p (operation component))

Daniel Barlow's avatar
Daniel Barlow committed
537
(defmethod component-visiting-p ((o operation) (c component))
538
  (let ((node (cons o c)))
539
540
    (member node (operation-visiting-nodes (operation-ancestor o))
	    :test 'equal)))
Daniel Barlow's avatar
Daniel Barlow committed
541

542
543
544
(defgeneric component-depends-on (operation component))

(defmethod component-depends-on ((o operation) (c component))
545
546
  (cdr (assoc (class-name (class-of o))
	      (slot-value c 'in-order-to))))
547

548
549
(defgeneric component-self-dependencies (operation component))

Daniel Barlow's avatar
   
Daniel Barlow committed
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
(defmethod component-self-dependencies ((o operation) (c component))
  (let ((all-deps (component-depends-on o c)))
    (remove-if-not (lambda (x)
		     (member (component-name c) (cdr x) :test #'string=))
		   all-deps)))
    
(defmethod input-files ((operation operation) (c component))
  (let ((parent (component-parent c))
	(self-deps (component-self-dependencies operation c)))
    (if self-deps
	(mapcan (lambda (dep)
		  (destructuring-bind (op name) dep
		    (output-files (make-instance op)
				  (find-component parent name))))
		self-deps)
	;; no previous operations needed?  I guess we work with the 
	;; original source file, then
	(list (component-pathname c)))))

569
(defmethod input-files ((operation operation) (c module)) nil)
570

Daniel Barlow's avatar
   
Daniel Barlow committed
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
(defmethod operation-done-p ((o operation) (c component))
  (let ((out-files (output-files o c))
	(in-files (input-files o c)))
    (cond ((and (not in-files) (not out-files))
	   ;; arbitrary decision: an operation that uses nothing to
	   ;; produce nothing probably isn't doing much 
	   t)
	  ((not out-files) 
	   (let ((op-done
		  (gethash (type-of o)
			   (component-operation-times c))))
	     (and op-done
		  (>= op-done
		      (or (apply #'max
				 (mapcar #'file-write-date in-files)) 0)))))
	  ((not in-files) nil)
	  (t
	   (and
	    (every #'probe-file out-files)
	    (> (apply #'min (mapcar #'file-write-date out-files))
	       (apply #'max (mapcar #'file-write-date in-files)) ))))))
592

Daniel Barlow's avatar
Daniel Barlow committed
593
594
595
;;; So you look at this code and think "why isn't it a bunch of
;;; methods".  And the answer is, because standard method combination
;;; runs :before methods most->least-specific, which is back to front
596
597
;;; for our purposes.  And CLISP doesn't have non-standard method
;;; combinations, so let's keep it simple and aspire to portability
Daniel Barlow's avatar
Daniel Barlow committed
598

Daniel Barlow's avatar
Daniel Barlow committed
599
600
(defgeneric traverse (operation component))
(defmethod traverse ((operation operation) (c component))
Daniel Barlow's avatar
   
Daniel Barlow committed
601
602
  (let ((forced nil))
    (labels ((do-one-dep (required-op required-c required-v)
603
604
605
606
607
608
609
610
611
612
	       (let* ((dep-c (or (find-component
				  (component-parent c)
				  ;; XXX tacky.  really we should build the
				  ;; in-order-to slot with canonicalized
				  ;; names instead of coercing this late
				  (coerce-name required-c) required-v)
				 (error 'missing-dependency :required-by c
					:version required-v
					:requires required-c)))
		      (op (make-sub-operation c operation dep-c required-op)))
Daniel Barlow's avatar
Daniel Barlow committed
613
		 (traverse op dep-c)))	   	   
Daniel Barlow's avatar
   
Daniel Barlow committed
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
	     (do-dep (op dep)
	       (cond ((eq op 'feature)
		      (or (member (car dep) *features*)
			  (error 'missing-dependency :required-by c
				 :requires (car dep) :version nil)))
		     (t
		      (dolist (d dep)
                        (cond ((consp d)
                               (assert (string-equal
                                        (symbol-name (first d))
                                        "VERSION"))
                               (appendf forced
					(do-one-dep op (second d) (third d))))
                              (t
                               (appendf forced (do-one-dep op d nil)))))))))
      (aif (component-visited-p operation c)
Daniel Barlow's avatar
Daniel Barlow committed
630
	   (return-from traverse
Daniel Barlow's avatar
   
Daniel Barlow committed
631
632
633
634
635
636
637
638
	     (if (cdr it) (list (cons 'pruned-op c)) nil)))
      ;; dependencies
      (if (component-visiting-p operation c)
	  (error 'circular-dependency :components (list c)))
      (setf (visiting-component operation c) t)
      (loop for (required-op . deps) in (component-depends-on operation c)
	    do (do-dep required-op deps))
      ;; constituent bits
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
      (let ((module-ops
	     (when (typep c 'module)
	       (let ((at-least-one nil)
		     (forced nil)
		     (error nil))
		 (loop for kid in (module-components c)
		       do (handler-case
			      (appendf forced (traverse operation kid ))
			    (missing-dependency (condition)
			      (if (eq (module-if-component-dep-fails c) :fail)
				  (error condition))
			      (setf error condition))
			    (:no-error (c)
			      (declare (ignore c))
			      (setf at-least-one t))))
		 (when (and (eq (module-if-component-dep-fails c) :try-next)
			    (not at-least-one))
		   (error error))
		 forced))))
	;; now the thing itself
	(when (or forced module-ops
660
661
662
663
664
665
666
		  (not (operation-done-p operation c))
		  (let ((f (operation-forced (operation-ancestor operation))))
		    (and f (or (not (consp f))
			       (member (component-name
					(operation-ancestor operation))
				       (mapcar #'coerce-name f)
				       :test #'string=)))))
667
668
669
670
671
672
673
	  (let ((do-first (cdr (assoc (class-name (class-of operation))
				      (slot-value c 'do-first)))))
	    (loop for (required-op . deps) in do-first
		  do (do-dep required-op deps)))
	  (setf forced (append (delete 'pruned-op forced :key #'car)
			       (delete 'pruned-op module-ops :key #'car)
			       (list (cons operation c))))))
Daniel Barlow's avatar
   
Daniel Barlow committed
674
675
676
677
      (setf (visiting-component operation c) nil)
      (visit-component operation c (and forced t))
      forced)))
  
Daniel Barlow's avatar
Daniel Barlow committed
678
679

(defmethod perform ((operation operation) (c source-file))
680
  (sysdef-error
681
682
   "~@<required method PERFORM not implemented ~
    for operation ~A, component ~A~@:>"
Daniel Barlow's avatar
Daniel Barlow committed
683
684
685
686
687
688
   (class-of operation) (class-of c)))

(defmethod perform ((operation operation) (c module))
  nil)

(defmethod explain ((operation operation) (component component))
689
  (format *verbose-out* "~&;;; ~A on ~A~%" operation component))
Daniel Barlow's avatar
Daniel Barlow committed
690

691
;;; compile-op
Daniel Barlow's avatar
Daniel Barlow committed
692

693
694
(defclass compile-op (operation)
  ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
Daniel Barlow's avatar
   
Daniel Barlow committed
695
696
697
698
   (on-warnings :initarg :on-warnings :accessor operation-on-warnings
		:initform *compile-file-warnings-behaviour*)
   (on-failure :initarg :on-failure :accessor operation-on-failure
	       :initform *compile-file-failure-behaviour*)))
699
700

(defmethod perform :before ((operation compile-op) (c source-file))
701
  (map nil #'ensure-directories-exist (output-files operation c)))
702

Daniel Barlow's avatar
   
Daniel Barlow committed
703
704
705
(defmethod perform :after ((operation operation) (c component))
  (setf (gethash (type-of operation) (component-operation-times c))
	(get-universal-time)))
Daniel Barlow's avatar
Daniel Barlow committed
706

707
708
;;; perform is required to check output-files to find out where to put
;;; its answers, in case it has been overridden for site policy
709
(defmethod perform ((operation compile-op) (c cl-source-file))
710
  #-:broken-fasl-loader
711
712
  (let ((source-file (component-pathname c))
	(output-file (car (output-files operation c))))
Daniel Barlow's avatar
Daniel Barlow committed
713
    (multiple-value-bind (output warnings-p failure-p)
714
715
	(compile-file source-file
		      :output-file output-file)
716
      ;(declare (ignore output))
Daniel Barlow's avatar
   
Daniel Barlow committed
717
718
      (when warnings-p
	(case (operation-on-warnings operation)
719
	  (:warn (warn
720
		  "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
721
		  operation c))
Daniel Barlow's avatar
   
Daniel Barlow committed
722
723
724
725
	  (:error (error 'compile-warned :component c :operation operation))
	  (:ignore nil)))
      (when failure-p
	(case (operation-on-failure operation)
726
	  (:warn (warn
727
		  "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
728
		  operation c))
Daniel Barlow's avatar
   
Daniel Barlow committed
729
	  (:error (error 'compile-failed :component c :operation operation))
730
731
732
	  (:ignore nil)))
      (unless output
	(error 'compile-error :component c :operation operation)))))
Daniel Barlow's avatar
Daniel Barlow committed
733

734
(defmethod output-files ((operation compile-op) (c cl-source-file))
735
736
  #-:broken-fasl-loader (list (compile-file-pathname (component-pathname c)))
  #+:broken-fasl-loader (list (component-pathname c)))
Daniel Barlow's avatar
Daniel Barlow committed
737

Daniel Barlow's avatar
Daniel Barlow committed
738
739
740
741
742
743
(defmethod perform ((operation compile-op) (c static-file))
  nil)

(defmethod output-files ((operation compile-op) (c static-file))
  nil)

744
;;; load-op
Daniel Barlow's avatar
Daniel Barlow committed
745

746
(defclass load-op (operation) ())
747

748
(defmethod perform ((o load-op) (c cl-source-file))
Daniel Barlow's avatar
Daniel Barlow committed
749
  (mapcar #'load (input-files o c)))
Daniel Barlow's avatar
Daniel Barlow committed
750

Daniel Barlow's avatar
Daniel Barlow committed
751
752
(defmethod perform ((operation load-op) (c static-file))
  nil)
Daniel Barlow's avatar
   
Daniel Barlow committed
753
754
(defmethod operation-done-p ((operation load-op) (c static-file))
  t)
Daniel Barlow's avatar
Daniel Barlow committed
755

Daniel Barlow's avatar
   
Daniel Barlow committed
756
(defmethod output-files ((o operation) (c component))
Daniel Barlow's avatar
Daniel Barlow committed
757
  nil)
758

759
(defmethod component-depends-on ((operation load-op) (c component))
760
761
762
  (cons (list 'compile-op (component-name c))
        (call-next-method)))

763
764
765
766
767
;;; load-source-op

(defclass load-source-op (operation) ())

(defmethod perform ((o load-source-op) (c cl-source-file))
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
  (let ((source (component-pathname c)))
    (setf (component-property c 'last-loaded-as-source)
          (and (load source)
               (get-universal-time)))))

(defmethod perform ((operation load-source-op) (c static-file))
  nil)

(defmethod output-files ((operation load-source-op) (c component))
  nil)

;;; FIXME: we simply copy load-op's dependencies.  this is Just Not Right.
(defmethod component-depends-on ((o load-source-op) (c component))
  (let ((what-would-load-op-do (cdr (assoc 'load-op
                                           (slot-value c 'in-order-to)))))
    (mapcar (lambda (dep)
              (if (eq (car dep) 'load-op)
                  (cons 'load-source-op (cdr dep))
                  dep))
            what-would-load-op-do)))

(defmethod operation-done-p ((o load-source-op) (c source-file))
  (if (or (not (component-property c 'last-loaded-as-source))
	  (> (file-write-date (component-pathname c))
	     (component-property c 'last-loaded-as-source)))
      nil t))
794

795
796
797
798
(defclass test-op (operation) ())

(defmethod perform ((operation test-op) (c component))
  nil)
799

Daniel Barlow's avatar
Daniel Barlow committed
800
801
802
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; invoking operations

Daniel Barlow's avatar
Daniel Barlow committed
803
(defun operate (operation-class system &rest args)
Daniel Barlow's avatar
   
Daniel Barlow committed
804
805
  (let* ((op (apply #'make-instance operation-class
		    :original-initargs args args))
806
807
	 (*verbose-out*
	  (if (getf args :verbose t)
808
	      *trace-output*
809
	      (make-broadcast-stream)))
Daniel Barlow's avatar
   
Daniel Barlow committed
810
	 (system (if (typep system 'component) system (find-system system)))
Daniel Barlow's avatar
Daniel Barlow committed
811
	 (steps (traverse op system)))
812
    (with-compilation-unit ()
Daniel Barlow's avatar
Daniel Barlow committed
813
      (loop for (op . component) in steps do
Daniel Barlow's avatar
   
Daniel Barlow committed
814
815
	    (loop
	     (restart-case 
Daniel Barlow's avatar
Daniel Barlow committed
816
		 (progn (perform op component)
Daniel Barlow's avatar
   
Daniel Barlow committed
817
			(return))
818
819
820
	       (retry ()
		 :report
		 (lambda (s)
821
		   (format s "~@<Retry performing ~S on ~S.~@:>"
822
823
824
825
826
			   op component)))
	       (accept ()
		 :report
		 (lambda (s)
		   (format s
827
828
			   "~@<Continue, treating ~S on ~S as ~
                            having been successful.~@:>"
829
830
831
832
833
			   op component))
		 (setf (gethash (type-of op)
				(component-operation-times component))
		       (get-universal-time))
		 (return))))))))
Daniel Barlow's avatar
Daniel Barlow committed
834

Daniel Barlow's avatar
Daniel Barlow committed
835
836
837
838
(defun oos (&rest args)
  "Alias of OPERATE function"
  (apply #'operate args))

Daniel Barlow's avatar
Daniel Barlow committed
839
840
841
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; syntax

842
(defun remove-keyword (key arglist)
843
844
845
846
847
848
849
  (labels ((aux (key arglist)
	     (cond ((null arglist) nil)
		   ((eq key (car arglist)) (cddr arglist))
		   (t (cons (car arglist) (cons (cadr arglist)
						(remove-keyword
						 key (cddr arglist))))))))
    (aux key arglist)))
850

Daniel Barlow's avatar
Daniel Barlow committed
851
(defmacro defsystem (name &body options)
Daniel Barlow's avatar
   
Daniel Barlow committed
852
  (destructuring-bind (&key pathname (class 'system) &allow-other-keys) options
853
    (let ((component-options (remove-keyword :class options)))
Daniel Barlow's avatar
   
Daniel Barlow committed
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
      `(progn
	;; system must be registered before we parse the body, otherwise
	;; we recur when trying to find an existing system of the same name
	;; to reuse options (e.g. pathname) from
	(let ((s (system-registered-p ',name)))
	  (cond ((and s (eq (type-of (cdr s)) ',class))
		 (setf (car s) (get-universal-time)))
		(s
		 #+clisp
		 (sysdef-error "Cannot redefine the existing system ~A with a different class" s)
		 #-clisp
		 (change-class (cdr s) ',class))
		(t
		 (register-system (quote ,name)
				  (make-instance ',class :name ',name)))))
	(parse-component-form nil (apply
				   #'list
				   :module (coerce-name ',name)
				   :pathname
				   (or ,pathname
874
				       (pathname-sans-name+type
Daniel Barlow's avatar
Daniel Barlow committed
875
					(resolve-symlinks  *load-truename*))
Daniel Barlow's avatar
   
Daniel Barlow committed
876
877
878
				       *default-pathname-defaults*)
				   ',component-options))))))
  
879
880

(defun class-for-type (parent type)
881
882
883
884
885
  (let ((class 
	 (find-class
	  (or (find-symbol (symbol-name type) *package*)
	      (find-symbol (symbol-name type) #.(package-name *package*)))
	  nil)))
886
887
888
889
    (or class
	(and (eq type :file)
	     (or (module-default-component-class parent)
		 (find-class 'cl-source-file)))
890
	(sysdef-error "~@<don't recognize component type ~A~@:>" type))))
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915

(defun maybe-add-tree (tree op1 op2 c)
  "Add the node C at /OP1/OP2 in TREE, unless it's there already.
Returns the new tree (which probably shares structure with the old one)"
  (let ((first-op-tree (assoc op1 tree)))
    (if first-op-tree
	(progn
	  (aif (assoc op2 (cdr first-op-tree))
	       (if (find c (cdr it))
		   nil
		   (setf (cdr it) (cons c (cdr it))))
	       (setf (cdr first-op-tree)
		     (acons op2 (list c) (cdr first-op-tree))))
	  tree)
	(acons op1 (list (list op2 c)) tree))))
		
(defun union-of-dependencies (&rest deps)
  (let ((new-tree nil))
    (dolist (dep deps)
      (dolist (op-tree dep)
	(dolist (op  (cdr op-tree))
	  (dolist (c (cdr op))
	    (setf new-tree
		  (maybe-add-tree new-tree (car op-tree) (car op) c))))))
    new-tree))
916

917
918
919
920
921
922
923

(defun remove-keys (key-names args)
  (loop for ( name val ) on args by #'cddr
	unless (member (symbol-name name) key-names 
		       :key #'symbol-name :test 'equal)
	append (list name val)))

924
925
(defvar *serial-depends-on*)

926
927
(defun parse-component-form (parent options)
  (destructuring-bind
Daniel Barlow's avatar
Daniel Barlow committed
928
929
930
931
932
	(type name &rest rest &key
	      ;; the following list of keywords is reproduced below in the
	      ;; remove-keys form.  important to keep them in sync
	      components pathname default-component-class
	      perform explain output-files operation-done-p
933
	      weakly-depends-on
934
	      depends-on serial in-order-to
Daniel Barlow's avatar
Daniel Barlow committed
935
936
	      ;; list ends
	      &allow-other-keys) options
937
    (check-component-input type name weakly-depends-on depends-on components in-order-to)
938
939
940
941
942
943
944
945
946

    (when (and parent
	     (find-component parent name)
	     ;; ignore the same object when rereading the defsystem
	     (not 
	      (typep (find-component parent name)
		     (class-for-type parent type))))	     
      (error 'duplicate-names :name name))
    
947
948
949
    (let* ((other-args (remove-keys
			'(components pathname default-component-class
			  perform explain output-files operation-done-p
950
			  weakly-depends-on
951
952
953
954
955
			  depends-on serial in-order-to)
			rest))
	   (ret
	    (or (find-component parent name)
		(make-instance (class-for-type parent type)))))
956
957
      (when weakly-depends-on
	(setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on))))
958
959
      (when (boundp '*serial-depends-on*)
	(setf depends-on
960
	      (concatenate 'list *serial-depends-on* depends-on)))      
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
      (apply #'reinitialize-instance
	     ret
	     :name (coerce-name name)
	     :pathname pathname
	     :parent parent
	     other-args)
      (when (typep ret 'module)
	(setf (module-default-component-class ret)
	      (or default-component-class
		  (and (typep parent 'module)
		       (module-default-component-class parent))))
	(let ((*serial-depends-on* nil))
	  (setf (module-components ret)
		(loop for c-form in components
		      for c = (parse-component-form ret c-form)
		      collect c
		      if serial
978
979
980
		      do (push (component-name c) *serial-depends-on*))))

	;; check for duplicate names
981
	(let ((name-hash (make-hash-table :test #'equal)))
982
983
984
985
986
987
988
989
990
	  (loop for c in (module-components ret)
		do
		(if (gethash (component-name c)
			     name-hash)
		    (error 'duplicate-names
			   :name (component-name c))
		  (setf (gethash (component-name c)
				 name-hash)
			t)))))
991
992
993
994
995
996
997
998
999
1000
      
      (setf (slot-value ret 'in-order-to)
	    (union-of-dependencies
	     in-order-to
	     `((compile-op (compile-op ,@depends-on))
	       (load-op (load-op ,@depends-on))))
	    (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on))))
      
      (loop for (n v) in `((perform ,perform) (explain ,explain)
			   (output-files ,output-files)
For faster browsing, not all history is shown. View entire blame