script-support.lisp 21.7 KB
Newer Older
1
2
3
4
5
6
7
8
;;;;; Minimal life-support for testing ASDF from a blank Lisp image.
#|
Some constraints:
* We cannot rely on any test library that could be loaded by ASDF.
 And we cannot even rely on ASDF being present until we load it.
 But we *can* rely on ASDF being present *after* we load it.
* evaluating this file MUST NOT print anything,
 because we use it in the forward-ref test to check that nothing is printed.
9
10
* We make sure that none of our symbols clash with asdf/driver or asdf,
 so we may use-package them during testing.
11
12
|#

13
14
15
(defpackage :asdf-test
  (:use :common-lisp)
  (:export
16
   #:asym #:acall #:asymval
17
   #:*test-directory* #:*asdf-directory*
18
19
   #:load-asdf #:maybe-compile-asdf
   #:load-asdf-lisp #:compile-asdf #:load-asdf-fasl
20
   #:compile-load-asdf #:load-asdf-system #:clean-load-asdf-system
21
22
23
   #:register-directory #:load-test-system
   #:with-test #:test-asdf #:debug-asdf
   #:assert-compare
24
   #:assert-equal
25
   #:leave-test #:def-test-system
26
   #:action-name #:in-plan-p
27
   #:test-source #:test-fasl #:resolve-output #:output-location
28
   #:quietly))
29

30
(in-package :asdf-test)
31

32
33
34
35
36
37
(declaim (optimize (speed 2) (safety 3) #-(or allegro gcl) (debug 3)
		   #+(or cmu scl) (c::brevity 2)))
(proclaim '(optimize (speed 2) (safety 3) #-(or allegro gcl) (debug 3)
		     #+(or cmu scl) (c::brevity 2)))

(defvar *trace-symbols*
38
  `(;; If you want to trace some stuff while debugging ASDF,
39
40
    ;; here's a nice place to say what.
    ;; These string designators will be interned in ASDF after it is loaded.
41
42
    
    ;;#+ecl ,@'( :perform :input-files :output-files :compile-file* :compile-file-pathname* :load*)
43
44
45
    ))

(defvar *debug-asdf* nil)
46
(defvar *quit-when-done* t)
47

48
49
50
(defun verbose (&optional (verbose t) (print verbose))
  (setf *load-verbose* verbose *compile-verbose* verbose)
  (setf *load-print* print *compile-print* print))
51
52
53

(verbose nil)

54
55
;;; Minimal compatibility layer
(eval-when (:compile-toplevel :load-toplevel :execute)
56
57
58
59
60
  #+allegro
  (setf excl:*warn-on-nested-reader-conditionals* nil
        excl::*autoload-package-name-alist*
        (remove "asdf" excl::*autoload-package-name-alist*
                :test 'equalp :key 'car)) ; We need that BEFORE any mention of package ASDF.
61
  #+cmucl (setf ext:*gc-verbose* nil)
62
  #+gcl
63
64
65
  (when (and (= system::*gcl-major-version* 2)
             (= system::*gcl-minor-version* 6))
    (pushnew :gcl2.6 *features*)
66
67
    (shadowing-import 'system:*load-pathname* :asdf-test))
  #+lispworks
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
68
  (setf system:*stack-overflow-behaviour* :warn))
69
70
71
72
73

#+(or gcl genera)
(unless (fboundp 'ensure-directories-exist)
  (defun ensure-directories-exist (path)
    #+genera (fs:create-directories-recursively (pathname path))
74
75
    #+gcl (lisp:system (format nil "mkdir -p ~S"
                               (namestring (make-pathname :name nil :type nil :defaults path))))))
76
77

;;; Survival utilities
78
(defun asym (name &optional package errorp)
79
80
81
82
83
84
  (let* ((pname (or package :asdf))
         (package (find-package pname)))
    (if package
        (or (find-symbol (string name) package)
            (when errorp (error "Can't find symbol ~A in ~A" name pname)))
        (when errorp (error "Can't find package ~A" pname)))))
85
(defun acall (name &rest args)
86
87
88
89
90
91
92
93
94
  (apply (apply 'asym (if (consp name) name (list name))) args))
(defun asymval (name &optional package)
  (symbol-value (asym name package)))
(defsetf asymval (name &optional package) (new-value) ;; NB: defun setf won't work on GCL2.6
  (let ((sym (gensym "SYM")))
    `(let ((,sym (asym ,name ,package)))
       (if ,sym
           (setf (symbol-value ,sym) ,new-value)
           (error "NIHIL EX NIHILO")))))
95

96
(defun finish-outputs* ()
97
98
99
  (loop :for s :in (list *standard-output* *error-output* *trace-output* *debug-io*)
        :do (finish-output s)))
(defun redirect-outputs ()
100
  (finish-outputs*)
101
102
  (setf *error-output* *standard-output*
        *trace-output* *standard-output*))
103

104
(redirect-outputs) ;; Put everything on standard output, for the sake of scripts
105

106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
;;; Helpful for debugging

(defun pathname-components (p)
  (when p
    (let ((p (pathname p)))
      (list :host (pathname-host p)
            :device (pathname-device p)
            :directory (pathname-directory p)
            :name (pathname-name p)
            :type (pathname-type p)
            :version (pathname-version p)))))

(defun assert-pathname-equal-helper (qx x qy y)
  (cond
    ((equal x y)
     (format t "~S and ~S both evaluate to same path:~%  ~S~%" qx qy x))
    ((acall :pathname-equal x y)
     (format t "These two expressions yield pathname-equal yet not equal path~%  ~S~%" x)
     (format t "the first expression ~S yields this:~%  ~S~%" qx (pathname-components x))
     (format t "the other expression ~S yields that:~%  ~S~%" qy (pathname-components y)))
    (t
     (format t "These two expressions yield paths that are not pathname-equal~%")
     (format t "the first expression ~S yields this:~%  ~S~%  ~S~%" qx x (pathname-components x))
     (format t "the other expression ~S yields that:~%  ~S~%  ~S~%" qy y (pathname-components y)))))
(defmacro assert-pathname-equal (x y)
  `(assert-pathname-equal-helper ',x ,x ',y ,y))
(defun assert-length-equal-helper (qx qy x y)
  (unless (= (length x) (length y))
    (format t "These two expressions yield sequences of unequal length~%")
    (format t "The first, ~S, has value ~S of length ~S~%" qx x (length x))
    (format t "The other, ~S, has value ~S of length ~S~%" qy y (length y))))
(defun assert-pathnames-equal-helper (qx x qy y)
  (assert-length-equal-helper qx x qy y)
  (loop :for n :from 0
        :for qpx = `(nth ,n ,qx)
        :for qpy = `(nth ,n ,qy)
        :for px :in x
        :for py :in y :do
        (assert-pathname-equal-helper qpx px qpy py)))
(defmacro assert-pathnames-equal (x y)
  `(assert-pathnames-equal-helper ',x ,x ',y ,y))

;; More pathname madness.
149
150
151
;; We can't use goodies from asdf/pathnames because ASDF isn't loaded yet.
;; We still want to work despite and host/device funkiness,
;; so we do it the hard way.
152
(defparameter *test-directory*
153
  (truename
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
   (make-pathname :name nil :type nil :version nil
                  :defaults (or *load-pathname* *compile-file-pathname*))))
(defun make-sub-pathname (&rest keys &key defaults &allow-other-keys)
  (merge-pathnames (apply 'make-pathname keys) defaults))
(defun relative-dir (&rest dir) #-gcl (cons ':relative dir) #+gcl dir)
(defun back-dir () #-gcl :back #+gcl :parent)
(defparameter *asdf-directory*
  (truename (make-sub-pathname :directory (relative-dir (back-dir)) :defaults *test-directory*)))
(defparameter *build-directory*
  (make-sub-pathname :directory (relative-dir "build") :defaults *asdf-directory*))
(defparameter *implementation*
  (or #+allegro
      (ecase excl:*current-case-mode*
        (:case-sensitive-lower :mlisp)
        (:case-insensitive-upper :alisp))
      #+armedbear :abcl
      #+clisp :clisp
      #+clozure :ccl
      #+cmu :cmucl
      #+corman :cormanlisp
      #+digitool :mcl
175
      #+ecl (or #+ecl-bytecmp :ecl_bytecodes :ecl)
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
      #+gcl :gcl
      #+lispworks :lispworks
      #+mkcl :mkcl
      #+sbcl :sbcl
      #+scl :scl
      #+xcl :xcl))
(defparameter *early-fasl-directory*
  (make-sub-pathname :directory (relative-dir "fasls" (string-downcase *implementation*))
                     :defaults *build-directory*))

(defun asdf-name (&optional tag)
  (format nil "asdf~@[-~A~]" tag))
(defun asdf-lisp (&optional tag)
  (make-pathname :name (asdf-name tag) :type "lisp" :defaults *build-directory*))
(defun debug-lisp ()
  (make-sub-pathname :directory (relative-dir "contrib") :name "debug" :type "lisp" :defaults *asdf-directory*))
(defun early-compile-file-pathname (file)
193
  (compile-file-pathname
194
195
196
   (make-pathname :name (pathname-name file) :type "lisp" :defaults *early-fasl-directory*)))
(defun asdf-fasl (&optional tag)
  (early-compile-file-pathname (asdf-lisp tag)))
197

198
199
;;; Test helper functions

200
(load (debug-lisp))
201
(verbose t nil)
202

203
204
205
206
207
208
(defmacro assert-compare (expr)
  (destructuring-bind (op x y) expr
    `(assert-compare-helper ',op ',x ',y ,x ,y)))

(defun assert-compare-helper (op qx qy x y)
  (unless (funcall op x y)
209
    (error "These two expressions fail comparison with ~S:~% ~
210
211
212
213
214
            ~S evaluates to ~S~% ~S evaluates to ~S~%"
            op qx x qy y)))

(defmacro assert-equal (x y)
  `(assert-compare (equal ,x ,y)))
215

216
217
218
(defun touch-file (file &key offset timestamp)
  (let* ((base (or timestamp (get-universal-time)))
         (stamp (if offset (+ base offset) base)))
219
    (if (asymval :*asdf-cache*)
220
221
222
223
224
225
226
227
228
229
        (acall :register-file-stamp file stamp)
        (multiple-value-bind (sec min hr day month year)
            (decode-universal-time stamp #+gcl2.6 -5) ;; -5 is for *my* localtime
          (error "Y U NO use stamp cache?")
          (acall :run-program
                 `("touch" "-t" ,(format nil "~4,'0D~2,'0D~2,'0D~2,'0D~2,'0D.~2,'0D"
                                         year month day hr min sec)
                           ,(acall :native-namestring file)))
          (assert-equal (file-write-date file) stamp)))))
(defun mark-file-deleted (file)
230
  (unless (asymval :*asdf-cache*) (error "Y U NO use asdf cache?"))
231
  (acall :register-file-stamp file nil))
232

233
234
235
236
(defun hash-table->alist (table)
  (loop :for key :being :the :hash-keys :of table :using (:hash-value value)
    :collect (cons key value)))

237
(defun exit-lisp (&optional (code 0)) ;; Simplified from asdf/image:quit
238
  (finish-outputs*)
239
240
241
242
243
244
245
246
247
248
249
250
  #+(or abcl xcl) (ext:quit :status code)
  #+allegro (excl:exit code :quiet t)
  #+clisp (ext:quit code)
  #+clozure (ccl:quit code)
  #+cormanlisp (win32:exitprocess code)
  #+(or cmu scl) (unix:unix-exit code)
  #+ecl (si:quit code)
  #+gcl (lisp:quit code)
  #+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code)
  #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
  #+mcl (ccl:quit) ;; or should we use FFI to call libc's exit(3) ?
  #+mkcl (mk-ext:quit :exit-code code)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
251
  #+sbcl #.(let ((exit (find-symbol "EXIT" :sb-ext))
252
		 (quit* (find-symbol "QUIT" :sb-ext)))
253
254
	     (cond
	       (exit `(,exit :code code :abort t))
255
	       (quit* `(,quit* :unix-status code :recklessly-p t))))
256
257
  #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
  (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code))
258
259


260
(defun leave-test (message return)
261
  (finish-outputs*)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
262
263
264
  (fresh-line *error-output*)
  (when message
    (format *error-output* message)
265
    (fresh-line *error-output*))
266
  (finish-outputs*)
267
  (throw :asdf-test-done return))
268

269
(defmacro with-test ((&optional) &body body)
270
  `(call-with-test (lambda () ,@body)))
271

272
(defun call-with-test (thunk)
Robert P. Goldman's avatar
   
Robert P. Goldman committed
273
274
275
  "Unless the environment variable DEBUG_ASDF_TEST
is bound, write a message and exit on an error.  If
*asdf-test-debug* is true, enter the debugger."
276
  (redirect-outputs)
277
278
279
280
  (let ((result
          (catch :asdf-test-done
            (handler-bind
                ((error (lambda (c)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
281
282
                          (ignore-errors
                           (format *error-output* "~&TEST ABORTED: ~A~&" c))
283
                          (finish-outputs*)
284
                          (cond
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
285
286
287
                            (*debug-asdf*
                             (format t "~&It's your baby, fix it!~%")
                             (break))
288
                            (t
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
289
290
291
                             (ignore-errors
                              (acall :print-condition-backtrace
                                     c :count 69 :stream *error-output*))
292
                             (leave-test "Script failed" 1))))))
293
              (funcall (or (asym :call-with-asdf-cache) 'funcall) thunk)
294
              (leave-test "Script succeeded" 0)))))
295
    (when *quit-when-done*
296
      (exit-lisp result))))
297
298
299
300
301
302
303
304
305
306

;;; These are used by the upgrade tests

(defmacro quietly (&body body)
  `(call-quietly #'(lambda () ,@body)))

(defun call-quietly (thunk)
  (handler-bind (#+sbcl (sb-kernel:redefinition-warning #'muffle-warning))
    (funcall thunk)))

307
308
309
310
311
312
313
(defun interactive-test (&optional files)
  (verbose t nil)
  (loop :for file :in files :do
    (load (string-downcase file)))
  (setf *package* (some 'find-package '(:asdf :asdf/driver :asdf/utility :asdf/package :asdf-test)))
  (load "contrib/debug.lisp"))

314
(defun load-asdf-lisp (&optional tag)
315
  (quietly (load (asdf-lisp tag) :verbose *load-verbose* :print *load-print*)))
316

317
318
(defun load-asdf-fasl (&optional tag)
  (quietly (load (asdf-fasl tag))))
319
320

(defun register-directory (dir)
321
  (pushnew dir (symbol-value (asym :*central-registry*))))
322

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
323
(defun load-asdf-system (&rest keys)
324
325
  (quietly
   (register-directory *asdf-directory*)
326
327
   (apply (asym :oos) (asym :load-op) :asdf keys)))

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
328
(defun call-with-asdf-conditions (thunk &optional verbose)
329
  (declare (ignorable verbose))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
330
331
332
333
  (handler-bind (#+sbcl
                 ((or sb-c::simple-compiler-note sb-kernel:redefinition-warning)
                   #'muffle-warning)
                 #+(and ecl (not ecl-bytecmp))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
334
335
                 ((or c::compiler-note c::compiler-debug-note
                      c::compiler-warning) ;; ECL emits more serious warnings than it should.
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
                   #'muffle-warning)
                 #+mkcl
                 ((or compiler:compiler-note) #'muffle-warning)
                 #-(or cmu scl)
                 ;; style warnings shouldn't abort the compilation [2010/02/03:rpg]
                 (style-warning
                   #'(lambda (w)
                       ;; escalate style-warnings to warnings - we don't want them.
                       (when verbose
                         (warn "Can you please fix ASDF to not emit style-warnings? Got a ~S:~%~A"
                               (type-of w) w))
                       (muffle-warning w))))
    (funcall thunk)))

(defmacro with-asdf-conditions ((&optional verbose) &body body)
  `(call-with-asdf-conditions #'(lambda () ,@body) ,verbose))

353
354
355
356
357
358
(defun compile-asdf (&optional tag verbose)
  (let* ((alisp (asdf-lisp tag))
         (afasl (asdf-fasl tag))
         (tmp (make-pathname :name "asdf-tmp" :defaults afasl)))
    (ensure-directories-exist afasl)
    (multiple-value-bind (result warnings-p errors-p)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
359
        (compile-file alisp :output-file tmp #-gcl :verbose #-gcl verbose :print verbose)
360
361
362
363
364
365
366
367
368
369
370
371
372
373
      (flet ((bad (key)
               (when result (ignore-errors (delete-file result)))
               key)
             (good (key)
               (when (probe-file afasl) (delete-file afasl))
               (rename-file tmp afasl)
               key))
        (cond
          (errors-p (bad :errors))
          (warnings-p
           (or
            ;; ECL 11.1.1 has spurious warnings, same with XCL 0.0.0.291.
            ;; SCL has no warning but still raises the warningp flag since 2.20.15 (?)
            #+(or cmu ecl scl xcl) (good :expected-warnings)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
374
          (bad :unexpected-warnings)))
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
          (t (good :success)))))))

(defun maybe-compile-asdf (&optional tag)
  (let ((alisp (asdf-lisp tag))
        (afasl (asdf-fasl tag)))
    (cond
      ((not (probe-file alisp))
       :not-found)
      ((and (probe-file afasl)
            (> (file-write-date afasl) (file-write-date alisp))
            (ignore-errors (load-asdf-fasl tag)))
       :previously-compiled)
      (t
       (load-asdf-lisp tag)
       (compile-asdf tag)))))

(defun compile-asdf-script ()
  (with-test ()
393
    #-gcl2.6
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
394
    (ecase (with-asdf-conditions () (maybe-compile-asdf))
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
      (:not-found
       (leave-test "Testsuite failed: unable to find ASDF source" 3))
      (:previously-compiled
       (leave-test "Reusing previously-compiled ASDF" 0))
      (:errors
       (leave-test "Testsuite failed: ASDF compiled with ERRORS" 2))
      (:unexpected-warnings
       (leave-test "Testsuite failed: ASDF compiled with unexpected warnings" 1))
      (:expected-warnings
       (leave-test "ASDF compiled with warnings, ignored for your implementation" 0))
      (:success
       (leave-test "ASDF compiled cleanly" 0)))))

(defun compile-load-asdf (&optional tag)
  ;; emulate the way asdf upgrades itself: load source, compile, load fasl.
  (load-asdf-lisp tag)
  (ecase (compile-asdf tag)
    ((:errors :unexpected-warnings) (leave-test "failed to compile ASDF" 1))
    ((:expected-warnings :success)
     (load-asdf-fasl tag))))

;;; Now, functions to compile and load ASDF.

(defun load-test-system (x &key verbose)
  (let ((*load-print* verbose)
        (*load-verbose* verbose))
    (register-directory *test-directory*)
    (acall :oos (asym :load-op) x :verbose verbose)))
423

424
425
(defun get-asdf-version ()
  (when (find-package :asdf)
426
427
428
429
430
431
    (or (symbol-value (find-symbol (string :*asdf-version*) :asdf))
        (let ((ver (symbol-value (find-symbol (string :*asdf-revision*) :asdf))))
          (etypecase ver
            (string ver)
            (cons (format nil "~{~D~^.~}" ver))
            (null "1.0"))))))
432

433
434
435
436
437
438
439
440
441
442
443
444
445
(defun output-location (&rest sublocation)
  (list* *asdf-directory* "build/fasls" :implementation sublocation))
(defun resolve-output (&rest sublocation)
  (acall :resolve-location (apply 'output-location sublocation)))

(defun test-source (file)
  (acall :subpathname *test-directory* file))
(defun test-output-dir ()
  (resolve-output "asdf" "test"))
(defun test-output (file)
  (acall :subpathname (test-output-dir) file))
(defun test-fasl (file)
  (acall :compile-file-pathname* (test-source file)))
446
447
448
449
450
451
452
453

(defun clean-asdf-system ()
  (let ((fasl (resolve-output "asdf" "build" "asdf.fasl")))
    (when (DBG :clean fasl (probe-file fasl)) (delete-file fasl))))

(defun load-asdf-lisp-clean ()
  (load-asdf-lisp)
  (clean-asdf-system))
454

455
(defun configure-asdf ()
456
457
458
  (format t "Configuring ASDF~%")
  (when (asym :getenvp)
    (format t "Enabling debugging~%")
459
    (setf *debug-asdf* (or *debug-asdf* (acall :getenvp "DEBUG_ASDF_TEST"))))
460
461
462
463
  (when *trace-symbols*
    (format t "Tracing~{ ~A~}~%" *trace-symbols*)
    (eval `(trace ,@(loop :for s :in *trace-symbols* :collect (asym s)))))
  (when (asym :initialize-source-registry)
464
465
    (acall :initialize-source-registry
           `(:source-registry :ignore-inherited-configuration)))
466
  (when (asym :initialize-output-translations)
467
468
    (acall :initialize-output-translations
           `(:output-translations
469
             ((,(namestring *asdf-directory*)) ,(output-location "asdf"))
470
471
             (t ,(output-location "root"))
             :ignore-inherited-configuration)))
472
  (when (asym :*central-registry*)
473
    (set (asym :*central-registry*) `(,*test-directory*)))
474
  (format t "Being a bit verbose~%")
475
476
  (when (asym :*asdf-verbose*) (setf (asymval :*asdf-verbose*) t))
  (when (asym :*verbose-out*) (setf (asymval :*verbose-out*) *standard-output*))
477
478
479
  (when (and (asym :locate-system) (asym :pathname-directory-pathname))
    (format t "Comparing directories~%")
    (let ((x (acall :pathname-directory-pathname (nth-value 2 (acall :locate-system :test-asdf)))))
480
481
482
      (assert-pathname-equal *test-directory* x) ;; not always EQUAL (!)
      (unless (equal *test-directory* x)
        (format t "Interestingly, while *test-directory* has components~% ~S~%~
483
                 ASDF finds the ASDs in~% ~S~%Using the latter.~%"
484
485
486
                (pathname-components *test-directory*)
                (pathname-components x)))
      (setf *test-directory* x)))
487
  t)
488
489

(defun load-asdf (&optional tag)
490
  #+gcl2.6 (load-asdf-lisp tag) #-gcl2.6
491
492
  (load-asdf-fasl tag)
  (use-package :asdf :asdf-test)
493
  (use-package :asdf/driver :asdf-test)
494
  (use-package :asdf/cache :asdf-test)
495
496
  (configure-asdf)
  (setf *package* (find-package :asdf-test)))
497

498
499
(defun debug-asdf ()
  (setf *debug-asdf* t)
500
  (setf *quit-when-done* nil)
501
502
  (setf *package* (find-package :asdf-test)))

503
504
(defun just-load-asdf-fasl () (load-asdf-fasl))

505
;; Actual scripts rely on this function:
506
(defun common-lisp-user::load-asdf () (load-asdf))
507

508
509
510
511
512
513
(setf *package* (find-package :asdf-test))

(defmacro def-test-system (name &rest rest)
  `(apply (asym :register-system-definition) ',name :pathname ,*test-directory*
          :source-file nil ',rest))

514
515
(defun in-plan-p (plan x) (member x plan :key (asym :action-path) :test 'equal))

516
517
(defmacro test-load-systems (&rest x)
  `(do-test-load-systems ',x))
518

519
520
521
522
523
524
(defun do-test-load-systems (systems)
  (load-asdf-lisp)
  (dolist (sys systems)
    (format t "~&Trying to load ~A~%" sys)
    (acall :load-system sys))
  (format t "~&Done!~%"))
525

526
527
528
529
530
531
532
533
534
535
536
537
538
539
(defun test-upgrade (old-method new-method tag) ;; called by run-test
  (with-test ()
    (verbose t nil)
    (when old-method
      (cond
        ((string-equal tag "REQUIRE")
         (format t "Requiring some previous ASDF ~A~%" tag)
         (ignore-errors (funcall 'require "asdf"))
         (if (member "ASDF" *modules* :test 'equalp)
             (format t "Your Lisp implementation provided ASDF ~A~%" (get-asdf-version))
             (leave-test "Your Lisp implementation does not provide ASDF. Skipping test.~%" 0)))
        (t
         (format t "Loading old asdf ~A via ~A~%" tag old-method)
         (funcall old-method tag))))
540
541
    (when (find-package :asdf)
      (configure-asdf))
542
543
544
545
546
    (format t "Now loading new asdf via method ~A~%" new-method)
    (funcall new-method)
    (format t "Testing it~%")
    (register-directory *test-directory*)
    (load-test-system :test-module-depend)
547
548
    (assert (asymval '#:*file1* :test-package))
    (assert (asymval '#:*file3* :test-package))))
549

550
551
552
553
;; These are shorthands for interactive debugging of test scripts:
(!a
 common-lisp-user::debug-asdf debug-asdf
 da debug-asdf common-lisp-user::da debug-asdf
554
555
556
 la load-asdf common-lisp-user::la load-asdf
 ll load-asdf-lisp
 v verbose)
557

558
559
560
561
#| For the record, the following form is sometimes useful to insert in
 asdf/plan:compute-action-stamp to find out what's happening.
 It depends on the DBG macro in contrib/debug.lisp,
 that you should load in your asdf/plan by inserting an (asdf-debug) form in it.
562

563
564
565
566
 (let ((action-path (action-path (cons o c)))) (DBG :cas action-path just-done plan stamp-lookup out-files in-files out-op op-time dep-stamp out-stamps in-stamps missing-in missing-out all-present earliest-out latest-in up-to-date-p done-stamp (operation-done-p o c)
;;; blah
))
|#