Changeset 9503 in project


Ignore:
Timestamp:
03/12/08 01:07:18 (12 years ago)
Author:
Kon Lovett
Message:

Copy of rel/3 branch - hope this works.

Location:
release/2/testbase-driver
Files:
1 deleted
3 edited

Legend:

Unmodified
Added
Removed
  • release/2/testbase-driver/testbase-driver.meta

    r9367 r9503  
    1010 (files
    1111  "setup-header.scm"
    12   "testbase-driver-version.scm"
    1312  "testbase-driver.setup"
    1413  "testbase-driver.scm"))
  • release/2/testbase-driver/testbase-driver.scm

    r8751 r9503  
    1414;; - Only works with testbase test-files.
    1515
    16 (use srfi-1 extras regex utils posix)
    17 (use srfi-37 args miscmacros lookup-table misc-extn-list misc-extn-posix misc-extn-condition)
    18 (use testbase-results)
    19 
    2016(eval-when (compile)
    2117  (declare
     
    2420    (fixnum)
    2521    (unused
    26       add-startup-object) ) )
     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)
    2728
    2829;;;
    2930
    30 (include "testbase-driver-version")
    31 
    3231(define pathname? string?)
    3332
    3433;;; Constants & Other Global Data
     34
     35(define-constant TESTBASE-DRIVER-VERSION "1.1.1")
    3536
    3637(define-constant STD-COMPILER "csc")
     
    4041(define-constant STD-INTERPRET-OPTIONS '("-n"))
    4142
    42 (define *compiler-command* (which-command-directory STD-COMPILER))
     43(define *compiler-command* (which-command-pathname STD-COMPILER))
    4344(define *default-compile-options* STD-COMPILE-OPTIONS)
    4445
    45 (define *interpreter-command* (which-command-directory STD-INTERPRETER))
     46(define *interpreter-command* (which-command-pathname STD-INTERPRETER))
    4647(define *default-interpret-options* STD-INTERPRET-OPTIONS)
    4748
     
    5657(define *results-mode* 'errors)
    5758
    58 (define *expectation-specifics?* #f)
    59 
    6059(define *initial-directory* (current-directory)) ; Save wd so we can set it back
    6160
     61(define-constant MAXIMUM-INDENT 32)
     62
     63(define-constant BASIC-INDENT 2)
     64
    6265;;; Printing messages
    6366
     
    6568
    6669(define (print-indent #!optional (amt *message-indent*))
    67   (do ([n amt (sub1 n)]) [(zero? n)] (display #\space) )
     70  (do ([n amt (sub1 n)]) [(zero? n)] (display #\space))
    6871  (flush-output) )
    6972
     
    8588
    8689(define (print-error . objs)
    87   (print-error-message
    88     (apply conc (intersperse objs #\space))
    89     (current-error-port)) )
     90  (print-error-message (apply conc (intersperse objs #\space)) (current-error-port)) )
    9091
    9192(define (print-exception-error cnd #!optional (start 0))
    92   (let ([err (current-error-port)])
    93     (print-error-message cnd err)
     93  ; +1 call-chain-start
     94  (let ([err (current-error-port)]) ; +1 call-chain-start
     95    (print-error-message cnd err)   ; +1 call-chain-start
     96    ; +1 call-chain-start
    9497    (print-call-chain err (+ 4 start)) ) )
    9598
     
    100103  (for-each
    101104    (lambda (obj)
    102       (print-indented-verbose-message 2 obj)
     105      (print-indented-verbose-message BASIC-INDENT obj)
    103106      (unless *dry-run?*
    104         (cond
    105           [(string? obj)  (display obj port)]
    106           [else           (write obj port)])
     107        (cond [(string? obj)  (display obj port)]
     108              [else           (write obj port)])
    107109        ; For any possible REPL
    108110        (newline port) ) )
    109111    objs) )
    110112
    111 (define (setup-skips minor-tbl)
    112   (and-let* ([skips (dict-ref minor-tbl 'skip)])
     113(define (setup-skips model-tbl)
     114  (and-let* ([skips (dict-ref model-tbl 'skip)])
    113115    (let loop ([lst '()] [skips skips])
    114       (cond
    115         [(null? skips)
    116           (unless (null? lst)
    117             (dict-update-list! minor-tbl 'setup `(begin ,@lst)))]
    118         [(pair? skips)
    119           (let ([skip (car skips)])
    120             (if (pair? skip)
    121               (loop (cons `(test::select 'skip ,@skip) lst) (cdr skips))
    122               (error 'setup-skips "invalid skip specification" skips)) )]
    123         [else
    124           (error 'setup-skips "invalid skip specification" skips)]) ) ) )
     116      (cond [(null? skips)
     117              (unless (null? lst)
     118                (dict-update-list! model-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)]) ) ) )
    125126
    126127;;; Simplified process* (Any non-zero exit code is an error!)
     
    135136          (when extcod
    136137            (print-error "abnormal process exit:" extcod))
    137           (eproc extcod))))) )
     138          (eproc extcod) ) ) ) ) )
    138139
    139140;;; Performing task list
     
    141142(define (perform-list loc objs)
    142143  (for-each
    143     (lambda (obj)
    144       (print-indented-verbose-message 2 obj)
    145       (unless *dry-run?*
    146         (cond
    147           [(procedure? obj)   (obj)]
    148           [(pair? obj)        (eval obj)]
    149           [(string? obj)      (eval (with-input-from-string obj read))]
    150           [else
    151             (error loc "invalid perform object" obj)]) ) )
    152     objs) )
    153 
    154 (define (perform-list-kind minor-tbl knd msg)
    155   (and-let* ([objs (dict-ref minor-tbl knd)])
     144   (lambda (obj)
     145     (print-indented-verbose-message BASIC-INDENT obj)
     146     (unless *dry-run?*
     147       (cond [(procedure? obj)   (obj)]
     148             [(pair? obj)        (eval obj)]
     149             [(string? obj)      (eval (with-input-from-string obj read))]
     150             [else
     151               (error loc "invalid perform object" obj)]) ) )
     152   objs) )
     153
     154(define (perform-list-kind model-tbl knd msg)
     155  (and-let* ([objs (dict-ref model-tbl knd)])
    156156    (print-verbose-message "Performing" msg)
    157157    (perform-list knd objs) ) )
    158158
    159 (define (perform-startup minor-tbl)
    160   (perform-list-kind minor-tbl 'startup "Startup") )
    161 
    162 (define (perform-cleanup minor-tbl)
    163   (perform-list-kind minor-tbl 'cleanup "Cleanup") )
    164 
    165 (define (add-cleanup-object minor-tbl proc)
    166   (dict-update-list! minor-tbl 'cleanup proc) )
    167 
    168 (define (add-startup-object minor-tbl proc)
    169   (dict-update-list! minor-tbl 'startup proc) )
     159(define (perform-startup model-tbl)
     160  (perform-list-kind model-tbl 'startup "Startup") )
     161
     162(define (perform-cleanup model-tbl)
     163  (perform-list-kind model-tbl 'cleanup "Cleanup") )
     164
     165(define (add-cleanup-object model-tbl proc)
     166  (dict-update-list! model-tbl 'cleanup proc) )
     167
     168(define (add-startup-object model-tbl proc)
     169  (dict-update-list! model-tbl 'startup proc) )
    170170
    171171;;; TestBase configuration support
     
    179179            (let ([lin (read-line)])
    180180              (if (eof-object? lin)
    181                 lin
    182                 (conc lin #\newline)) ) )])
     181                  lin
     182                  (conc lin #\newline)) ) ) ] )
    183183    (lambda (test-file)
    184184      (with-input-from-file test-file
     
    187187          (let find-loop ([linlst '()])
    188188            (let ([lin (read-line/newline)])
    189               (cond
    190                 [(eof-object? lin)
    191                   ; Convert configuration section into s-exprs
    192                   (with-input-from-string
    193                     (apply string-append (reverse! linlst))
    194                     (lambda () (port-map identity read)))]
    195                 [(string-match info-begin-re lin)
    196                   (let get-loop ([linlst linlst])
    197                     (let ([lin (read-line/newline)])
    198                       (cond
    199                         [(eof-object? lin)
    200                           (error 'retrieve-test-config "unexpected EOF")]
    201                         [(string-match info-end-re lin)
    202                           (find-loop linlst)]
    203                         [else
    204                           (get-loop (cons lin linlst))])))]
    205                 [else
    206                   (find-loop linlst)]))))) ) ) )
     189              (cond [(eof-object? lin)
     190                      ; Convert configuration section into s-exprs
     191                      (with-input-from-string
     192                        (apply string-append (reverse! linlst))
     193                        (lambda () (port-map identity read)))]
     194                    [(string-match info-begin-re lin)
     195                      (let get-loop ([linlst linlst])
     196                        (let ([lin (read-line/newline)])
     197                          (cond [(eof-object? lin)
     198                                  (error 'retrieve-test-config "unexpected EOF")]
     199                                [(string-match info-end-re lin)
     200                                  (find-loop linlst)]
     201                                [else
     202                                  (get-loop (cons lin linlst))])))]
     203                    [else
     204                      (find-loop linlst)]))))) ) ) )
    207205
    208206(define (merge-test-config major-tbl major-lst)
    209207  (let major-loop ([major-lst major-lst])
    210208    (if (null? major-lst)
    211       major-tbl
    212       (let ([major-elm (car major-lst)])
    213         (if (pair? major-elm)
    214           (let ([minor-tbl (dict-update-dict! major-tbl (car major-elm))])
    215             (let minor-loop ([minor-lst (cdr major-elm)])
    216               (if (null? minor-lst)
    217                 (major-loop (cdr major-lst))
    218                 (let ([minor-elm (car minor-lst)])
    219                   (if (pair? minor-elm)
    220                     (begin
    221                       (apply dict-update-list! minor-tbl minor-elm)
    222                       (minor-loop (cdr minor-lst)) )
    223                     (error 'merge-test-config "invalid minor element" minor-elm)) ) ) ) )
    224           (error 'merge-test-config "invalid major element" major-elm)) ) ) ) )
     209        major-tbl
     210        (let ([major-elm (car major-lst)])
     211          (if (pair? major-elm)
     212              (let ([minor-tbl (dict-update-dict! major-tbl (car major-elm))])
     213                (let minor-loop ([minor-lst (cdr major-elm)])
     214                  (if (null? minor-lst)
     215                      (major-loop (cdr major-lst))
     216                      (let ([minor-elm (car minor-lst)])
     217                        (if (pair? minor-elm)
     218                            (begin
     219                              (apply dict-update-list! minor-tbl minor-elm)
     220                              (minor-loop (cdr minor-lst)) )
     221                            (error 'merge-test-config "invalid minor element" minor-elm)) ) ) ) )
     222              (error 'merge-test-config "invalid major element" major-elm) ) ) ) ) )
    225223
    226224;;; Saving test results
    227225
    228 (define (append-results test-file minor-tbl knd rslts)
     226(define (save-results test-file model-tbl knd rslts)
    229227  (print-verbose-message "Saving Test Results")
    230228  (unless *dry-run?*
    231229    (let ([optn-col
    232230          (lambda (dict-key #!optional (result-key dict-key))
    233             (let ([itm (dict-ref minor-tbl dict-key)])
    234               (if itm `((,result-key . ,itm)) '()) ) )])
     231            (let ([itm (dict-ref model-tbl dict-key)])
     232              (if itm
     233                  `((,result-key . ,itm))
     234                  '()) ) )])
    235235      (append-test-results-row
    236         (pathname-file test-file)
    237         (apply make-test-results-row knd rslts
    238           `((mode . ,*results-mode*)
    239             ,@(optn-col 'purpose)
    240             ,@(optn-col 'feature)))
    241         (apply make-test-results-row-header
    242           `(,@(optn-col 'reader-extension 'extension) ; MUST be before setup!
    243             ,@(optn-col 'reader-setup 'setup)))) ) ) )
     236       (pathname-file test-file)
     237       (apply make-test-results-row knd
     238                                    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)))) ) ) )
    244245
    245246(define (remove-results rslts test-names)
    246247  (if test-names
    247     (begin
    248       (apply print-verbose-message "Removing Some Test Results" test-names)
    249       (if *dry-run?*
    250         rslts
    251         (test-results-remove! rslts test-names) ) )
    252     rslts) )
     248      (begin
     249        (apply print-verbose-message "Removing Some Test Results" test-names)
     250        (test-results-remove! rslts test-names) )
     251      rslts ) )
    253252
    254253(define (failure-results rslts)
    255   (if *dry-run?*
    256     '()
    257     (let ([failures (test-results-failures rslts)])
    258       (when (not-null? failures)
    259         (print-message "Some Tests Failed")
    260         (apply print-verbose-message failures) )
    261       failures ) ) )
    262 
    263 (define (save-test-results test-file minor-tbl knd rslts)
    264   (let* ([rslts (remove-results rslts (dict-ref minor-tbl 'ignore))]
    265          [frslts (failure-results rslts)])
    266     (unless (eq? 'none *results-mode*)
    267       (append-results test-file minor-tbl knd
    268         (if (eq? 'errors *results-mode*) frslts rslts)) ) ) )
     254  (let ([frslts (test-results-failures rslts)])
     255    (unless (null? frslts)
     256      (print-message "Some Tests Failed")
     257      (apply print-verbose-message frslts) )
     258    frslts ) )
    269259
    270260;;; Running test models
     
    272262(define (make-temp-file extn)
    273263  (if *dry-run?*
    274     (make-pathname #f "TEMPORARY" extn)
    275     (create-temporary-file extn)) )
     264      (make-pathname #f "<TEMPORARY>" extn)
     265      (create-temporary-file extn)) )
    276266
    277267(define (read-test-results port)
     
    284274                  (let ([obj (read port)])
    285275                    (if (eof-object? obj)
    286                       rslts
    287                       (begin
    288                         (set! rslts (cons obj rslts))
    289                         (loop)))))))])
     276                        rslts
     277                        (begin
     278                          (set! rslts (cons obj rslts))
     279                          (loop)))))))])
    290280      (when (condition? actual)
    291         (print-exception-error actual 1)
     281        (print-exception-error actual 1) ; +1 call-chain-start
    292282        ; Must read all of the port so it can be closed
    293283        (read-all port))
     
    295285
    296286(define (drive-test-process cmd args frms dir)
    297   (let ([frms (or frms '())]
    298         [rslts '()]
     287  ; Test(s) invocation must come last
     288  (set! frms (append frms '((test::run))))
     289  ; Change to test directory, if necessary
     290  (when dir
     291    (print-verbose-message "In" dir)
     292    (change-directory dir) )
     293  ; State what we would send as setup phase
     294  (when *dry-run?*
     295    (output-objects "Performing Setup" frms #f) )
     296  ; Drive the test
     297  (let ([rslts '()]
    299298        [errstr ""])
    300     ; Enable saving of expectation test result value fields?
    301     (when *expectation-specifics?*
    302       ; Must come first
    303       (set! frms
    304         (cons
    305           '(test::for-each
    306              (lambda (x)
    307                (test::set-echo-option! x 'include-expectation-specifics #t)))
    308           frms)) )
    309     ; Test(s) invocation must come last
    310     (set! frms (append frms '((test::run))))
    311     ; Change to test directory, if necessary
    312     (when dir
    313       (print-verbose-message "In" dir)
    314       (change-directory dir) )
    315     ; State what we would send as setup phase
    316     (when *dry-run?*
    317       (output-objects "Performing Setup" frms #f) )
    318     ; Drive the test
    319     (run-process cmd (append args '("-i"))
    320       (lambda (in out pid err)
    321         ; Tell the test what to do
    322         (output-objects "Performing Setup" frms out)
    323         ; Done telling
    324         (close-output-port out)
    325         ; Get everything from stdin
    326         (set! rslts (read-test-results in))
    327         ; Just in case
    328         (set! errstr (read-all err)) )
    329       (lambda (ecode)
    330         (when ecode
    331           (print-error errstr)
    332           (set! rslts
    333             (append! rslts
    334               (list (make-test-abnormal-exit-result ecode errstr)))))))
    335     rslts ) )
     299      (run-process
     300       cmd
     301       (append args '("-i"))
     302       (lambda (in out pid err)
     303         ; Tell the test what to do
     304         (output-objects "Performing Setup" frms out)
     305         ; Done telling
     306         (close-output-port out)
     307         ; Get everything from stdin
     308         (set! rslts (read-test-results in))
     309         ; Just in case
     310         (set! errstr (read-all err)) )
     311       (lambda (ecode)
     312         (when ecode
     313           (print-error errstr)
     314           (set! rslts
     315                 (append! rslts (list (make-test-abnormal-exit-result ecode errstr)))))))
     316      ; Test results
     317      rslts ) )
    336318
    337319(define (compile-test-file cmd args dir)
     
    340322        [errstr ""]
    341323        [out-err #f])
     324    ;XXX Due to no-spaces-in-windows-command-name bug
    342325    #+windows
    343326    (when dir
    344       (print-verbose-message "In" dir)
    345       (change-directory dir) )
     327      (change-directory dir)
     328      (print-verbose-message "In" dir) )
    346329    ; Compile the test file source
    347330    (run-process cmd (append *default-compile-options* args)
     
    356339          (set! out-flnm #f)
    357340          (set! out-err (cons ecode (conc instr #\newline errstr))))))
     341    ;XXX Due to no-spaces-in-windows-command-name bug
    358342    #+windows
    359343    (when dir
     
    365349  (let ([res (compile-test-file cmd args dir)])
    366350    (if (pathname? res)
    367       (drive-test-process res '() frms dir)
    368       (list (make-test-abnormal-exit-result (car res) (cdr res)))) ) )
     351        (drive-test-process res '() frms dir)
     352        (list (make-test-abnormal-exit-result (car res) (cdr res)))) ) )
    369353
    370354(define (run-interpreted-test cmd args frms dir)
    371   (drive-test-process
    372     cmd (append *default-interpret-options* args '("--")) frms dir) )
    373 
    374 (define (make-compile-arguments test-file minor-tbl)
     355  (drive-test-process cmd (append *default-interpret-options* args '("--")) frms dir) )
     356
     357(define (make-compile-arguments test-file model-tbl)
    375358  ; User specified options?
    376   (let ([arglst (or (dict-ref minor-tbl 'option) '())])
     359  (let ([arglst (or (dict-ref model-tbl 'option) '())])
    377360    ; User specified compiler extensions?
    378     (and-let* ([exts (dict-ref minor-tbl 'extend)])
     361    (and-let* ([exts (dict-ref model-tbl 'extend)])
    379362      (let ([flnm (make-temp-file "ext")])
    380363        (if *dry-run?*
    381           (output-objects "Performing Compiler Extend" exts #f)
    382           (call-with-output-file flnm
    383             (lambda (port)
    384               (output-objects "Performing Compiler Extend" exts port))))
    385         (add-cleanup-object minor-tbl
    386           (lambda () (delete-file* flnm)))
     364            (output-objects "Performing Compiler Extend" exts #f)
     365            (call-with-output-file flnm
     366                                   (lambda (port)
     367                                     (output-objects "Performing Compiler Extend" exts port))))
     368        (add-cleanup-object model-tbl (lambda () (delete-file* flnm)))
    387369        (set! arglst (cons "-X" (cons flnm arglst))) ) )
    388370    ; The executable file
    389371    (let ([flnm (make-temp-file "out")])
    390372      (set! arglst (cons "-o" (cons flnm arglst)))
    391       (add-cleanup-object minor-tbl
    392         (lambda () (delete-file* flnm))) )
     373      (add-cleanup-object model-tbl (lambda () (delete-file* flnm))) )
    393374    ; Add file to compile
    394375    (cons test-file arglst) ) )
    395376
    396 (define (make-interpret-arguments test-file minor-tbl)
     377(define (make-interpret-arguments test-file model-tbl)
    397378  ; User specified options?
    398   (let ([arglst (or (dict-ref minor-tbl 'option) '())])
     379  (let ([arglst (or (dict-ref model-tbl 'option) '())])
    399380    ; Add file to interpret
    400381    (cons "-s" (cons test-file arglst)) ) )
    401382
    402 (define (canonicalize-option minor-tbl)
    403   (and-let* ([val (dict-ref minor-tbl 'option)])
    404     (dict-set! minor-tbl 'option (map ->string val)) ) )
    405 
    406 (define (merge-table-list-items to-tbl from-tbl #!key (except-keys '()))
     383(define (canonicalize-option model-tbl)
     384  (and-let* ([val (dict-ref model-tbl 'option)])
     385    (dict-set! model-tbl 'option (map ->string val)) ) )
     386
     387(define (merge-table-list-items to-tbl from-tbl except-keys)
    407388  (dict-for-each from-tbl
    408     (lambda (key val)
    409       (unless (memq key except-keys)
    410         (and-let* ([objs (dict-ref from-tbl key)])
    411           (apply dict-update-list! to-tbl key objs))))) )
    412 
    413 (define (configure-test-model minor-tbl test-tbl knd defcmd)
    414   ; Merge from test table
    415   (unless (dict-ref minor-tbl 'directory)
     389                 (lambda (key val)
     390                   (unless (memq key except-keys)
     391                     (and-let* ([objs (dict-ref from-tbl key)])
     392                       (apply dict-update-list! to-tbl key objs))))) )
     393
     394(define (configure-test-model model-tbl test-tbl knd defcmd)
     395  ; Merge directory from test table, unless already specified
     396  (unless (dict-ref model-tbl 'directory)
    416397    (and-let* ([dir (dict-ref test-tbl 'directory)])
    417       (dict-set! minor-tbl 'directory dir) ) )
     398      (dict-set! model-tbl 'directory dir) ) )
     399  ; Early exit?
     400  (and-let* ([cod (dict-ref test-tbl 'failure-exit)])
     401    (dict-set! model-tbl 'failure-exit cod) )
    418402  ; Merge list items from test table (except the single valued)
    419   (merge-table-list-items minor-tbl test-tbl
    420     #:except-keys '(interpret compile directory))
     403  (merge-table-list-items model-tbl test-tbl '(interpret compile directory failure-exit))
    421404  ; Any user specified skips?
    422   (setup-skips minor-tbl)
     405  (setup-skips model-tbl)
     406  ; Including result values?
     407  (and-let* ([(dict-ref test-tbl 'expectation-specifics)])
     408    (dict-update-list! model-tbl 'setup
     409                       '(test::for-each
     410                         (lambda (x)
     411                           (test::set-echo-option! x 'include-expectation-specifics #t)))) )
    423412  ; Can only have string arguments for process
    424   (canonicalize-option minor-tbl)
     413  (canonicalize-option model-tbl)
    425414  ; Must have a command to execute
    426   (unless (dict-ref minor-tbl 'command)
    427     (dict-set! minor-tbl 'command defcmd) ) )
    428 
    429 (define (run-test-model test-file minor-tbl knd makargs runtst)
     415  (unless (dict-ref model-tbl 'command)
     416    (dict-set! model-tbl 'command defcmd) ) )
     417
     418(define (run-test-model test-file model-tbl knd makargs runtst)
    430419  ; Any test results reader extension?
    431   (and-let* ([syms (dict-ref minor-tbl 'reader-extension)])
     420  (and-let* ([syms (dict-ref model-tbl 'reader-extension)])
    432421    (print-verbose-message "Performing Reader Extension")
    433     (for-each (cut print-indented-verbose-message 2 <>) syms)
     422    (for-each (cut print-indented-verbose-message BASIC-INDENT <>) syms)
    434423    (unless *dry-run?* (load-test-results-reader-extension syms) ) )
    435424  ; Any test results reader setup?
    436   (and-let* ([forms (dict-ref minor-tbl 'reader-setup)])
     425  (and-let* ([forms (dict-ref model-tbl 'reader-setup)])
    437426    (print-verbose-message "Performing Reader Setup")
    438     (for-each (cut print-indented-verbose-message 2 <>) forms)
     427    (for-each (cut print-indented-verbose-message BASIC-INDENT <>) forms)
    439428    (unless *dry-run?* (test-results-reader-setup forms) ) )
    440429  ; Startup actions
    441   (perform-startup minor-tbl)
     430  (perform-startup model-tbl)
    442431  ; Run the test, using the execution model.
    443   (let ([rslts
    444           (runtst
    445             (dict-ref minor-tbl 'command)
    446             (makargs
    447               (cond-expand
    448                 [windows (pathname-strip-directory test-file)]
    449                 [else test-file])
    450               minor-tbl)
    451             (dict-ref minor-tbl 'setup)
    452             (dict-ref minor-tbl 'directory))])
     432  (let ([rslts (runtst (dict-ref model-tbl 'command)
     433                       (makargs (cond-expand
     434                                  ;XXX Due to no-spaces-in-windows-command-name bug
     435                                  [windows (pathname-strip-directory test-file)]
     436                                  [else    test-file])
     437                                model-tbl)
     438                       (or (dict-ref model-tbl 'setup) '())
     439                       (dict-ref model-tbl 'directory))])
    453440    ; Cleanup actions
    454     (perform-cleanup minor-tbl)
     441    (perform-cleanup model-tbl)
    455442    ; Save test results to database
    456     (when rslts
    457       (save-test-results test-file minor-tbl knd rslts) ) ) )
     443    (unless (eq? 'none *results-mode*)
     444      (when rslts
     445        (let* ([srslts (remove-results rslts (dict-ref model-tbl 'ignore))]
     446               [extcod (dict-ref model-tbl 'failure-exit)]
     447               [frslts (if (or (eq? 'errors *results-mode*) extcod)
     448                           (failure-results srslts)
     449                           '() ) ] )
     450          (save-results
     451           test-file model-tbl knd (if (eq? 'errors *results-mode*) frslts rslts))
     452          ; Early exit?
     453          (when (and extcod (not-null? frslts))
     454            (exit extcod) ) ) ) ) ) )
    458455
    459456(define (configure-test test-file major-tbl)
     
    464461    (unless (dict-ref test-tbl 'directory)
    465462      (dict-set! test-tbl 'directory (pathname-directory test-file)) )
    466     ; Unless specific test execution model
    467     ; perform all models
     463    ; Unless specific test execution model perform all models
    468464    (unless (or (dict-ref test-tbl 'compile)
    469465                (dict-ref test-tbl 'interpret))
     
    477473    (when (dict-ref test-tbl knd)
    478474      ; Must have a table
    479       (let ([minor-tbl (dict-update-dict! major-tbl knd)])
    480         (configure-test-model minor-tbl test-tbl knd defcmd)
    481         (run-test-model test-file minor-tbl knd makargs runtst) ) ) ) )
     475      (let ([model-tbl (dict-update-dict! major-tbl knd)])
     476        (configure-test-model model-tbl test-tbl knd defcmd)
     477        (run-test-model test-file model-tbl knd makargs runtst) ) ) ) )
    482478
    483479(define (run-test test-file major-tbl)
     
    493489  ; Configure test section
    494490  (configure-test test-file major-tbl)
    495   ; Conditionally run test execution models
     491  ; Conditionally run all test execution models
    496492  (perform-test-model test-file major-tbl 'compile
    497     *compiler-command* make-compile-arguments
    498     run-compiled-test)
     493                      *compiler-command* make-compile-arguments
     494                      run-compiled-test)
    499495  (perform-test-model test-file major-tbl 'interpret
    500     *interpreter-command* make-interpret-arguments
    501     run-interpreted-test)
     496                      *interpreter-command* make-interpret-arguments
     497                      run-interpreted-test)
    502498  ; Restore wd, could have be changed for test run
    503499  (change-directory *initial-directory*) )
     
    579575
    580576  ,(args:make-option (results-mode) (#:required "all|errors|none")
    581     (conc "How are test results stored [default: " *results-mode* "]") )
     577    (conc "Which test results are stored [default: " *results-mode* "]") )
     578
     579  ,(args:make-option (failure-exit) (#:required "CODE")
     580    "Exit upon failure with exit code" )
    582581
    583582  ,(args:make-option (q quiet) #:none
     
    601600
    602601(define (option->list str)
    603   (with-input-from-string str
    604     (lambda () (read-file (current-input-port)))) )
     602  (with-input-from-string str (lambda () (read-file (current-input-port)))) )
    605603
    606604(define-macro (option-set! VAR NAME #!optional (EXPR '(or optval #t)))
    607605  `(let ([optval (alist-ref ',NAME opts eq? (void))])
    608     (unless (eq? optval (void))
    609       (set! ,VAR ,EXPR) ) ) )
     606     (unless (eq? optval (void))
     607       (set! ,VAR ,EXPR) ) ) )
    610608
    611609(define-macro (list-option-set! VAR NAME EXPR)
     
    618616  (and-let* ([dir (alist-ref key opts eq?)])
    619617    (if (absolute-pathname? dir)
    620       (prm dir)
    621       (option-usage-error key "pathname must be absolute" dir)) ) )
     618        (prm dir)
     619        (option-usage-error key "pathname must be absolute" dir)) ) )
    622620
    623621(define (extend-test-file-table tbl major-lst flnms)
     
    626624      (and-let* ([dir (pathname-directory flnm)])
    627625        (unless (absolute-pathname? dir)
    628           (option-usage-error 'test-file
    629             "directory must be absolute" flnm) ) )
    630       (merge-test-config
    631         (dict-update-dict! tbl (make-test-file-pathname flnm))
    632         major-lst))
     626          (option-usage-error 'test-file "directory must be absolute" flnm) ) )
     627      (merge-test-config (dict-update-dict! tbl (make-test-file-pathname flnm)) major-lst))
    633628    flnms) )
    634629
     
    636631  (receive [opts oprs] (args:parse arglst options)
    637632    (let ([lst '()])
     633      ;
    638634      (and-let* ([amt (alist-ref 'indent opts eq?)]
    639635                 [int (string->number amt)])
    640         (unless (and (integer? int) (<= 0 int 32))
     636        (unless (and (integer? int) (<= 0 int MAXIMUM-INDENT))
    641637          (usage-error (conc "invalid indent" #\; #\space amt)))
    642638        (set! *message-indent* int) )
     
    644640      (option-set! *verbose?* verbose)
    645641      (option-set! *dry-run?* dry-run)
    646       (option-set! *expectation-specifics?* results-expectation-specifics)
    647642      (and-let* ([md (alist-ref 'results-mode opts eq?)])
    648643        (set! *results-mode* (string->symbol md))
     
    651646      (absolute-pathname-parameter-option-set! test-results-directory 'results-repository opts)
    652647      (absolute-pathname-parameter-option-set! test-files-directory 'files-repository opts)
     648      ;
    653649      (tagged-alist-option-set! lst compiler-option 'compile 'option option->list)
    654650      (tagged-alist-option-set! lst compiler 'compile 'command)
     
    663659      (tagged-alist-option-set! lst test-directory 'test 'directory)
    664660      (tagged-alist-option-set! lst test-reader-extension 'test 'reader-extension option->list)
     661      (tagged-alist-option-set! lst results-expectation-specifics 'test 'expectation-specifics)
     662      (tagged-alist-option-set! lst failure-exit 'test 'failure-exit
     663                                (lambda (str)
     664                                  (let ([cod (string->number str)])
     665                                    (unless (integer? cod)
     666                                      (usage-error (conc "invalid exit code" #\; #\space cod)) )
     667                                    cod)))
     668      ;
    665669      (if (pair? oprs)
    666         (extend-test-file-table tbl lst oprs)
    667         (usage-error "missing test-file") ) ) ) )
     670          (extend-test-file-table tbl lst oprs)
     671          (usage-error "missing test-file") ) ) ) )
    668672
    669673;; Skip over csi options, if necessary
  • release/2/testbase-driver/testbase-driver.setup

    r8751 r9503  
    55(required-extension-version
    66  'testbase-results       "1.1"
    7   'misc-extn              "3.0"
     7  'misc-extn              "3.1"
    88  'miscmacros             "2.4"
    99  'args                   "1.2"
     
    1111  'lookup-table           "1.5")
    1212
    13 (include "testbase-driver-version")
    14 
    1513(compile -block -check-imports testbase-driver.scm -o chicken-testbase-driver)
    1614
    1715(install-program 'testbase-driver
    1816        '("chicken-testbase-driver")
    19         `((version ,TESTBASE-DRIVER-VERSION)))
     17        `((version "1.2.0")))
Note: See TracChangeset for help on using the changeset viewer.