From 5a8bc6fabb684b09e847535c170a8105ae596479 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 5 Jun 2008 21:42:44 +0000 Subject: [PATCH] Add new tests. Fix old tests for new Struct datatype. svn: r10161 --- .../typed-scheme/succeed/int-def-colon.ss | 10 ++++++++++ .../tests/typed-scheme/succeed/module-lang.ss | 18 ++++++++++++++++++ .../typed-scheme/succeed/provide-struct.ss | 16 ++++++++++++++++ .../tests/typed-scheme/succeed/require-poly.ss | 3 +++ .../tests/typed-scheme/succeed/simple-poly.ss | 5 +++++ .../tests/typed-scheme/succeed/struct-cert.ss | 16 ++++++++++++++++ .../typed-scheme/unit-tests/subtype-tests.ss | 8 ++++---- .../unit-tests/type-equal-tests.ss | 6 ++++-- 8 files changed, 76 insertions(+), 6 deletions(-) create mode 100644 collects/tests/typed-scheme/succeed/int-def-colon.ss create mode 100644 collects/tests/typed-scheme/succeed/module-lang.ss create mode 100644 collects/tests/typed-scheme/succeed/provide-struct.ss create mode 100644 collects/tests/typed-scheme/succeed/require-poly.ss create mode 100644 collects/tests/typed-scheme/succeed/simple-poly.ss create mode 100644 collects/tests/typed-scheme/succeed/struct-cert.ss diff --git a/collects/tests/typed-scheme/succeed/int-def-colon.ss b/collects/tests/typed-scheme/succeed/int-def-colon.ss new file mode 100644 index 0000000000..991b709c74 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/int-def-colon.ss @@ -0,0 +1,10 @@ +#lang typed-scheme + +(define-type-alias Int Integer) + +(: foo (Int -> Int)) +(define (foo) + (: loop (Int -> Int)) + (define (loop x) + (loop x)) + (loop 0)) \ No newline at end of file diff --git a/collects/tests/typed-scheme/succeed/module-lang.ss b/collects/tests/typed-scheme/succeed/module-lang.ss new file mode 100644 index 0000000000..3b47b96be0 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/module-lang.ss @@ -0,0 +1,18 @@ +#lang scheme/load + +(module m typed-scheme + (: f (All (a) (a -> a))) + (define (f x) x) + (provide f)) + +(module n typed-scheme + (require 'm)) + +(require typed-scheme) + +(require 'n) + +(current-namespace (module->namespace ''n)) + +(f 1) + diff --git a/collects/tests/typed-scheme/succeed/provide-struct.ss b/collects/tests/typed-scheme/succeed/provide-struct.ss new file mode 100644 index 0000000000..ad29cb5244 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/provide-struct.ss @@ -0,0 +1,16 @@ +#lang scheme/load + + +(module m typed-scheme + (define-typed-struct A ()) + (define-typed-struct (x A) ([y : Number] [z : Boolean])) + (: foo (x -> Number)) + (define (foo z) 1) + (provide (all-defined-out))) + +(module n scheme + (require (prefix-in m: 'm)) + (m:foo (m:make-x 1 #f)) + m:x?) + +(require 'n) \ No newline at end of file diff --git a/collects/tests/typed-scheme/succeed/require-poly.ss b/collects/tests/typed-scheme/succeed/require-poly.ss new file mode 100644 index 0000000000..5c12f98fb1 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/require-poly.ss @@ -0,0 +1,3 @@ +#lang typed-scheme + +(require "simple-poly.ss") \ No newline at end of file diff --git a/collects/tests/typed-scheme/succeed/simple-poly.ss b/collects/tests/typed-scheme/succeed/simple-poly.ss new file mode 100644 index 0000000000..d4e8db726b --- /dev/null +++ b/collects/tests/typed-scheme/succeed/simple-poly.ss @@ -0,0 +1,5 @@ +(module simple-poly typed-scheme + (: f (All (a) (a -> a))) + (define (f x) x) + (define: z : Any 2) + (provide f)) \ No newline at end of file diff --git a/collects/tests/typed-scheme/succeed/struct-cert.ss b/collects/tests/typed-scheme/succeed/struct-cert.ss new file mode 100644 index 0000000000..f0317d1a53 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/struct-cert.ss @@ -0,0 +1,16 @@ +#lang scheme/load + +(module for-broken typed-scheme + + (define-typed-struct type ()) + + (provide (all-defined-out))) + +(module broken typed-scheme + + (require (prefix-in t: 'for-broken)) + (define-typed-struct binding ([type : t:type])) + ;; Comment out the below and it works fine. + (provide (all-defined-out))) + +(require 'broken) \ No newline at end of file diff --git a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss index 6b1082f619..2f8f450679 100644 --- a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss @@ -110,10 +110,10 @@ (cl-> [() (-pair N (-v b))] [(N) (-pair N (-v b))])] - [(-poly (a) ((Un (-base 'foo) (-struct 'bar #f (list N a) #f)) . -> . (-lst a))) - ((Un (-base 'foo) (-struct 'bar #f (list N (-pair N (-v a))) #f)) . -> . (-lst (-pair N (-v a))))] - [(-poly (a) ((-struct 'bar #f (list N a) #f) . -> . (-lst a))) - ((-struct 'bar #f (list N (-pair N (-v a))) #f) . -> . (-lst (-pair N (-v a))))] + [(-poly (a) ((Un (-base 'foo) (-struct 'bar #f (list N a) #f #f #f values)) . -> . (-lst a))) + ((Un (-base 'foo) (-struct 'bar #f (list N (-pair N (-v a))) #f #f #f values)) . -> . (-lst (-pair N (-v a))))] + [(-poly (a) ((-struct 'bar #f (list N a) #f #f #f values) . -> . (-lst a))) + ((-struct 'bar #f (list N (-pair N (-v a))) #f #f #f values) . -> . (-lst (-pair N (-v a))))] [(-poly (a) (a . -> . (make-Listof a))) ((-v b) . -> . (make-Listof (-v b)))] [(-poly (a) (a . -> . (make-Listof a))) ((-pair N (-v b)) . -> . (make-Listof (-pair N (-v b))))] diff --git a/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss b/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss index 0e04a22189..6488d47b16 100644 --- a/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss @@ -33,9 +33,11 @@ [(-poly (x) (-> (Un Sym N) x)) (-poly (xyz) (-> (Un N Sym) xyz))] [(-mu x (Un N Sym x)) (-mu y (Un N Sym y))] ;; found bug - [FAIL (Un (-mu heap-node (-struct 'heap-node #f (list (-base 'comparator) N (-v a) (Un heap-node (-base 'heap-empty))) #f)) + [FAIL (Un (-mu heap-node + (-struct 'heap-node #f (list (-base 'comparator) N (-v a) (Un heap-node (-base 'heap-empty))) #f #f #f values)) (-base 'heap-empty)) - (Un (-mu heap-node (-struct 'heap-node #f (list (-base 'comparator) N (-pair N N) (Un heap-node (-base 'heap-empty))) #f)) + (Un (-mu heap-node + (-struct 'heap-node #f (list (-base 'comparator) N (-pair N N) (Un heap-node (-base 'heap-empty))) #f #f #f values)) (-base 'heap-empty))]))