306 lines
12 KiB
Scheme
306 lines
12 KiB
Scheme
(module mz-testing mzscheme
|
|
|
|
;;; `test.scm' Test correctness of MzScheme implementations.
|
|
;;; Copyright (C) 1991, 1992, 1993, 1994 Aubrey Jaffer.
|
|
;;; Modified for MzScheme by Matthew
|
|
|
|
;;; MODIFIED for MzScheme - Matthew 8/95
|
|
;;; Added a few more tests, like append!, reverse!, etc.
|
|
;;; Added testing for inexact numbers
|
|
;;; Added a lot of error testing
|
|
;;; modified for rational and complex numbers - Matthew 12/95
|
|
;;; modified to test exceptions and more of MzScheme - Matthew 4/96
|
|
;;; split into multiple files - Matthew 4/96
|
|
;;; extended, extended, extended
|
|
;;; turned into a module - John Clements, 5/03
|
|
|
|
;;; This includes examples from
|
|
;;; William Clinger and Jonathan Rees, editors.
|
|
;;; Revised^4 Report on the Algorithmic Language Scheme
|
|
;;; and the IEEE specification.
|
|
|
|
(provide building-flat-tests?
|
|
in-drscheme?
|
|
SECTION
|
|
test
|
|
err/rt-test
|
|
arity-test
|
|
report-errs
|
|
|
|
;; Backward compatibility:
|
|
exn:application:mismatch?
|
|
exn:application:type?
|
|
exn:application:arity?)
|
|
|
|
; The format of the next line is important: file.ss relies on it
|
|
; JBC : not in this version...
|
|
(define cur-section '())(define errs '())
|
|
|
|
(define teval eval)
|
|
|
|
; JBC : changed instances of namespace-variable-value into plain old module var refs & defs.
|
|
; I freely admit I don't see why the file didn't just use set!, unless it was out of concern
|
|
; for capture when this code was embedded...?
|
|
; Also, I now see that the old code admitted the possibility of set!'s to these variables
|
|
; from outside of this code. This will no longer be possible. I'll make them parameters, then.
|
|
|
|
(define building-flat-tests?
|
|
(make-parameter #f))
|
|
|
|
(define in-drscheme?
|
|
(make-parameter #f))
|
|
|
|
(define SECTION (lambda args
|
|
(let ([ep (current-error-port)])
|
|
(display "SECTION" ep) (write args ep) (newline ep)
|
|
(set! cur-section args) #t)))
|
|
|
|
(define record-error (lambda (e) (set! errs (cons (list cur-section e) errs))))
|
|
|
|
(print-struct #t)
|
|
|
|
(define number-of-tests 0)
|
|
(define number-of-error-tests 0)
|
|
(define number-of-exn-tests 0)
|
|
|
|
(define test
|
|
(lambda (expect fun . args)
|
|
(set! number-of-tests (add1 number-of-tests))
|
|
(write (cons fun args))
|
|
(display " ==> ")
|
|
(flush-output)
|
|
((lambda (res)
|
|
(write res)
|
|
(newline)
|
|
(cond ((not (equal? expect res))
|
|
(record-error (list res expect (cons fun args)))
|
|
(display " BUT EXPECTED ")
|
|
(write expect)
|
|
(newline)
|
|
#f)
|
|
(else #t)))
|
|
(if (procedure? fun) (apply fun args) (car args)))))
|
|
|
|
|
|
(define (nonneg-exact? x)
|
|
(and (exact? x)
|
|
(integer? x)
|
|
(x . >= . 0)))
|
|
|
|
(define (pos-exact? x)
|
|
(and (exact? x)
|
|
(integer? x)
|
|
(positive? x)))
|
|
|
|
(define exn-table
|
|
(list (cons exn? (cons exn-message string?))
|
|
(cons exn? (cons exn-continuation-marks continuation-mark-set?))
|
|
(cons exn:fail:contract:variable? (cons exn:fail:contract:variable-id symbol?))
|
|
(cons exn:fail:syntax? (cons exn:fail:syntax-exprs (lambda (x) (and (list? x) (andmap syntax? x)))))
|
|
|
|
(cons exn:fail:read? (cons exn:fail:read-srclocs (lambda (x) (and (list? x) (andmap srcloc? x)))))))
|
|
|
|
(define exn:application:mismatch? exn:fail:contract?)
|
|
(define exn:application:type? exn:fail:contract?)
|
|
(define exn:application:arity? exn:fail:contract:arity?)
|
|
|
|
(define mz-test-syntax-errors-allowed? #t)
|
|
|
|
(define thunk-error-test
|
|
(case-lambda
|
|
[(th expr) (thunk-error-test th expr exn:application:type?)]
|
|
[(th expr exn?)
|
|
(set! expr (syntax-object->datum expr))
|
|
(set! number-of-error-tests (add1 number-of-error-tests))
|
|
(write expr)
|
|
(display " =e=> ")
|
|
(call/ec (lambda (escape)
|
|
(let* ([old-esc-handler (error-escape-handler)]
|
|
[old-handler (current-exception-handler)]
|
|
[orig-err-port (current-error-port)]
|
|
[test-handler
|
|
(lambda ()
|
|
(escape #t))]
|
|
[test-exn-handler
|
|
(lambda (e)
|
|
(when (and exn? (not (exn? e)))
|
|
(printf " WRONG EXN TYPE: ~s " e)
|
|
(record-error (list e 'exn-type expr)))
|
|
(when (and (exn:fail:syntax? e)
|
|
(not mz-test-syntax-errors-allowed?))
|
|
(printf " LATE SYNTAX EXN: ~s " e)
|
|
(record-error (list e 'exn-late expr)))
|
|
|
|
(for-each
|
|
(lambda (row)
|
|
(let ([pred? (car row)])
|
|
(when (pred? e)
|
|
(set! number-of-exn-tests
|
|
(add1 number-of-exn-tests))
|
|
(let ([sel (cadr row)]
|
|
[pred? (cddr row)])
|
|
(unless (pred? (sel e))
|
|
(printf " WRONG EXN ELEM ~s: ~s " sel e)
|
|
(record-error (list e (cons 'exn-elem sel) expr)))))))
|
|
exn-table)
|
|
|
|
(old-handler e))])
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(current-error-port (current-output-port))
|
|
(current-exception-handler test-exn-handler)
|
|
(error-escape-handler test-handler))
|
|
(lambda ()
|
|
(let ([v (th)])
|
|
(write v)
|
|
(display " BUT EXPECTED ERROR")
|
|
(record-error (list v 'Error expr))
|
|
(newline)
|
|
#f))
|
|
(lambda ()
|
|
(current-error-port orig-err-port)
|
|
(current-exception-handler old-handler)
|
|
(error-escape-handler old-esc-handler))))))]))
|
|
|
|
(define error-test
|
|
(make-parameter
|
|
(case-lambda
|
|
[(expr) (error-test expr exn:application:type?)]
|
|
[(expr exn?)
|
|
(thunk-error-test (lambda () (eval expr)) expr exn?)])))
|
|
|
|
; JBC : I'm not going to worry about this for the time being :
|
|
; (require (rename mzscheme err:mz:lambda lambda)) ; so err/rt-test works with beginner.ss
|
|
|
|
(define-syntax err/rt-test
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ e exn?)
|
|
(syntax
|
|
(thunk-error-test (lambda () e) (quote-syntax e) exn?))]
|
|
[(_ e)
|
|
(syntax
|
|
(err/rt-test e exn:application:type?))])))
|
|
|
|
(define no-extra-if-tests? #f)
|
|
|
|
(define (syntax-test expr)
|
|
(error-test expr exn:fail:syntax?)
|
|
(unless no-extra-if-tests?
|
|
(error-test (datum->syntax-object expr `(if #f ,expr) expr) exn:fail:syntax?)))
|
|
|
|
(define arity-test
|
|
(case-lambda
|
|
[(f min max except)
|
|
(letrec ([aok?
|
|
(lambda (a)
|
|
(cond
|
|
[(integer? a) (= a min max)]
|
|
[(arity-at-least? a) (and (negative? max)
|
|
(= (arity-at-least-value a) min))]
|
|
[(and (list? a) (andmap integer? a))
|
|
(and (= min (car a)) (= max
|
|
(let loop ([l a])
|
|
(if (null? (cdr l))
|
|
(car l)
|
|
(loop (cdr l))))))]
|
|
[(list? a)
|
|
;; Just check that all are consistent for now.
|
|
;; This should be improved.
|
|
(andmap
|
|
(lambda (a)
|
|
(if (number? a)
|
|
(<= min a (if (negative? max) a max))
|
|
(>= (arity-at-least-value a) min)))
|
|
a)]
|
|
[else #f]))]
|
|
[make-ok?
|
|
(lambda (v)
|
|
(lambda (e)
|
|
(exn:application:arity? e)))]
|
|
[do-test
|
|
(lambda (f args check?)
|
|
(set! number-of-error-tests (add1 number-of-error-tests))
|
|
(printf "(apply ~s '~s) =e=> " f args)
|
|
(let/ec done
|
|
(let ([v (with-handlers ([void
|
|
(lambda (exn)
|
|
(if (check? exn)
|
|
(printf " ~a~n" (exn-message exn))
|
|
(let ([ok-type? (exn:application:arity? exn)])
|
|
(printf " WRONG EXN ~a: ~s~n"
|
|
(if ok-type?
|
|
"FIELD"
|
|
"TYPE")
|
|
exn)
|
|
(record-error (list exn
|
|
(if ok-type?
|
|
'exn-field
|
|
'exn-type)
|
|
(cons f args)))))
|
|
(done (void)))])
|
|
(apply f args))])
|
|
(printf "~s~n BUT EXPECTED ERROR~n" v)
|
|
(record-error (list v 'Error (cons f args))))))])
|
|
(let loop ([n 0][l '()])
|
|
(unless (>= n min)
|
|
(unless (memq n except)
|
|
(do-test f l (make-ok? n)))
|
|
(loop (add1 n) (cons 1 l))))
|
|
(let loop ([n min])
|
|
(unless (memq n except)
|
|
(test #t procedure-arity-includes? f n))
|
|
(unless (>= n max)
|
|
(loop (add1 n))))
|
|
(if (>= max 0)
|
|
(do-test f (let loop ([n 0][l '(1)])
|
|
(if (= n max)
|
|
l
|
|
(loop (add1 n) (cons 1 l))))
|
|
(make-ok? (add1 max)))
|
|
(test #t procedure-arity-includes? f (arithmetic-shift 1 100))))]
|
|
[(f min max) (arity-test f min max null)]))
|
|
|
|
(define (test-values l thunk)
|
|
(test l call-with-values thunk list))
|
|
|
|
(define (report-errs)
|
|
(printf "~nPerformed ~a expression tests (~a good expressions, ~a bad expressions)~n"
|
|
(+ number-of-tests number-of-error-tests)
|
|
number-of-tests
|
|
number-of-error-tests)
|
|
(printf "and ~a exception field tests.~n~n"
|
|
number-of-exn-tests)
|
|
(if (null? errs)
|
|
(display "Passed all tests.")
|
|
(begin
|
|
(display "Errors were:")
|
|
(newline)
|
|
(display "(SECTION (got expected (call)))")
|
|
(newline)
|
|
(for-each (lambda (l) (write l) (newline))
|
|
errs)))
|
|
(newline)
|
|
(display "(Other messages report successful tests of error-handling behavior.)")
|
|
(newline))
|
|
|
|
(define type? exn:application:type?)
|
|
(define arity? exn:application:arity?)
|
|
(define syntaxe? exn:fail:syntax?)
|
|
|
|
(define non-z void)
|
|
|
|
(define (find-depth go)
|
|
; Find depth that triggers a stack overflow (assuming no other
|
|
; threads are running and overflowing)
|
|
(let ([v0 (make-vector 6)]
|
|
[v1 (make-vector 6)])
|
|
(let find-loop ([d 100])
|
|
(vector-set-performance-stats! v0)
|
|
(go d)
|
|
(vector-set-performance-stats! v1)
|
|
(if (> (vector-ref v1 5)
|
|
(vector-ref v0 5))
|
|
d
|
|
(find-loop (* 2 d)))))))
|