asdf.lisp 59.7 KB
Newer Older
1
;;; This is asdf: Another System Definition Facility. 
2
;;; hash - $Format:%H$
3
;;;
Gary King's avatar
Gary King committed
4
5
6
7
;;; Local Variables:
;;; mode: lisp
;;; End:
;;;
8
;;; Feedback, bug reports, and patches are all welcome: please mail to
9
10
11
;;; <asdf-devel@common-lisp.net>.  But note first that the canonical
;;; source for asdf is presently on common-lisp.net at
;;; <URL:http://common-lisp.net/project/asdf/>
12
13
14
15
16
;;;
;;; 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
17
;;; bugs.  There are usually two "supported" revisions - the git HEAD
18
19
20
;;; is the latest development version, whereas the revision tagged
;;; RELEASE may be slightly older but is considered `stable'

21
22
23
24
25
;;; -- LICENSE START
;;; (This is the MIT / X Consortium license as taken from 
;;;  http://www.opensource.org/licenses/mit-license.html on or about
;;;  Monday; July 13, 2009)
;;;
26
;;; Copyright (c) 2001-2009 Daniel Barlow and contributors
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
;;;
;;; 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.
46
47
;;;
;;; -- LICENSE END
48

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

52
53
#+xcvb (module ())

Daniel Barlow's avatar
Daniel Barlow committed
54
(defpackage #:asdf
Daniel Barlow's avatar
Daniel Barlow committed
55
  (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command
56
           #:system-definition-pathname #:find-component ; miscellaneous
57
	   #:compile-system #:load-system #:test-system
Nikodemus Siivola's avatar
Nikodemus Siivola committed
58
           #:compile-op #:load-op #:load-source-op
59
           #:test-op
60
61
62
           #:operation		 ; operations
           #:feature		 ; sort-of operation
           #:version		 ; metaphorically sort-of an operation
63

64
           #:input-files #:output-files #:perform ; operation methods
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
           #:operation-done-p #:explain

           #:component #:source-file
           #:c-source-file #:cl-source-file #:java-source-file
           #:static-file
           #:doc-file
           #:html-file
           #:text-file
           #:source-file-type
           #:module                     ; components
           #:system
           #:unix-dso

           #:module-components          ; component accessors
           #:component-pathname
           #:component-relative-pathname
           #:component-name
           #:component-version
           #:component-parent
           #:component-property
           #:component-system

           #:component-depends-on

           #:system-description
           #:system-long-description
           #:system-author
           #:system-maintainer
           #:system-license
           #:system-licence
           #:system-source-file
           #:system-relative-pathname
Gary King's avatar
Gary King committed
97
	   #:map-systems
98
99
100
101

           #:operation-on-warnings
           #:operation-on-failure

102
					;#:*component-parent-pathname*
103
104
105
106
107
108
109
110
111
112
           #:*system-definition-search-functions*
           #:*central-registry*         ; variables
           #:*compile-file-warnings-behaviour*
           #:*compile-file-failure-behaviour*
           #:*asdf-revision*

           #:operation-error #:compile-failed #:compile-warned #:compile-error
           #:error-component #:error-operation
           #:system-definition-error
           #:missing-component
113
	   #:missing-component-of-version
114
           #:missing-dependency
115
           #:missing-dependency-of-version
116
117
118
           #:circular-dependency        ; errors
           #:duplicate-names

119
	   #:try-recompiling
120
121
           #:retry
           #:accept                     ; restarts
122
123
	   #:coerce-entry-to-directory
	   #:remove-entry-from-registry
124
125
126

           #:standard-asdf-method-combination
           #:around                     ; protocol assistants
127
	   )
Daniel Barlow's avatar
Daniel Barlow committed
128
  (:use :cl))
129

130

131
#+nil
132
133
134
(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")
135

Daniel Barlow's avatar
Daniel Barlow committed
136
137
(in-package #:asdf)

138
(defvar *asdf-revision*
139
140
  ;; find first tag that looks like /tags/[0-9]*\.[0-9]*. E.g., /tags/1.34
  ;; return nil or a list of the major and minor version numbers
141
142
  (let* ((v "$Format:%d$")
	 (to-find "tags/")
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
	 (start 0))
    (when v
      (loop for tag-start = (search to-find v :test #'char= :start2 start)
	 while tag-start do
	 (when tag-start
	   (let ((dot (position #\. v :start tag-start))
		 (space (position #\space v :start tag-start)))
	     (when (and dot (or (not space) (< dot space)))
	       ;; success
	       (return
		 (list (parse-integer v :start (+ tag-start (length to-find))
				      :junk-allowed t)
		       (parse-integer v :start (1+ dot)
				      :junk-allowed t))))
	     (setf start (1+ tag-start))))))))
158

159
(defvar *compile-file-warnings-behaviour* :warn)
160

161
(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn)
Daniel Barlow's avatar
   
Daniel Barlow committed
162

163
(defvar *verbose-out* nil)
164

165
166
167
(defparameter +asdf-methods+
  '(perform explain output-files operation-done-p))

168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
(define-method-combination standard-asdf-method-combination ()
  ((around-asdf (around))
   (around (:around))
   (before (:before))
   (primary () :required t)
   (after (:after)))
  (flet ((call-methods (methods)
           (mapcar #'(lambda (method)
                       `(call-method ,method))
                   methods)))
    (let* ((form (if (or before after (rest primary))
                     `(multiple-value-prog1
                          (progn ,@(call-methods before)
                                 (call-method ,(first primary)
                                              ,(rest primary)))
                        ,@(call-methods (reverse after)))
                     `(call-method ,(first primary))))
           (standard-form (if around
                              `(call-method ,(first around)
                                            (,@(rest around)
                                               (make-method ,form)))
                              form)))
      (if around-asdf
          `(call-method ,(first around-asdf)
                        (,@(rest around-asdf) (make-method ,standard-form)))
          standard-form))))

