Adding more testing support
svn: r5571
This commit is contained in:
Kathy Gray
parent
51dc8cb94a
commit
5503e79355
|
|
@ -300,6 +300,9 @@
|
|||
;(make-check-catch (U #f type) src Expression type-spec)
|
||||
(p-define-struct (check-catch check) (test exn))
|
||||
|
||||
;(make-check-by (U #f type) src Expression Expression (U '== Name))
|
||||
(p-define-struct (check-by check) (test actual compare))
|
||||
|
||||
;(make-check-mutate (U #f type) src Expression Expression src)
|
||||
(p-define-struct (check-mutate check) (mutate check op-src))
|
||||
|
||||
|
|
|
|||
|
|
@ -2725,6 +2725,16 @@
|
|||
env
|
||||
(expr-src exp)
|
||||
type-recs))
|
||||
((check-by? exp)
|
||||
(check-test-by exp
|
||||
(check-by-test exp)
|
||||
(check-by-actual exp)
|
||||
(check-by-compare exp)
|
||||
check-sub-expr
|
||||
env
|
||||
level
|
||||
(expr-src exp)
|
||||
type-recs))
|
||||
((check-mutate? exp)
|
||||
(check-test-mutate (check-mutate-mutate exp)
|
||||
(check-mutate-check exp)
|
||||
|
|
@ -2796,6 +2806,61 @@
|
|||
[test-type (check-e test new-env)])
|
||||
(make-type/env 'boolean (restore-exn-env (type/env-e test-type) env)))))
|
||||
|
||||
;check-test-by: expr expr (U symbol id) (expr env -> type-env) env symbol src type-records -> type/env
|
||||
(define (check-test-by exp test actual by check-e env level src type-recs)
|
||||
(let* ([test-et (check-e test env)]
|
||||
[actual-et (check-e actual (type/env-e test-et))]
|
||||
[test-type (type/env-t test-et)]
|
||||
[actual-type (type/env-t actual-et)]
|
||||
[new-env (type/env-e actual-et)])
|
||||
(cond
|
||||
[(eq? '== by)
|
||||
(unless
|
||||
(or (and (prim-numeric-type? test-type)
|
||||
(prim-numeric-type? actual-type))
|
||||
(and (boolean? test-type)
|
||||
(boolean? actual-type))
|
||||
(and
|
||||
(reference-type? test-type)
|
||||
(reference-type? actual-type)
|
||||
(castable? actual-type test-type type-recs))
|
||||
(and
|
||||
(reference-type? test-type)
|
||||
(reference-type? actual-type)
|
||||
(castable? test-type actual-type type-recs)))
|
||||
(check-by-==-error test-type actual-type src))]
|
||||
[else
|
||||
(unless (and (reference-type? test-type)
|
||||
(reference-type? actual-type))
|
||||
(check-by-error 'not-obj test-type actual-type #f src))
|
||||
(unless (or (dynamic-val? test-type)
|
||||
(eq? 'dynamic test-type))
|
||||
(let* ([class-rec (send type-recs get-class-record test-type)]
|
||||
[methods (get-method-records by class-rec type-recs)])
|
||||
(cond
|
||||
[(null? methods)
|
||||
(check-by-error 'no-such-method test-type #f by src)]
|
||||
[else
|
||||
(let ([meth (resolve-overloading methods
|
||||
(list actual-type)
|
||||
(lambda ()
|
||||
(check-by-error 'no-arg-count
|
||||
test-type #f by src))
|
||||
(lambda ()
|
||||
(check-by-error 'conflict
|
||||
test-type actual-type
|
||||
by src))
|
||||
(lambda ()
|
||||
(check-by-error 'no-match
|
||||
test-type actual-type
|
||||
by src))
|
||||
type-recs)])
|
||||
(when meth
|
||||
(unless (eq? (method-record-rtype meth) 'boolean)
|
||||
(check-by-error 'not-boolean test-type actual-type by src))
|
||||
(set-check-by-compare! exp meth)))])
|
||||
(make-type/env 'boolean new-env)))])))
|
||||
|
||||
;check-test-mutate: exp exp (exp env -> type/env) env src type-records -> type/env
|
||||
(define (check-test-mutate mutatee check check-sub-expr env src type-recs)
|
||||
(unless (or (call? mutatee)
|
||||
|
|
@ -3553,6 +3618,41 @@
|
|||
'check ta-src
|
||||
))
|
||||
|
||||
(define (check-by-==-error t-type a-type src)
|
||||
(raise-error
|
||||
'check
|
||||
(string-append "In a 'check' expression with '==', the type of the expected and actual expression must be castable to each other~n"
|
||||
(format "Given ~a and ~a, which are not comparable."
|
||||
(type->ext-name t-type) (type->ext-name a-type)))
|
||||
'by
|
||||
src))
|
||||
|
||||
(define (check-by-error kind t-type a-type by src)
|
||||
(let ([by (if (id? by) (id-string by) by)])
|
||||
(raise-error
|
||||
'check
|
||||
(case kind
|
||||
[(not-obj)
|
||||
(string-append "In a 'check' expression with 'by', the type of the expected value must be an interface or class~n"
|
||||
(format "Exepected value is of ~a type, which is not allowed."
|
||||
(type->ext-name t-type)))]
|
||||
[(no-such-method)
|
||||
(format "Class or interface ~a does not have a method ~a to compare with in this 'check'."
|
||||
(type->ext-name t-type) by)]
|
||||
[(no-arg-count)
|
||||
(format "Class or interface ~a does not have a method ~a accepting one argument for this 'check'"
|
||||
(type->ext-name t-type) by)]
|
||||
[(conflict)
|
||||
(format "Multiple methods in ~a could accept the argument ~a for comparison in this 'check'."
|
||||
(type->ext-name t-type) (type->ext-name a-type) by)]
|
||||
[(no-match)
|
||||
(format "No ~a method in ~a expects a ~a for comparison in this 'check'."
|
||||
by (type->ext-name t-type) (type->ext-name a-type))]
|
||||
[(not-bool)
|
||||
(format "Method ~a accepting ~a in ~a does not return a boolean and cannot do the comparison in this 'check'."
|
||||
by (type->ext-name a-type) (type->ext-name t-type))])
|
||||
'by src)))
|
||||
|
||||
;check-catch-error: type src -> void
|
||||
(define (check-catch-error name src)
|
||||
(raise-error
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@
|
|||
|
||||
(provide convert-to-string shift not-equal bitwise mod divide-dynamic divide-int
|
||||
divide-float and or cast-primitive cast-reference instanceof-array nullError
|
||||
check-eq? dynamic-equal? compare compare-within check-catch check-mutate)
|
||||
check-eq? dynamic-equal? compare compare-within check-catch check-mutate check-by)
|
||||
|
||||
(define (check-eq? obj1 obj2)
|
||||
(or (eq? obj1 obj2)
|
||||
|
|
@ -207,6 +207,8 @@
|
|||
(compare-within test act 0.0 info src test-obj catch? #f))
|
||||
|
||||
(define exception (gensym 'exception))
|
||||
;(make-exn-thrown exn boolean string)
|
||||
(define-struct exn-thrown (exception expected? cause))
|
||||
|
||||
;compare-within: (-> val) val val (list symbol string) (U #f object) boolean . boolean -> boolean
|
||||
(define (compare-within test act range info src test-obj catch? . within?)
|
||||
|
|
@ -246,10 +248,10 @@
|
|||
(else #f)))))
|
||||
(fail? #f))
|
||||
(set! test
|
||||
(with-handlers ((exn?
|
||||
(with-handlers ([exn?
|
||||
(lambda (e)
|
||||
(set! fail? #t)
|
||||
(list exception catch? e))))
|
||||
(list exception catch? e "eval"))])
|
||||
(test)))
|
||||
(let ([res (if fail? #f (java-equal? test act null null))]
|
||||
[values-list (append (list act test) (if (null? within?) (list range) null))])
|
||||
|
|
@ -275,6 +277,26 @@
|
|||
(stored-checks (cons (list return 'check-catch info values-list src) (stored-checks)))
|
||||
(report-check-result return 'check-catch info values-list src test-obj))
|
||||
return))
|
||||
|
||||
;check-by: (-> val) value (value value -> boolean) (list string) string src object -> boolean
|
||||
(define (check-by test act comp info meth src test-obj)
|
||||
(let* ([fail? #f]
|
||||
[test (with-handlers ([exn?
|
||||
(lambda (e)
|
||||
(set! fail? #t)
|
||||
(list exception e "eval"))])
|
||||
(test))]
|
||||
[result (with-handlers ([exn?
|
||||
(lambda (e)
|
||||
(set! fail? #t)
|
||||
(list exception e "comp"))])
|
||||
(and (not fail?)
|
||||
(comp test act)))]
|
||||
[values-list (list act test meth result)])
|
||||
(if (in-check-mutate?)
|
||||
(stored-checks (cons (list (and (not fail?) result) 'check-by info values-list src) (stored-checks)))
|
||||
(report-check-result (and (not fail?) result) 'check-by info values-list src test-obj))
|
||||
(and (not fail?) result)))
|
||||
|
||||
;check-mutate: (-> val) (-> boolean) (list string) src object -> boolean
|
||||
(define (check-mutate mutatee check info src test-obj)
|
||||
|
|
@ -311,39 +333,61 @@
|
|||
|
||||
(define (compose-message test-obj check-kind info values mutate-message)
|
||||
(letrec ((test-format (construct-info-msg info))
|
||||
(exception-raised? #f)
|
||||
(eval-exception-raised? #f)
|
||||
(comp-exception-raised? #f)
|
||||
(exception-not-error? #f)
|
||||
(formatted-values (map (lambda (v)
|
||||
(if (and (pair? v) (eq? (car v) exception))
|
||||
(begin (set! exception-raised? #t)
|
||||
(set! exception-not-error? (cadr v))
|
||||
(send test-obj format-value (caddr v)))
|
||||
(send test-obj format-value v))) values))
|
||||
(cond
|
||||
[(and (pair? v) (eq? (car v) exception))
|
||||
(if (equal? (cadddr v) "eval")
|
||||
(set! eval-exception-raised? #t)
|
||||
(set! comp-exception-raised? #t))
|
||||
(set! exception-not-error? (cadr v))
|
||||
(send test-obj format-value (caddr v))]
|
||||
[else (send test-obj format-value v)])) values))
|
||||
(expected-format
|
||||
(case check-kind
|
||||
((check-expect) "to produce ")
|
||||
((check-expect check-by) "to produce ")
|
||||
((check-catch) "to throw an instance of "))))
|
||||
(append (list (if mutate-message mutate-message "check expected ")
|
||||
test-format
|
||||
expected-format
|
||||
(first formatted-values))
|
||||
(case check-kind
|
||||
((check-expect)
|
||||
(append (if (= (length formatted-values) 3)
|
||||
(list ", within " (third formatted-values))
|
||||
null)
|
||||
(cond
|
||||
[(and exception-raised? (not exception-not-error?))
|
||||
(list ", instead a " (second formatted-values) " exception occurred")]
|
||||
[(and exception-raised? exception-not-error?)
|
||||
(list", instead an error occured")]
|
||||
[else
|
||||
(list ", instead found " (second formatted-values))])))
|
||||
((check-catch)
|
||||
(if (= (length formatted-values) 1)
|
||||
(list ", instead no exceptions occured")
|
||||
(list ", instead an instance of " (second formatted-values) " was thrown"))))
|
||||
(list "."))))
|
||||
(cond
|
||||
[(not (eq? 'check-by check-kind))
|
||||
(append (list (if mutate-message mutate-message "check expected ")
|
||||
test-format
|
||||
expected-format
|
||||
(first formatted-values))
|
||||
(case check-kind
|
||||
((check-expect)
|
||||
(append (if (= (length formatted-values) 3)
|
||||
(list ", within " (third formatted-values))
|
||||
null)
|
||||
(cond
|
||||
[(and eval-exception-raised? (not exception-not-error?))
|
||||
(list ", instead a " (second formatted-values) " exception occurred")]
|
||||
[(and eval-exception-raised? exception-not-error?)
|
||||
(list", instead an error occurred")]
|
||||
[else
|
||||
(list ", instead found " (second formatted-values))])))
|
||||
((check-catch)
|
||||
(if (= (length formatted-values) 1)
|
||||
(list ", instead no exceptions occurred")
|
||||
(list ", instead an instance of " (second formatted-values) " was thrown"))))
|
||||
(list "."))]
|
||||
[(and (eq? check-kind 'check-by)
|
||||
comp-exception-raised?)
|
||||
(list "check encountered a " (fourth formatted-values)
|
||||
" exception when using " (third formatted-values)
|
||||
" to compare the actual value " (second formatted-values)
|
||||
" with the expected result " (first formatted-values) ".")]
|
||||
[(and (eq? check-kind 'check-by) eval-exception-raised?)
|
||||
(list "check expected a value to use in " (third formatted-values)
|
||||
" with argument " (first formatted-values)
|
||||
" instead, a " (second formatted-values)
|
||||
" exception occurred.")]
|
||||
[else
|
||||
(list "check received the value " (second formatted-values)
|
||||
" to compare to " (first formatted-values)
|
||||
" using " (third formatted-values)
|
||||
". This value did not match the expectation.")])))
|
||||
|
||||
;construct-info-msg (list symbol string ...) -> string
|
||||
(define (construct-info-msg info)
|
||||
|
|
|
|||
|
|
@ -1028,7 +1028,11 @@
|
|||
[(check ConditionalExpression expect ConditionalExpression within ConditionalExpression)
|
||||
(make-check-expect #f (build-src 6) $2 $4 $6 (build-src 2 4))]
|
||||
[(check ConditionalExpression catch Type)
|
||||
(make-check-catch #f (build-src 4) $2 $4)])
|
||||
(make-check-catch #f (build-src 4) $2 $4)]
|
||||
[(check ConditionalExpression expect ConditionalExpression by ==)
|
||||
(make-check-by #f (build-src 6) $2 $4 '==)]
|
||||
[(check ConditionalExpression expect ConditionalExpression by IDENTIFIER)
|
||||
(make-check-by #f (build-src 6) $2 $4 $6)])
|
||||
|
||||
(MutateExpression
|
||||
[(CheckExpression) $1]
|
||||
|
|
|
|||
|
|
@ -44,7 +44,7 @@
|
|||
const for new switch
|
||||
continue goto package synchronized))
|
||||
|
||||
(define-empty-tokens ExtraKeywords (dynamic check expect within -> ->> ->>> test tests testcase))
|
||||
(define-empty-tokens ExtraKeywords (dynamic check expect within by -> ->> ->>> test tests testcase))
|
||||
|
||||
(define-tokens java-vals
|
||||
(STRING_LIT CHAR_LIT INTEGER_LIT LONG_LIT FLOAT_LIT DOUBLE_LIT
|
||||
|
|
@ -317,7 +317,7 @@
|
|||
((test-ext?) (string->symbol lexeme))
|
||||
(else (token-IDENTIFIER lexeme))))
|
||||
|
||||
((re:or "test" "tests" "testcase")
|
||||
((re:or "test" "tests" "testcase" "by")
|
||||
(cond
|
||||
((testcase-ext?) (string->symbol lexeme))
|
||||
(else (token-IDENTIFIER lexeme))))
|
||||
|
|
|
|||
|
|
@ -2938,6 +2938,10 @@
|
|||
((check-catch? expr) (translate-check-catch (check-catch-test expr)
|
||||
(check-catch-exn expr)
|
||||
(expr-src expr)))
|
||||
((check-by? expr) (translate-check-by (check-by-test expr)
|
||||
(check-by-actual expr)
|
||||
(check-by-compare expr)
|
||||
(expr-src expr)))
|
||||
((check-mutate? expr) (translate-check-mutate (check-mutate-mutate expr)
|
||||
(check-mutate-check expr)
|
||||
(expr-src expr)))))
|
||||
|
|
@ -2968,6 +2972,29 @@
|
|||
(lambda () #f)))
|
||||
(build-src src))))
|
||||
|
||||
;translate-check-by: expression expression (U '== method-record) src -> syntax
|
||||
(define (translate-check-by test actual comp src)
|
||||
(let ([t (create-syntax #f `(lambda () ,(translate-expression test)) #f)]
|
||||
[a (translate-expression actual)]
|
||||
[info (checked-info test)])
|
||||
(make-syntax #f
|
||||
`(javaRuntime:check-by ,t ,a
|
||||
,(if (method-record? comp)
|
||||
(create-syntax #f `(lambda (test-v a)
|
||||
(send test-v
|
||||
,(build-identifier
|
||||
(mangle-method-name
|
||||
(method-record-name comp)
|
||||
(method-record-atypes comp)))
|
||||
a))
|
||||
(build-src src))
|
||||
'eq?)
|
||||
,info
|
||||
,(if (method-record? comp) (method-record-name comp) "==")
|
||||
,src
|
||||
(namespace-variable-value 'current~test~object% #f (lambda () #f)))
|
||||
(build-src src))))
|
||||
|
||||
;translate-check-mutate: expression expression src -> syntax
|
||||
(define (translate-check-mutate mutatee check src)
|
||||
(let ((t (create-syntax #f `(lambda () ,(translate-expression mutatee)) #f))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user