asdf.lisp 41.4 KB
Newer Older
1
;;; This is asdf: Another System Definition Facility.  $Revision: 1.99 $
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
	   #:system-description
	   #:system-long-description
	   #:system-author
	   #:system-maintainer
	   #:system-license
81
	   #:system-licence
Daniel Barlow's avatar
Daniel Barlow committed
82
	   
83
84
	   #:operation-on-warnings
	   #:operation-on-failure
85
	   
Daniel Barlow's avatar
Daniel Barlow committed
86
	   ;#:*component-parent-pathname* 
Daniel Barlow's avatar
Daniel Barlow committed
87
	   #:*system-definition-search-functions*
Daniel Barlow's avatar
Daniel Barlow committed
88
	   #:*central-registry*		; variables
89
90
	   #:*compile-file-warnings-behaviour*
	   #:*compile-file-failure-behaviour*
Daniel Barlow's avatar
Daniel Barlow committed
91
	   #:*asdf-revision*
92
	   
93
	   #:operation-error #:compile-failed #:compile-warned #:compile-error
94
	   #:error-component #:error-operation
95
96
	   #:system-definition-error 
	   #:missing-component
97
	   #:missing-dependency
98
	   #:circular-dependency	; errors
99
100
	   #:duplicate-names
	   
101
102
103
	   #:retry
	   #:accept                     ; restarts
	   
104
	   )
Daniel Barlow's avatar
Daniel Barlow committed
105
  (:use :cl))
106

