script-support.lisp 21.3 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
79
80
81
82
83
84
(defun asym (name &optional package (errorp t))
  (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 :asdf nil) '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
(defun test-upgrade (old-method new-method tag) ;; called by run-test
434
  (with-test ()
435
    (verbose t nil)
436
437
    (when old-method
      (cond
438
        ((string-equal tag "REQUIRE")
439
         (format t "Requiring some previous ASDF ~A~%" tag)
440
         (ignore-errors (funcall 'require "asdf"))
441
442
443
         (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)))
444
445
        (t
         (format t "Loading old asdf ~A via ~A~%" tag old-method)
446
447
448
         (funcall old-method tag))))
    (when (asym :*asdf-verbose* nil nil) (setf (asymval :*asdf-verbose*) t))
    (when (asym :*verbose-out* nil nil) (setf (asymval :*verbose-out*) *standard-output*))
449
450
    (format t "Now loading new asdf via method ~A~%" new-method)
    (funcall new-method)
451
    (format t "Testing it~%")
452
    (register-directory *test-directory*)
453
454
455
    (load-test-system :test-module-depend)
    (assert (eval (intern (symbol-name '#:*file1*) :test-package)))
    (assert (eval (intern (symbol-name '#:*file3*) :test-package)))))
456

457
458
459
460
461
462
463
464
465
466
467
468
469
(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)))
470
471
472
473
474
475
476
477

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

479
480
(defun configure-asdf ()
  (setf *debug-asdf* (or *debug-asdf* (acall :getenvp "DEBUG_ASDF_TEST")))
481
  (untrace)
482
483
484
485
486
  (eval `(trace ,@(loop :for s :in *trace-symbols* :collect (asym s))))
  (acall :initialize-source-registry
         `(:source-registry :ignore-inherited-configuration))
  (acall :initialize-output-translations
         `(:output-translations
487
488
           ((,*asdf-directory* :**/ :*.*.*) ,(output-location "asdf"))
           (t ,(output-location "root"))
489
490
           :ignore-inherited-configuration))
  (set (asym :*central-registry*) `(,*test-directory*))
491
492
  (when (asym :*asdf-verbose*) (setf (asymval :*asdf-verbose*) t))
  (when (asym :*verbose-out*) (setf (asymval :*verbose-out*) *standard-output*))
493
494
495
496
497
498
499
500
501
  (let ((x (acall :system-source-directory :hello-world-example)))
    (assert-pathname-equal *test-directory* x) ;; not always EQUAL (!)
    (unless (equal *test-directory* x)
      (format t "Interestingly, while *test-directory* has components~% ~S~%~
                 ASDF finds the ASDs in~% ~S~%Using the latter.~%"
              (pathname-components *test-directory*)
              (pathname-components x)))
    (setf *test-directory* x))
  t)
502
503

(defun load-asdf (&optional tag)
504
  #+gcl2.6 (load-asdf-lisp tag) #-gcl2.6
505
506
  (load-asdf-fasl tag)
  (use-package :asdf :asdf-test)
507
  (use-package :asdf/driver :asdf-test)
508
  (use-package :asdf/cache :asdf-test)
509
510
  (configure-asdf)
  (setf *package* (find-package :asdf-test)))
511

512
513
(defun debug-asdf ()
  (setf *debug-asdf* t)
514
  (setf *quit-when-done* nil)
515
516
  (setf *package* (find-package :asdf-test)))

517
518
(defun just-load-asdf-fasl () (load-asdf-fasl))

519
;; Actual scripts rely on this function:
520
(defun common-lisp-user::load-asdf () (load-asdf))
521

522
523
524
525
526
527
(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))

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

530
531
(defmacro test-load-systems (&rest x)
  `(do-test-load-systems ',x))
532

533
534
535
536
537
538
(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!~%"))
539

540
541
542
543
;; 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
544
545
546
 la load-asdf common-lisp-user::la load-asdf
 ll load-asdf-lisp
 v verbose)
547

548
549
550
551
#| 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.
552

553
554
555
556
 (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
))
|#