From ccd1337e310ace6eea15fc2d87d8fb7f11a1d69c Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 2 May 2008 17:20:05 +0000 Subject: [PATCH] Use syntax-loc in tests. Don't check that effects match, since they may involve identifiers. Fix tests for correct type names, Integer. svn: r9595 --- .../typed-scheme/succeed/apply-append.ss | 4 ++ .../typed-scheme/unit-tests/test-utils.ss | 19 ++++++-- .../unit-tests/typecheck-tests.ss | 48 +++++++++---------- 3 files changed, 42 insertions(+), 29 deletions(-) create mode 100644 collects/tests/typed-scheme/succeed/apply-append.ss diff --git a/collects/tests/typed-scheme/succeed/apply-append.ss b/collects/tests/typed-scheme/succeed/apply-append.ss new file mode 100644 index 0000000000..9393072675 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/apply-append.ss @@ -0,0 +1,4 @@ +#lang typed-scheme + +(apply append '((1 2 3) (4 5 6))) +(apply append (list (list 1 2 3) (list 4 5 6))) \ No newline at end of file diff --git a/collects/tests/typed-scheme/unit-tests/test-utils.ss b/collects/tests/typed-scheme/unit-tests/test-utils.ss index 834556249b..49c24dae50 100644 --- a/collects/tests/typed-scheme/unit-tests/test-utils.ss +++ b/collects/tests/typed-scheme/unit-tests/test-utils.ss @@ -15,11 +15,12 @@ (string->symbol (string-append "typed-scheme/private/" - (symbol->string (syntax-e id)))))) + (symbol->string (syntax-e id)))) + id id)) (syntax->list #'(id ...)))]) - #`(combine-in id* ...))]))) + (syntax/loc stx (combine-in id* ...)))]))) -(require (private planet-requires type-comparison utils)) +(require (private planet-requires type-comparison utils type-utils)) (require (schemeunit)) @@ -47,12 +48,20 @@ (values (lambda () (run tmps ...)) (lambda () (run/gui tmps ...))))))])) +;; FIXME - check that effects are equal +(define (tc-result-equal/test? a b) + (match* (a b) + [((tc-result: t1 thn1 els1) (tc-result: t2 thn2 els2)) + (and (type-equal? t1 t2) + (= (length thn1) (length thn2)) + (= (length els1) (length els2)))])) + (define-syntax (check-type-equal? stx) (syntax-case stx () [(_ nm a b) - #`(test-check nm type-equal? a b)])) + (syntax/loc stx (test-check nm type-equal? a b))])) (define-syntax (check-tc-result-equal? stx) (syntax-case stx () [(_ nm a b) - #`(test-check nm tc-result-equal? a b)])) + (syntax/loc stx (test-check nm tc-result-equal/test? a b))])) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss index c5f43ffa1b..f2ab5a97ec 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss @@ -39,11 +39,11 @@ ;; check that an expression typechecks correctly (define-syntax (tc-e stx) (syntax-case stx () - [(_ expr ty) #'(tc-e expr ty (list) (list))] + [(_ expr ty) (syntax/loc stx (tc-e expr ty (list) (list)))] [(_ expr ty eff1 eff2) - #`(check-tc-result-equal? (format "~a" 'expr) - (tc-expr/expand expr) - (ret ty eff1 eff2))])) + (syntax/loc stx (check-tc-result-equal? (format "~a" 'expr) + (tc-expr/expand expr) + (ret ty eff1 eff2)))])) (require (for-syntax syntax/kerncase)) @@ -58,12 +58,12 @@ [e (local-expand #'e 'expression '())]))) ;; check that typechecking this expression fails -(define-syntax (tc-err stx) - (syntax-case stx () +(define-syntax tc-err + (syntax-rules () [(_ expr) - #'(test-exn (format "~a" 'expr) - exn:fail:syntax? - (lambda () (tc-expr/expand expr)))])) + (test-exn (format "~a" 'expr) + exn:fail:syntax? + (lambda () (tc-expr/expand expr)))])) (define (typecheck-tests) @@ -102,7 +102,7 @@ [tc-e '(#t #f) (-lst* (-val #t) (-val #f))] [tc-e (plambda: (a) ([l : (Listof a)]) (car l)) (make-Poly '(a) (-> (make-Listof (-v a)) (-v a)))] - [tc-e #{(lambda: ([l : (list-of a)]) (car l)) PROP typechecker:plambda (a)} + [tc-e #{(lambda: ([l : (Listof a)]) (car l)) PROP typechecker:plambda (a)} (make-Poly '(a) (-> (make-Listof (-v a)) (-v a)))] [tc-e (case-lambda: [([a : Number] [b : Number]) (+ a b)]) (-> N N N)] [tc-e (let: ([x : Number 5]) x) N (-vet #'x) (-vef #'x)] @@ -112,7 +112,7 @@ [tc-e (values 3) -Integer] [tc-e (values) (-values (list))] [tc-e (values 3 #f) (-values (list -Integer (-val #f)))] - [tc-e (map #{values : (symbol -> symbol)} '(a b c)) (make-Listof Sym)] + [tc-e (map #{values @ Symbol} '(a b c)) (make-Listof Sym)] [tc-e (letrec: ([fact : (Number -> Number) (lambda: ([n : Number]) (if (zero? n) 1 (* n (fact (- n 1)))))]) (fact 20)) N] @@ -172,10 +172,10 @@ (when (boolean? x) #t)) -Void] - [tc-e (let: ([x : Sexp 3]) + [tc-e (let: ([x : Any 3]) (if (list? x) (begin (car x) 1) 2)) - N] + -Integer] [tc-e (let: ([x : (U Number Boolean) 3]) @@ -218,8 +218,8 @@ (string-append "foo" (a v)))) -String] - [tc-e (apply (plambda: (a) [x : a] x) '(5)) (-lst N)] - [tc-e (apply append (list '(1 2 3) '(4 5 6))) (-lst N)] + [tc-e (apply (plambda: (a) [x : a] x) '(5)) (-lst -Integer)] + [tc-e (apply append (list '(1 2 3) '(4 5 6))) (-lst -Integer)] [tc-err ((case-lambda: [([x : Number]) x] [([y : Number] [x : Number]) x]) @@ -294,11 +294,11 @@ [tc-e (let* ([sym 'squarf] [x (if (= 1 2) 3 sym)]) (if (equal? x sym) 3 x)) - N] + -Integer] [tc-e (let* ([sym 'squarf] [x (if (= 1 2) 3 sym)]) (if (equal? sym x) 3 x)) - N] + -Integer] [tc-e (let: ([x : (Listof Symbol)'(a b c)]) (cond [(memq 'a x) => car] @@ -327,7 +327,7 @@ (error 'foo))) (-pair Univ (-lst Univ))] - ;[tc-e (cadr (cadr (list 1 (list 1 2 3) 3))) N] + [tc-e (cadr (cadr (list 1 (list 1 2 3) 3))) -Integer] @@ -339,10 +339,10 @@ [tc-e (let: ([x : Any 1]) (and x (boolean? x))) B (list (-rem (-val #f) #'x) (-rest B #'x)) (list)] - [tc-e (let: ([x : Sexp 3]) - (if (and (list? x) (not (null? x))) + [tc-e (let: ([x : Any 3]) + (if (and (list? x) (not (null? x))) (begin (car x) 1) 2)) - N] + -Integer] ;; set! tests [tc-e (let: ([x : Any 3]) @@ -394,7 +394,7 @@ [tc-e (let* ([z 1] [p? (lambda: ([x : Any]) (number? z))]) (lambda: ([x : Any]) (if (p? x) 11 12))) - (-> Univ N)] + (-> Univ -Integer)] [tc-e (let* ([z 1] [p? (lambda: ([x : Any]) (number? z))]) (lambda: ([x : Any]) (if (p? x) x 12))) @@ -461,7 +461,7 @@ [tc-e (let ([app apply] [f (lambda: [x : Number] 3)]) (app f (list 1 2 3))) - N] + -Integer] [tc-e ((lambda () (call/cc (lambda: ([k : (Number -> (U))]) (if (read) 5 (k 10)))))) N] @@ -539,7 +539,7 @@ [tc-err (let: ([x : Number #f]) (+ 1 x))] [tc-err - (let: ([x : Sexp '(foo)]) + (let: ([x : Any '(foo)]) (if (null? x) 1 (if (list? x) (add1 x)