107
108
109
110
#+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
111
112
(in-package #:asdf)

113
(defvar *asdf-revision* (let* ((v "$Revision: 1.99 $")
114
			       (colon (or (position #\: v) -1))
115
116
117
118
119
120
121
			       (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)))))

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

125
(defvar *verbose-out* nil)
126

127
128
129
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; utility stuff

130
131
132
133
134
135
136
(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))
137

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

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

144
145
146
147
148
149
150
151
152
(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
153
(define-condition formatted-system-definition-error (system-definition-error)
154
155
156
157
158
  ((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
159
(define-condition circular-dependency (system-definition-error)
160
  ((components :initarg :components :reader circular-dependency-components)))
161

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

165
166
167
168
169
170
171
172
(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
173
174
175
176
(define-condition operation-error (error)
  ((component :reader error-component :initarg :component)
   (operation :reader error-operation :initarg :operation))
  (:report (lambda (c s)
177
	     (format s "~@<erred while invoking ~A on ~A~@:>"
Daniel Barlow's avatar
Daniel Barlow committed
178
		     (error-operation c) (error-component c)))))
179
180
181
(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
182
183

(defclass component ()
184
185
  ((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
186
   (version :accessor component-version :initarg :version)
187
   (in-order-to :initform nil :initarg :in-order-to)
188
189
   ;;; XXX crap name
   (do-first :initform nil :initarg :do-first)
190
191
192
193
   ;; 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
194
   (parent :initarg :parent :initform nil :reader component-parent)
Daniel Barlow's avatar
Daniel Barlow committed
195
196
   ;; 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
197
   (relative-pathname :initarg :pathname)
Daniel Barlow's avatar
   
Daniel Barlow committed
198
199
   (operation-times :initform (make-hash-table )
		    :accessor component-operation-times)
Daniel Barlow's avatar
   
Daniel Barlow committed
200
201
   ;; XXX we should provide some atomic interface for updating the
   ;; component properties
202
203
   (properties :accessor component-properties :initarg :properties
	       :initform nil)))
Daniel Barlow's avatar
   
Daniel Barlow committed
204

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

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

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

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

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

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

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

(defclass module (component)
Daniel Barlow's avatar
   
Daniel Barlow committed
239
  ((components :initform nil :accessor module-components :initarg :components)
240
241
242
243
244
   ;; 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
245
246
247
   (default-component-class :accessor module-default-component-class
     :initform 'cl-source-file :initarg :default-component-class)))

Daniel Barlow's avatar
   
Daniel Barlow committed
248
249
250
251
252
253
254
255
(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*))

256
257
258
(defgeneric component-relative-pathname (component)
  (:documentation "Extracts the relative pathname applicable for a particular component."))
   
Daniel Barlow's avatar
Daniel Barlow committed
259
(defmethod component-relative-pathname ((component module))
Daniel Barlow's avatar
Daniel Barlow committed
260
261
262
263
264
  (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
265
266
267
268
(defmethod component-pathname ((component component))
  (let ((*default-pathname-defaults* (component-parent-pathname component)))
    (merge-pathnames (component-relative-pathname component))))

269
270
(defgeneric component-property (component property))

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

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

276
(defmethod (setf component-property) (new-value (c component) property)
Daniel Barlow's avatar
Daniel Barlow committed
277
  (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
278
279
280
281
282
    (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
283
284
(defclass system (module)
  ((description :accessor system-description :initarg :description)
Daniel Barlow's avatar
Daniel Barlow committed
285
286
   (long-description
    :accessor system-long-description :initarg :long-description)
Daniel Barlow's avatar
   
Daniel Barlow committed
287
288
   (author :accessor system-author :initarg :author)
   (maintainer :accessor system-maintainer :initarg :maintainer)
289
290
   (licence :accessor system-licence :initarg :licence
	    :accessor system-license :initarg :license)))
Daniel Barlow's avatar
   
Daniel Barlow committed
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307

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

308
309
(defgeneric version-satisfies (component version))

Daniel Barlow's avatar
   
Daniel Barlow committed
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
(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)
335
     (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
Daniel Barlow's avatar
   
Daniel Barlow committed
336

337
338
339
340
341
342
;;; 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))

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

352
353
354
355
356
357
358
359
360
361
362
363
(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
364
365
366
367
368
369
370
371
(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))))
372

Daniel Barlow's avatar
   
Daniel Barlow committed
373
374
375
376
377
378
379
(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
380
381
382
383
384
385
386
387
      (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.
388
389
		on-disk
		*package*)
Christophe Rhodes's avatar
Fixes    
Christophe Rhodes committed
390
391
               (load on-disk))
          (delete-package package))))
Daniel Barlow's avatar
   
Daniel Barlow committed
392
393
394
395
396
397
398
    (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)
399
  (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
Daniel Barlow's avatar
   
Daniel Barlow committed
400
401
402
403
404
405
406
407
  (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
408

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

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

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

Daniel Barlow's avatar
   
Daniel Barlow committed
426
427
;;; component subclasses

Daniel Barlow's avatar
Daniel Barlow committed
428
429
430
(defclass source-file (component) ())

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

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

Daniel Barlow's avatar
Daniel Barlow committed
444
(defmethod component-relative-pathname ((component source-file))
Christophe Rhodes's avatar
Fixes    
Christophe Rhodes committed
445
446
  (let ((relative-pathname (slot-value component 'relative-pathname)))
    (if relative-pathname
447
448
449
450
        (merge-pathnames 
         relative-pathname
         (make-pathname 
          :type (source-file-type component (component-system component))))
Christophe Rhodes's avatar
Fixes    
Christophe Rhodes committed
451
452
453
454
455
456
457
458
        (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
459
460
461
462
463
464
465

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

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

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

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

478
479
480
481
482
483
(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
484

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

491
492
493
(defun node-for (o c)
  (cons (class-name (class-of o)) c))

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

497
498
499
500
501
(defmethod operation-ancestor ((operation operation))
  (aif (operation-parent operation)
       (operation-ancestor it)
       operation))

502
503
504
505
506
507
508
509
510
511
512
513

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

522

Daniel Barlow's avatar
   
Daniel Barlow committed
523
(defgeneric visit-component (operation component data))
524

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

530
(defgeneric component-visited-p (operation component))
Daniel Barlow's avatar
   
Daniel Barlow committed
531

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

537
538
(defgeneric (setf visiting-component) (new-value operation component))

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

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

551
552
(defgeneric component-visiting-p (operation component))

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

558
559
560
(defgeneric component-depends-on (operation component))

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

564
565
(defgeneric component-self-dependencies (operation component))

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

585
(defmethod input-files ((operation operation) (c module)) nil)
586

Daniel Barlow's avatar
   
Daniel Barlow committed
587
(defmethod operation-done-p ((o operation) (c component))
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
  (flet ((fwd-or-return-t (file)
           ;; if FILE-WRITE-DATE returns NIL, it's possible that the
           ;; user or some other agent has deleted an input file.  If
           ;; that's the case, well, that's not good, but as long as
           ;; the operation is otherwise considered to be done we
           ;; could continue and survive.
           (let ((date (file-write-date file)))
             (cond
               (date)
               (t 
                (warn "~@<Missing FILE-WRITE-DATE for ~S: treating ~
                       operation ~S on component ~S as done.~@:>" 
                      file o c)
                (return-from operation-done-p t))))))
    (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
                        (apply #'max
                               (mapcar #'fwd-or-return-t in-files))))))
            ((not in-files) nil)
            (t
             (and
              (every #'probe-file out-files)
              (> (apply #'min (mapcar #'file-write-date out-files))
                 (apply #'max (mapcar #'fwd-or-return-t in-files)))))))))
622

Daniel Barlow's avatar
Daniel Barlow committed
623
624
625
;;; 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
626
627
;;; 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
628

Daniel Barlow's avatar
Daniel Barlow committed
629
630
(defgeneric traverse (operation component))
(defmethod traverse ((operation operation) (c component))
Daniel Barlow's avatar
   
Daniel Barlow committed
631
632
  (let ((forced nil))
    (labels ((do-one-dep (required-op required-c required-v)
633
634
635
636
637
638
639
640
641
642
	       (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
643
		 (traverse op dep-c)))	   	   
Daniel Barlow's avatar
   
Daniel Barlow committed
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
	     (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
660
	   (return-from traverse
Daniel Barlow's avatar
   
Daniel Barlow committed
661
662
663
664
665
666
667
668
	     (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
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
      (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
690
691
692
693
694
695
696
		  (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=)))))
697
698
699
700
701
702
703
	  (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
704
705
706
707
      (setf (visiting-component operation c) nil)
      (visit-component operation c (and forced t))
      forced)))
  
Daniel Barlow's avatar
Daniel Barlow committed
708
709

(defmethod perform ((operation operation) (c source-file))
710
  (sysdef-error
711
712
   "~@<required method PERFORM not implemented ~
    for operation ~A, component ~A~@:>"
Daniel Barlow's avatar
Daniel Barlow committed
713
714
715
716
717
718
   (class-of operation) (class-of c)))

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

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

721
;;; compile-op
Daniel Barlow's avatar
Daniel Barlow committed
722

723
724
(defclass compile-op (operation)
  ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
Daniel Barlow's avatar
   
Daniel Barlow committed
725
726
727
728
   (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*)))
729
730

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

Daniel Barlow's avatar
   
Daniel Barlow committed
733
734
735
(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
736

737
738
;;; perform is required to check output-files to find out where to put
;;; its answers, in case it has been overridden for site policy
739
(defmethod perform ((operation compile-op) (c cl-source-file))
740
  #-:broken-fasl-loader
741
742
  (let ((source-file (component-pathname c))
	(output-file (car (output-files operation c))))
Daniel Barlow's avatar
Daniel Barlow committed
743
    (multiple-value-bind (output warnings-p failure-p)
744
745
	(compile-file source-file
		      :output-file output-file)
746
      ;(declare (ignore output))
Daniel Barlow's avatar
   
Daniel Barlow committed
747
748
      (when warnings-p
	(case (operation-on-warnings operation)
749
	  (:warn (warn
750
		  "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
751
		  operation c))
Daniel Barlow's avatar
   
Daniel Barlow committed
752
753
754
755
	  (:error (error 'compile-warned :component c :operation operation))
	  (:ignore nil)))
      (when failure-p
	(case (operation-on-failure operation)
756
	  (:warn (warn
757
		  "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
758
		  operation c))
Daniel Barlow's avatar
   
Daniel Barlow committed
759
	  (:error (error 'compile-failed :component c :operation operation))
760
761
762
	  (:ignore nil)))
      (unless output
	(error 'compile-error :component c :operation operation)))))
Daniel Barlow's avatar
Daniel Barlow committed
763

764
(defmethod output-files ((operation compile-op) (c cl-source-file))
765
766
  #-:broken-fasl-loader (list (compile-file-pathname (component-pathname c)))
  #+:broken-fasl-loader (list (component-pathname c)))
Daniel Barlow's avatar
Daniel Barlow committed
767

Daniel Barlow's avatar
Daniel Barlow committed
768
769
770
771
772
773
(defmethod perform ((operation compile-op) (c static-file))
  nil)

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

774
;;; load-op
Daniel Barlow's avatar
Daniel Barlow committed
775

776
(defclass load-op (operation) ())
777

778
(defmethod perform ((o load-op) (c cl-source-file))
Daniel Barlow's avatar
Daniel Barlow committed
779
  (mapcar #'load (input-files o c)))
Daniel Barlow's avatar
Daniel Barlow committed
780

Daniel Barlow's avatar
Daniel Barlow committed
781
782
(defmethod perform ((operation load-op) (c static-file))
  nil)
Daniel Barlow's avatar
   
Daniel Barlow committed
783
784
(defmethod operation-done-p ((operation load-op) (c static-file))
  t)
Daniel Barlow's avatar
Daniel Barlow committed
785

Daniel Barlow's avatar
   
Daniel Barlow committed
786
(defmethod output-files ((o operation) (c component))
Daniel Barlow's avatar
Daniel Barlow committed
787
  nil)
788

789
(defmethod component-depends-on ((operation load-op) (c component))
790
791
792
  (cons (list 'compile-op (component-name c))
        (call-next-method)))

793
794
795
796
797
;;; load-source-op

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

(defmethod perform ((o load-source-op) (c cl-source-file))
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
  (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))
824

825
826
827
828
(defclass test-op (operation) ())

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

Daniel Barlow's avatar
Daniel Barlow committed
830
831
832
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; invoking operations

833
834
(defun operate (operation-class system &rest args &key (verbose t) version 
                                &allow-other-keys)
Daniel Barlow's avatar
   
Daniel Barlow committed
835
  (let* ((op (apply #'make-instance operation-class
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
		    :original-initargs args
		    args))
	 (*verbose-out* (if verbose *trace-output* (make-broadcast-stream)))
	 (system (if (typep system 'component) system (find-system system))))
    (unless (version-satisfies system version)
      (error 'missing-component :requires system :version version))
    (let ((steps (traverse op system)))
      (with-compilation-unit ()
	(loop for (op . component) in steps do
	     (loop
		(restart-case 
		    (progn (perform op component)
			   (return))
		  (retry ()
		    :report
		    (lambda (s)
		      (format s "~@<Retry performing ~S on ~S.~@:>"
			      op component)))
		  (accept ()
		    :report
		    (lambda (s)
		      (format s
			      "~@<Continue, treating ~S on ~S as ~
                               having been successful.~@:>"
			      op component))
		    (setf (gethash (type-of op)
				   (component-operation-times component))
			  (get-universal-time))
		    (return)))))))))
Daniel Barlow's avatar
Daniel Barlow committed
865

Daniel Barlow's avatar
Daniel Barlow committed
866
867
868
869
(defun oos (&rest args)
  "Alias of OPERATE function"
  (apply #'operate args))

Daniel Barlow's avatar
Daniel Barlow committed
870
871
872
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; syntax

873
(defun remove-keyword (key arglist)
874
875
876
877
878
879
880
  (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)))
881

Daniel Barlow's avatar
Daniel Barlow committed
882
(defmacro defsystem (name &body options)
Daniel Barlow's avatar
   
Daniel Barlow committed
883
  (destructuring-bind (&key pathname (class 'system) &allow-other-keys) options
884
    (let ((component-options (remove-keyword :class options)))
Daniel Barlow's avatar
   
Daniel Barlow committed
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
      `(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
905
				       (pathname-sans-name+type
Daniel Barlow's avatar
Daniel Barlow committed
906
					(resolve-symlinks  *load-truename*))
Daniel Barlow's avatar
   
Daniel Barlow committed
907
908
909
				       *default-pathname-defaults*)
				   ',component-options))))))
  
910
911

(defun class-for-type (parent type)
912
913
914
915
916
  (let ((class 
	 (find-class
	  (or (find-symbol (symbol-name type) *package*)
	      (find-symbol (symbol-name type) #.(package-name *package*)))
	  nil)))
917
918
919
920
    (or class
	(and (eq type :file)
	     (or (module-default-component-class parent)
		 (find-class 'cl-source-file)))
921
	(sysdef-error "~@<don't recognize component type ~A~@:>" type))))
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946

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

948
949
950
951
952
953
954

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

955
956
(defvar *serial-depends-on*)

957
958
(defun parse-component-form (parent options)
  (destructuring-bind
Daniel Barlow's avatar
Daniel Barlow committed
959
960
961
962
963
	(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
964
	      weakly-depends-on
965
	      depends-on serial in-order-to
Daniel Barlow's avatar
Daniel Barlow committed
966
967
	      ;; list ends
	      &allow-other-keys) options
968
    (check-component-input type name weakly-depends-on depends-on components in-order-to)
969
970
971
972
973
974
975
976
977

    (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))
    
978
979
980
    (let* ((other-args (remove-keys
			'(components pathname default-component-class
			  perform explain output-files operation-done-p
981
			  weakly-depends-on
982
983
984
985
986
			  depends-on serial in-order-to)
			rest))
	   (ret
	    (or (find-component parent name)
		(make-instance (class-for-type parent type)))))
987
988
      (when weakly-depends-on
	(setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on))))
989
990
      (when (boundp '*serial-depends-on*)
	(setf depends-on
991
	      (concatenate 'list *serial-depends-on* depends-on)))      
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
      (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
1009
1010
1011
		      do (push (component-name c) *serial-depends-on*))))

	;; check for duplicate names
1012
	(let ((name-hash (make-hash-table :test #'equal)))
1013
1014
1015
1016
1017
1018
1019
1020
1021
	  (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)))))
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
      
      (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)
			   (operation-done-p ,operation-done-p))
	    do (map 'nil
		    ;; this is inefficient as most of the stored
		    ;; methods will not be for this particular gf n
		    ;; But this is hardly performance-critical
		    (lambda (m) (remove-method (symbol-function n) m))
		    (component-inline-methods ret))
	    when v
	    do (destructuring-bind (op qual (o c) &body body) v
		 (pushnew
		  (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret)))
			  ,@body))
		  (component-inline-methods ret))))
      ret)))
1046

1047
(defun check-component-input (type name weakly-depends-on depends-on components in-order-to)
1048
  "A partial test of the values of a component."
1049
  (when weakly-depends-on (warn "We got one! XXXXX"))
1050
  (unless (listp depends-on)
Kevin Rosenberg's avatar
1.70:    
Kevin Rosenberg committed
1051
1052
    (sysdef-error-component ":depends-on must be a list."
			    type name depends-on))
1053
1054
1055
  (unless (listp weakly-depends-on)
    (sysdef-error-component ":weakly-depends-on must be a list."
			    type name weakly-depends-on))
Kevin Rosenberg's avatar
1.70:    
Kevin Rosenberg committed
1056
1057
1058
1059
  (unless (listp components)
    (sysdef-error-component ":components must be NIL or a list of components."
			    type name components))
  (unless (and (listp in-order-to) (listp (car in-order-to)))
1060
    (sysdef-error-component ":in-order-to must be NIL or a list of components."
Kevin Rosenberg's avatar
1.70:    
Kevin Rosenberg committed
1061
1062
1063
1064
1065
1066
			   type name in-order-to)))

(defun sysdef-error-component (msg type name value)
  (sysdef-error (concatenate 'string msg
			     "~&The value specified for ~(~A~) ~A is ~W")
		type name value))
Daniel Barlow's avatar
Daniel Barlow committed
1067

1068
(defun resolve-symlinks (path)
1069
1070
1071
  #-allegro (truename path)
  #+allegro (excl:pathname-resolve-symbolic-links path)
  )
1072

Daniel Barlow's avatar
Daniel Barlow committed
1073
1074
;;; optional extras

1075
1076
1077
1078
;;; run-shell-command functions for other lisp implementations will be
;;; gratefully accepted, if they do the same thing.  If the docstring
;;; is ambiguous, send a bug report

Daniel Barlow's avatar
Daniel Barlow committed
1079
(defun run-shell-command (control-string &rest args)
1080
1081
  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
synchronously execute the result using a Bourne-compatible shell, with
1082
output to *VERBOSE-OUT*.  Returns the shell's exit code."
Daniel Barlow's avatar
Daniel Barlow committed
1083
  (let ((command (apply #'format nil control-string args)))
1084
    (format *verbose-out* "; $ ~A~%" command)
1085
    #+sbcl
1086
    (sb-ext:process-exit-code
Daniel Barlow's avatar
Daniel Barlow committed
1087
     (sb-ext:run-program  
1088
      #+win32 "sh" #-win32 "/bin/sh"
Daniel Barlow's avatar
Daniel Barlow committed
1089
      (list  "-c" command)
1090
      #+win32 #+win32 :search t
1091
      :input nil :output *verbose-out*))
1092
1093
    
    #+(or cmu scl)
Daniel Barlow's avatar
Daniel Barlow committed
1094
1095
1096
1097
    (ext:process-exit-code
     (ext:run-program  
      "/bin/sh"
      (list  "-c" command)
1098
      :input nil :output *verbose-out*))
1099
1100

    #+allegro
1101
    (excl:run-shell-command command :input nil :output *verbose-out*)
1102
1103
1104
1105
1106
    
    #+lispworks
    (system:call-system-showing-output
     command
     :shell-type "/bin/sh"
1107
     :output-stream *verbose-out*)
1108
    
1109
    #+clisp				;XXX not exactly *verbose-out*, I know
1110
1111
1112
    (ext:run-shell-command  command :output :terminal :wait t)

    #+openmcl
1113
    (nth-value 1
1114
1115
	       (ccl:external-process-status
		(ccl:run-program "/bin/sh" (list "-c" command)
1116
				 :input nil :output *verbose-out*
1117
				 :wait t)))
1118
1119
1120
    #+ecl ;; courtesy of Juan Jose Garcia Ripoll
    (si:system command)
    #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl)
1121
1122
    (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
    ))
1123

1124
1125
1126
1127
1128
1129
1130
1131
1132

(defgeneric hyperdocumentation (package name doc-type))
(defmethod hyperdocumentation ((package symbol) name doc-type)
  (hyperdocumentation (find-package package) name doc-type))

(defun hyperdoc (name doc-type)
  (hyperdocumentation (symbol-package name) name doc-type))


Daniel Barlow's avatar
Daniel Barlow committed
1133
(pushnew :asdf *features*)
1134
1135
1136
1137
1138
1139
1140
1141
1142

#+sbcl
(eval-when (:compile-toplevel :load-toplevel :execute)
  (when (sb-ext:posix-getenv "SBCL_BUILDING_CONTRIB")
    (pushnew :sbcl-hooks-require *features*)))

#+(and sbcl sbcl-hooks-require)
(progn
  (defun module-provide-asdf (name)
1143
1144
1145
1146
1147
1148
    (handler-bind ((style-warning #'muffle-warning))
      (let* ((*verbose-out* (make-broadcast-stream))
	     (system (asdf:find-system name nil)))
	(when system
	  (asdf:operate 'asdf:load-op name)
	  t))))
1149

1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
  (defun contrib-sysdef-search (system)
    (let* ((name (coerce-name system))
           (home (truename (sb-ext:posix-getenv "SBCL_HOME")))
           (contrib (merge-pathnames
                     (make-pathname :directory `(:relative ,name)
                                    :name name
                                    :type "asd"
                                    :case :local
                                    :version :newest)
                     home)))
      (probe-file contrib)))
1161
  
1162
  (pushnew
1163
1164
   '(merge-pathnames "site-systems/"
     (truename (sb-ext:posix-getenv "SBCL_HOME")))
1165
1166
1167
   *central-registry*)
  
  (pushnew
1168
1169
   '(merge-pathnames ".sbcl/systems/"
     (user-homedir-pathname))
1170
1171
   *central-registry*)
  
1172
1173
  (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)
  (pushnew 'contrib-sysdef-search *system-definition-search-functions*))
1174
1175

(provide 'asdf)