From 9252ba3bc3e4ddf3ca3de99765d525d063a4e865 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Fri, 24 Jun 2011 11:20:13 -0400 Subject: [PATCH] TR: Added tests for new identifiers and export type names. original commit: 0f0b9ebc7a01df4e4d7c079040b0ab0ddaaa05a9 --- .../typed-scheme/succeed/places-helper.rkt | 13 ++ .../tests/typed-scheme/succeed/places.rkt | 19 +++ .../unit-tests/typecheck-tests.rkt | 128 ++++++++++++++++++ collects/typed-scheme/base-env/base-env.rkt | 77 +++++++---- collects/typed-scheme/base-env/base-types.rkt | 17 ++- collects/typed-scheme/types/abbrev.rkt | 11 +- 6 files changed, 233 insertions(+), 32 deletions(-) create mode 100644 collects/tests/typed-scheme/succeed/places-helper.rkt create mode 100644 collects/tests/typed-scheme/succeed/places.rkt diff --git a/collects/tests/typed-scheme/succeed/places-helper.rkt b/collects/tests/typed-scheme/succeed/places-helper.rkt new file mode 100644 index 00000000..012740dd --- /dev/null +++ b/collects/tests/typed-scheme/succeed/places-helper.rkt @@ -0,0 +1,13 @@ +#lang typed/racket/no-check + +(provide double-place echo-place) + + +(: double-place (Place-Channel -> Void)) +(define (double-place pch) + (place-channel-put pch (* 2 (place-channel-get pch)))) + + +(: echo-place (Place-Channel -> Void)) +(define (echo-place pch) + (place-channel-put pch (place-channel-get pch))) diff --git a/collects/tests/typed-scheme/succeed/places.rkt b/collects/tests/typed-scheme/succeed/places.rkt new file mode 100644 index 00000000..9b0cdd98 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/places.rkt @@ -0,0 +1,19 @@ +#lang typed/racket + +(: p Place) +(: p2 Place) +(: p3 Place) + +(define p (dynamic-place 'tests/typed-scheme/succeed/places-helper 'double-place)) +(place-channel-put/get p 10) +(place-wait p) + + +(define p2 (dynamic-place 'tests/typed-scheme/succeed/places-helper 'double-place)) +(place-channel-put/get p2 -2+4i) +(place-wait p2) + + +(define p3 (dynamic-place 'tests/typed-scheme/succeed/places-helper 'echo-place)) +(place-channel-put/get p3 'echo-this) +(place-wait p3) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt index f460d34e..e758c07a 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt @@ -1224,6 +1224,134 @@ (tc-e (udp-addresses (udp-open-socket) #f) (list -String -String)) (tc-e (udp-addresses (udp-open-socket) #t) (list -String -NonNegFixnum -String -NonNegFixnum)) + ;Byte converters + (tc-e (bytes-open-converter "UTF-8" "UTF-8") (-opt -Bytes-Converter)) + (tc-e (let () + (define: c : Bytes-Converter (assert (bytes-open-converter "UTF-8" "UTF-8"))) + (bytes-convert c #"abcde")) (list -Bytes -Nat (one-of/c 'complete 'continues 'aborts 'error))) + (tc-e (let () + (define: c : Bytes-Converter (assert (bytes-open-converter "UTF-8" "UTF-8"))) + (bytes-convert c #"abcde" 0 5 (make-bytes 10))) (list -Nat -Nat (one-of/c 'complete 'continues 'aborts 'error))) + + (tc-e (let () + (define: c : Bytes-Converter (assert (bytes-open-converter "UTF-8" "UTF-8"))) + (bytes-convert-end c)) (list -Bytes (one-of/c 'complete 'continues))) + + (tc-e (let () + (define: c : Bytes-Converter (assert (bytes-open-converter "UTF-8" "UTF-8"))) + (bytes-convert-end c (make-bytes 10))) (list -Nat (one-of/c 'complete 'continues))) + + ;Subprocess + (tc-e (subprocess #f #f #f (string->path "/usr/bin/echo") "string" (string->path "path") #"bytes") + (list + -Subprocess + (-opt -Input-Port) + (-opt -Output-Port) + (-opt -Input-Port))) + + (tc-e (subprocess #f #f #f (string->path "/usr/bin/echo") 'exact "arg") + (list + -Subprocess + (-opt -Input-Port) + (-opt -Output-Port) + (-opt -Input-Port))) + + (tc-e (let () + (: p Subprocess) + (: std-out (Option Input-Port)) + (: std-in (Option Output-Port)) + (: std-err (Option Input-Port)) + (define-values (p std-out std-in std-err) + (subprocess #f #f #f (string->path "/bin/bash"))) + (subprocess? p)) + #:ret (ret B (-FS -top -bot))) + + ;Compilation + (tc-e (compile-syntax #'(+ 1 2)) -Compiled-Expression) + (tc-e (let: ((e : Compiled-Expression (compile #'(+ 1 2)))) + (compiled-expression? e)) + #:ret (ret B (-FS -top -bot))) + (tc-e (let: ((e : Compiled-Expression (compile #'(module + racket 2)))) + (compiled-module-expression? e)) B) + + ;Impersonator Property + (tc-e (make-impersonator-property 'prop) (list -Impersonator-Property (t:-> Univ B) (t:-> Univ Univ))) + (tc-e (let-values: ((((prop : Impersonator-Property) (pred : (Any -> Any)) (acc : (Any -> Any))) + (make-impersonator-property 'prop))) + (impersonator-property? prop)) + #:ret (ret B (-FS -top -bot))) + + ;Security Guards + (tc-e (make-security-guard (current-security-guard) (lambda args (void)) (lambda args (void))) -Security-Guard) + (tc-e (let: ((s : Security-Guard (current-security-guard))) + (security-guard? s)) + #:ret (ret B (-FS -top -bot))) + + + ;Custodians + (tc-e (make-custodian) -Custodian) + (tc-e (let: ((c : Custodian (current-custodian))) + (custodian? c)) + #:ret (ret B (-FS -top -bot))) + (tc-e (let: ((c : (CustodianBoxof Integer) (make-custodian-box (current-custodian) 1))) + (custodian-box-value c)) -Int) + + ;Thread Groups + (tc-e (make-thread-group) -Thread-Group) + (tc-e (let: ((tg : Thread-Group (current-thread-group))) + (thread-group? tg)) + #:ret (ret B (-FS -top -bot))) + + + ;Inspector + (tc-e (make-inspector) -Inspector) + (tc-e (let: ((i : Inspector (current-inspector))) + (inspector? i)) + #:ret (ret B (-FS -top -bot))) + + ;Continuation Prompt Tags ang Continuation Mark Sets + (tc-e (default-continuation-prompt-tag) -Prompt-Tag) + (tc-e (let: ((pt : Prompt-Tag (make-continuation-prompt-tag))) + (continuation-marks #f pt)) -Cont-Mark-Set) + (tc-e (let: ((set : Continuation-Mark-Set (current-continuation-marks))) + (continuation-mark-set? set)) #:ret (ret B (-FS -top -bot))) + + ;Logging + (tc-e (make-logger 'name) -Logger) + (tc-e (let: ((l : Logger (make-logger))) + (let: ((lr : Log-Receiver (make-log-receiver l 'error))) + (log-message l 'error "Message" 'value))) -Void) + + ;Semaphores + (tc-e (make-semaphore) -Semaphore) + (tc-e (let: ((s : Semaphore (make-semaphore 3))) + (semaphore-post s)) -Void) + + ;Random Numbers + (tc-e (make-pseudo-random-generator) -Pseudo-Random-Generator) + (tc-e (let: ((pg : Pseudo-Random-Generator (make-pseudo-random-generator))) + (pseudo-random-generator->vector pg)) (make-HeterogenousVector (list -PosInt -PosInt -PosInt -PosInt -PosInt -PosInt))) + + ;Structure Type Properties + (tc-e (make-struct-type-property 'prop) (list -Struct-Type-Property (t:-> Univ B) (t:-> Univ Univ))) + (tc-e (let-values: ((((prop : Struct-Type-Property) (pred : (Any -> Any)) (acc : (Any -> Any))) + (make-struct-type-property 'prop))) + (struct-type-property? prop)) + #:ret (ret B (-FS -top -bot))) + + ;Wills + (tc-e (make-will-executor) -Will-Executor) + (tc-e (let: ((w : Will-Executor (make-will-executor))) + (will-register w 'a (lambda: ((s : Symbol)) (void))) + (will-execute w)) ManyUniv) + + ;Promises + ;For some reason they are failing in the test suite + #| + (tc-e (delay 's) (-Promise -Symbol)) + (tc-e (let: ((p : (Promise Symbol) (delay 's))) + (promise-running? p)) B) + |# ) diff --git a/collects/typed-scheme/base-env/base-env.rkt b/collects/typed-scheme/base-env/base-env.rkt index c1ae3cf4..1b957afd 100644 --- a/collects/typed-scheme/base-env/base-env.rkt +++ b/collects/typed-scheme/base-env/base-env.rkt @@ -1040,31 +1040,52 @@ -[bytes-open-converter (-> -String -String -BytesConverter)] -[bytes-close-converter (-> -BytesConverter -Void)] +[bytes-open-converter (-> -String -String (-opt -Bytes-Converter))] +[bytes-close-converter (-> -Bytes-Converter -Void)] [bytes-convert - (->opt -BytesConverter - -Bytes - [-Nat + (cl->* + (->opt -Bytes-Converter + -Bytes + [-Nat + -Nat + (-val #f) + -Nat + (-opt -Nat)] + (-values (list + -Bytes + -Nat + (Un (-val 'complete) (-val 'continues) (-val 'aborts) (-val 'error))))) + + (->opt -Bytes-Converter + -Bytes -Nat - (-opt -Bytes) -Nat - (-opt -Nat)] - (-values (list - (Un -Bytes -Nat) - -Nat - (Un (-val 'complete) (-val 'continues) (-val 'aborts) (-val 'error)))))] + -Bytes + [-Nat + (-opt -Nat)] + (-values (list + -Nat + -Nat + (Un (-val 'complete) (-val 'continues) (-val 'aborts) (-val 'error))))))] [bytes-convert-end - (->opt -BytesConverter - [(-opt -Bytes) - -Nat - (-opt -Nat)] - (-values (list - (Un -Bytes -Nat) - (Un (-val 'complete) (-val 'continues)))))] + (cl->* + (->opt -Bytes-Converter + [(-val #f) + -Nat + (-opt -Nat)] + (-values (list + -Bytes + (Un (-val 'complete) (-val 'continues))))) + (->opt -Bytes-Converter + -Bytes + [-Nat + (-opt -Nat)] + (-values (list + -Nat + (Un (-val 'complete) (-val 'continues))))))] -[bytes-converter? (make-pred-ty -BytesConverter)] +[bytes-converter? (make-pred-ty -Bytes-Converter)] [locale-string-encoding (-> -String)] @@ -1718,10 +1739,10 @@ [current-read-interaction (-Param (-> Univ -Input-Port Univ) (-> Univ -Input-Port Univ))] [current-print (-Param (-> Univ ManyUniv) (-> Univ ManyUniv))] -[current-compile (-Param (-> Univ B -CompiledExpression) (-> Univ B -CompiledExpression))] -[compile (-> Univ -CompiledExpression)] -[compile-syntax (-> (-Syntax Univ) -CompiledExpression)] -[compiled-expression? (make-pred-ty -CompiledExpression)] +[current-compile (-Param (-> Univ B -Compiled-Expression) (-> Univ B -Compiled-Expression))] +[compile (-> Univ -Compiled-Expression)] +[compile-syntax (-> (-Syntax Univ) -Compiled-Expression)] +[compiled-expression? (make-pred-ty -Compiled-Expression)] [compile-enforce-module-constants (-Param B B)] [compile-allow-set!-undefined (-Param B B)] @@ -1950,11 +1971,11 @@ [logger-name (-> -Logger (-opt Sym))] [current-logger (-Param -Logger -Logger)] -[log-message (-> -Logger -LogLevel -String Univ -Void)] -[log-level? (-> -Logger -LogLevel B)] +[log-message (-> -Logger -Log-Level -String Univ -Void)] +[log-level? (-> -Logger -Log-Level B)] -[log-receiver? (make-pred-ty -LogReceiver)] -[make-log-receiver (-> -Logger -LogLevel -LogReceiver)] +[log-receiver? (make-pred-ty -Log-Receiver)] +[make-log-receiver (-> -Logger -Log-Level -Log-Receiver)] ;Section 10.2.3 Semaphores @@ -2518,6 +2539,6 @@ ;Section 15.3 (Wills and Executors) [make-will-executor (-> -Will-Executor)] [will-executor? (make-pred-ty -Will-Executor)] -[will-register (-poly (a) (-> -Will-Executor a (-> a ManyUniv)))] +[will-register (-poly (a) (-> -Will-Executor a (-> a ManyUniv) -Void))] [will-execute (-> -Will-Executor ManyUniv)] [will-try-execute (-> -Will-Executor ManyUniv)] diff --git a/collects/typed-scheme/base-env/base-types.rkt b/collects/typed-scheme/base-env/base-types.rkt index 9babccf4..90ba84a8 100644 --- a/collects/typed-scheme/base-env/base-types.rkt +++ b/collects/typed-scheme/base-env/base-types.rkt @@ -103,6 +103,7 @@ [Module-Path -Module-Path] [Module-Path-Index -Module-Path-Index] [Compiled-Module-Expression -Compiled-Module-Expression] +[Compiled-Expression -Compiled-Expression] [Read-Table -Read-Table] [Special-Comment -Special-Comment] [Struct-Type-Property -Struct-Type-Property] @@ -114,7 +115,20 @@ [Namespace-Anchor -Namespace-Anchor] [Variable-Reference -Variable-Reference] [Internal-Definition-Context -Internal-Definition-Context] - +[Subprocess -Subprocess] +[Security-Guard -Security-Guard] +[Thread-Group -Thread-Group] +[Impersonator-Property -Impersonator-Property] +[Semaphore -Semaphore] +[Bytes-Converter -Bytes-Converter] +[Pseudo-Random-Generator -Pseudo-Random-Generator] +[Logger -Logger] +[Log-Receiver -Log-Receiver] +[Log-Level -Log-Level] +[Place-Channel -Place-Channel] +[Place -Place] +[Will-Executor -Will-Executor] +[Prompt-Tag -Prompt-Tag] [Listof -Listof] @@ -139,4 +153,5 @@ [MListof (-poly (a) (-mlst a))] [Sequenceof (-poly (a) (-seq a))] [ThreadCellof (-poly (a) (-thread-cell a))] +[CustodianBoxof (-poly (a) (make-CustodianBox a))] diff --git a/collects/typed-scheme/types/abbrev.rkt b/collects/typed-scheme/types/abbrev.rkt index 03718648..d974cb16 100644 --- a/collects/typed-scheme/types/abbrev.rkt +++ b/collects/typed-scheme/types/abbrev.rkt @@ -160,7 +160,12 @@ (define -Resolved-Module-Path (make-Base 'Resolved-Module-Path #'resolved-module-path? resolved-module-path? #'-Resolved-Module-Path)) (define -Module-Path-Index (make-Base 'Module-Path-Index #'module-path-index? module-path-index? #'-Module-Path-Index)) (define -Compiled-Module-Expression (make-Base 'Compiled-Module-Expression #'compiled-module-expression? compiled-module-expression? #'-Compiled-Module-Expression)) -(define -CompiledExpression (make-Base 'CompiledExpression #'compiled-expression? compiled-expression? #'-CompiledExpression)) +(define -Compiled-Non-Module-Expression + (make-Base 'Compiled-Non-Module-Expression + #'(and/c compiled-expression? (not/c compiled-module-expression?)) + (conjoin compiled-expression? (negate compiled-module-expression?)) + #'-CompiledExpression)) +(define -Compiled-Expression (*Un -Compiled-Module-Expression -Compiled-Non-Module-Expression)) (define -Prompt-Tag (make-Base 'Prompt-Tag #'continuation-prompt-tag? continuation-prompt-tag? #'-Prompt-Tag)) (define -Cont-Mark-Set (make-Base 'Continuation-Mark-Set #'continuation-mark-set? continuation-mark-set? #'-Cont-Mark-Set)) (define -Path (make-Base 'Path #'path? path? #'-Path)) @@ -243,13 +248,13 @@ (define -Semaphore (make-Base 'Semaphore #'semaphore? semaphore? #'-Semaphore)) -(define -BytesConverter (make-Base 'BytesConverter #'bytes-converter? bytes-converter? #'-BytesConverter)) +(define -Bytes-Converter (make-Base 'Bytes-Converter #'bytes-converter? bytes-converter? #'-Bytes-Converter)) (define -Pseudo-Random-Generator (make-Base 'Pseudo-Random-Generator #'pseudo-random-generator? pseudo-random-generator? #'-Pseudo-Random-Generator)) (define -Logger (make-Base 'Logger #'logger? logger? #'-Logger)) -(define -LogReceiver (make-Base 'LogReceiver #'log-receiver? log-receiver? #'-LogReceiver)) +(define -Log-Receiver (make-Base 'LogReceiver #'log-receiver? log-receiver? #'-Log-Receiver)) (define -Place