source: project/release/3/testbase-driver/trunk/testbase-driver.scm @ 9377

Last change on this file since 9377 was 9377, checked in by Kon Lovett, 12 years ago

Rmvd use of deperecated proc.

File size: 23.5 KB
Line 
1;;;; testbase-driver.scm
2;;;; Kon Lovett, Feb '07
3
4;; Issues
5;;
6;; - Removes the directory from the test-file pathname & changes to the directory
7;; to compile and/or interpret. This is a hack to get around the whitespace embedded
8;; filename on the command-line for windows.
9;;
10;; - User specified test results ignore are cross test-procedure.
11;;
12;; - Command line options are cross test-file.
13;;
14;; - Only works with testbase test-files.
15
16(eval-when (compile)
17  (declare
18    (usual-integrations)
19    (inline)
20    (fixnum)
21    (unused
22      add-startup-object) ) )
23
24(use srfi-1 extras regex utils posix)
25(use srfi-37 args miscmacros lookup-table
26     misc-extn-list misc-extn-directory misc-extn-condition)
27(use testbase-results)
28
29;;;
30
31(include "testbase-driver-version")
32
33(define pathname? string?)
34
35;;; Constants & Other Global Data
36
37(define-constant STD-COMPILER "csc")
38(define-constant STD-COMPILE-OPTIONS '())
39
40(define-constant STD-INTERPRETER "csi")
41(define-constant STD-INTERPRET-OPTIONS '("-n"))
42
43(define *compiler-command* (which-command-pathname STD-COMPILER))
44(define *default-compile-options* STD-COMPILE-OPTIONS)
45
46(define *interpreter-command* (which-command-pathname STD-INTERPRETER))
47(define *default-interpret-options* STD-INTERPRET-OPTIONS)
48
49(define *test-file-table* (make-dict equal?))
50
51(define *dry-run?* #f)
52
53(define *quiet?* #f)
54
55(define *verbose?* #f)
56
57(define *results-mode* 'errors)
58
59(define *expectation-specifics?* #f)
60
61(define *initial-directory* (current-directory)) ; Save wd so we can set it back
62
63;;; Printing messages
64
65(define *message-indent* 0)
66
67(define (print-indent #!optional (amt *message-indent*))
68  (do ([n amt (sub1 n)]) [(zero? n)] (display #\space) )
69  (flush-output) )
70
71(define (print-from-list objs)
72  (print-indent)
73  (apply print (intersperse objs #\space))
74  (flush-output) )
75
76(define (print-message . objs)
77  (unless *quiet?* (print-from-list objs) ) )
78
79(define (print-verbose-message . objs)
80  (when *verbose?* (apply print-message objs)) )
81
82(define (print-indented-verbose-message indent . objs)
83  (when *verbose?*
84    (print-indent indent)
85    (apply print-verbose-message objs) ) )
86
87(define (print-error . objs)
88  (print-error-message
89    (apply conc (intersperse objs #\space))
90    (current-error-port)) )
91
92(define (print-exception-error cnd #!optional (start 0))
93  (let ([err (current-error-port)])
94    (print-error-message cnd err)
95    (print-call-chain err (+ 4 start)) ) )
96
97;;; Performing extend/setup
98
99(define (output-objects msg objs port)
100  (print-verbose-message msg)
101  (for-each
102    (lambda (obj)
103      (print-indented-verbose-message 2 obj) 
104      (unless *dry-run?*
105        (cond
106          [(string? obj)  (display obj port)]
107          [else           (write obj port)])
108        ; For any possible REPL
109        (newline port) ) )
110    objs) )
111
112(define (setup-skips minor-tbl)
113  (and-let* ([skips (dict-ref minor-tbl 'skip)])
114    (let loop ([lst '()] [skips skips])
115      (cond
116        [(null? skips)
117          (unless (null? lst)
118            (dict-update-list! minor-tbl 'setup `(begin ,@lst)))]
119        [(pair? skips)
120          (let ([skip (car skips)])
121            (if (pair? skip)
122              (loop (cons `(test::select 'skip ,@skip) lst) (cdr skips))
123              (error 'setup-skips "invalid skip specification" skips)) )]
124        [else
125          (error 'setup-skips "invalid skip specification" skips)]) ) ) )
126
127;;; Simplified process* (Any non-zero exit code is an error!)
128
129(define (run-process cmd args rproc eproc)
130  (apply print-verbose-message "Executing" cmd args)
131  (unless *dry-run?*
132    (receive [in out pid err] (process* cmd args)
133      (rproc in out pid err)
134      (receive [epid enorm ecode] (process-wait pid)
135        (let ([extcod (and (not (zero? ecode)) ecode)])
136          (when extcod
137            (print-error "abnormal process exit:" extcod))
138          (eproc extcod))))) )
139
140;;; Performing task list
141
142(define (perform-list loc objs)
143  (for-each
144    (lambda (obj)
145      (print-indented-verbose-message 2 obj) 
146      (unless *dry-run?*
147        (cond
148          [(procedure? obj)   (obj)]
149          [(pair? obj)        (eval obj)]
150          [(string? obj)      (eval (with-input-from-string obj read))]
151          [else
152            (error loc "invalid perform object" obj)]) ) )
153    objs) )
154
155(define (perform-list-kind minor-tbl knd msg)
156  (and-let* ([objs (dict-ref minor-tbl knd)])
157    (print-verbose-message "Performing" msg)
158    (perform-list knd objs) ) )
159
160(define (perform-startup minor-tbl)
161  (perform-list-kind minor-tbl 'startup "Startup") )
162
163(define (perform-cleanup minor-tbl)
164  (perform-list-kind minor-tbl 'cleanup "Cleanup") )
165
166(define (add-cleanup-object minor-tbl proc)
167  (dict-update-list! minor-tbl 'cleanup proc) )
168
169(define (add-startup-object minor-tbl proc)
170  (dict-update-list! minor-tbl 'startup proc) )
171
172;;; TestBase configuration support
173
174(define retrieve-test-config
175  (let ([info-begin-re (regexp "\\s*\\#\\|\\s*testbase.*" #t)]
176        [info-end-re (regexp "\\s*\\|\\#.*")]
177        ; Necessary to handle embedded EOL comments
178        [read-line/newline
179          (lambda ()
180            (let ([lin (read-line)])
181              (if (eof-object? lin)
182                lin
183                (conc lin #\newline)) ) )])
184    (lambda (test-file)
185      (with-input-from-file test-file
186        (lambda ()
187          ; Collect all lines in TestBase configuration section(s)
188          (let find-loop ([linlst '()])
189            (let ([lin (read-line/newline)])
190              (cond
191                [(eof-object? lin)
192                  ; Convert configuration section into s-exprs
193                  (with-input-from-string
194                    (apply string-append (reverse! linlst))
195                    (lambda () (port-map identity read)))]
196                [(string-match info-begin-re lin)
197                  (let get-loop ([linlst linlst])
198                    (let ([lin (read-line/newline)])
199                      (cond
200                        [(eof-object? lin)
201                          (error 'retrieve-test-config "unexpected EOF")]
202                        [(string-match info-end-re lin)
203                          (find-loop linlst)]
204                        [else
205                          (get-loop (cons lin linlst))])))]
206                [else
207                  (find-loop linlst)]))))) ) ) )
208
209(define (merge-test-config major-tbl major-lst)
210  (let major-loop ([major-lst major-lst])
211    (if (null? major-lst)
212      major-tbl
213      (let ([major-elm (car major-lst)])
214        (if (pair? major-elm)
215          (let ([minor-tbl (dict-update-dict! major-tbl (car major-elm))])
216            (let minor-loop ([minor-lst (cdr major-elm)])
217              (if (null? minor-lst)
218                (major-loop (cdr major-lst))
219                (let ([minor-elm (car minor-lst)])
220                  (if (pair? minor-elm)
221                    (begin
222                      (apply dict-update-list! minor-tbl minor-elm)
223                      (minor-loop (cdr minor-lst)) )
224                    (error 'merge-test-config "invalid minor element" minor-elm)) ) ) ) )
225          (error 'merge-test-config "invalid major element" major-elm)) ) ) ) )
226
227;;; Saving test results
228
229(define (append-results test-file minor-tbl knd rslts)
230  (print-verbose-message "Saving Test Results")
231  (unless *dry-run?*
232    (let ([optn-col
233          (lambda (dict-key #!optional (result-key dict-key))
234            (let ([itm (dict-ref minor-tbl dict-key)])
235              (if itm `((,result-key . ,itm)) '()) ) )])
236      (append-test-results-row
237        (pathname-file test-file)
238        (apply make-test-results-row knd rslts
239          `((mode . ,*results-mode*)
240            ,@(optn-col 'purpose)
241            ,@(optn-col 'feature)))
242        (apply make-test-results-row-header
243          `(,@(optn-col 'reader-extension 'extension) ; MUST be before setup!
244            ,@(optn-col 'reader-setup 'setup)))) ) ) )
245
246(define (remove-results rslts test-names)
247  (if test-names
248    (begin
249      (apply print-verbose-message "Removing Some Test Results" test-names)
250      (if *dry-run?*
251        rslts
252        (test-results-remove! rslts test-names) ) )
253    rslts) )
254
255(define (failure-results rslts)
256  (if *dry-run?*
257    '()
258    (let ([failures (test-results-failures rslts)])
259      (when (not-null? failures)
260        (print-message "Some Tests Failed")
261        (apply print-verbose-message failures) )
262      failures ) ) )
263
264(define (save-test-results test-file minor-tbl knd rslts)
265  (let* ([rslts (remove-results rslts (dict-ref minor-tbl 'ignore))]
266         [frslts (failure-results rslts)])
267    (unless (eq? 'none *results-mode*)
268      (append-results test-file minor-tbl knd
269        (if (eq? 'errors *results-mode*) frslts rslts)) ) ) )
270
271;;; Running test models
272
273(define (make-temp-file extn)
274  (if *dry-run?*
275    (make-pathname #f "TEMPORARY" extn)
276    (create-temporary-file extn)) )
277
278(define (read-test-results port)
279  (print-verbose-message "Acquiring Test Results")
280  (let ([rslts '()])
281    (let ([actual
282            (handle-condition
283              (lambda ()
284                (let loop ()
285                  (let ([obj (read port)])
286                    (if (eof-object? obj)
287                      rslts
288                      (begin
289                        (set! rslts (cons obj rslts))
290                        (loop)))))))])
291      (when (condition? actual)
292        (print-exception-error actual 1)
293        ; Must read all of the port so it can be closed
294        (read-all port))
295      (reverse! rslts) ) ) )
296
297(define (drive-test-process cmd args frms dir)
298  (let ([frms (or frms '())]
299        [rslts '()]
300        [errstr ""])
301    ; Enable saving of expectation test result value fields?
302    (when *expectation-specifics?*
303      ; Must come first
304      (set! frms
305        (cons
306          '(test::for-each
307             (lambda (x)
308               (test::set-echo-option! x 'include-expectation-specifics #t)))
309          frms)) )
310    ; Test(s) invocation must come last
311    (set! frms (append frms '((test::run))))
312    ; Change to test directory, if necessary
313    (when dir
314      (print-verbose-message "In" dir)
315      (change-directory dir) )
316    ; State what we would send as setup phase
317    (when *dry-run?*
318      (output-objects "Performing Setup" frms #f) )
319    ; Drive the test
320    (run-process cmd (append args '("-i"))
321      (lambda (in out pid err)
322        ; Tell the test what to do
323        (output-objects "Performing Setup" frms out)
324        ; Done telling
325        (close-output-port out)
326        ; Get everything from stdin
327        (set! rslts (read-test-results in))
328        ; Just in case
329        (set! errstr (read-all err)) )
330      (lambda (ecode)
331        (when ecode
332          (print-error errstr)
333          (set! rslts
334            (append! rslts
335              (list (make-test-abnormal-exit-result ecode errstr)))))))
336    rslts ) )
337
338(define (compile-test-file cmd args dir)
339  (let ([out-flnm (cadr (member "-o" args))]
340        [instr ""]
341        [errstr ""]
342        [out-err #f])
343    #+windows
344    (when dir
345      (print-verbose-message "In" dir)
346      (change-directory dir) )
347    ; Compile the test file source
348    (run-process cmd (append *default-compile-options* args)
349      (lambda (in out pid err)
350        (set! instr (read-all in))
351        (set! errstr (read-all err)) )
352      (lambda (ecode)
353        (when ecode
354          (print-message instr)
355          (print-message errstr)
356          ; Indicate compile failure for next phase
357          (set! out-flnm #f)
358          (set! out-err (cons ecode (conc instr #\newline errstr))))))
359    #+windows
360    (when dir
361      (change-directory *initial-directory*) )
362    ; Success or failure result
363    (or out-flnm out-err) ) )
364
365(define (run-compiled-test cmd args frms dir)
366  (let ([res (compile-test-file cmd args dir)])
367    (if (pathname? res)
368      (drive-test-process res '() frms dir)
369      (list (make-test-abnormal-exit-result (car res) (cdr res)))) ) )
370
371(define (run-interpreted-test cmd args frms dir)
372  (drive-test-process
373    cmd (append *default-interpret-options* args '("--")) frms dir) )
374
375(define (make-compile-arguments test-file minor-tbl)
376  ; User specified options?
377  (let ([arglst (or (dict-ref minor-tbl 'option) '())])
378    ; User specified compiler extensions?
379    (and-let* ([exts (dict-ref minor-tbl 'extend)])
380      (let ([flnm (make-temp-file "ext")])
381        (if *dry-run?*
382          (output-objects "Performing Compiler Extend" exts #f)
383          (call-with-output-file flnm
384            (lambda (port)
385              (output-objects "Performing Compiler Extend" exts port))))
386        (add-cleanup-object minor-tbl
387          (lambda () (delete-file* flnm)))
388        (set! arglst (cons "-X" (cons flnm arglst))) ) )
389    ; The executable file
390    (let ([flnm (make-temp-file "out")])
391      (set! arglst (cons "-o" (cons flnm arglst)))
392      (add-cleanup-object minor-tbl
393        (lambda () (delete-file* flnm))) )
394    ; Add file to compile
395    (cons test-file arglst) ) )
396
397(define (make-interpret-arguments test-file minor-tbl)
398  ; User specified options?
399  (let ([arglst (or (dict-ref minor-tbl 'option) '())])
400    ; Add file to interpret
401    (cons "-s" (cons test-file arglst)) ) )
402
403(define (canonicalize-option minor-tbl)
404  (and-let* ([val (dict-ref minor-tbl 'option)])
405    (dict-set! minor-tbl 'option (map ->string val)) ) )
406
407(define (merge-table-list-items to-tbl from-tbl #!key (except-keys '()))
408  (dict-for-each from-tbl
409    (lambda (key val)
410      (unless (memq key except-keys)
411        (and-let* ([objs (dict-ref from-tbl key)])
412          (apply dict-update-list! to-tbl key objs))))) )
413
414(define (configure-test-model minor-tbl test-tbl knd defcmd)
415  ; Merge from test table
416  (unless (dict-ref minor-tbl 'directory)
417    (and-let* ([dir (dict-ref test-tbl 'directory)])
418      (dict-set! minor-tbl 'directory dir) ) )
419  ; Merge list items from test table (except the single valued)
420  (merge-table-list-items minor-tbl test-tbl
421    #:except-keys '(interpret compile directory))
422  ; Any user specified skips?
423  (setup-skips minor-tbl)
424  ; Can only have string arguments for process
425  (canonicalize-option minor-tbl)
426  ; Must have a command to execute
427  (unless (dict-ref minor-tbl 'command)
428    (dict-set! minor-tbl 'command defcmd) ) )
429
430(define (run-test-model test-file minor-tbl knd makargs runtst)
431  ; Any test results reader extension?
432  (and-let* ([syms (dict-ref minor-tbl 'reader-extension)])
433    (print-verbose-message "Performing Reader Extension")
434    (for-each (cut print-indented-verbose-message 2 <>) syms)
435    (unless *dry-run?* (load-test-results-reader-extension syms) ) )
436  ; Any test results reader setup?
437  (and-let* ([forms (dict-ref minor-tbl 'reader-setup)])
438    (print-verbose-message "Performing Reader Setup")
439    (for-each (cut print-indented-verbose-message 2 <>) forms)
440    (unless *dry-run?* (test-results-reader-setup forms) ) )
441  ; Startup actions
442  (perform-startup minor-tbl)
443  ; Run the test, using the execution model.
444  (let ([rslts
445          (runtst
446            (dict-ref minor-tbl 'command)
447            (makargs
448              (cond-expand
449                [windows (pathname-strip-directory test-file)]
450                [else test-file])
451              minor-tbl)
452            (dict-ref minor-tbl 'setup)
453            (dict-ref minor-tbl 'directory))])
454    ; Cleanup actions
455    (perform-cleanup minor-tbl)
456    ; Save test results to database
457    (when rslts
458      (save-test-results test-file minor-tbl knd rslts) ) ) )
459
460(define (configure-test test-file major-tbl)
461  ; When testing must have a test table
462  (let ([test-tbl (dict-update-dict! major-tbl 'test)])
463    ; Unless otherwise stated use the directory where the test-file
464    ; resides as the test directory
465    (unless (dict-ref test-tbl 'directory)
466      (dict-set! test-tbl 'directory (pathname-directory test-file)) )
467    ; Unless specific test execution model
468    ; perform all models
469    (unless (or (dict-ref test-tbl 'compile)
470                (dict-ref test-tbl 'interpret))
471      (dict-set! test-tbl 'compile #t)
472      (dict-set! test-tbl 'interpret #t) ) ) )
473
474(define (perform-test-model test-file major-tbl knd defcmd makargs runtst)
475  ; Only perform when testing
476  (and-let* ([test-tbl (dict-ref major-tbl 'test)])
477    ; Only perform when execution model specified
478    (when (dict-ref test-tbl knd)
479      ; Must have a table
480      (let ([minor-tbl (dict-update-dict! major-tbl knd)])
481        (configure-test-model minor-tbl test-tbl knd defcmd)
482        (run-test-model test-file minor-tbl knd makargs runtst) ) ) ) )
483
484(define (run-test test-file major-tbl)
485  ;
486  (print-message "Running" (pathname-file test-file) "in" (pathname-directory test-file))
487  ; Merge any configuration from test-file
488  (let ([config (retrieve-test-config test-file)])
489    (when (not-null? config)
490      (merge-test-config major-tbl config)
491      (dict-set! major-tbl 'has-configuration #t) ) )
492  ; Only testbase tests for now
493  (dict-set! major-tbl 'is-testbase #t)
494  ; Configure test section
495  (configure-test test-file major-tbl)
496  ; Conditionally run test execution models
497  (perform-test-model test-file major-tbl 'compile
498    *compiler-command* make-compile-arguments
499    run-compiled-test)
500  (perform-test-model test-file major-tbl 'interpret
501    *interpreter-command* make-interpret-arguments
502    run-interpreted-test)
503  ; Restore wd, could have be changed for test run
504  (change-directory *initial-directory*) )
505
506;;; Command Line Argument Processing
507
508(define (usage)
509  (print "Usage: " (car (argv)) " [options...] test-file")
510  (newline)
511  (print (parameterize ([args:width 38]) (args:usage options)))
512  (print* " test-file" "  ")
513  (print "Pathname of test file; missing directory and extension components default to")
514  (print* "          " "  ")
515  (print #\" (test-files-directory) #\" " and " #\" (default-test-file-extension) #\" ".")
516  (newline)
517  (print "Report bugs to klovett at pacbell.net") )
518
519(define (usage-error msg)
520  (with-output-to-port (current-error-port)
521    (lambda ()
522      (display "Error: " )
523      (display msg)
524      (newline)
525      (usage)))
526  (exit 1) )
527
528(define (option-usage-error name msg arg)
529  (usage-error (sprintf "option '~A' - ~A: ~A" name msg arg)) )
530
531(define options `(
532
533  ,(args:make-option (indent) (#:required "INTEGER")
534    (conc "Amount to indent messages [default: " *message-indent* "]" ) )
535
536  ,(args:make-option (test-compile) #:none
537    "Run compiled test" )
538
539  ,(args:make-option (compiler) (#:required "PATHNAME")
540    "Compiler command pathname" )
541
542  ,(args:make-option (compiler-option) (#:required "OPTION(S)")
543    "Option(s) for the compiler" )
544
545  ,(args:make-option (compiler-extend) (#:required "FORM(S)")
546    "Form(s) for compiler to load before compiling" )
547
548  ,(args:make-option (test-interpret) #:none
549    "Run interpreted test" )
550
551  ,(args:make-option (interpreter) (#:required "PATHNAME")
552    "Interpreter command pathname" )
553
554  ,(args:make-option (interpreter-option) (#:required "OPTION(S)")
555    "Option(s) for the interpreter" )
556
557  ,(args:make-option (test-ignore) (#:required "TESTNAME")
558    "Ignore the result(s) for the specified test" )
559
560  ,(args:make-option (test-skip) (#:required "TESTNAME")
561    "Skip the specified test" )
562
563  ,(args:make-option (test-directory) (#:required "PATHNAME")
564    "Directory in which to run the test" )
565
566  ,(args:make-option (test-setup) (#:required "FORM(S)")
567    "Form(s) to pass on to the running test" )
568
569  ,(args:make-option (test-reader-extension) (#:required "ID(S)")
570    "Module(s) for test results reader to load before reading" )
571
572  ,(args:make-option (files-repository) (#:required "PATHNAME")
573    (conc "Directory where test files are stored [default: " (test-files-directory) "]") )
574
575  ,(args:make-option (results-repository) (#:required "DIRECTORY")
576    (conc "Directory where test results are stored [default: " (test-results-directory) "]") )
577
578  ,(args:make-option (results-expectation-specifics) #:none
579    (conc "Enable inclusion of the actual values for expectation test results") )
580
581  ,(args:make-option (results-mode) (#:required "all|errors|none")
582    (conc "How are test results stored [default: " *results-mode* "]") )
583
584  ,(args:make-option (q quiet) #:none
585    "Do not print messages" )
586
587  ,(args:make-option (v verbose) #:none
588    "Print phase messages" )
589
590  ,(args:make-option (n dry-run) #:none
591    "Just show commands to be executed, don't run them" )
592
593  ,(args:make-option (V version) #:none
594    "Display version"
595    (print TESTBASE-DRIVER-VERSION)
596    (exit) )
597
598  ,(args:make-option (h help) #:none
599    "Display this text"
600    (usage)
601    (exit)) ) )
602
603(define (option->list str)
604  (with-input-from-string str
605    (lambda () (read-file (current-input-port)))) )
606
607(define-macro (option-set! VAR NAME #!optional (EXPR '(or optval #t)))
608  `(let ([optval (alist-ref ',NAME opts eq? (void))])
609    (unless (eq? optval (void))
610      (set! ,VAR ,EXPR) ) ) )
611
612(define-macro (list-option-set! VAR NAME EXPR)
613  `(option-set! ,VAR ,NAME (cons ,EXPR ,VAR)) )
614
615(define-macro (tagged-alist-option-set! VAR NAME TAG KEY #!optional (FUNC 'identity))
616  `(list-option-set! ,VAR ,NAME (list ,TAG (list ,KEY (,FUNC (or optval #t))))) )
617
618(define (absolute-pathname-parameter-option-set! prm key opts)
619  (and-let* ([dir (alist-ref key opts eq?)])
620    (if (absolute-pathname? dir)
621      (prm dir)
622      (option-usage-error key "pathname must be absolute" dir)) ) )
623
624(define (extend-test-file-table tbl major-lst flnms)
625  (for-each
626    (lambda (flnm)
627      (and-let* ([dir (pathname-directory flnm)])
628        (unless (absolute-pathname? dir)
629          (option-usage-error 'test-file
630            "directory must be absolute" flnm) ) )
631      (merge-test-config
632        (dict-update-dict! tbl (make-test-file-pathname flnm))
633        major-lst))
634    flnms) )
635
636(define (process-options arglst tbl)
637  (receive [opts oprs] (args:parse arglst options)
638    (let ([lst '()])
639      (and-let* ([amt (alist-ref 'indent opts eq?)]
640                 [int (string->number amt)])
641        (unless (and (integer? int) (<= 0 int 32))
642          (usage-error (conc "invalid indent" #\; #\space amt)))
643        (set! *message-indent* int) )
644      (option-set! *quiet?* quiet)
645      (option-set! *verbose?* verbose)
646      (option-set! *dry-run?* dry-run)
647      (option-set! *expectation-specifics?* results-expectation-specifics)
648      (and-let* ([md (alist-ref 'results-mode opts eq?)])
649        (set! *results-mode* (string->symbol md))
650        (unless (memq *results-mode* '(all errors none))
651          (usage-error (conc "invalid results mode" #\; #\space *results-mode*)) ) )
652      (absolute-pathname-parameter-option-set! test-results-directory 'results-repository opts)
653      (absolute-pathname-parameter-option-set! test-files-directory 'files-repository opts)
654      (tagged-alist-option-set! lst compiler-option 'compile 'option option->list)
655      (tagged-alist-option-set! lst compiler 'compile 'command)
656      (tagged-alist-option-set! lst compiler-extend 'compile 'extend option->list)
657      (tagged-alist-option-set! lst interpreter-option 'interpret 'option option->list)
658      (tagged-alist-option-set! lst interpreter 'interpret 'command)
659      (tagged-alist-option-set! lst test-ignore 'test 'ignore option->list)
660      (tagged-alist-option-set! lst test-skip 'test 'skip option->list)
661      (tagged-alist-option-set! lst test-setup 'test 'setup option->list)
662      (tagged-alist-option-set! lst test-compile 'test 'compile)
663      (tagged-alist-option-set! lst test-interpret 'test 'interpret)
664      (tagged-alist-option-set! lst test-directory 'test 'directory)
665      (tagged-alist-option-set! lst test-reader-extension 'test 'reader-extension option->list)
666      (if (pair? oprs)
667        (extend-test-file-table tbl lst oprs)
668        (usage-error "missing test-file") ) ) ) )
669
670;; Skip over csi options, if necessary
671
672(define (preprocess-options)
673  (let ([args (command-line-arguments)])
674    (when (memq #:csi (features))
675      (and-let* ([rest (member "--" args)])
676        (set! args (cdr args))))
677    args ) )
678
679;;; Main
680
681(process-options (preprocess-options) *test-file-table*)
682(dict-for-each *test-file-table* run-test)
Note: See TracBrowser for help on using the repository browser.