Changeset 9357 in project


Ignore:
Timestamp:
03/09/08 15:37:57 (13 years ago)
Author:
Kon Lovett
Message:

Save.

Location:
release/2/testbase
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/2/testbase/testbase-expects.scm

    r8751 r9357  
    2424
    2525(define (->boolean val)
    26   (and val #t)
    27   #;(not (not val)) )
     26  (and val
     27       #t) )
    2828
    2929(define-macro (expected VAL TEST)
    30   `(if (condition? ,VAL) ,VAL ,TEST) )
     30  `(if (condition? ,VAL)
     31        ,VAL
     32        (->boolean ,TEST) ) )
    3133
    3234(define (check-multiple-predicate-arguments1 args prds)
     
    5052
    5153(define (tb$true? obj)
    52         (and (boolean? obj) obj) )
     54        (and (boolean? obj)
     55             obj) )
    5356
    5457(define (tb$false? obj)
    55         (and (boolean? obj) (not obj)) )
     58        (and (boolean? obj)
     59             (not obj)) )
    5660
    5761;;;
     
    7175
    7276(define (tb$exptsucc val)
    73   (and (not (condition? val)) (->boolean val)) )
     77  (and (not (condition? val))
     78       (->boolean val)) )
    7479
    7580(define (tb$exptfail val)
    76   (or (condition? val) (not val)) )
     81  (or (condition? val)
     82      (not val)) )
    7783
    7884(define (tb$makmltprd1 prds)
  • release/2/testbase/testbase-proc.scm

    r8751 r9357  
    154154
    155155(define (->boolean obj)
    156   (and obj #t)
    157   #;(not (not obj)) )
     156  (and obj
     157       #t) )
    158158
    159159(define (length=2? obj)
     
    243243    (let ([lst (test-procedure-descriptors)])
    244244      (if (null? tplst)
    245         lst
    246         (filter!
    247           (cut test-procedure-descriptor-in-test-procedure-list? <> tplst)
    248           lst) ) ) ) )
     245          lst
     246          (filter!
     247            (cut test-procedure-descriptor-in-test-procedure-list? <> tplst)
     248            lst) ) ) ) )
    249249
    250250;; Only formal & actual test-procedures
     
    304304      (lambda (tpd)
    305305        (and (mbrlst? tpd)
    306              (cond
    307                [(test-procedure-descriptor-actual? tpd)  #t]
    308                [(test-procedure-descriptor-formal? tpd)  #f]
    309                [(test-procedure-actual-descriptor? tpd)  (mbrlst? tpd)])))
     306             (cond [(test-procedure-descriptor-actual? tpd)  #t]
     307                   [(test-procedure-descriptor-formal? tpd)  #f]
     308                   [(test-procedure-actual-descriptor? tpd)  (mbrlst? tpd)])))
    310309      (test-procedure-descriptor-immutable-list)) ) )
    311310
     
    509508            (test-procedure-descriptor-immutable-list)))])
    510509    (if (= (length args) (length (tb$state-argument-list state)))
    511       (let ([formal-name (tb$state-name state)])
    512         (if (tb$report-mode? state)
    513           (apply values formal-name args)
    514           (apply values
    515             (conc formal-name #\: #\space (or (actual-test-name) ""))
    516             args)) )
    517       (tb$errtstprcargs state args)) ) )
     510        (let ([formal-name (tb$state-name state)])
     511          (if (tb$report-mode? state)
     512              (apply values formal-name args)
     513              (apply values
     514                (conc formal-name #\: #\space (or (actual-test-name) ""))
     515                args)) )
     516        (tb$errtstprcargs state args)) ) )
    518517
    519518(define (tb$newtstprc loc tp . rest)
     
    521520    (let ([tpd (make-test-procedure-descriptor tp nam args)])
    522521      (if (test-procedure-actual-descriptor? tpd)
    523         (check-actual-has-formal tp nam loc)
    524         (begin
    525           (tb$state-procedure-set! (%test-procedure-state tp) tp)
    526           (check-unique-test-name tp loc)))
     522          (check-actual-has-formal tp nam loc)
     523          (begin
     524            (tb$state-procedure-set! (%test-procedure-state tp) tp)
     525            (check-unique-test-name tp loc)))
    527526      (add-test-procedure-descriptor tpd) ) ) )
    528527
     
    559558(define (test::declarations obj)
    560559  (let ([tp (checked-test-procedure-argument obj 'test::declarations)])
    561     (cond
    562       [(%test-procedure-formal? tp)
    563         ; Returns the actual tpds!
    564         (filter
    565           (lambda (tpd)
    566             (and (test-procedure-actual-descriptor? tpd)
    567                  (eq? tp (test-procedure-descriptor-procedure tpd))))
    568           (test-procedure-descriptor-immutable-list))]
    569       [(%test-procedure-actual? tp)
    570         (list (list tp (%test-name tp) '()))]
    571       [else
    572         (error 'test::declarations "internal" obj)]) ) )
     560    (cond [(%test-procedure-formal? tp)
     561            ; Returns the actual tpds!
     562            (filter
     563              (lambda (tpd)
     564                (and (test-procedure-actual-descriptor? tpd)
     565                     (eq? tp (test-procedure-descriptor-procedure tpd))))
     566              (test-procedure-descriptor-immutable-list))]
     567          [(%test-procedure-actual? tp)
     568            (list (list tp (%test-name tp) '()))]
     569          [else
     570            (error 'test::declarations "internal" obj)]) ) )
    573571
    574572(define (test::procedure-variable obj)
     
    658656         [state (%test-procedure-state tp)])
    659657    (if (null? test-names)
    660       (tb$clear-test-selections state selection-mode)
    661       (tb$activate-test-selections state
    662         (checked-test-element-identifiers test-names 'test::select!)
    663         selection-mode)) ) )
     658        (tb$clear-test-selections state selection-mode)
     659        (tb$activate-test-selections state
     660          (checked-test-element-identifiers test-names 'test::select!)
     661          selection-mode)) ) )
    664662
    665663(define (test::selection-mode obj)
     
    682680    (replace-test-procedure-descriptors/list
    683681      (if (null? tplst)
    684         '()
    685         (remove
    686           (cut test-procedure-descriptor-in-test-procedure-list? <> tplst)
    687           (test-procedure-descriptor-immutable-list)))) )
     682          '()
     683          (remove
     684            (cut test-procedure-descriptor-in-test-procedure-list? <> tplst)
     685            (test-procedure-descriptor-immutable-list)))) )
    688686  (void) )
    689687
     
    692690  (let ([tplst
    693691          (if (null? objs)
    694             (%test-procedures)
    695             (checked-test-procedure-arguments objs 'test::for-each-procedures))])
     692              (%test-procedures)
     693              (checked-test-procedure-arguments objs 'test::for-each-procedures))])
    696694    (for-each proc tplst) ) )
    697695
     
    700698  (let ([tplst
    701699          (if (null? objs)
    702             (%test-procedures)
    703             (checked-test-procedure-arguments objs 'test::for-each-procedures))])
     700              (%test-procedures)
     701              (checked-test-procedure-arguments objs 'test::for-each-procedures))])
    704702    (map proc tplst) ) )
    705703
    706704(define (test::run . objs)
    707   (let* ([name
    708            (if (null? objs)
    709              #f
    710              (let ([name (car objs)]) (set! objs (cdr objs)) name))]
     705  (let* ([name (and (not (null? objs))
     706                    (let ([name (car objs)])
     707                      (set! objs (cdr objs))
     708                     name))]
    711709         [tplst (checked-test-procedure-arguments objs 'test::run)]
    712          [driven (eq? (test::run-mode) 'driven)]
     710         [driven (eq? 'driven (test::run-mode))]
    713711         [run-nam (run-name name)])
    714712    (unless driven
  • release/2/testbase/testbase-support.scm

    r8751 r9357  
    1111; or anyone else liable for any use of this source code. Please try to keep
    1212; this source code as close to R5RS (or later) scheme as possible. Thank you.
    13 
    14 (require-extension srfi-1 srfi-4 srfi-9 #;srfi-12 srfi-18 srfi-69 extras utils lolevel)
    15 (require-extension #;srfi-38 vector-lib)
    16 (require-extension srfi-37 args)
    17 (require-extension testbase-printers)
    1813
    1914(eval-when (compile)
     
    288283      #;test::improper-object-mapping) ) )
    289284
     285(require-extension srfi-1 srfi-4 srfi-9 #;srfi-12 srfi-18 srfi-69 extras utils lolevel)
     286(require-extension #;srfi-38 vector-lib)
     287(require-extension srfi-37 args)
     288(require-extension testbase-printers)
     289
    290290;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    291291;; Test Mode Predicates
     
    320320              (lambda (calls) ; calls is a list, (actual ... formal ...)
    321321                (if (tb$eval-mode? state)
    322                   (let ([calls-cnt (/ (length calls) 2)])
    323                     (for-each
    324                       (lambda call (queue-add! q call) )
    325                       (take calls calls-cnt)            ; the dereferenced form(s)
    326                       (take-right calls calls-cnt)) ) ) ; the quoted form(s)
    327                 (tb$make-ignore-result state) )]
     322                    (let ([calls-cnt (/ (length calls) 2)])
     323                      (for-each
     324                        (lambda call (queue-add! q call) )
     325                        (take calls calls-cnt)            ; the dereferenced form(s)
     326                        (take-right calls calls-cnt)) ) ) ; the quoted form(s)
     327                  (tb$make-ignore-result state) )]
    328328            [clear
    329329              (lambda ()
    330                 (if (tb$eval-mode? state)
    331                   (set! q (make-queue)))
    332                 (tb$make-ignore-result state) )]
     330                (when (tb$eval-mode? state)
     331                  (set! q (make-queue)) )
     332                (tb$make-ignore-result state) ) ]
    333333            [activate
    334334              (lambda ()
    335335                (if (tb$eval-mode? state)
    336                   (let ([alst
    337                           (map
    338                             (lambda (call)
    339                               (let ([actual (car call)])
    340                                 (cons
    341                                   (cadr call)
    342                                   (call/cc
    343                                     (lambda (k)
    344                                       (with-exception-handler
    345                                         (lambda (exp)
    346                                           (k exp))
    347                                         (lambda () (apply (car actual) (cdr actual)))))))))
    348                             (queue->list q))])
    349                     (set! q (make-queue))
    350                     (tb$make-destructor-result state alst) )
    351                   (tb$make-ignore-result state) ) )]
     336                    (let ([alst
     337                            (map
     338                              (lambda (call)
     339                                (let ([actual (car call)])
     340                                  (cons
     341                                    (cadr call)
     342                                    (call/cc
     343                                      (lambda (k)
     344                                        (with-exception-handler
     345                                          (lambda (exp)
     346                                            (k exp))
     347                                          (lambda () (apply (car actual) (cdr actual)))))))))
     348                              (queue->list q))])
     349                      (set! q (make-queue))
     350                      (tb$make-destructor-result state alst) )
     351                    (tb$make-ignore-result state) ) )]
    352352            [dump
    353353              (lambda ()
    354                 (if (tb$eval-mode? state)
     354                (when (tb$eval-mode? state)
    355355                  (for-each
    356356                    test::display-objects-newline
    357                     (queue->list q)))
     357                    (queue->list q)) )
    358358                (tb$make-ignore-result state) )])
    359359        (lambda (proc)
     
    467467  (let loop ([clauses thunk-list] [results '()])
    468468    (if (null? clauses)
    469       (reverse! results)
    470       (let ([result ((car clauses))]) ; Call lambda wrapped clause
    471         (loop (if (test-case-continue-result? state result)
    472                 (cdr clauses)
    473                 '())
    474               (cons result results)) ) ) ) )
     469        (reverse! results)
     470        (let ([result ((car clauses))]) ; Call lambda wrapped clause
     471          (loop (if (test-case-continue-result? state result)
     472                    (cdr clauses)
     473                    '())
     474                (cons result results)) ) ) ) )
    475475
    476476(define (tb$cltres state cltr nam res)
     
    480480(define (tb$cltexpt state results args)
    481481  (if (null? args)
    482     (reverse! results)
    483     (cons (cadr args) results) ) )
     482      (reverse! results)
     483      (cons (cadr args) results) ) )
    484484
    485485(define (tb$expt1 state message warning kind predicate unevaled evaled)
     
    576576    (let ([stripped-results
    577577            (if (tb$user-termination? results)
    578               ;then replace w/ a termination object
    579               (let ([trmrec
    580                       (tb$make-terminate-result state
    581                         (tb$user-termination-finding results)
    582                         (test::result-name resobj)
    583                         kind
    584                         (tb$user-termination-message results))])
    585                 (list (tb$echfltr state trmrec)))
    586               ;else results bound to a list
    587               (strip-ignored-results results))])
     578                ;then replace w/ a termination object
     579                (let ([trmrec
     580                        (tb$make-terminate-result state
     581                          (tb$user-termination-finding results)
     582                          (test::result-name resobj)
     583                          kind
     584                          (tb$user-termination-message results))])
     585                  (list (tb$echfltr state trmrec)))
     586                ;else results bound to a list
     587                (strip-ignored-results results))])
    588588      ; Return the typed list for this kind of test result
    589589      (let ([resobj
     
    594594        ; continue unwinding
    595595        (if (or (not stopescr) (eq? stopescr escr))
    596           resobj
    597           ((tb$state-escaper-peek state) (list resobj))) ) ) ) )
     596            resobj
     597            ((tb$state-escaper-peek state) (list resobj))) ) ) ) )
    598598
    599599;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    690690                ; Since suite is the top-most container tree could be empty
    691691                (if (null? tree)
    692                   (set! tree newlvl)
    693                   (append! tree (list newlvl)))
     692                    (set! tree newlvl)
     693                    (append! tree (list newlvl)))
    694694                (next-level newlvl (test::test-suite-result-list resnode)))]
    695695            ;
     
    716716          (lambda (flag elms)
    717717            (if flag
    718               ;then toggle on
    719               (begin
    720                 (set! old-mode (tb$state-mode state))
    721                 (tb$state-mode-set! state 'report))
    722               ;else revert
    723               (tb$state-mode-set! state old-mode))
     718                ;then toggle on
     719                (begin
     720                  (set! old-mode (tb$state-mode state))
     721                  (tb$state-mode-set! state 'report))
     722                ;else revert
     723                (tb$state-mode-set! state old-mode))
    724724            ; New tree structure
    725725            (tb$state-structure-set! state elms)) )])
     
    742742  (let ([elms (tb$state-structure state)])
    743743    (if (null? elms)
    744       (begin
    745         (capture-test-structure state)
    746         (tb$state-structure state))
    747       elms) ) )
     744        (begin
     745          (capture-test-structure state)
     746          (tb$state-structure state))
     747        elms) ) )
    748748
    749749;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    768768               (let ([tree-nodes (cddr tree-node)])
    769769                 (if (desired-container? tree-node)
    770                    tree-nodes
    771                    (any loop tree-nodes)))]
     770                     tree-nodes
     771                     (any loop tree-nodes)))]
    772772             [else
    773773               #f]) ) ) ) )
     
    902902  (let ([type-labels '#("Test-Procedure" "Test-Suite" "Test-Case" "Expectation")])
    903903    (lambda (state typ nam thunk)
    904       (cond
    905         [(take-test? state typ nam)
    906           (thunk)]
    907         [(tb$report-mode? state)
    908           ; Special skip-result message used to hold expectation
    909           ; See capture-test-structure.
    910           (if (eq? 'expect typ)
    911             (tb$make-skip-result state (list *report-expect-tag* typ nam) '())
    912             (tb$make-ignore-result state))]
    913         [else
    914           (tb$make-skip-result state
    915             (conc
    916               (tb$test-type->object typ type-labels 'tb$prftst)
    917               " - "
    918               (tb$printable-test-name nam))
    919             '())]) ) ) )
     904      (cond [(take-test? state typ nam)
     905              (thunk)]
     906            [(tb$report-mode? state)
     907              ; Special skip-result message used to hold expectation
     908              ; See capture-test-structure.
     909              (if (eq? 'expect typ)
     910                  (tb$make-skip-result state (list *report-expect-tag* typ nam) '())
     911                  (tb$make-ignore-result state))]
     912            [else
     913              (tb$make-skip-result state
     914                (conc
     915                  (tb$test-type->object typ type-labels 'tb$prftst)
     916                  " - "
     917                  (tb$printable-test-name nam))
     918                '())]) ) ) )
    920919
    921920;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    10371036
    10381037  (define (object-type-tag obj)
    1039     (cond
    1040       [(eof-object? obj)          'eof-object] ; not a good idea to print literally
    1041       [(extended-procedure? obj)  'extended-procedure]
    1042       [(procedure? obj)           'procedure]
    1043       [(thread? obj)              'thread]
    1044       [(continuation? obj)        'continuation]
    1045       [(condition? obj)           'condition]
    1046       [(locative? obj)            'locative]
    1047       [(pointer? obj)             'pointer]
    1048       [(read-table? obj)          'read-table]
    1049       [(list? obj)                'list]
    1050       [(vector? obj)              'vector]
    1051       [(record? obj)              (list 'record (record-type-name obj))]
    1052       [(hash-table? obj)          'hash-table]
    1053       [else                       'unknown]) )
     1038    (cond [(eof-object? obj)          'eof-object] ; not a good idea to print literally
     1039          [(extended-procedure? obj)  'extended-procedure]
     1040          [(procedure? obj)           'procedure]
     1041          [(thread? obj)              'thread]
     1042          [(continuation? obj)        'continuation]
     1043          [(condition? obj)           'condition]
     1044          [(locative? obj)            'locative]
     1045          [(pointer? obj)             'pointer]
     1046          [(read-table? obj)          'read-table]
     1047          [(list? obj)                'list]
     1048          [(vector? obj)              'vector]
     1049          [(record? obj)              (list 'record (record-type-name obj))]
     1050          [(hash-table? obj)          'hash-table]
     1051          [else                       'unknown]) )
    10541052
    10551053  ;; Determines if the object is circular and/or printable.
     
    11031101(define (object->string obj)
    11041102  (if (string? obj)
    1105     obj
    1106     (call/cc
    1107       (lambda (k)
    1108         (with-exception-handler
    1109           (lambda (exp) (k exp))
    1110           (lambda () (->string obj)))))) )
     1103      obj
     1104      (call/cc
     1105        (lambda (k)
     1106          (with-exception-handler
     1107            (lambda (exp) (k exp))
     1108            (lambda () (->string obj)))))) )
    11111109
    11121110;; Return string form of circular object.
     
    11281126  (receive [info val]
    11291127            (if (car props)
    1130               (let ([str (circular-object->string obj)])
    1131                 (if (string? str)
    1132                   (values #f str)
    1133                   (values
    1134                     (list (object-type-tag obj) 'unprintable 'circular)
    1135                     (unspecified-value))))
    1136               (let ([str (object->string obj)])
    1137                 (if (string? str)
    1138                   (values #f str)
    1139                   (values
    1140                     (list (object-type-tag obj) 'unprintable exp)
    1141                     (unspecified-value)))))
     1128                (let ([str (circular-object->string obj)])
     1129                  (if (string? str)
     1130                      (values #f str)
     1131                      (values
     1132                        (list (object-type-tag obj) 'unprintable 'circular)
     1133                        (unspecified-value))))
     1134                (let ([str (object->string obj)])
     1135                  (if (string? str)
     1136                      (values #f str)
     1137                      (values
     1138                        (list (object-type-tag obj) 'unprintable exp)
     1139                        (unspecified-value)))))
    11421140      (make-wrapped-object info val) ) )
    11431141
     
    11631161      (let ([props (cons #f #t)])
    11641162        (if (proper-object? obj props)
    1165           obj
    1166           (wrap-object obj props)) )]) )
     1163            obj
     1164            (wrap-object obj props)) )]) )
    11671165|#
    11681166
     
    11701168  (let ([props (cons #f #t)])
    11711169    (if (proper-object? obj props)
    1172       obj
    1173       (wrap-object obj props)) ) )
     1170        obj
     1171        (wrap-object obj props)) ) )
    11741172
    11751173;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    11941192                    ; Make sure any non-boolean finding is echoed.
    11951193                  ,(let ([finding (test::result-finding res)])
    1196                     (if (boolean? finding)
    1197                       (make-item 'finding finding)
    1198                       (make-proper-item 'finding finding)))
     1194                     (if (boolean? finding)
     1195                         (make-item 'finding finding)
     1196                         (make-proper-item 'finding finding)))
    11991197                    ; Could be an improper object.
    12001198                  ,(make-proper-item msgtag (test::result-message res))
    12011199                    ; May not have a warning.
    12021200                  ,@(if (test::result-warning? res)
    1203                     `(,(make-proper-item 'warning (test::result-warning res)))
    1204                     '())
     1201                        `(,(make-proper-item 'warning (test::result-warning res)))
     1202                        '())
    12051203                    ; May not have a timing.
    12061204                  ,@(if (test::result-timing? res)
    1207                     `(,(make-item 'timing (test::result-timing res)))
    1208                     '())
     1205                        `(,(make-item 'timing (test::result-timing res)))
     1206                        '())
    12091207                    ; Optional items.
    12101208                  ,@others))])
     
    12191217                    [(test::test-suite-result? res)
    12201218                      (if (test::test-suite-result-list res)
    1221                         ;then suite evaluated, so exit test hiearchy level
    1222                         (make-alist 'end 'name)
    1223                         ;then suite unevaluated, so enter test hiearchy level
    1224                         (make-alist 'begin 'name))]
     1219                          ;then suite evaluated, so exit test hiearchy level
     1220                          (make-alist 'end 'name)
     1221                          ;else suite unevaluated, so enter test hiearchy level
     1222                          (make-alist 'begin 'name))]
    12251223                    ;
    12261224                    [(test::test-case-result? res)
    12271225                      (if (test::test-case-result-list res)
    1228                         ;then case evaluated, so exit test hiearchy level
    1229                         (make-alist 'end 'name)
    1230                         ;then case unevaluated, so enter test hiearchy level
    1231                         (make-alist 'begin 'name))]
     1226                          ;then case evaluated, so exit test hiearchy level
     1227                          (make-alist 'end 'name)
     1228                          ;else case unevaluated, so enter test hiearchy level
     1229                          (make-alist 'begin 'name))]
    12321230                    ;
    12331231                    [(test::expect-result? res)
    12341232                      (make-alist 'expectation 'name
    12351233                        (if incl-expt-spec
    1236                           `(,(make-item 'unevaluated
    1237                               (test::expect-result-unevaled res))
    1238                             ,(make-proper-item 'actual
    1239                               (test::expect-result-evaled res)))
    1240                           '()))]
     1234                            `(,(make-item 'unevaluated
     1235                                (test::expect-result-unevaled res))
     1236                              ,(make-proper-item 'actual
     1237                                (test::expect-result-evaled res)))
     1238                            '()))]
    12411239                    ;
    12421240                    [(test::expect-tolerance-result? res)
    12431241                      (make-alist 'expectation 'name
    12441242                        (if incl-expt-spec
    1245                           `(,(make-proper-item 'tolerance
    1246                               (test::expect-tolerance-result-lhs-tol-evaled res))
    1247                             ,(make-item 'unevaluated
    1248                               (test::expect-tolerance-result-rhs-unevaled res))
    1249                             ,(make-proper-item 'expected
    1250                               (test::expect-tolerance-result-lhs-evaled res))
    1251                             ,(make-proper-item 'actual
    1252                               (test::expect-tolerance-result-rhs-evaled res)))
    1253                           '()))]
     1243                            `(,(make-proper-item 'tolerance
     1244                                (test::expect-tolerance-result-lhs-tol-evaled res))
     1245                              ,(make-item 'unevaluated
     1246                                (test::expect-tolerance-result-rhs-unevaled res))
     1247                              ,(make-proper-item 'expected
     1248                                (test::expect-tolerance-result-lhs-evaled res))
     1249                              ,(make-proper-item 'actual
     1250                                (test::expect-tolerance-result-rhs-evaled res)))
     1251                            '()))]
    12541252                    ;
    12551253                    [(test::expect-equivalence-result? res)
    12561254                      (make-alist 'expectation 'name
    12571255                        (if incl-expt-spec
    1258                           `(,(make-item 'unevaluated
    1259                               (test::expect-equivalence-result-rhs-unevaled res))
    1260                             ,(make-proper-item 'expected
    1261                               (test::expect-equivalence-result-lhs-evaled res))
    1262                             ,(make-proper-item 'actual
    1263                               (test::expect-equivalence-result-rhs-evaled res)))
    1264                           '()))]
     1256                            `(,(make-item 'unevaluated
     1257                                (test::expect-equivalence-result-rhs-unevaled res))
     1258                              ,(make-proper-item 'expected
     1259                                (test::expect-equivalence-result-lhs-evaled res))
     1260                              ,(make-proper-item 'actual
     1261                                (test::expect-equivalence-result-rhs-evaled res)))
     1262                            '()))]
    12651263                    ;
    12661264                    [(test::terminate-result? res)
     
    13411339      (let-optionals rest ([prompt-template #t])
    13421340        (parameterize ([repl-prompt
    1343                         (cond
    1344                           [(not prompt-template) none]
    1345                           [(boolean? prompt-template) same]
    1346                           [(procedure? prompt-template) prompt-template]
    1347                           [(string? prompt-template) (lambda () prompt-template)]
    1348                           [else
    1349                             (error 'system-repl
    1350                               "invalid prompt template" prompt-template)])])
     1341                        (cond [(not prompt-template)          none]
     1342                              [(boolean? prompt-template)     same]
     1343                              [(procedure? prompt-template)   prompt-template]
     1344                              [(string? prompt-template)      (lambda () prompt-template)]
     1345                              [else
     1346                                (error 'system-repl
     1347                                  "invalid prompt template" prompt-template)])])
    13511348          (repl) ) ) ) ) )
    13521349
     
    13671364    ; Setup for human or machine REPL
    13681365    (if (eq? (test::run-mode) 'driven)
    1369       ;then setup for machine interaction
    1370       (tb$driven-mode-setup name)
    1371       ;else setup for human interaction
    1372       (begin
    1373         (set! prompt-template #t)
    1374         (tb$interactive-mode-setup name)))
     1366        ;then setup for machine interaction
     1367        (tb$driven-mode-setup name)
     1368        ;else setup for human interaction
     1369        (begin
     1370          (set! prompt-template #t)
     1371          (tb$interactive-mode-setup name)))
    13751372    ;Use system repl w/ our own prompt
    13761373    (system-repl prompt-template) ) )
  • release/2/testbase/testbase.setup

    r8902 r9357  
    11(include "setup-header")
    2 
    3 (include "testbase-version")
    42
    53(required-extension-version
     
    7573                ,(make-dynld-filename "testbase-proc")
    7674                "testbase.html" )
    77   `((version ,TESTBASE-VERSION)
     75  `((version ,*version*)
    7876    (documentation "testbase.html")
    7977    (syntax)
Note: See TracChangeset for help on using the changeset viewer.