asdf.lisp 96.4 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
;;; -- LICENSE START
22
;;; (This is the MIT / X Consortium license as taken from
23
24
25
;;;  http://www.opensource.org/licenses/mit-license.html on or about
;;;  Monday; July 13, 2009)
;;;
26
;;; Copyright (c) 2001-2010 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
55
  (:documentation "Another System Definition Facility")
Daniel Barlow's avatar
Daniel Barlow committed
56
  (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command
57
           #:system-definition-pathname #:find-component ; miscellaneous
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
58
           #:compile-system #:load-system #:test-system
Nikodemus Siivola's avatar
Nikodemus Siivola committed
59
           #:compile-op #:load-op #:load-source-op
60
           #:test-op
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
61
62
63
           #:operation                 ; operations
           #:feature                 ; sort-of operation
           #:version                 ; metaphorically sort-of an operation
64

65
           #:input-files #:output-files #:perform ; operation methods
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
97
           #: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
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
98
           #:map-systems
99
100
101
102

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

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
103
                                        ;#:*component-parent-pathname*
104
105
106
107
           #:*system-definition-search-functions*
           #:*central-registry*         ; variables
           #:*compile-file-warnings-behaviour*
           #:*compile-file-failure-behaviour*
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
108
           #:*resolve-symlinks*
109

110
111
           #:asdf-version

112
           #:operation-error #:compile-failed #:compile-warned #:compile-error
113
114
115
           #:error-name
           #:error-pathname
           #:missing-definition
116
117
118
           #:error-component #:error-operation
           #:system-definition-error
           #:missing-component
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
119
           #:missing-component-of-version
120
           #:missing-dependency
121
           #:missing-dependency-of-version
122
123
124
           #:circular-dependency        ; errors
           #:duplicate-names

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
125
           #:try-recompiling
126
127
           #:retry
           #:accept                     ; restarts
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
128
129
           #:coerce-entry-to-directory
           #:remove-entry-from-registry
130
131
132

           #:standard-asdf-method-combination
           #:around                     ; protocol assistants
133

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
134
135
136
137
138
139
140
           #:*source-to-target-mappings*
           #:*default-toplevel-directory*
           #:*centralize-lisp-binaries*
           #:*include-per-user-information*
           #:*map-all-source-files*
           #:output-files-for-system-and-operation
           #:*enable-asdf-binary-locations*
141
142
143
144
145
146
           #:implementation-specific-directory-name

           #:initialize-source-registry
           #:clear-source-registry
           #:ensure-source-registry
           #:process-source-registry)
147
  (:intern #:coerce-name
148
           #:getenv
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
149
150
151
152
           #:system-registered-p
           #:asdf-message
           #:resolve-symlinks
           #:pathname-sans-name+type)
Daniel Barlow's avatar
Daniel Barlow committed
153
  (:use :cl))
154

155
156
157
(defpackage #:asdf-extensions
  (:use #:common-lisp #:asdf)
  (:import-from #:asdf
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
158
                #:coerce-name
159
                #:getenv
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
160
161
162
163
                #:system-registered-p
                #:asdf-message
                #:resolve-symlinks
                #:pathname-sans-name+type))
164

165
#+nil
166
167
168
(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")
169

Daniel Barlow's avatar
Daniel Barlow committed
170
171
(in-package #:asdf)

172
173
174
;;;; -------------------------------------------------------------------------
;;;; User-visible parameters
;;;;
175
(defparameter *asdf-version*
Gary King's avatar
Gary King committed
176
  ;; the 1+ hair is to ensure that we don't do an inadvertent find and replace
177
  (subseq "VERSION:1.502" (1+ (length "VERSION"))))
178
179
180

(defun asdf-version ()
  *asdf-version*)
181

182
183
184
185
(defvar *resolve-symlinks* t
  "Determine whether or not ASDF resolves symlinks when defining systems.

Defaults to `t`.")
186

187
(defvar *compile-file-warnings-behaviour* :warn)
188

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

191
(defvar *verbose-out* nil)
192

193
194
195
(defparameter +asdf-methods+
  '(perform explain output-files operation-done-p))

196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
;;;; -------------------------------------------------------------------------
;;;; Cleanups before hot-upgrade.
;;;; Things to do in case we're upgrading from a previous version of ASDF.
;;;; See https://bugs.launchpad.net/asdf/+bug/485687
;;;; * fmakunbound functions that once (in previous version of ASDF)
;;;;   were simple DEFUNs but now are generic functions.
;;;; * define methods on UPDATE-INSTANCE-FOR-REDEFINED-CLASS
;;;;   for each of the classes we define that has changed incompatibly.
(eval-when (:compile-toplevel :load-toplevel :execute)
  (fmakunbound 'system-source-file)
  #+ecl
  (when (find-class 'compile-op nil)
    (defmethod update-instance-for-redefined-class :after
        ((c compile-op) added deleted plist &key)
      (format *trace-output* "~&UI4RC:a ~S~%" (list c added deleted plist))
      (let ((system-p (getf plist 'system-p)))
        (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p))))))

214
215
216
;;;; -------------------------------------------------------------------------
;;;; CLOS magic for asdf:around methods

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

244
(setf (documentation 'standard-asdf-method-combination
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
245
                     'method-combination)
246
247
248
249
250
251
      "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.")

252
253
254
;;;; -------------------------------------------------------------------------
;;;; ASDF Interface, in terms of generic functions.

255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
(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
323
(defgeneric traverse (operation component)
324
  (:documentation
Gary King's avatar
Gary King committed
325
326
327
"Generate and return a plan for performing `operation` on `component`.

The plan returned is a list of dotted-pairs. Each pair is the `cons`
328
of ASDF operation object and a `component` object. The pairs will be
Gary King's avatar
Gary King committed
329
processed in order by `operate`."))
330

331
(defgeneric output-files-using-mappings (source possible-paths path-mappings)
332
  (:documentation
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
"Use the variable \\*source-to-target-mappings\\* to find
an output path for the source. The algorithm transforms each
entry in possible-paths as follows: If there is a mapping
whose source starts with the path of possible-path, then
replace possible-path with a pathname that starts with the
target of the mapping and continues with the rest of
possible-path. If no such mapping is found, then use the
default mapping.

If \\*centralize-lisp-binaries\\* is false, then the default
mapping is to place the output in a subdirectory of the
source. The subdirectory is named using the Lisp
implementation \(see
implementation-specific-directory-name\). If
\\*centralize-lisp-binaries\\* is true, then the default
mapping is to place the output in subdirectories of
\\*default-toplevel-directory\\* where the subdirectory
structure will mirror that of the source."))

352

353
354
;;;; -------------------------------------------------------------------------
;;;; General Purpose Utilities
355

356
357
358
359
360
361
362
(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))
363

364
365
(define-modify-macro appendf (&rest args)
  append "Append onto list")
Daniel Barlow's avatar
   
Daniel Barlow committed
366

367
368
369
370
(defun asdf-message (format-string &rest format-args)
  (declare (dynamic-extent format-args))
  (apply #'format *verbose-out* format-string format-args))

371
372
373
374
375
376
377
378
379
380
381
382
383
384
;;; 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)))))))

385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
(defun split-path-string (s &optional force-directory)
  (check-type s string)
  (let* ((components (split s nil "/"))
         (last-comp (car (last components))))
    (multiple-value-bind (relative components)
        (if (equal (first components) "")
          (values :absolute (cdr components))
          (values :relative components))
      (cond
        ((equal last-comp "")
         (values relative (butlast components) nil))
        (force-directory
         (values relative components nil))
        (t
         (values relative (butlast components) last-comp))))))
400

401
(defun remove-keys (key-names args)
402
403
404
405
406
407
408
409
410
  (loop :for (name val) :on args :by #'cddr
    :unless (member (symbol-name name) key-names
                    :key #'symbol-name :test 'equal)
    :append (list name val)))

(defun remove-keyword (key args)
  (loop :for (k v) :on args :by #'cddr
    :unless (eq k key)
    :append (list k v)))
411
412
413
414

(defun resolve-symlinks (path)
  #-allegro (truename path)
  #+allegro (excl:pathname-resolve-symbolic-links path))
415

416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
(defun getenv (x)
  #+sbcl
  (sb-ext:posix-getenv x)
  #+clozure
  (ccl::getenv x)
  #+clisp
  (ext:getenv x)
  #+cmu
  (cdr (assoc (intern x :keyword) ext:*environment-list*))
  #+lispworks
  (lispworks:environment-xiable x)
  #+allegro
  (sys:getenv x)
  #+gcl
  (system:getenv x)
  #+ecl
  (si:getenv x))

434
435
(defun ensure-directory-pathname (pathspec)
  "Converts the non-wild pathname designator PATHSPEC to directory form."
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
  (cond
   ((stringp pathspec)
    (pathname (concatenate 'string pathspec "/")))
   ((not (pathnamep pathspec))
    (error "Invalid pathname designator ~S" pathspec))
   ((wild-pathname-p pathspec)
    (error "Can't reliably convert wild pathnames."))
   ((directory-pathname-p pathspec)
    pathspec)
   (t
    (make-pathname :directory (append (or (pathname-directory pathspec)
                                          (list :relative))
                                      (list (file-namestring pathspec)))
                   :name nil :type nil :version nil
                   :defaults pathspec))))
451

452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
(defun length=n-p (x n) ;is it that (= (length x) n) ?
  (check-type n (integer 0 *))
  (loop
    :for l = x :then (cdr l)
    :for i :downfrom n :do
    (cond
      ((zerop i) (return (null l)))
      ((not (consp l)) (return nil)))))

(defun ends-with (s suffix)
  (check-type s string)
  (check-type suffix string)
  (let ((start (- (length s) (length suffix))))
    (and (<= 0 start)
         (string-equal s suffix :start1 start))))
467

468
469
;;;; -------------------------------------------------------------------------
;;;; Classes, Conditions
Daniel Barlow's avatar
Daniel Barlow committed
470

471
472
473
474
475
476
477
478
479
(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
480
(define-condition formatted-system-definition-error (system-definition-error)
481
482
483
  ((format-control :initarg :format-control :reader format-control)
   (format-arguments :initarg :format-arguments :reader format-arguments))
  (:report (lambda (c s)
484
             (apply #'format s (format-control c) (format-arguments c)))))
485

486
487
488
489
490
491
492
493
(define-condition missing-definition (system-definition-error)
  ((name :initarg :name :reader error-name)
   (pathname :initarg :pathname :reader error-pathname))
  (:report (lambda (c s)
             (format s "~@<Definition search function returned a wrong pathname ~A ~
                           in search of a definition for system ~A.~@:>"
                     (error-pathname c) (error-name c)))))

Daniel Barlow's avatar
Daniel Barlow committed
494
(define-condition circular-dependency (system-definition-error)
495
  ((components :initarg :components :reader circular-dependency-components)))
496

497
498
499
(define-condition duplicate-names (system-definition-error)
  ((name :initarg :name :reader duplicate-names-name)))

500
501
502
503
(define-condition missing-component (system-definition-error)
  ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
   (parent :initform nil :reader missing-parent :initarg :parent)))

504
505
506
(define-condition missing-component-of-version (missing-component)
  ((version :initform nil :reader missing-version :initarg :version)))

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

510
(define-condition missing-dependency-of-version (missing-dependency
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
511
                                                 missing-component-of-version)
512
513
  ())

Daniel Barlow's avatar
Daniel Barlow committed
514
515
516
517
(define-condition operation-error (error)
  ((component :reader error-component :initarg :component)
   (operation :reader error-operation :initarg :operation))
  (:report (lambda (c s)
518
519
             (format s "~@<erred while invoking ~A on ~A~@:>"
                     (error-operation c) (error-component c)))))
520
521
522
(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
523
524

(defclass component ()
525
  ((name :accessor component-name :initarg :name :documentation
526
         "Component name: designator for a string composed of portable pathname characters")
Daniel Barlow's avatar
Daniel Barlow committed
527
   (version :accessor component-version :initarg :version)
528
529
   (in-order-to :initform nil :initarg :in-order-to
                :accessor component-in-order-to)
530
   ;; XXX crap name
531
532
   (do-first :initform nil :initarg :do-first
             :accessor component-do-first)
533
534
535
536
   ;; 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
537
   (parent :initarg :parent :initform nil :reader component-parent)
Daniel Barlow's avatar
Daniel Barlow committed
538
539
   ;; 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
540
   (relative-pathname :initarg :pathname)
541
   (operation-times :initform (make-hash-table)
542
                    :accessor component-operation-times)
Daniel Barlow's avatar
   
Daniel Barlow committed
543
544
   ;; XXX we should provide some atomic interface for updating the
   ;; component properties
545
   (properties :accessor component-properties :initarg :properties
546
               :initform nil)))
Daniel Barlow's avatar
   
Daniel Barlow committed
547

Daniel Barlow's avatar
   
Daniel Barlow committed
548
549
550
;;;; methods: conditions

(defmethod print-object ((c missing-dependency) s)
551
  (format s "~@<~A, required by ~A~@:>"
552
          (call-next-method c nil) (missing-required-by c)))
Daniel Barlow's avatar
   
Daniel Barlow committed
553
554

(defun sysdef-error (format &rest arguments)
555
  (error 'formatted-system-definition-error :format-control
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
556
         format :format-arguments arguments))
Daniel Barlow's avatar
Daniel Barlow committed
557

Daniel Barlow's avatar
   
Daniel Barlow committed
558
559
560
;;;; methods: components

(defmethod print-object ((c missing-component) s)
561
   (format s "~@<component ~S not found~
562
             ~@[ in ~A~]~@:>"
563
564
565
          (missing-requires c)
          (when (missing-parent c)
            (component-name (missing-parent c)))))
Daniel Barlow's avatar
   
Daniel Barlow committed
566

567
568
569
570
571
(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)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
572
573
           (when (missing-parent c)
             (component-name (missing-parent c)))))
574

Daniel Barlow's avatar
Daniel Barlow committed
575
576
577
578
579
(defmethod component-system ((component component))
  (aif (component-parent component)
       (component-system it)
       component))

580
(defmethod print-object ((c component) stream)
Daniel Barlow's avatar
Daniel Barlow committed
581
  (print-unreadable-object (c stream :type t :identity t)
Daniel Barlow's avatar
Daniel Barlow committed
582
583
    (ignore-errors
      (prin1 (component-name c) stream))))
Daniel Barlow's avatar
Daniel Barlow committed
584
585

(defclass module (component)
Daniel Barlow's avatar
   
Daniel Barlow committed
586
  ((components :initform nil :accessor module-components :initarg :components)
587
588
589
   ;; 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
590
591
                           :accessor module-if-component-dep-fails
                           :initarg :if-component-dep-fails)
Daniel Barlow's avatar
Daniel Barlow committed
592
593
594
   (default-component-class :accessor module-default-component-class
     :initform 'cl-source-file :initarg :default-component-class)))

Daniel Barlow's avatar
   
Daniel Barlow committed
595
596
597
598
599
(defun component-parent-pathname (component)
  (aif (component-parent component)
       (component-pathname it)
       *default-pathname-defaults*))

Daniel Barlow's avatar
Daniel Barlow committed
600
(defmethod component-relative-pathname ((component module))
Daniel Barlow's avatar
Daniel Barlow committed
601
  (or (slot-value component 'relative-pathname)
602
      (multiple-value-bind (relative path)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
603
          (split-path-string (component-name component) t)
604
605
606
        (make-pathname
         :directory `(,relative ,@path)
         :host (pathname-host (component-parent-pathname component))))))
Daniel Barlow's avatar
Daniel Barlow committed
607

Daniel Barlow's avatar
   
Daniel Barlow committed
608
609
610
611
(defmethod component-pathname ((component component))
  (let ((*default-pathname-defaults* (component-parent-pathname component)))
    (merge-pathnames (component-relative-pathname component))))

612
(defmethod component-property ((c component) property)
Daniel Barlow's avatar
Daniel Barlow committed
613
  (cdr (assoc property (slot-value c 'properties) :test #'equal)))
614
615

(defmethod (setf component-property) (new-value (c component) property)
Daniel Barlow's avatar
Daniel Barlow committed
616
  (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
617
    (if a
618
619
620
        (setf (cdr a) new-value)
        (setf (slot-value c 'properties)
              (acons property new-value (slot-value c 'properties))))))
621

Daniel Barlow's avatar
   
Daniel Barlow committed
622
623
(defclass system (module)
  ((description :accessor system-description :initarg :description)
Daniel Barlow's avatar
Daniel Barlow committed
624
625
   (long-description
    :accessor system-long-description :initarg :long-description)
Daniel Barlow's avatar
   
Daniel Barlow committed
626
627
   (author :accessor system-author :initarg :author)
   (maintainer :accessor system-maintainer :initarg :maintainer)
628
   (licence :accessor system-licence :initarg :licence
629
630
            :accessor system-license :initarg :license)
   (source-file :reader system-source-file :initarg :source-file
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
631
                :writer %set-system-source-file)))
Daniel Barlow's avatar
   
Daniel Barlow committed
632

633
634
;;;; -------------------------------------------------------------------------
;;;; version-satisfies
Daniel Barlow's avatar
   
Daniel Barlow committed
635
636
637
638
639

(defmethod version-satisfies ((c component) version)
  (unless (and version (slot-boundp c 'version))
    (return-from version-satisfies t))
  (let ((x (mapcar #'parse-integer
640
641
642
                   (split (component-version c) nil '(#\.))))
        (y (mapcar #'parse-integer
                   (split version nil '(#\.)))))
Daniel Barlow's avatar
   
Daniel Barlow committed
643
    (labels ((bigger (x y)
644
645
646
647
648
               (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
649
      (and (= (car x) (car y))
650
           (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
Daniel Barlow's avatar
   
Daniel Barlow committed
651

652
653
;;;; -------------------------------------------------------------------------
;;;; Finding systems
Daniel Barlow's avatar
   
Daniel Barlow committed
654

Gary King's avatar
Gary King committed
655
656
657
(defun make-defined-systems-table ()
  (make-hash-table :test 'equal))

658
659
660
661
662
663
(defvar *defined-systems* (make-defined-systems-table)
  "This is a hash table whose keys are strings, being the
names of the systems, and whose values are pairs, the first
element of which is a universal-time indicating when the
system definition was last updated, and the second element
of which is a system object.")
Gary King's avatar
Gary King committed
664

Daniel Barlow's avatar
   
Daniel Barlow committed
665
(defun coerce-name (name)
666
667
668
669
670
  (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
671

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

Gary King's avatar
Gary King committed
675
676
677
678
679
680
(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)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
681
682
683
684
685
             (declare (ignore _))
             (destructuring-bind (_ . def) datum
               (declare (ignore _))
               (funcall fn def)))
           *defined-systems*))
686

687
688
689
690
691
692
;;; 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))

693
(defun system-definition-pathname (system)
694
695
696
  (let ((system-name (coerce-name system)))
    (or
     (some (lambda (x) (funcall x system-name))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
697
           *system-definition-search-functions*)
698
     (let ((system-pair (system-registered-p system-name)))
699
       (and system-pair
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
700
            (system-source-file (cdr system-pair)))))))
701

702
(defvar *central-registry*
Gary King's avatar
Gary King committed
703
  `((directory-namestring *default-pathname-defaults*))
704
705
"A list of 'system directory designators' ASDF uses to find systems.

706
A 'system directory designator' is a pathname or a function
707
708
709
710
711
712
713
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/\"))
")
714

715
(defun directory-pathname-p (pathname)
Gary King's avatar
Gary King committed
716
717
718
  "Does `pathname` represent a directory?

A directory-pathname is a pathname _without_ a filename. The three
719
ways that the filename components can be missing are for it to be `nil`,
Gary King's avatar
Gary King committed
720
721
722
723
`:unspecific` or the empty string.

Note that this does _not_ check to see that `pathname` points to an
actually-existing directory."
724
  (flet ((check-one (x)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
725
726
           (not (null (member x '(nil :unspecific "")
                              :test 'equal)))))
727
    (and (check-one (pathname-name pathname))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
728
         (check-one (pathname-type pathname)))))
729

730
(defun sysdef-central-registry-search (system)
731
  (let ((name (coerce-name system))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
732
733
        (to-remove nil)
        (to-replace nil))
734
    (block nil
735
      (unwind-protect
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
736
737
738
739
740
741
742
743
           (dolist (dir *central-registry*)
             (let ((defaults (eval dir)))
               (when defaults
                 (cond ((directory-pathname-p defaults)
                        (let ((file (and defaults
                                         (make-pathname
                                          :defaults defaults :version :newest
                                          :name name :type "asd" :case :local)))
744
                               #+(and (or win32 windows) (not :clisp))
745
746
747
                               (shortcut (make-pathname
                                          :defaults defaults :version :newest
                                          :name name :type "asd.lnk" :case :local)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
748
749
                          (if (and file (probe-file file))
                              (return file))
750
                          #+(and (or win32 windows) (not :clisp))
751
752
753
                          (when (probe-file shortcut)
                            (let ((target (parse-windows-shortcut shortcut)))
                              (when target
754
                                (return (pathname target)))))))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
755
756
757
758
759
760
                       (t
                        (restart-case
                            (let* ((*print-circle* nil)
                                   (message
                                    (format nil
                                            "~@<While searching for system `~a`: `~a` evaluated ~
761
to `~a` which is not a directory.~@:>"
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
                                            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))))))))))
783

Christophe Rhodes's avatar
Fixes    
Christophe Rhodes committed
784
785
786
(defun make-temporary-package ()
  (flet ((try (counter)
           (ignore-errors
787
             (make-package (format nil "~a~D" 'asdf counter)
788
                           :use '(:cl :asdf)))))
Christophe Rhodes's avatar
Fixes    
Christophe Rhodes committed
789
790
791
    (do* ((counter 0 (+ counter 1))
          (package (try counter) (try counter)))
         (package package))))
792

793
794
795
796
797
798
799
800
(defun safe-file-write-date (pathname)
           ;; 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.
  (or (file-write-date pathname) 0))

Daniel Barlow's avatar
   
Daniel Barlow committed
801
802
(defun find-system (name &optional (error-p t))
  (let* ((name (coerce-name name))
803
         (in-memory (system-registered-p name))
804
         (on-disk (system-definition-pathname name)))
Daniel Barlow's avatar
   
Daniel Barlow committed
805
    (when (and on-disk
806
               (or (not in-memory)
807
                   (< (car in-memory) (safe-file-write-date on-disk))))
Christophe Rhodes's avatar
Fixes    
Christophe Rhodes committed
808
809
      (let ((package (make-temporary-package)))
        (unwind-protect
810
811
812
813
814
815
816
817
818
             (with-open-file (asd on-disk :if-does-not-exist nil)
               (if asd
                   (let ((*package* package))
                     (asdf-message
                      "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
                      ;; FIXME: This wants to be (ENOUGH-NAMESTRING
                      ;; ON-DISK), but CMUCL barfs on that.
                      on-disk
                      *package*)
819
                     (load on-disk))
820
                   (error 'missing-definition :name name :pathname on-disk)))
Christophe Rhodes's avatar
Fixes    
Christophe Rhodes committed
821
          (delete-package package))))
822
    (let ((in-memory (system-registered-p name)))
Daniel Barlow's avatar
   
Daniel Barlow committed
823
      (if in-memory
824
          (progn (if on-disk (setf (car in-memory)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
825
                                   (safe-file-write-date on-disk)))
826
827
                 (cdr in-memory))
          (if error-p (error 'missing-component :requires name))))))
Daniel Barlow's avatar
   
Daniel Barlow committed
828
829

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

834

835
836
;;;; -------------------------------------------------------------------------
;;;; Finding components
Daniel Barlow's avatar
Daniel Barlow committed
837

838
(defmethod find-component ((module module) name &optional version)
Daniel Barlow's avatar
Daniel Barlow committed
839
  (if (slot-boundp module 'components)
840
      (let ((m (find name (module-components module)
841
842
843
                     :test #'equal :key #'component-name)))
        (if (and m (version-satisfies m version)) m))))

Daniel Barlow's avatar
Daniel Barlow committed
844
845

;;; a component with no parent is a system
846
(defmethod find-component ((module (eql nil)) name &optional version)
Daniel Barlow's avatar
   
Daniel Barlow committed
847
  (let ((m (find-system name nil)))
848
    (if (and m (version-satisfies m version)) m)))
Daniel Barlow's avatar
Daniel Barlow committed
849

Daniel Barlow's avatar
   
Daniel Barlow committed
850
851
;;; component subclasses

Daniel Barlow's avatar
Daniel Barlow committed
852
853
854
(defclass source-file (component) ())

(defclass cl-source-file (source-file) ())
Daniel Barlow's avatar
Daniel Barlow committed
855
856
(defclass c-source-file (source-file) ())
(defclass java-source-file (source-file) ())
857
858
859
(defclass static-file (source-file) ())
(defclass doc-file (static-file) ())
(defclass html-file (doc-file) ())
Daniel Barlow's avatar
Daniel Barlow committed
860

Daniel Barlow's avatar
Daniel Barlow committed
861
862
863
(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
864
(defmethod source-file-type ((c html-file) (s module)) "html")
865
866
(defmethod source-file-type ((c static-file) (s module)) nil)

867
868
869
870
871
872
873
874
(defun merge-component-relative-pathname (pathname name type)
  (multiple-value-bind (relative path filename)
      (split-path-string name)
  (merge-pathnames
   (or pathname (make-pathname :directory `(,relative ,@path)))
   (if type
       (make-pathname :name filename :type type)
       filename))))
875

Daniel Barlow's avatar
Daniel Barlow committed
876
(defmethod component-relative-pathname ((component source-file))
877
878
879
880
  (merge-component-relative-pathname
   (slot-value component 'relative-pathname)
   (component-name component)
   (source-file-type component (component-system component))))
Daniel Barlow's avatar
Daniel Barlow committed
881

882
883
;;;; -------------------------------------------------------------------------
;;;; Operations
Daniel Barlow's avatar
Daniel Barlow committed
884

885
;;; one of these is instantiated whenever #'operate is called
Daniel Barlow's avatar
Daniel Barlow committed
886
887

(defclass operation ()
888
  ((forced :initform nil :initarg :force :accessor operation-forced)
889
   (original-initargs :initform nil :initarg :original-initargs
890
                      :accessor operation-original-initargs)
891
892
893
894
   (visited-nodes :initform nil :accessor operation-visited-nodes)
   (visiting-nodes :initform nil :accessor operation-visiting-nodes)
   (parent :initform nil :initarg :parent :accessor operation-parent)))

895
896
897
898
899
(defmethod print-object ((o operation) stream)
  (print-unreadable-object (o stream :type t :identity t)
    (ignore-errors
      (prin1 (operation-original-initargs o) stream))))

900
(defmethod shared-initialize :after ((operation operation) slot-names
901
902
                                     &key force
                                     &allow-other-keys)
903
904
905
  (declare (ignore slot-names force))
  ;; empty method to disable initarg validity checking
  )
Daniel Barlow's avatar
Daniel Barlow committed
906

907
908
909
(defun node-for (o c)
  (cons (class-name (class-of o)) c))

910
911
912
913
914
(defmethod operation-ancestor ((operation operation))
  (aif (operation-parent operation)
       (operation-ancestor it)
       operation))

915
916
917

(defun make-sub-operation (c o dep-c dep-o)
  (let* ((args (copy-list (operation-original-initargs o)))
918
         (force-p (getf args :force)))
919
920
921
    ;; note explicit comparison with T: any other non-NIL force value
    ;; (e.g. :recursive) will pass through
    (cond ((and (null (component-parent c))
922
923
924
925
926
927
928
929
930
931
932
933
                (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)))))
934

935

Daniel Barlow's avatar
   
Daniel Barlow committed
936
937
938
(defmethod visit-component ((o operation) (c component) data)
  (unless (component-visited-p o c)
    (push (cons (node-for o c) data)
939
          (operation-visited-nodes (operation-ancestor o)))))
Daniel Barlow's avatar
Daniel Barlow committed
940
941

(defmethod component-visited-p ((o operation) (c component))
Daniel Barlow's avatar
   
Daniel Barlow committed
942
  (assoc (node-for o c)
943
944
         (operation-visited-nodes (operation-ancestor o))
         :test 'equal))
Daniel Barlow's avatar
Daniel Barlow committed
945

946
947
948
(defmethod (setf visiting-component) (new-value operation component)
  ;; MCL complains about unused lexical variables
  (declare (ignorable new-value operation component)))
949

Daniel Barlow's avatar
Daniel Barlow committed
950
(defmethod (setf visiting-component) (new-value (o operation) (c component))
951
  (let ((node (node-for o c))
952
        (a (operation-ancestor o)))
953
    (if new-value
954
955
956
        (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
957
958

(defmethod component-visiting-p ((o operation) (c component))
959
  (let ((node (node-for o c)))
960
    (member node (operation-visiting-nodes (operation-ancestor o))
961
            :test 'equal)))
Daniel Barlow's avatar
Daniel Barlow committed
962

963
964
(defmethod component-depends-on ((op-spec symbol) (c component))
  (component-depends-on (make-instance op-spec) c))
965
966

(defmethod component-depends-on ((o operation) (c component))
967
  (cdr (assoc (class-name (class-of o))
968
              (component-in-order-to c))))
969

Daniel Barlow's avatar
   
Daniel Barlow committed
970
971
972
(defmethod component-self-dependencies ((o operation) (c component))
  (let ((all-deps (component-depends-on o c)))
    (remove-if-not (lambda (x)
973
974
975
                     (member (component-name c) (cdr x) :test #'string=))
                   all-deps)))

Daniel Barlow's avatar
   
Daniel Barlow committed
976
977
(defmethod input-files ((operation operation) (c component))
  (let ((parent (component-parent c))
978
        (self-deps (component-self-dependencies operation c)))
Daniel Barlow's avatar
   
Daniel Barlow committed
979
    (if self-deps
980
981
982
983
984
985
986
987
        (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
988

989
(defmethod input-files ((operation operation) (c module)) nil)
990

Daniel Barlow's avatar
   
Daniel Barlow committed
991
(defmethod operation-done-p ((o operation) (c component))
992
  (flet ((fwd-or-return-t (file)
993
           (let ((date (safe-file-write-date file)))
994
995
             (cond
               (date)
996
               (t
997
                (warn "~@<Missing FILE-WRITE-DATE for ~S: treating ~
998
                       operation ~S on component ~S as done.~@:>"
999
1000
1001
1002
1003
1004
                      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
1005
             ;; produce nothing probably isn't doing much
1006
             t)
1007
            ((not out-files)
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
             (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)
1019
              (> (apply #'min (mapcar #'safe-file-write-date out-files))
1020
                 (apply #'max (mapcar #'fwd-or-return-t in-files)))))))))
1021

Daniel Barlow's avatar
Daniel Barlow committed
1022
1023
1024
;;; 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
1025
;;; for our purposes.
Daniel Barlow's avatar
Daniel Barlow committed
1026

Daniel Barlow's avatar
Daniel Barlow committed
1027
(defmethod traverse ((operation operation) (c component))
Daniel Barlow's avatar
   
Daniel Barlow committed
1028
  (let ((forced nil))
Gary King's avatar
Gary King committed
1029
    (labels ((%do-one-dep (required-op required-c required-v)
1030
1031
1032
1033
1034
1035
               (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)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
1036
1037
1038
1039
1040
1041
1042
1043
                                 (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))))
1044
1045
                      (op (make-sub-operation c operation dep-c required-op)))
                 (traverse op dep-c)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
1046
             (do-one-dep (required-op required-c required-v)
Gary King's avatar
Gary King committed
1047
               (loop
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
1048
1049
1050
1051
1052
1053
1054
1055
                  (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)
Gary King's avatar
Gary King committed
1056
#|
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
1057
1058
1059
1060
1061
                        (print (list :c1 c (typep c 'missing-dependency)))
                        (when (typep c 'missing-dependency)
                          (print (list :c2 (missing-requires c) required-c
                                       (equalp (missing-requires c)
                                               required-c))))
Gary King's avatar
Gary King committed
1062
|#
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
1063
1064
1065
                        (and (typep c 'missing-dependency)
                             (equalp (missing-requires c)
                                     required-c)))))))
1066
1067
1068
             (do-dep (op dep)
               (cond ((eq op 'feature)
                      (or (member (car dep) *features*)
Nikodemus Siivola's avatar
Nikodemus Siivola committed
1069
                          (error 'missing-dependency
1070
                                 :required-by c
1071
                                 :requires (car dep))))
1072
1073
                     (t
                      (dolist (d dep)
Daniel Barlow's avatar
   
Daniel Barlow committed
1074
                        (cond ((consp d)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
                               (cond ((string-equal
                                       (symbol-name (first d))
                                       "VERSION")
                                      (appendf
                                       forced
                                       (do-one-dep op (second d) (third d))))
                                     ((and (string-equal
                                            (symbol-name (first d))
                                            "FEATURE")
                                           (find (second d) *features*
                                                 :test 'string-equal))
                                      (appendf
                                       forced
                                       (do-one-dep op (second d) (third d))))
                                     (t
                                      (error "Bad dependency ~a.  Dependencies must be (:version <version>), (:feature <feature>), or a name" d))))
Daniel Barlow's avatar
   
Daniel Barlow committed
1091
1092
1093
                              (t
                               (appendf forced (do-one-dep op d nil)))))))))
      (aif (component-visited-p operation c)
1094
1095
           (return-from traverse
             (if (cdr it) (list (cons 'pruned-op c)) nil)))
Daniel Barlow's avatar
   
Daniel Barlow committed
1096
1097
      ;; dependencies
      (if (component-visiting-p operation c)
1098
          (error 'circular-dependency :components (list c)))
Daniel Barlow's avatar
   
Daniel Barlow committed
1099
      (setf (visiting-component operation c) t)
1100
      (unwind-protect
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
1101
           (progn
1102
1103
1104
             (loop :for (required-op . deps) :in
               (component-depends-on operation c)
               :do (do-dep required-op deps))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
1105
1106
1107
1108
1109
1110
             ;; constituent bits
             (let ((module-ops
                    (when (typep c 'module)
                      (let ((at-least-one nil)
                            (forced nil)
                            (error nil))
1111
1112
                        (dolist (kid (module-components c))
                          (handler-case
1113
                              (appendf forced (traverse operation kid))