195
196
197
198
199
200
201
202
(setf (documentation 'standard-asdf-method-combination 
		     'method-combination)
      "This method combination is based on the standard method combination,
but defines a new method-qualifier, `asdf:around`.  `asdf:around`
methods will be run *around* any `:around` methods, so that the core
protocol may employ around methods and those around methods will not
be overridden by around methods added by a system developer.")

203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
(defgeneric perform (operation component)
  (:method-combination standard-asdf-method-combination))
(defgeneric operation-done-p (operation component)
  (:method-combination standard-asdf-method-combination))
(defgeneric explain (operation component)
  (:method-combination standard-asdf-method-combination))
(defgeneric output-files (operation component)
  (:method-combination standard-asdf-method-combination))
(defgeneric input-files (operation component)
  (:method-combination standard-asdf-method-combination))

(defgeneric system-source-file (system)
  (:documentation "Return the source file in which system is defined."))

(defgeneric component-system (component)
  (:documentation "Find the top-level system containing COMPONENT"))

(defgeneric component-pathname (component)
  (:documentation "Extracts the pathname applicable for a particular component."))

(defgeneric component-relative-pathname (component)
  (:documentation "Extracts the relative pathname applicable for a particular component."))

(defgeneric component-property (component property))

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

(defgeneric version-satisfies (component version))

(defgeneric find-component (module name &optional version)
  (: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."))

(defgeneric source-file-type (component system))

(defgeneric operation-ancestor (operation)
  (:documentation
   "Recursively chase the operation's parent pointer until we get to
the head of the tree"))

(defgeneric component-visited-p (operation component))

(defgeneric visit-component (operation component data))

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

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

(defgeneric component-depends-on (operation component)
  (:documentation
   "Returns a list of dependencies needed by the component to perform
    the operation.  A dependency has one of the following forms:

      (<operation> <component>*), where <operation> is a class
        designator and each <component> is a component
        designator, which means that the component depends on
        <operation> having been performed on each <component>; or

      (FEATURE <feature>), which means that the component depends
        on <feature>'s presence in *FEATURES*.

    Methods specialized on subclasses of existing component types
    should usually append the results of CALL-NEXT-METHOD to the
    list."))

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

Gary King's avatar
Gary King committed
271
272
273
274
275
276
277
(defgeneric traverse (operation component)
  (:documentation 
"Generate and return a plan for performing `operation` on `component`.

The plan returned is a list of dotted-pairs. Each pair is the `cons`
of ASDF operation object and a `component` object. The pairs will be 
processed in order by `operate`."))
278
279


280
281
282
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; utility stuff

283
284
285
286
287
288
289
(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))
290

291
292
(define-modify-macro appendf (&rest args)
  append "Append onto list")
Daniel Barlow's avatar
   
Daniel Barlow committed
293

294
295
296
297
298
(defun asdf-message (format-string &rest format-args)
  (declare (dynamic-extent format-args))
  (apply #'format *verbose-out* format-string format-args))


Daniel Barlow's avatar
Daniel Barlow committed
299
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Daniel Barlow's avatar
   
Daniel Barlow committed
300
;; classes, condiitons
Daniel Barlow's avatar
Daniel Barlow committed
301

302
303
304
305
306
307
308
309
310
(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
311
(define-condition formatted-system-definition-error (system-definition-error)
312
313
314
  ((format-control :initarg :format-control :reader format-control)
   (format-arguments :initarg :format-arguments :reader format-arguments))
  (:report (lambda (c s)
315
             (apply #'format s (format-control c) (format-arguments c)))))
316

Daniel Barlow's avatar
Daniel Barlow committed
317
(define-condition circular-dependency (system-definition-error)
318
  ((components :initarg :components :reader circular-dependency-components)))
319

320
321
322
(define-condition duplicate-names (system-definition-error)
  ((name :initarg :name :reader duplicate-names-name)))

323
324
325
326
(define-condition missing-component (system-definition-error)
  ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
   (parent :initform nil :reader missing-parent :initarg :parent)))

327
328
329
(define-condition missing-component-of-version (missing-component)
  ((version :initform nil :reader missing-version :initarg :version)))

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

333
334
335
336
(define-condition missing-dependency-of-version (missing-dependency
						 missing-component-of-version)
  ())

Daniel Barlow's avatar
Daniel Barlow committed
337
338
339
340
(define-condition operation-error (error)
  ((component :reader error-component :initarg :component)
   (operation :reader error-operation :initarg :operation))
  (:report (lambda (c s)
341
342
             (format s "~@<erred while invoking ~A on ~A~@:>"
                     (error-operation c) (error-component c)))))
343
344
345
(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
346
347

(defclass component ()
348
  ((name :accessor component-name :initarg :name :documentation
349
         "Component name: designator for a string composed of portable pathname characters")
Daniel Barlow's avatar
Daniel Barlow committed
350
   (version :accessor component-version :initarg :version)
351
   (in-order-to :initform nil :initarg :in-order-to)
352
   ;; XXX crap name
353
   (do-first :initform nil :initarg :do-first)
354
355
356
357
   ;; 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
358
   (parent :initarg :parent :initform nil :reader component-parent)
Daniel Barlow's avatar
Daniel Barlow committed
359
360
   ;; 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
361
   (relative-pathname :initarg :pathname)
Daniel Barlow's avatar
   
Daniel Barlow committed
362
   (operation-times :initform (make-hash-table )
363
                    :accessor component-operation-times)
Daniel Barlow's avatar
   
Daniel Barlow committed
364
365
   ;; XXX we should provide some atomic interface for updating the
   ;; component properties
366
   (properties :accessor component-properties :initarg :properties
367
               :initform nil)))
Daniel Barlow's avatar
   
Daniel Barlow committed
368

Daniel Barlow's avatar
   
Daniel Barlow committed
369
370
371
;;;; methods: conditions

(defmethod print-object ((c missing-dependency) s)
372
  (format s "~@<~A, required by ~A~@:>"
373
          (call-next-method c nil) (missing-required-by c)))
Daniel Barlow's avatar
   
Daniel Barlow committed
374
375
376

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

Daniel Barlow's avatar
   
Daniel Barlow committed
378
379
380
;;;; methods: components

(defmethod print-object ((c missing-component) s)
381
   (format s "~@<component ~S not found~
382
             ~@[ in ~A~]~@:>"
383
384
385
          (missing-requires c)
          (when (missing-parent c)
            (component-name (missing-parent c)))))
Daniel Barlow's avatar
   
Daniel Barlow committed
386

387
388
389
390
391
392
393
394
(defmethod print-object ((c missing-component-of-version) s)
  (format s "~@<component ~S does not match version ~A~
              ~@[ in ~A~]~@:>"
           (missing-requires c)
           (missing-version c)
	   (when (missing-parent c)
	     (component-name (missing-parent c)))))

Daniel Barlow's avatar
Daniel Barlow committed
395
396
397
398
399
(defmethod component-system ((component component))
  (aif (component-parent component)
       (component-system it)
       component))

400
(defmethod print-object ((c component) stream)
Daniel Barlow's avatar
Daniel Barlow committed
401
  (print-unreadable-object (c stream :type t :identity t)
Daniel Barlow's avatar
Daniel Barlow committed
402
403
    (ignore-errors
      (prin1 (component-name c) stream))))
Daniel Barlow's avatar
Daniel Barlow committed
404
405

(defclass module (component)
Daniel Barlow's avatar
   
Daniel Barlow committed
406
  ((components :initform nil :accessor module-components :initarg :components)
407
408
409
   ;; 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
410
411
                           :accessor module-if-component-dep-fails
                           :initarg :if-component-dep-fails)
Daniel Barlow's avatar
Daniel Barlow committed
412
413
414
   (default-component-class :accessor module-default-component-class
     :initform 'cl-source-file :initarg :default-component-class)))

Daniel Barlow's avatar
   
Daniel Barlow committed
415
416
417
418
419
(defun component-parent-pathname (component)
  (aif (component-parent component)
       (component-pathname it)
       *default-pathname-defaults*))

Daniel Barlow's avatar
Daniel Barlow committed
420
(defmethod component-relative-pathname ((component module))
Daniel Barlow's avatar
Daniel Barlow committed
421
422
423
424
425
  (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
426
427
428
429
(defmethod component-pathname ((component component))
  (let ((*default-pathname-defaults* (component-parent-pathname component)))
    (merge-pathnames (component-relative-pathname component))))

430
(defmethod component-property ((c component) property)
Daniel Barlow's avatar
Daniel Barlow committed
431
  (cdr (assoc property (slot-value c 'properties) :test #'equal)))
432
433

(defmethod (setf component-property) (new-value (c component) property)
Daniel Barlow's avatar
Daniel Barlow committed
434
  (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
435
    (if a
436
437
438
        (setf (cdr a) new-value)
        (setf (slot-value c 'properties)
              (acons property new-value (slot-value c 'properties))))))
439

Daniel Barlow's avatar
   
Daniel Barlow committed
440
441
(defclass system (module)
  ((description :accessor system-description :initarg :description)
Daniel Barlow's avatar
Daniel Barlow committed
442
443
   (long-description
    :accessor system-long-description :initarg :long-description)
Daniel Barlow's avatar
   
Daniel Barlow committed
444
445
   (author :accessor system-author :initarg :author)
   (maintainer :accessor system-maintainer :initarg :maintainer)
446
   (licence :accessor system-licence :initarg :licence
447
448
449
            :accessor system-license :initarg :license)
   (source-file :reader system-source-file :initarg :source-file
		:writer %set-system-source-file)))
Daniel Barlow's avatar
   
Daniel Barlow committed
450
451
452
453
454
455
456
457
458

;;; 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
459
460
461
462
463
464
465
         (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)))))))
Daniel Barlow's avatar
   
Daniel Barlow committed
466
467
468
469
470

(defmethod version-satisfies ((c component) version)
  (unless (and version (slot-boundp c 'version))
    (return-from version-satisfies t))
  (let ((x (mapcar #'parse-integer
471
472
473
                   (split (component-version c) nil '(#\.))))
        (y (mapcar #'parse-integer
                   (split version nil '(#\.)))))
Daniel Barlow's avatar
   
Daniel Barlow committed
474
    (labels ((bigger (x y)
475
476
477
478
479
               (cond ((not y) t)
                     ((not x) nil)
                     ((> (car x) (car y)) t)
                     ((= (car x) (car y))
                      (bigger (cdr x) (cdr y))))))
Daniel Barlow's avatar
   
Daniel Barlow committed
480
      (and (= (car x) (car y))
481
           (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
Daniel Barlow's avatar
   
Daniel Barlow committed
482
483
484
485

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

Gary King's avatar
Gary King committed
486
487
488
489
490
(defun make-defined-systems-table ()
  (make-hash-table :test 'equal))

(defvar *defined-systems* (make-defined-systems-table))

Daniel Barlow's avatar
   
Daniel Barlow committed
491
(defun coerce-name (name)
492
493
494
495
496
  (typecase name
    (component (component-name name))
    (symbol (string-downcase (symbol-name name)))
    (string name)
    (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
Daniel Barlow's avatar
   
Daniel Barlow committed
497

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

Gary King's avatar
Gary King committed
501
502
503
504
505
506
507
508
509
510
511
(defun map-systems (fn)
  "Apply `fn` to each defined system.

`fn` should be a function of one argument. It will be
called with an object of type asdf:system."
  (maphash (lambda (_ datum)
	     (declare (ignore _))
	     (destructuring-bind (_ . def) datum
	       (declare (ignore _))
	       (funcall fn def)))
	   *defined-systems*))
512

513
514
515
516
517
518
;;; 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))

519
(defun system-definition-pathname (system)
520
521
522
523
  (let ((system-name (coerce-name system)))
    (or
     (some (lambda (x) (funcall x system-name))
	   *system-definition-search-functions*)
524
     (let ((system-pair (system-registered-p system-name)))
525
526
       (and system-pair
	    (system-source-file (cdr system-pair)))))))
527

528
(defvar *central-registry*
529
530
531
532
533
534
535
536
537
538
539
  '(*default-pathname-defaults*)
"A list of 'system directory designators' ASDF uses to find systems.

A 'system directory designator' is a pathname or a function 
which evaluates to a pathname. For example:

    (setf asdf:*central-registry*
          (list '*default-pathname-defaults*
                #p\"/home/me/cl/systems/\"
                #p\"/usr/share/common-lisp/systems/\"))
")
540

541
(defun directory-pathname-p (pathname)
Gary King's avatar
Gary King committed
542
543
544
545
546
547
548
549
  "Does `pathname` represent a directory?

A directory-pathname is a pathname _without_ a filename. The three
ways that the filename components can be missing are for it to be `nil`, 
`:unspecific` or the empty string.

Note that this does _not_ check to see that `pathname` points to an
actually-existing directory."
550
551
552
553
554
  (flet ((check-one (x)
	   (not (null (member x '(nil :unspecific "")
			      :test 'equal)))))
    (and (check-one (pathname-name pathname))
	 (check-one (pathname-type pathname)))))
Gary King's avatar
Gary King committed
555
556
557
558
559
560
561
562
563
564
565
566
567
568

#+(or)
;;test
;;?? move into testsuite sometime soon
(every (lambda (p)
	  (directory-pathname-p p))
	(list 
	 (make-pathname :name "." :type nil :directory '(:absolute "tmp"))
	 (make-pathname :name "." :type "" :directory '(:absolute "tmp"))
	 (make-pathname :name nil :type "" :directory '(:absolute "tmp"))
	 (make-pathname :name "" :directory '(:absolute "tmp"))
	 (make-pathname :type :unspecific :directory '(:absolute "tmp"))
	 (make-pathname :name :unspecific :directory '(:absolute "tmp"))
	 (make-pathname :name :unspecific :directory '(:absolute "tmp"))
569
	 (make-pathname :type "" :directory '(:absolute "tmp"))
Gary King's avatar
Gary King committed
570
	 ))
571
572
573
574
575
576
577
578
579
580

(defun ensure-directory-pathname (pathname)
  (if (directory-pathname-p pathname)
      pathname
      (make-pathname :defaults pathname
		     :directory (append
				 (pathname-directory pathname)
				 (list (file-namestring pathname)))
		     :name nil :type nil :version nil)))

581
(defun sysdef-central-registry-search (system)
582
583
584
  (let ((name (coerce-name system))
	(to-remove nil)
	(to-replace nil))
585
    (block nil
586
587
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
622
623
      (unwind-protect
	   (dolist (dir *central-registry*)
	     (let ((defaults (eval dir)))
	       (cond ((directory-pathname-p defaults)
		      (let ((file (and defaults
				       (make-pathname
					:defaults defaults :version :newest
					:name name :type "asd" :case :local))))
			(if (and file (probe-file file))
			    (return file))))
		     (t
		      (restart-case 
			  (let* ((*print-circle* nil)
				 (message 
				  (format nil 
					  "~@<While searching for system `~a`: `~a` evaluated ~
to `~a` which is not a directory.~@:>" 
					  system dir defaults)))
			    (error message))
			(remove-entry-from-registry ()
			    :report "Remove entry from *central-registry* and continue"
			    (push dir to-remove))
			(coerce-entry-to-directory ()
			    :report (lambda (s)
				      (format s "Coerce entry to ~a, replace ~a and continue."
					      (ensure-directory-pathname defaults) dir))
			    (push (cons dir (ensure-directory-pathname defaults)) to-replace)))))))
	;; cleanup
	(dolist (dir to-remove)
	  (setf *central-registry* (remove dir *central-registry*)))
	(dolist (pair to-replace)
	  (let* ((current (car pair))
		 (new (cdr pair))
		 (position (position current *central-registry*)))
	    (setf *central-registry*
		  (append (subseq *central-registry* 0 position)
			  (list new)
			  (subseq *central-registry* (1+ position))))))))))
624

Christophe Rhodes's avatar
Fixes    
Christophe Rhodes committed
625
626
627
(defun make-temporary-package ()
  (flet ((try (counter)
           (ignore-errors
628
             (make-package (format nil "~a~D" 'asdf counter)
629
                           :use '(:cl :asdf)))))
Christophe Rhodes's avatar
Fixes    
Christophe Rhodes committed
630
631
632
    (do* ((counter 0 (+ counter 1))
          (package (try counter) (try counter)))
         (package package))))
633

Daniel Barlow's avatar
   
Daniel Barlow committed
634
635
(defun find-system (name &optional (error-p t))
  (let* ((name (coerce-name name))
636
         (in-memory (system-registered-p name))
637
         (on-disk (system-definition-pathname name)))
Daniel Barlow's avatar
   
Daniel Barlow committed
638
    (when (and on-disk
639
640
               (or (not in-memory)
                   (< (car in-memory) (file-write-date on-disk))))
Christophe Rhodes's avatar
Fixes    
Christophe Rhodes committed
641
642
643
      (let ((package (make-temporary-package)))
        (unwind-protect
             (let ((*package* package))
644
	       (asdf-message
Christophe Rhodes's avatar
Fixes    
Christophe Rhodes committed
645
646
647
                "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
                ;; FIXME: This wants to be (ENOUGH-NAMESTRING
                ;; ON-DISK), but CMUCL barfs on that.
648
649
                on-disk
                *package*)
Christophe Rhodes's avatar
Fixes    
Christophe Rhodes committed
650
651
               (load on-disk))
          (delete-package package))))
652
    (let ((in-memory (system-registered-p name)))
Daniel Barlow's avatar
   
Daniel Barlow committed
653
      (if in-memory
654
655
656
          (progn (if on-disk (setf (car in-memory) (file-write-date on-disk)))
                 (cdr in-memory))
          (if error-p (error 'missing-component :requires name))))))
Daniel Barlow's avatar
   
Daniel Barlow committed
657
658

(defun register-system (name system)
659
  (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
660
  (setf (gethash (coerce-name name) *defined-systems*)
661
        (cons (get-universal-time) system)))
Daniel Barlow's avatar
   
Daniel Barlow committed
662

663

Daniel Barlow's avatar
   
Daniel Barlow committed
664
665
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; finding components
Daniel Barlow's avatar
Daniel Barlow committed
666

667
(defmethod find-component ((module module) name &optional version)
Daniel Barlow's avatar
Daniel Barlow committed
668
  (if (slot-boundp module 'components)
669
      (let ((m (find name (module-components module)
670
671
672
                     :test #'equal :key #'component-name)))
        (if (and m (version-satisfies m version)) m))))

Daniel Barlow's avatar
Daniel Barlow committed
673
674

;;; a component with no parent is a system
675
(defmethod find-component ((module (eql nil)) name &optional version)
Daniel Barlow's avatar
   
Daniel Barlow committed
676
  (let ((m (find-system name nil)))
677
    (if (and m (version-satisfies m version)) m)))
Daniel Barlow's avatar
Daniel Barlow committed
678

Daniel Barlow's avatar
   
Daniel Barlow committed
679
680
;;; component subclasses

Daniel Barlow's avatar
Daniel Barlow committed
681
682
683
(defclass source-file (component) ())

(defclass cl-source-file (source-file) ())
Daniel Barlow's avatar
Daniel Barlow committed
684
685
(defclass c-source-file (source-file) ())
(defclass java-source-file (source-file) ())
686
687
688
(defclass static-file (source-file) ())
(defclass doc-file (static-file) ())
(defclass html-file (doc-file) ())
Daniel Barlow's avatar
Daniel Barlow committed
689

Daniel Barlow's avatar
Daniel Barlow committed
690
691
692
(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
693
(defmethod source-file-type ((c html-file) (s module)) "html")
694
695
(defmethod source-file-type ((c static-file) (s module)) nil)

Daniel Barlow's avatar
Daniel Barlow committed
696
(defmethod component-relative-pathname ((component source-file))
Christophe Rhodes's avatar
Fixes    
Christophe Rhodes committed
697
698
  (let ((relative-pathname (slot-value component 'relative-pathname)))
    (if relative-pathname
699
        (merge-pathnames
700
         relative-pathname
701
         (make-pathname
702
          :type (source-file-type component (component-system component))))
703
        (let* ((*default-pathname-defaults*
Christophe Rhodes's avatar
Fixes    
Christophe Rhodes committed
704
705
706
707
708
709
710
                (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
711
712
713
714
715
716
717

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

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

(defclass operation ()
718
  ((forced :initform nil :initarg :force :accessor operation-forced)
719
   (original-initargs :initform nil :initarg :original-initargs
720
                      :accessor operation-original-initargs)
721
722
723
724
   (visited-nodes :initform nil :accessor operation-visited-nodes)
   (visiting-nodes :initform nil :accessor operation-visiting-nodes)
   (parent :initform nil :initarg :parent :accessor operation-parent)))

725
726
727
728
729
(defmethod print-object ((o operation) stream)
  (print-unreadable-object (o stream :type t :identity t)
    (ignore-errors
      (prin1 (operation-original-initargs o) stream))))

730
(defmethod shared-initialize :after ((operation operation) slot-names
731
732
                                     &key force
                                     &allow-other-keys)
733
734
735
  (declare (ignore slot-names force))
  ;; empty method to disable initarg validity checking
  )
Daniel Barlow's avatar
Daniel Barlow committed
736

737
738
739
(defun node-for (o c)
  (cons (class-name (class-of o)) c))

740
741
742
743
744
(defmethod operation-ancestor ((operation operation))
  (aif (operation-parent operation)
       (operation-ancestor it)
       operation))

745
746
747

(defun make-sub-operation (c o dep-c dep-o)
  (let* ((args (copy-list (operation-original-initargs o)))
748
         (force-p (getf args :force)))
749
750
751
    ;; note explicit comparison with T: any other non-NIL force value
    ;; (e.g. :recursive) will pass through
    (cond ((and (null (component-parent c))
752
753
754
755
756
757
758
759
760
761
762
763
                (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
                  :parent o
                  :original-initargs args args))
          ((subtypep (type-of o) dep-o)
           o)
          (t
           (apply #'make-instance dep-o
                  :parent o :original-initargs args args)))))
764

765

Daniel Barlow's avatar
   
Daniel Barlow committed
766
767
768
(defmethod visit-component ((o operation) (c component) data)
  (unless (component-visited-p o c)
    (push (cons (node-for o c) data)
769
          (operation-visited-nodes (operation-ancestor o)))))
Daniel Barlow's avatar
Daniel Barlow committed
770
771

(defmethod component-visited-p ((o operation) (c component))
Daniel Barlow's avatar
   
Daniel Barlow committed
772
  (assoc (node-for o c)
773
774
         (operation-visited-nodes (operation-ancestor o))
         :test 'equal))
Daniel Barlow's avatar
Daniel Barlow committed
775

776
777
778
(defmethod (setf visiting-component) (new-value operation component)
  ;; MCL complains about unused lexical variables
  (declare (ignorable new-value operation component)))
779

Daniel Barlow's avatar
Daniel Barlow committed
780
(defmethod (setf visiting-component) (new-value (o operation) (c component))
781
  (let ((node (node-for o c))
782
        (a (operation-ancestor o)))
783
    (if new-value
784
785
786
        (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
787
788

(defmethod component-visiting-p ((o operation) (c component))
789
  (let ((node (node-for o c)))
790
    (member node (operation-visiting-nodes (operation-ancestor o))
791
            :test 'equal)))
Daniel Barlow's avatar
Daniel Barlow committed
792

793
794
(defmethod component-depends-on ((op-spec symbol) (c component))
  (component-depends-on (make-instance op-spec) c))
795
796

(defmethod component-depends-on ((o operation) (c component))
797
  (cdr (assoc (class-name (class-of o))
798
              (slot-value c 'in-order-to))))
799

Daniel Barlow's avatar
   
Daniel Barlow committed
800
801
802
(defmethod component-self-dependencies ((o operation) (c component))
  (let ((all-deps (component-depends-on o c)))
    (remove-if-not (lambda (x)
803
804
805
                     (member (component-name c) (cdr x) :test #'string=))
                   all-deps)))

Daniel Barlow's avatar
   
Daniel Barlow committed
806
807
(defmethod input-files ((operation operation) (c component))
  (let ((parent (component-parent c))
808
        (self-deps (component-self-dependencies operation c)))
Daniel Barlow's avatar
   
Daniel Barlow committed
809
    (if self-deps
810
811
812
813
814
815
816
817
        (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)))))
Daniel Barlow's avatar
   
Daniel Barlow committed
818

819
(defmethod input-files ((operation operation) (c module)) nil)
820

Daniel Barlow's avatar
   
Daniel Barlow committed
821
(defmethod operation-done-p ((o operation) (c component))
822
823
824
825
826
827
828
829
830
  (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)
831
               (t
832
                (warn "~@<Missing FILE-WRITE-DATE for ~S: treating ~
833
                       operation ~S on component ~S as done.~@:>"
834
835
836
837
838
839
                      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
840
             ;; produce nothing probably isn't doing much
841
             t)
842
            ((not out-files)
843
844
845
846
847
848
849
850
851
852
853
854
855
             (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)))))))))
856

Daniel Barlow's avatar
Daniel Barlow committed
857
858
859
;;; 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
860
;;; for our purposes.  
Daniel Barlow's avatar
Daniel Barlow committed
861

Daniel Barlow's avatar
Daniel Barlow committed
862
(defmethod traverse ((operation operation) (c component))
Daniel Barlow's avatar
   
Daniel Barlow committed
863
  (let ((forced nil))
Gary King's avatar
Gary King committed
864
    (labels ((%do-one-dep (required-op required-c required-v)
865
866
867
868
869
870
               (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)
871
872
873
874
875
876
877
878
				 (if required-v
				     (error 'missing-dependency-of-version
					    :required-by c
					    :version required-v
					    :requires required-c)
				     (error 'missing-dependency
					    :required-by c
					    :requires required-c))))
879
880
                      (op (make-sub-operation c operation dep-c required-op)))
                 (traverse op dep-c)))
Gary King's avatar
Gary King committed
881
882
883
884
885
886
887
888
889
890
891
892
893
	     (do-one-dep (required-op required-c required-v)
               (loop
		  (restart-case
		      (return (%do-one-dep required-op required-c required-v))
		    (retry ()
		      :report (lambda (s)
				(format s "~@<Retry loading component ~S.~@:>"
					required-c))
		      :test
		      (lambda (c)
#|
			(print (list :c1 c (typep c 'missing-dependency)))
			(when (typep c 'missing-dependency)
Nikodemus Siivola's avatar
Nikodemus Siivola committed
894
			  (print (list :c2 (missing-requires c) required-c
Gary King's avatar
Gary King committed
895
896
897
898
899
900
				       (equalp (missing-requires c)
					       required-c))))
|#
			(and (typep c 'missing-dependency)
			     (equalp (missing-requires c)
				     required-c)))))))
901
902
903
             (do-dep (op dep)
               (cond ((eq op 'feature)
                      (or (member (car dep) *features*)
Nikodemus Siivola's avatar
Nikodemus Siivola committed
904
                          (error 'missing-dependency
905
                                 :required-by c
906
                                 :requires (car dep))))
907
908
                     (t
                      (dolist (d dep)
Daniel Barlow's avatar
   
Daniel Barlow committed
909
                        (cond ((consp d)
Gary King's avatar
Gary King committed
910
911
912
			       (cond ((string-equal
				       (symbol-name (first d))
				       "VERSION")
Nikodemus Siivola's avatar
Nikodemus Siivola committed
913
				      (appendf
Gary King's avatar
Gary King committed
914
915
916
917
918
919
920
				       forced
				       (do-one-dep op (second d) (third d))))
				     ((and (string-equal
					    (symbol-name (first d))
					    "FEATURE")
					   (find (second d) *features*
						 :test 'string-equal))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
921
				      (appendf
Gary King's avatar
Gary King committed
922
923
924
				       forced
				       (do-one-dep op (second d) (third d))))
				     (t
925
				      (error "Bad dependency ~a.  Dependencies must be (:version <version>), (:feature <feature>), or a name" d))))
Daniel Barlow's avatar
   
Daniel Barlow committed
926
927
928
                              (t
                               (appendf forced (do-one-dep op d nil)))))))))
      (aif (component-visited-p operation c)
929
930
           (return-from traverse
             (if (cdr it) (list (cons 'pruned-op c)) nil)))
Daniel Barlow's avatar
   
Daniel Barlow committed
931
932
      ;; dependencies
      (if (component-visiting-p operation c)
933
          (error 'circular-dependency :components (list c)))
Daniel Barlow's avatar
   
Daniel Barlow committed
934
      (setf (visiting-component operation c) t)
935
936
      (unwind-protect
	   (progn
Nikodemus Siivola's avatar
Nikodemus Siivola committed
937
	     (loop for (required-op . deps) in
938
		  (component-depends-on operation c)
Gary King's avatar
Gary King committed
939
		  do (do-dep required-op deps))
940
941
942
943
944
945
946
947
948
949
	     ;; constituent bits
	     (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)
Nikodemus Siivola's avatar
Nikodemus Siivola committed
950
				  (if (eq (module-if-component-dep-fails c)
951
952
953
954
955
956
957
958
959
960
961
962
963
964
					  :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
			 (not (operation-done-p operation c))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
965
			 (let ((f (operation-forced
966
967
968
969
970
971
972
973
974
975
976
977
978
979
				   (operation-ancestor operation))))
			   (and f (or (not (consp f))
				      (member (component-name
					       (operation-ancestor operation))
					      (mapcar #'coerce-name f)
					      :test #'string=)))))
		 (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)))))))
	(setf (visiting-component operation c) nil))
Daniel Barlow's avatar
   
Daniel Barlow committed
980
981
      (visit-component operation c (and forced t))
      forced)))
982

Daniel Barlow's avatar
Daniel Barlow committed
983
984

(defmethod perform ((operation operation) (c source-file))
985
  (sysdef-error
986
987
   "~@<required method PERFORM not implemented ~
    for operation ~A, component ~A~@:>"
Daniel Barlow's avatar
Daniel Barlow committed
988
989
990
991
992
993
   (class-of operation) (class-of c)))

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

(defmethod explain ((operation operation) (component component))
994
  (asdf-message "~&;;; ~A on ~A~%" operation component))
Daniel Barlow's avatar
Daniel Barlow committed
995

996
;;; compile-op
Daniel Barlow's avatar
Daniel Barlow committed
997

998
999
(defclass compile-op (operation)
  ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
Daniel Barlow's avatar
   
Daniel Barlow committed
1000
   (on-warnings :initarg :on-warnings :accessor operation-on-warnings
1001
                :initform *compile-file-warnings-behaviour*)
Daniel Barlow's avatar
   
Daniel Barlow committed
1002
   (on-failure :initarg :on-failure :accessor operation-on-failure
1003
               :initform *compile-file-failure-behaviour*)))
1004
1005

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

Daniel Barlow's avatar
   
Daniel Barlow committed
1008
1009
(defmethod perform :after ((operation operation) (c component))
  (setf (gethash (type-of operation) (component-operation-times c))
1010
        (get-universal-time)))
Daniel Barlow's avatar
Daniel Barlow committed
1011

1012
1013
;;; perform is required to check output-files to find out where to put
;;; its answers, in case it has been overridden for site policy
1014
(defmethod perform ((operation compile-op) (c cl-source-file))
1015
  #-:broken-fasl-loader
1016
  (let ((source-file (component-pathname c))
1017
        (output-file (car (output-files operation c))))
Daniel Barlow's avatar
Daniel Barlow committed
1018
    (multiple-value-bind (output warnings-p failure-p)
1019
        (compile-file source-file :output-file output-file)
Daniel Barlow's avatar
   
Daniel Barlow committed
1020
      (when warnings-p
1021
1022
1023
1024
1025
1026
        (case (operation-on-warnings operation)
          (:warn (warn
                  "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
                  operation c))
          (:error (error 'compile-warned :component c :operation operation))
          (:ignore nil)))
Daniel Barlow's avatar
   
Daniel Barlow committed
1027
      (when failure-p
1028
1029
1030
1031
1032
1033
        (case (operation-on-failure operation)
          (:warn (warn
                  "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
                  operation c))
          (:error (error 'compile-failed :component c :operation operation))
          (:ignore nil)))
1034
      (unless output
1035
        (error 'compile-error :component c :operation operation)))))
Daniel Barlow's avatar
Daniel Barlow committed
1036

1037
(defmethod output-files ((operation compile-op) (c cl-source-file))
1038
1039
  #-:broken-fasl-loader (list (compile-file-pathname (component-pathname c)))
  #+:broken-fasl-loader (list (component-pathname c)))
Daniel Barlow's avatar
Daniel Barlow committed
1040

Daniel Barlow's avatar
Daniel Barlow committed
1041
1042
1043
1044
1045
1046
(defmethod perform ((operation compile-op) (c static-file))
  nil)

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

1047
1048
1049
1050
(defmethod input-files ((op compile-op) (c static-file))
  nil)


1051
;;; load-op
Daniel Barlow's avatar
Daniel Barlow committed
1052

1053
1054
1055
(defclass basic-load-op (operation) ())

(defclass load-op (basic-load-op) ())
1056

1057
(defmethod perform ((o load-op) (c cl-source-file))
Daniel Barlow's avatar
Daniel Barlow committed
1058
  (mapcar #'load (input-files o c)))
Daniel Barlow's avatar
Daniel Barlow committed
1059

1060
(defmethod perform around ((o load-op) (c cl-source-file))
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
  (let ((state :initial))
    (loop until (or (eq state :success)
		    (eq state :failure)) do
	 (case state
	   (:recompiled
	    (setf state :failure)
	    (call-next-method)
	    (setf state :success))
	   (:failed-load
	    (setf state :recompiled)
	    (perform (make-instance 'asdf:compile-op) c))
	   (t
Nikodemus Siivola's avatar
Nikodemus Siivola committed
1073
	    (with-simple-restart
1074
		(try-recompiling "Recompile ~a and try loading it again"
1075
1076
1077
1078
1079
				  (component-name c))
	      (setf state :failed-load)
	      (call-next-method)
	      (setf state :success)))))))

1080
(defmethod perform around ((o compile-op) (c cl-source-file))
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
  (let ((state :initial))
    (loop until (or (eq state :success)
		    (eq state :failure)) do
	 (case state
	   (:recompiled
	    (setf state :failure)
	    (call-next-method)
	    (setf state :success))
	   (:failed-compile
	    (setf state :recompiled)
	    (perform (make-instance 'asdf:compile-op) c))
	   (t
Nikodemus Siivola's avatar
Nikodemus Siivola committed
1093
	    (with-simple-restart
1094
		(try-recompiling "Try recompiling ~a"
1095
1096
1097
1098
1099
				  (component-name c))
	      (setf state :failed-compile)
	      (call-next-method)
	      (setf state :success)))))))

Daniel Barlow's avatar
Daniel Barlow committed
1100
1101
(defmethod perform ((operation load-op) (c static-file))
  nil)
1102

Daniel Barlow's avatar
   
Daniel Barlow committed
1103
1104
(defmethod operation-done-p ((operation load-op) (c static-file))
  t)
Daniel Barlow's avatar
Daniel Barlow committed
1105

Daniel Barlow's avatar
   
Daniel Barlow committed
1106
(defmethod output-files ((o operation) (c component))
Daniel Barlow's avatar
Daniel Barlow committed
1107
  nil)
1108

1109
(defmethod component-depends-on ((operation load-op) (c component))
1110
1111
1112
  (cons (list 'compile-op (component-name c))
        (call-next-method)))

1113
1114
;;; load-source-op

1115
(defclass load-source-op (basic-load-op) ())
1116
1117

(defmethod perform ((o load-source-op) (c cl-source-file))
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
  (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))
1141
1142
          (> (file-write-date (component-pathname c))
             (component-property c 'last-loaded-as-source)))
1143
      nil t))
1144

1145
1146
1147
1148
(defclass test-op (operation) ())

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

1150
1151
1152
1153
(defmethod operation-done-p ((operation test-op) (c system))
  "Testing a system is _never_ done."
  nil)

1154
1155