asdf.lisp 40.2 KB
Newer Older
1
;;; This is asdf: Another System Definition Facility.  $Revision: 1.94 $
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.94 $")
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
(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)))))))

Christophe Rhodes's avatar
Fixes    
Christophe Rhodes committed
362
363
364
365
366
367
368
369
(defun make-temporary-package ()
  (flet ((try (counter)
           (ignore-errors
                   (make-package (format nil "ASDF~D" counter)
                                 :use '(:cl :asdf)))))
    (do* ((counter 0 (+ counter 1))
          (package (try counter) (try counter)))
         (package package))))
370

Daniel Barlow's avatar
   
Daniel Barlow committed
371
372
373
374
375
376
377
(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))))
Christophe Rhodes's avatar
Fixes    
Christophe Rhodes committed
378
379
380
381
382
383
384
385
      (let ((package (make-temporary-package)))
        (unwind-protect
             (let ((*package* package))
               (format 
                *verbose-out*
                "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
                ;; FIXME: This wants to be (ENOUGH-NAMESTRING
                ;; ON-DISK), but CMUCL barfs on that.
386
387
		on-disk
		*package*)
Christophe Rhodes's avatar
Fixes    
Christophe Rhodes committed
388
389
               (load on-disk))
          (delete-package package))))
Daniel Barlow's avatar
   
Daniel Barlow committed
390
391
392
393
394
395
396
    (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)
