Changeset 11761 in project


Ignore:
Timestamp:
08/25/08 21:30:36 (13 years ago)
Author:
sjamaan
Message:

Import latest changes from release/3/test... by hand!

Location:
release/4/test
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/test/test-support.scm

    r11433 r11761  
    115115
    116116(define (test-print-name info . indent)
    117   (let ((width (- (current-column-width) (if (pair? indent) (car indent) 0)))
     117  (let ((width (- (current-column-width)
     118                  (or (and (pair? indent) (car indent)) 0)))
    118119        (name (test-get-name! info)))
    119120    (display name)
    120     (display " ")
    121121    (let ((diff (- width 9 (string-length name))))
    122       (if (positive? diff)
    123         (display (make-string diff #\.))))
     122      (cond
     123       ((positive? diff)
     124        (display " ")
     125        (display (make-string diff #\.)))))
    124126    (display " ")
    125127    (flush-output)))
     
    162164      (newline)
    163165      (print-header-line
    164        (string-append "testing " (test-group-name group))
     166       (string-append "testing " (or (test-group-name group) ""))
    165167       (or indent 0))))
    166168    (if (and indent (positive? indent))
     
    355357      ))
    356358    (print-header-line
    357      (string-append "done testing " (test-group-name group))
     359     (string-append "done testing " (or (test-group-name group) ""))
    358360     (or (test-group-indent-width group) 0))
    359361    (newline)
     
    381383         (group (make-test-group name))
    382384         (parent (current-test-group)))
     385    (cond
     386     ((and parent
     387           (equal? 0 (test-group-ref parent 'count 0))
     388           (zero? (test-group-ref parent 'subgroups-count 0))
     389           (test-group-ref parent 'verbosity))
     390      (newline)
     391      (print-header-line
     392       (string-append "testing " (test-group-name parent))
     393       (or (test-group-indent-width parent) 0))))
    383394    (test-group-set! group 'parent parent)
    384395    (test-group-set! group 'verbosity
  • release/4/test/test.scm

    r11439 r11761  
    1818;; test interface
    1919
    20  (define-syntax test
    21    (syntax-rules ()
    22      ((test expect expr)
    23       (test #f expect expr))
    24      ((test name expect (expr ...))
    25       (test-info name expect (expr ...) ()))
    26      ((test name expect expr)
    27       (let-syntax
    28           ((sym? (syntax-rules ()
    29                    ((_ expr sk fk) sk)
    30                    ((_ anything sk fk) fk))))
    31         (sym? test-symbol
    32               (test-info name expect expr)
    33               (test-syntax-error
    34                'test
    35                "the test expression should come last "
    36                (test name expect expr)))))
    37      ((test a ...)
    38       (test-syntax-error 'test "2 or 3 arguments required"
    39                          (test a ...)))
    40      ))
     20(define-syntax test
     21  (syntax-rules ()
     22    ((test expect expr)
     23     (test #f expect expr))
     24    ((test name expect (expr ...))
     25     (test-info name expect (expr ...) ()))
     26    ((test name (expect ...) expr)
     27     (test-syntax-error
     28      'test
     29      "the test expression should come last "
     30      (test name (expect ...) expr)))
     31    ((test name expect expr)
     32     (test-info name expect expr))
     33    ((test a ...)
     34     (test-syntax-error 'test "2 or 3 arguments required"
     35                        (test a ...)))
     36    ))
    4137
    4238(define-syntax test-assert
     
    4844    ((test a ...)
    4945     (test-syntax-error 'test-assert "1 or 2 arguments required"
    50                         (test a ...)))
     46                        (test a ...)))
    5147    ))
    5248
     
    5955    ((test a ...)
    6056     (test-syntax-error 'test-error "1 or 2 arguments required"
    61                         (test a ...)))
     57                        (test a ...)))
    6258    ))
    6359
     60;;    (define-syntax test-error*
     61;;      (syntax-rules ()
     62;;        ((_ ?msg (?error-type ...) ?expr)
     63;;         (let-syntax ((expression:
     64;;                       (syntax-rules ()
     65;;                         ((_ ?expr)
     66;;                          (condition-case (begin ?expr "<no error thrown>")
     67;;                            ((?error-type ...) '(?error-type ...))
     68;;                            (exn () (##sys#slot exn 1)))))))
     69;;           (test ?msg '(?error-type ...) (expression: ?expr))))
     70;;        ((_ ?msg ?error-type ?expr)
     71;;         (test-error* ?msg (?error-type) ?expr))
     72;;        ((_ ?error-type ?expr)
     73;;         (test-error* (sprintf "~S" '?expr) ?error-type ?expr))))
    6474
    6575;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    7080    ((_ name-expr body ...)
    7181     (let ((name name-expr)
    72            (old-group (current-test-group)))
    73           (if (not (string? name))
    74             (syntax-error 'test-group "a name is required, got " 'name-expr name))
    75           (test-begin name)
    76           body ...
    77           (test-end name)
    78           (current-test-group old-group)))))
     82           (old-group (current-test-group)))
     83       (if (not (string? name))
     84           (syntax-error 'test-group "a name is required, got " 'name-expr name))
     85       (test-begin name)
     86       (condition-case (begin body ...)
     87                       (e ()
     88                          (warning "error in group outside of tests")
     89                          (print-error-message e)
     90                          (test-group-inc! (current-test-group) 'count)
     91                          (test-group-inc! (current-test-group) 'ERROR)))
     92       (test-end name)
     93       (current-test-group old-group)))))
    7994
    8095;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    8499  (syntax-rules ()
    85100    ((_) (syntax-error "invalid use of test-syntax-error"))))
    86 
    87101
    88102(define-syntax test-info
     
    100114    ((_ (vars ...) n expect expr ((key . val) ...))
    101115     (test-run (lambda () expect)
    102                (lambda () expr)
    103                (cons (cons 'name n)
    104                      '((source . expr)
    105                        ;;(var-names . (vars ...))
    106                        ;;(var-values . ,(list vars))
    107                        (key . val) ...)))))))
     116               (lambda () expr)
     117               (cons (cons 'name n)
     118                     '((source . expr)
     119                       ;;(var-names . (vars ...))
     120                       ;;(var-values . ,(list vars))
     121                       (key . val) ...)))))))
Note: See TracChangeset for help on using the changeset viewer.