suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Correction to behavior of instanceof and check

Browse Source 
svn: r3691
This commit is contained in:
Kathy Gray 2006-07-12 19:27:08 +00:00
parent 1c46dde5dc
commit 36f7613855
3 changed files with 37 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/profj/check.ss
View File

@ -2602,6 +2602,7 @@
(is-eq-subclass? type exp-type type-recs) (is-eq-subclass? type exp-type type-recs)
(implements? exp-type type type-recs) (implements? exp-type type type-recs)
(implements? type exp-type type-recs))) 'boolean) (implements? type exp-type type-recs))) 'boolean)
((and (ref-type? type) (eq? 'null exp-type)) 'boolean)
((and (ref-type? exp-type) (ref-type? type)) ((and (ref-type? exp-type) (ref-type? type))
(instanceof-error 'not-related-type type exp-type src)) (instanceof-error 'not-related-type type exp-type src))
((ref-type? exp-type) ((ref-type? exp-type)

43
collects/profj/libs/java/runtime.scm
View File

@ -202,12 +202,14 @@
(define in-check-mutate? (make-parameter #f)) (define in-check-mutate? (make-parameter #f))
(define stored-checks (make-parameter null)) (define stored-checks (make-parameter null))
;compare: val val (list symbol string ...) string (U #f object)-> boolean ;compare: val val (list symbol string ...) string (U #f object) boolean-> boolean
(define (compare test act info src test-obj) (define (compare test act info src test-obj catch?)
(compare-within test act 0.0 info src test-obj #f)) (compare-within test act 0.0 info src test-obj catch? #f))
;compare-within: (-> val) val val (list symbol string) (U #f object) . boolean -> boolean (define exception (gensym 'exception))
(define (compare-within test act range info src test-obj . within?)
;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?)
(letrec ((java-equal? (letrec ((java-equal?
(lambda (v1 v2 visited-v1 visited-v2) (lambda (v1 v2 visited-v1 visited-v2)
(or (eq? v1 v2) (or (eq? v1 v2)
@ -241,9 +243,16 @@
(map (lambda (v) (cons v1 visited-v1)) v1-fields) (map (lambda (v) (cons v1 visited-v1)) v1-fields)
(map (lambda (v) (cons v2 visited-v2)) v2-fields))))))))) (map (lambda (v) (cons v2 visited-v2)) v2-fields)))))))))
((and (not (object? v1)) (not (object? v2))) (equal? v1 v2)) ((and (not (object? v1)) (not (object? v2))) (equal? v1 v2))
(else #f)))))) (else #f)))))
(set! test (test)) (fail? #f))
(let ([res (java-equal? test act null null)] (set! test
(with-handlers ((exn?
(lambda (e) (if catch?
(begin (set! fail? #t)
(list exception e))
(raise e)))))
(test)))
(let ([res (if fail? #f (java-equal? test act null null))]
[values-list (append (list act test) (if (null? within?) (list range) null))]) [values-list (append (list act test) (if (null? within?) (list range) null))])
(if (in-check-mutate?) (if (in-check-mutate?)
(stored-checks (cons (list res 'check-expect info values-list src) (stored-checks))) (stored-checks (cons (list res 'check-expect info values-list src) (stored-checks)))
@ -302,8 +311,13 @@
src)))) src))))
(define (compose-message test-obj check-kind info values mutate-message) (define (compose-message test-obj check-kind info values mutate-message)
(let ((test-format (construct-info-msg info)) (letrec ((test-format (construct-info-msg info))
(formatted-values (map (lambda (v) (send test-obj format-value v)) values)) (exception-raised? #f)
(formatted-values (map (lambda (v)
(if (and (pair? v) (eq? (car v) exception))
(begin (set! exception-raised? #t)
(send test-obj format-value (cadr v)))
(send test-obj format-value v))) values))
(expected-format (expected-format
(case check-kind (case check-kind
((check-expect) "to produce ") ((check-expect) "to produce ")
@ -314,9 +328,12 @@
(first formatted-values)) (first formatted-values))
(case check-kind (case check-kind
((check-expect) ((check-expect)
(if (= (length formatted-values) 3) (append (if (= (length formatted-values) 3)
(list ", within " (third formatted-values) ", instead found " (second formatted-values)) (list ", within " (third formatted-values))
(list ", instead found" (second formatted-values)))) null)
(if exception-raised?
(list ", instead a " (second formatted-values) " exception occurred")
(list ", instead found " (second formatted-values)))))
((check-catch) ((check-catch)
(if (= (length formatted-values) 1) (if (= (length formatted-values) 1)
(list ", instead no exceptions occured") (list ", instead no exceptions occured")

3
collects/profj/to-scheme.ss
View File

@ -2935,7 +2935,8 @@
,@(if range (list t a r) (list t a)) ,@(if range (list t a r) (list t a))
,extracted-info ,src ,extracted-info ,src
(namespace-variable-value 'current~test~object% #f (namespace-variable-value 'current~test~object% #f
(lambda () #f))) (lambda () #f))
,(testcase-ext?))
(build-src src)))) (build-src src))))
;translate-check-catch: expression type-spec src -> syntax ;translate-check-catch: expression type-spec src -> syntax