397
  (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
Daniel Barlow's avatar
   
Daniel Barlow committed
398
399
400
401
402
403
404
405
  (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
406

407
(defgeneric find-component (module name &optional version)
Christophe Rhodes's avatar
Christophe Rhodes committed
408
409
410
411
  (: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."))

412
(defmethod find-component ((module module) name &optional version)
Daniel Barlow's avatar
Daniel Barlow committed
413
  (if (slot-boundp module 'components)
414
415
416
417
      (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
418
419

;;; a component with no parent is a system
420
(defmethod find-component ((module (eql nil)) name &optional version)
Daniel Barlow's avatar
   
Daniel Barlow committed
421
  (let ((m (find-system name nil)))
422
    (if (and m (version-satisfies m version)) m)))
Daniel Barlow's avatar
Daniel Barlow committed
423

Daniel Barlow's avatar
   
Daniel Barlow committed
424
425
;;; component subclasses

Daniel Barlow's avatar
Daniel Barlow committed
426
427
428
(defclass source-file (component) ())

(defclass cl-source-file (source-file) ())
Daniel Barlow's avatar
Daniel Barlow committed
429
430
(defclass c-source-file (source-file) ())
(defclass java-source-file (source-file) ())
431
432
433
(defclass static-file (source-file) ())
(defclass doc-file (static-file) ())
(defclass html-file (doc-file) ())
Daniel Barlow's avatar
Daniel Barlow committed
434

Daniel Barlow's avatar
Daniel Barlow committed
435
436
437
438
(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
439
(defmethod source-file-type ((c html-file) (s module)) "html")
440
441
(defmethod source-file-type ((c static-file) (s module)) nil)

Daniel Barlow's avatar
Daniel Barlow committed
442
(defmethod component-relative-pathname ((component source-file))
Christophe Rhodes's avatar
Fixes    
Christophe Rhodes committed
443
444
  (let ((relative-pathname (slot-value component 'relative-pathname)))
    (if relative-pathname
445
446
447
448
        (merge-pathnames 
         relative-pathname
         (make-pathname 
          :type (source-file-type component (component-system component))))
Christophe Rhodes's avatar
Fixes    
Christophe Rhodes committed
449
450
451
452
453
454
455
456
        (let* ((*default-pathname-defaults* 
                (component-parent-pathname component))
               (name-type
                (make-pathname
                 :name (component-name component)
                 :type (source-file-type component
                                         (component-system component)))))
          name-type))))
Daniel Barlow's avatar
Daniel Barlow committed
457
458
459
460
461
462
463

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

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

(defclass operation ()
464
  ((forced :initform nil :initarg :force :accessor operation-forced)
465
466
467
468
469
470
   (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)))

471
472
473
474
475
(defmethod print-object ((o operation) stream)
  (print-unreadable-object (o stream :type t :identity t)
    (ignore-errors
      (prin1 (operation-original-initargs o) stream))))

476
477
478
479
480
481
(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
482

483
484
485
486
(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
487
(defgeneric input-files (operation component))
Daniel Barlow's avatar
Daniel Barlow committed
488

489
490
491
(defun node-for (o c)
  (cons (class-name (class-of o)) c))

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

495
496
497
498
499
(defmethod operation-ancestor ((operation operation))
  (aif (operation-parent operation)
       (operation-ancestor it)
       operation))

500
501
502
503
504
505
506
507
508
509
510
511

(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
512
		  :parent o
513
514
515
516
517
518
519
		  :original-initargs args args))
	  ((subtypep (type-of o) dep-o)
	   o)
	  (t 
	   (apply #'make-instance dep-o
		  :parent o :original-initargs args args)))))

520

Daniel Barlow's avatar
   
Daniel Barlow committed
521
(defgeneric visit-component (operation component data))
522

Daniel Barlow's avatar
   
Daniel Barlow committed
523
524
525
526
(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
527

528
(defgeneric component-visited-p (operation component))
Daniel Barlow's avatar
   
Daniel Barlow committed
529

Daniel Barlow's avatar
Daniel Barlow committed
530
(defmethod component-visited-p ((o operation) (c component))
Daniel Barlow's avatar
   
Daniel Barlow committed
531
532
533
  (assoc (node-for o c)
	 (operation-visited-nodes (operation-ancestor o))
	 :test 'equal))
Daniel Barlow's avatar
Daniel Barlow committed
534

535
536
(defgeneric (setf visiting-component) (new-value operation component))

537
538
539
(defmethod (setf visiting-component) (new-value operation component)
  ;; MCL complains about unused lexical variables
  (declare (ignorable new-value operation component)))
540

Daniel Barlow's avatar
Daniel Barlow committed
541
(defmethod (setf visiting-component) (new-value (o operation) (c component))
542
543
  (let ((node (node-for o c))
	(a (operation-ancestor o)))
544
    (if new-value
545
546
547
	(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
548

549
550
(defgeneric component-visiting-p (operation component))

Daniel Barlow's avatar
Daniel Barlow committed
551
(defmethod component-visiting-p ((o operation) (c component))
552
  (let ((node (cons o c)))
553
554
    (member node (operation-visiting-nodes (operation-ancestor o))
	    :test 'equal)))
Daniel Barlow's avatar
Daniel Barlow committed
555

556
557
558
(defgeneric component-depends-on (operation component))

(defmethod component-depends-on ((o operation) (c component))
559
560
  (cdr (assoc (class-name (class-of o))
	      (slot-value c 'in-order-to))))
561

562
563
(defgeneric component-self-dependencies (operation component))

Daniel Barlow's avatar
   
Daniel Barlow committed
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
(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)))))

583
(defmethod input-files ((operation operation) (c module)) nil)
584

Daniel Barlow's avatar
   
Daniel Barlow committed
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
(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)) ))))))
606

Daniel Barlow's avatar
Daniel Barlow committed
607
608
609
;;; 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
610
611
;;; 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
612

Daniel Barlow's avatar
Daniel Barlow committed
613
614
(defgeneric traverse (operation component))
(defmethod traverse ((operation operation) (c component))
Daniel Barlow's avatar
   
Daniel Barlow committed
615
616
  (let ((forced nil))
    (labels ((do-one-dep (required-op required-c required-v)
617
618
619
620
621
622
623
624
625
626
	       (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
627
		 (traverse op dep-c)))	   	   
Daniel Barlow's avatar
   
Daniel Barlow committed
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
	     (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
644
	   (return-from traverse
Daniel Barlow's avatar
   
Daniel Barlow committed
645
646
647
648
649
650
651
652
	     (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
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
      (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
674
675
676
677
678
679
680
		  (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=)))))
681
682
683
684
685
686
687
	  (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
688
689
690
691
      (setf (visiting-component operation c) nil)
      (visit-component operation c (and forced t))
      forced)))
  
Daniel Barlow's avatar
Daniel Barlow committed
692
693

(defmethod perform ((operation operation) (c source-file))
694
  (sysdef-error
695
696
   "~@<required method PERFORM not implemented ~
    for operation ~A, component ~A~@:>"
Daniel Barlow's avatar
Daniel Barlow committed
697
698
699
700
701
702
   (class-of operation) (class-of c)))

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

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

705
;;; compile-op
Daniel Barlow's avatar
Daniel Barlow committed
706

707
708
(defclass compile-op (operation)
  ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
Daniel Barlow's avatar
   
Daniel Barlow committed
709
710
711
712
   (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*)))
713
714

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

Daniel Barlow's avatar
   
Daniel Barlow committed
717
718
719
(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
720

721
722
;;; perform is required to check output-files to find out where to put
;;; its answers, in case it has been overridden for site policy
723
(defmethod perform ((operation compile-op) (c cl-source-file))
724
  #-:broken-fasl-loader
725
726
  (let ((source-file (component-pathname c))
	(output-file (car (output-files operation c))))
Daniel Barlow's avatar
Daniel Barlow committed
727
    (multiple-value-bind (output warnings-p failure-p)
728
729
	(compile-file source-file
		      :output-file output-file)
730
      ;(declare (ignore output))
Daniel Barlow's avatar
   
Daniel Barlow committed
731
732
      (when warnings-p
	(case (operation-on-warnings operation)
733
	  (:warn (warn
734
		  "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
735
		  operation c))
Daniel Barlow's avatar
   
Daniel Barlow committed
736
737
738
739
	  (:error (error 'compile-warned :component c :operation operation))
	  (:ignore nil)))
      (when failure-p
	(case (operation-on-failure operation)
740
	  (:warn (warn
741
		  "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
742
		  operation c))
Daniel Barlow's avatar
   
Daniel Barlow committed
743
	  (:error (error 'compile-failed :component c :operation operation))
744
745
746
	  (:ignore nil)))
      (unless output
	(error 'compile-error :component c :operation operation)))))
Daniel Barlow's avatar
Daniel Barlow committed
747

748
(defmethod output-files ((operation compile-op) (c cl-source-file))
749
750
  #-:broken-fasl-loader (list (compile-file-pathname (component-pathname c)))
  #+:broken-fasl-loader (list (component-pathname c)))
Daniel Barlow's avatar
Daniel Barlow committed
751

Daniel Barlow's avatar
Daniel Barlow committed
752
753
754
755
756
757
(defmethod perform ((operation compile-op) (c static-file))
  nil)

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

758
;;; load-op
Daniel Barlow's avatar
Daniel Barlow committed
759

760
(defclass load-op (operation) ())
761

762
(defmethod perform ((o load-op) (c cl-source-file))
Daniel Barlow's avatar
Daniel Barlow committed
763
  (mapcar #'load (input-files o c)))
Daniel Barlow's avatar
Daniel Barlow committed
764

Daniel Barlow's avatar
Daniel Barlow committed
765
766
(defmethod perform ((operation load-op) (c static-file))
  nil)
Daniel Barlow's avatar
   
Daniel Barlow committed
767
768
(defmethod operation-done-p ((operation load-op) (c static-file))
  t)
Daniel Barlow's avatar
Daniel Barlow committed
769

Daniel Barlow's avatar
   
Daniel Barlow committed
770
(defmethod output-files ((o operation) (c component))
Daniel Barlow's avatar
Daniel Barlow committed
771
  nil)
772

773
(defmethod component-depends-on ((operation load-op) (c component))
774
775
776
  (cons (list 'compile-op (component-name c))
        (call-next-method)))

777
778
779
780
781
;;; load-source-op

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

(defmethod perform ((o load-source-op) (c cl-source-file))
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
  (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))
808

809
810
811
812
(defclass test-op (operation) ())

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

Daniel Barlow's avatar
Daniel Barlow committed
814
815
816
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; invoking operations

Daniel Barlow's avatar
Daniel Barlow committed
817
(defun operate (operation-class system &rest args)
Daniel Barlow's avatar
   
Daniel Barlow committed
818
819
  (let* ((op (apply #'make-instance operation-class
		    :original-initargs args args))
820
821
	 (*verbose-out*
	  (if (getf args :verbose t)
822
	      *trace-output*
823
	      (make-broadcast-stream)))
Daniel Barlow's avatar
   
Daniel Barlow committed
824
	 (system (if (typep system 'component) system (find-system system)))
Daniel Barlow's avatar
Daniel Barlow committed
825
	 (steps (traverse op system)))
826
    (with-compilation-unit ()
Daniel Barlow's avatar
Daniel Barlow committed
827
      (loop for (op . component) in steps do
Daniel Barlow's avatar
   
Daniel Barlow committed
828
829
	    (loop
	     (restart-case 
Daniel Barlow's avatar
Daniel Barlow committed
830
		 (progn (perform op component)
Daniel Barlow's avatar
   
Daniel Barlow committed
831
			(return))
832
833
834
	       (retry ()
		 :report
		 (lambda (s)
835
		   (format s "~@<Retry performing ~S on ~S.~@:>"
836
837
838
839
840
			   op component)))
	       (accept ()
		 :report
		 (lambda (s)
		   (format s
841
842
			   "~@<Continue, treating ~S on ~S as ~
                            having been successful.~@:>"
843
844
845
846
847
			   op component))
		 (setf (gethash (type-of op)
				(component-operation-times component))
		       (get-universal-time))
		 (return))))))))
Daniel Barlow's avatar
Daniel Barlow committed
848

Daniel Barlow's avatar
Daniel Barlow committed
849
850
851
852
(defun oos (&rest args)
  "Alias of OPERATE function"
  (apply #'operate args))

Daniel Barlow's avatar
Daniel Barlow committed
853
854
855
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; syntax

856
(defun remove-keyword (key arglist)
857
858
859
860
861
862
863
  (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)))
864

Daniel Barlow's avatar
Daniel Barlow committed
865
(defmacro defsystem (name &body options)
Daniel Barlow's avatar
   
Daniel Barlow committed
866
  (destructuring-bind (&key pathname (class 'system) &allow-other-keys) options
867
    (let ((component-options (remove-keyword :class options)))
Daniel Barlow's avatar
   
Daniel Barlow committed
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
      `(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
888
				       (pathname-sans-name+type
Daniel Barlow's avatar
Daniel Barlow committed
889
					(resolve-symlinks  *load-truename*))
Daniel Barlow's avatar
   
Daniel Barlow committed
890
891
892
				       *default-pathname-defaults*)
				   ',component-options))))))
  
893
894

(defun class-for-type (parent type)
895
896
897
898
899
  (let ((class 
	 (find-class
	  (or (find-symbol (symbol-name type) *package*)
	      (find-symbol (symbol-name type) #.(package-name *package*)))
	  nil)))
900
901
902
903
    (or class
	(and (eq type :file)
	     (or (module-default-component-class parent)
		 (find-class 'cl-source-file)))
904
	(sysdef-error "~@<don't recognize component type ~A~@:>" type))))
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929

(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))
930

931
932
933
934
935
936
937

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

938
939
(defvar *serial-depends-on*)

940
941
(defun parse-component-form (parent options)
  (destructuring-bind
Daniel Barlow's avatar
Daniel Barlow committed
942
943
944
945
946
	(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
947
	      weakly-depends-on
948
	      depends-on serial in-order-to
Daniel Barlow's avatar
Daniel Barlow committed
949
950
	      ;; list ends
	      &allow-other-keys) options
951
    (check-component-input type name weakly-depends-on depends-on components in-order-to)
952
953
954
955
956
957
958
959
960

    (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))
    
961
962
963
    (let* ((other-args (remove-keys
			'(components pathname default-component-class
			  perform explain output-files operation-done-p
964
			  weakly-depends-on
965
966
967
968
969
			  depends-on serial in-order-to)
			rest))
	   (ret
	    (or (find-component parent name)
		(make-instance (class-for-type parent type)))))
970
971
      (when weakly-depends-on
	(setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on))))
972
973
      (when (boundp '*serial-depends-on*)
	(setf depends-on
974
	      (concatenate 'list *serial-depends-on* depends-on)))      
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
      (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
992
993
994
		      do (push (component-name c) *serial-depends-on*))))

	;; check for duplicate names
995
	(let ((name-hash (make-hash-table :test #'equal)))
996
997
998
999
1000
	  (loop for c in (module-components ret)
		do
		(if (gethash (component-name c)
			     name-hash)
		    (error 'duplicate-names
For faster browsing, not all history is shown. View entire blame