From e54f1c3a5e651dda265cf82268ea7aec8a8c0cbe Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sat, 27 Feb 2010 01:03:55 +0000 Subject: [PATCH 01/14] scheme/contract => scheme/contract/base svn: r18371 --- collects/mzlib/port.ss | 2 +- collects/mzlib/private/contract-define.ss | 2 +- collects/scheme/unit.ss | 2 +- collects/syntax/id-table.ss | 2 +- collects/syntax/keyword.ss | 2 +- collects/syntax/modcollapse.ss | 2 +- collects/syntax/modresolve.ss | 2 +- 7 files changed, 7 insertions(+), 7 deletions(-) diff --git a/collects/mzlib/port.ss b/collects/mzlib/port.ss index df1cd9bf8a..56b12030af 100644 --- a/collects/mzlib/port.ss +++ b/collects/mzlib/port.ss @@ -2,7 +2,7 @@ (require (for-syntax scheme/base) mzlib/etc - scheme/contract + scheme/contract/base mzlib/list "private/port.ss") diff --git a/collects/mzlib/private/contract-define.ss b/collects/mzlib/private/contract-define.ss index cf76531378..4cece1f07b 100644 --- a/collects/mzlib/private/contract-define.ss +++ b/collects/mzlib/private/contract-define.ss @@ -5,7 +5,7 @@ (require (for-syntax scheme/base unstable/srcloc (prefix-in a: scheme/contract/private/helpers)) - (only-in scheme/contract contract)) + (only-in scheme/contract/private/base contract)) ;; First, we have the old define/contract implementation, which ;; is still used in mzlib/contract. diff --git a/collects/scheme/unit.ss b/collects/scheme/unit.ss index 6909a99c8b..e0d706406b 100644 --- a/collects/scheme/unit.ss +++ b/collects/scheme/unit.ss @@ -1,7 +1,7 @@ (module unit scheme/base (require mzlib/unit - scheme/contract + scheme/contract/base (for-syntax scheme/base syntax/struct)) (provide (except-out (all-from-out mzlib/unit) diff --git a/collects/syntax/id-table.ss b/collects/syntax/id-table.ss index 1c7ddc5778..0e1f89972e 100644 --- a/collects/syntax/id-table.ss +++ b/collects/syntax/id-table.ss @@ -1,6 +1,6 @@ #lang scheme/base (require (for-syntax scheme/base) - scheme/contract + scheme/contract/base scheme/dict "private/id-table.ss") #| diff --git a/collects/syntax/keyword.ss b/collects/syntax/keyword.ss index b28c209378..f3dfcffbf3 100644 --- a/collects/syntax/keyword.ss +++ b/collects/syntax/keyword.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require scheme/contract +(require scheme/contract/base scheme/dict "private/keyword.ss") diff --git a/collects/syntax/modcollapse.ss b/collects/syntax/modcollapse.ss index a673d2d324..9a94d274cd 100644 --- a/collects/syntax/modcollapse.ss +++ b/collects/syntax/modcollapse.ss @@ -1,6 +1,6 @@ #lang scheme/base -(require scheme/contract +(require scheme/contract/base "private/modcollapse-noctc.ss") (define simple-rel-to-module-path-v/c diff --git a/collects/syntax/modresolve.ss b/collects/syntax/modresolve.ss index fe5972a000..e6a4dba735 100644 --- a/collects/syntax/modresolve.ss +++ b/collects/syntax/modresolve.ss @@ -1,6 +1,6 @@ #lang scheme/base -(require scheme/contract +(require scheme/contract/base "private/modhelp.ss") (define (force-relto relto dir?) From 7dacfaea85b9bb66fe9ae5b5fcdb547c61f00a43 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sat, 27 Feb 2010 01:05:03 +0000 Subject: [PATCH 02/14] Add with-contract for expression positions. svn: r18372 --- collects/scheme/contract/regions.ss | 262 ++++++++++-------- .../scribblings/reference/contracts.scrbl | 24 +- collects/tests/mzscheme/contract-test.ss | 58 +++- 3 files changed, 207 insertions(+), 137 deletions(-) diff --git a/collects/scheme/contract/regions.ss b/collects/scheme/contract/regions.ss index 758e2ca916..2d5c6726b2 100644 --- a/collects/scheme/contract/regions.ss +++ b/collects/scheme/contract/regions.ss @@ -9,8 +9,11 @@ scheme/struct-info syntax/define syntax/kerncase + syntax/parse + unstable/syntax (prefix-in a: "private/helpers.ss")) scheme/splicing + scheme/stxparam "private/arrow.ss" "private/base.ss" "private/guts.ss") @@ -87,7 +90,7 @@ [body-expr body-expr] [type (if (identifier? #'name+arg-list) 'definition 'function)]) (syntax/loc define-stx - (with-contract #:type type name + (with-contract #:region type name ([name contract]) #:freevars args (define name body-expr))))))] @@ -337,7 +340,7 @@ (values super-fields ... non-auto-name ...)) (define blame-id (current-contract-region)) - (with-contract #:type struct struct-name + (with-contract #:region struct struct-name ctc-bindings (define-struct/derived orig name (field ...) kwds ... @@ -404,28 +407,6 @@ (quote #,id) (quote-syntax #,id)))])))) -(define-for-syntax (check-and-split-with-contracts args) - (let loop ([args args] - [protected null] - [protections null]) - (cond - [(null? args) - (values protected protections)] - [(let ([lst (syntax->list (car args))]) - (and (list? lst) - (= (length lst) 2) - (identifier? (first lst)) - lst)) - => - (lambda (l) - (loop (cdr args) - (cons (first l) protected) - (cons (second l) protections)))] - [else - (raise-syntax-error 'with-contract - "expected (identifier contract)" - (car args))]))) - (define-syntax (with-contract-helper stx) (syntax-case stx () [(_ ()) @@ -467,39 +448,110 @@ (with-contract-helper (p ...) body ...)))]))])) (define-syntax (with-contract stx) - (when (eq? (syntax-local-context) 'expression) - (raise-syntax-error 'with-contract - "used in expression context" - stx)) - (syntax-case stx () - [(_ #:type type etc ...) - (not (identifier? #'type)) - (raise-syntax-error 'with-contract - "expected identifier for type" - #'type)] - [(_ #:type type args etc ...) - (not (identifier? #'args)) - (raise-syntax-error 'with-contract - "expected identifier for blame" - #'args)] - [(_ #:type type blame (arg ...) #:freevars (fv ...) #:freevar x c . body) - (identifier? #'x) - (syntax/loc stx - (with-contract #:type type blame (arg ...) #:freevars (fv ... [x c]) . body))] - [(_ #:type type blame (arg ...) #:freevars (fv ...) #:freevar x c . body) - (raise-syntax-error 'with-contract - "use of #:freevar with non-identifier" - #'x)] - [(_ #:type type blame (arg ...) #:freevars (fv ...) . body) - (and (identifier? #'blame) - (identifier? #'type)) + (define-splicing-syntax-class region-clause + #:description "contract region type" + [pattern (~seq #:region region:id)]) + (define-splicing-syntax-class fv-clause + #:description "a free variable clause" + #:attributes ([var 1] [ctc 1]) + [pattern (~seq #:freevars ([var:id ctc:expr] ...))] + [pattern (~seq #:freevar v:id c:expr) + #:with (var ...) (list #'v) + #:with (ctc ...) (list #'c)]) + (define-splicing-syntax-class fvs + #:description "a sequence of free variable clauses" + #:attributes ([var 1] [ctc 1]) + [pattern (~seq f:fv-clause ...) + #:with (var ...) #'(f.var ... ...) + #:with (ctc ...) #'(f.ctc ... ...) + #:fail-when (check-duplicate-identifier (syntax->list #'(var ...))) + (format "duplicate imported name ~a" + (syntax-e (check-duplicate-identifier (syntax->list #'(var ...)))))]) + (define-syntax-class export-clause + #:description "a name/contract pair" + [pattern (var:id ctc:expr)]) + (define-syntax-class exports-clause + #:attributes ([var 1] [ctc 1]) + #:description "a sequence of name/contract pairs" + [pattern (ec:export-clause ...) + #:with (var ...) #'(ec.var ...) + #:with (ctc ...) #'(ec.ctc ...) + #:fail-when (check-duplicate-identifier (syntax->list #'(var ...))) + (format "duplicate exported name ~a" + (syntax-e (check-duplicate-identifier (syntax->list #'(var ...)))))]) + (define-splicing-syntax-class result-clause + #:description "a results clause" + [pattern (~seq #:result ctc:expr)]) + (syntax-parse stx + [(_ (~optional :region-clause #:defaults ([region #'region])) blame:id rc:result-clause fv:fvs . body) + (if (not (eq? (syntax-local-context) 'expression)) + (quasisyntax/loc stx (#%expression #,stx)) + (let*-values ([(intdef) (syntax-local-make-definition-context)] + [(ctx) (list (gensym 'intdef))] + [(cid-marker) (make-syntax-introducer)] + [(free-vars free-ctcs) + (values (syntax->list #'(fv.var ...)) + (syntax->list #'(fv.ctc ...)))]) + (define (add-context stx) + (let ([ctx-added-stx (local-expand #`(quote #,stx) + ctx + (list #'quote) + intdef)]) + (syntax-case ctx-added-stx () + [(_ expr) #'expr]))) + (syntax-local-bind-syntaxes free-vars #f intdef) + (internal-definition-context-seal intdef) + (with-syntax ([blame-stx #''(region blame)] + [blame-id (generate-temporary)] + [(free-var ...) free-vars] + [(free-var-id ...) (add-context #`#,free-vars)] + [(free-ctc-id ...) (map cid-marker free-vars)] + [(free-ctc ...) (map (λ (c v) + (syntax-property c 'inferred-name v)) + free-ctcs + free-vars)]) + (with-syntax ([new-stx (add-context #'(syntax-parameterize + ([current-contract-region (λ (stx) #'blame-stx)]) + (contract (verify-contract 'with-contract rc.ctc) + (let () . body) + blame-stx + blame-id)))]) + (quasisyntax/loc stx + (let () + (define-values (free-ctc-id ...) + (values (verify-contract 'with-contract free-ctc) ...)) + (define blame-id + (current-contract-region)) + (define-values () + (begin (contract free-ctc-id + free-var + blame-id + 'cant-happen + (quote free-var) + (quote-syntax free-var)) + ... + (values))) + (define-syntaxes (free-var-id ...) + (values (make-contracted-id-transformer + (quote-syntax free-var) + (quote-syntax free-ctc-id) + (quote-syntax blame-id) + (quote-syntax blame-stx)) ...)) + new-stx))))))] + [(_ (~optional :region-clause #:defaults ([region #'region])) blame:id ec:exports-clause fv:fvs . body) + (when (memq (syntax-local-context) '(expression module-begin)) + (raise-syntax-error 'with-contract + "not used in definition context" + stx)) (let*-values ([(intdef) (syntax-local-make-definition-context)] [(ctx) (list (gensym 'intdef))] [(cid-marker) (make-syntax-introducer)] [(free-vars free-ctcs) - (check-and-split-with-contracts (syntax->list #'(fv ...)))] + (values (syntax->list #'(fv.var ...)) + (syntax->list #'(fv.ctc ...)))] [(protected protections) - (check-and-split-with-contracts (syntax->list #'(arg ...)))]) + (values (syntax->list #'(ec.var ...)) + (syntax->list #'(ec.ctc ...)))]) (define (add-context stx) (let ([ctx-added-stx (local-expand #`(quote #,stx) ctx @@ -507,20 +559,11 @@ intdef)]) (syntax-case ctx-added-stx () [(_ expr) #'expr]))) - (when (eq? (syntax-local-context) 'expression) - (raise-syntax-error 'with-contract - "cannot use in an expression context" - stx)) - (let ([dupd-id (check-duplicate-identifier protected)]) - (when dupd-id - (raise-syntax-error 'with-contract - "identifier appears twice in exports" - dupd-id))) (syntax-local-bind-syntaxes protected #f intdef) (syntax-local-bind-syntaxes free-vars #f intdef) (internal-definition-context-seal intdef) - (with-syntax ([blame-stx #''(type blame)] - [blame-id (car (generate-temporaries (list #t)))] + (with-syntax ([blame-stx #''(region blame)] + [blame-id (generate-temporary)] [(free-var ...) free-vars] [(free-var-id ...) (add-context #`#,free-vars)] [(free-ctc-id ...) (map cid-marker free-vars)] @@ -539,58 +582,41 @@ ([current-contract-region (λ (stx) #'blame-stx)]) . body))]) (quasisyntax/loc stx - (begin - (define-values (free-ctc-id ...) - (values (verify-contract 'with-contract free-ctc) ...)) - (define blame-id - (current-contract-region)) - (define-values () - (begin (contract free-ctc-id - free-var - blame-id - 'cant-happen - (quote free-var) - (quote-syntax free-var)) - ... - (values))) - (define-syntaxes (free-var-id ...) - (values (make-contracted-id-transformer - (quote-syntax free-var) - (quote-syntax free-ctc-id) - (quote-syntax blame-id) - (quote-syntax blame-stx)) ...)) - (with-contract-helper (marked-p ...) new-stx) - (define-values (ctc-id ...) - (values (verify-contract 'with-contract ctc) ...)) - (define-values () - (begin (contract ctc-id - marked-p - blame-stx - 'cant-happen - (quote marked-p) - (quote-syntax marked-p)) - ... - (values))) - (define-syntaxes (p ...) - (values (make-contracted-id-transformer - (quote-syntax marked-p) - (quote-syntax ctc-id) - (quote-syntax blame-stx) - (quote-syntax blame-id)) ...)))))))] - [(_ #:type type blame (arg ...) #:freevar x c . body) - (syntax/loc stx - (with-contract #:type type blame (arg ...) #:freevars ([x c]) . body))] - [(_ #:type type blame (arg ...) . body) - (syntax/loc stx - (with-contract #:type type blame (arg ...) #:freevars () . body))] - [(_ #:type type blame bad-args etc ...) - (raise-syntax-error 'with-contract - "expected list of identifier and/or (identifier contract)" - #'bad-args)] - [(_ #:type type blame) - (raise-syntax-error 'with-contract - "only blame" - stx)] - [(_ etc ...) - (syntax/loc stx - (with-contract #:type region etc ...))])) + (begin + (define-values (free-ctc-id ...) + (values (verify-contract 'with-contract free-ctc) ...)) + (define blame-id + (current-contract-region)) + (define-values () + (begin (contract free-ctc-id + free-var + blame-id + 'cant-happen + (quote free-var) + (quote-syntax free-var)) + ... + (values))) + (define-syntaxes (free-var-id ...) + (values (make-contracted-id-transformer + (quote-syntax free-var) + (quote-syntax free-ctc-id) + (quote-syntax blame-id) + (quote-syntax blame-stx)) ...)) + (with-contract-helper (marked-p ...) new-stx) + (define-values (ctc-id ...) + (values (verify-contract 'with-contract ctc) ...)) + (define-values () + (begin (contract ctc-id + marked-p + blame-stx + 'cant-happen + (quote marked-p) + (quote-syntax marked-p)) + ... + (values))) + (define-syntaxes (p ...) + (values (make-contracted-id-transformer + (quote-syntax marked-p) + (quote-syntax ctc-id) + (quote-syntax blame-stx) + (quote-syntax blame-id)) ...)))))))])) diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 680fabdca4..4ba6ce07ef 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -743,20 +743,28 @@ expression to new contracts that hide the values they accept and ensure that the exported functions are treated parametrically. } -@defform/subs[ - (with-contract blame-id (wc-export ...) free-var-list body ...+) +@defform*/subs[ + (with-contract blame-id (wc-export ...) free-var-list ... body ...+) + (with-contract blame-id result-spec free-var-list ... body ...+) ([wc-export (id contract-expr)] + [result-spec + (code:line #:result contract-expr)] [free-var-list - code:blank (code:line #:freevars ([id contract-expr] ...)) (code:line #:freevar id contract-expr)])]{ -Generates a local contract boundary. The @scheme[contract-expr] -form cannot appear in expression position. The @scheme[body] of the -form allows definition/expression interleaving like a @scheme[module] -body. All names defined within the @scheme[with-contract] form are +Generates a local contract boundary. + +The first @scheme[with-contract] form cannot appear in expression position. +All names defined within the first @scheme[with-contract] form are visible externally, but those names listed in the @scheme[wc-export] -list are protected with the corresponding contract. +list are protected with the corresponding contract. The @scheme[body] of +the form allows definition/expression interleaving if its context does. + +The second @scheme[with-contract] form must appear in expression position. +The result of the final @scheme[body] expression is contracted with +the contract listed in the @scheme[result-spec]. The sequence of @scheme[body] +forms is treated as for @scheme[let]. The @scheme[blame-id] is used for the positive positions of contracts paired with exported @scheme[id]s. Contracts broken diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 49a9525ae4..2d35de9984 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -2878,7 +2878,7 @@ ; (test/spec-passed - 'with-contract1 + 'with-contract-def-1 '(let () (with-contract odd-even ([oddp (-> number? boolean?)] @@ -2890,7 +2890,7 @@ (oddp 5))) (test/spec-failed - 'with-contract2 + 'with-contract-def-2 '(let () (with-contract odd-even ([oddp (-> number? boolean?)] @@ -2903,7 +2903,7 @@ "top-level") (test/spec-failed - 'with-contract3 + 'with-contract-def-3 '(let () (with-contract odd-even ([oddp (-> number? boolean?)] @@ -2920,7 +2920,7 @@ ;; call odd? with a boolean, even though its contract in ;; the odd-even contract says it only takes numbers. (test/spec-passed - 'with-contract4 + 'with-contract-def-4 '(let () (with-contract odd-even ([oddp (-> number? boolean?)] @@ -2935,7 +2935,7 @@ (oddp 5))) (test/spec-passed - 'with-contract5 + 'with-contract-def-5 '(let () (with-contract region1 ([x (-> number? number?)]) @@ -2946,7 +2946,7 @@ (x 4))) (test/spec-failed - 'with-contract6 + 'with-contract-def-6 '(let () (with-contract region1 ([x (-> number? number?)]) @@ -2958,7 +2958,7 @@ "(region region1)") (test/spec-failed - 'with-contract7 + 'with-contract-def-7 '(let () (with-contract region1 ([x (-> number? number?)]) @@ -2970,7 +2970,7 @@ "(region region1)") (test/spec-failed - 'with-contract8 + 'with-contract-def-8 '(let () (with-contract region1 ([x (-> number? number?)]) @@ -2983,14 +2983,14 @@ ;; make sure uncontracted exports make it out (test/spec-passed - 'with-contract9 + 'with-contract-def-9 '(let () (with-contract region1 () (define f 3)) f)) (test/spec-failed - 'with-contract10 + 'with-contract-def-10 '(let () (with-contract r ([x number?]) @@ -3001,7 +3001,7 @@ "(region r)") (test/spec-failed - 'with-contract11 + 'with-contract-def-11 '(let () (with-contract r ([x number?]) @@ -3009,6 +3009,42 @@ (set! x #f) x) "top-level") + + (test/spec-passed + 'with-contract-exp-1 + '(with-contract r + #:result number? + 3)) + + (test/spec-failed + 'with-contract-exp-2 + '(with-contract r + #:result number? + "foo") + "(region r)") + + (test/spec-passed + 'with-contract-exp-3 + '((with-contract r + #:result (-> number? number?) + (λ (x) 5)) + 3)) + + (test/spec-failed + 'with-contract-exp-4 + '((with-contract r + #:result (-> number? number?) + (λ (x) (zero? x))) + 3) + "(region r)") + + (test/spec-failed + 'with-contract-exp-5 + '((with-contract r + #:result (-> number? number?) + (λ (x) 5)) + #t) + "top-level") ; ; From 0900b6c2e3c3b884630028800ec938b360c3b5f6 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sat, 27 Feb 2010 01:18:17 +0000 Subject: [PATCH 03/14] Fix use of defform*/subs. svn: r18373 --- collects/scribblings/reference/contracts.scrbl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 4ba6ce07ef..96e9a76faa 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -744,8 +744,8 @@ ensure that the exported functions are treated parametrically. } @defform*/subs[ - (with-contract blame-id (wc-export ...) free-var-list ... body ...+) - (with-contract blame-id result-spec free-var-list ... body ...+) + [(with-contract blame-id (wc-export ...) free-var-list ... body ...+) + (with-contract blame-id result-spec free-var-list ... body ...+)] ([wc-export (id contract-expr)] [result-spec From 8e3a67936eeb14fc08279a075966f93e35209f23 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sat, 27 Feb 2010 01:26:16 +0000 Subject: [PATCH 04/14] Add `unregister-type' Add type regions. Untyped lexical vars not an internal error. svn: r18374 --- .../tests/typed-scheme/fail/with-type1.ss | 8 ++ .../tests/typed-scheme/fail/with-type2.ss | 10 ++ .../tests/typed-scheme/succeed/with-type.ss | 9 ++ collects/typed-scheme/env/type-env.ss | 26 +++--- collects/typed-scheme/main.ss | 2 +- collects/typed-scheme/private/with-types.ss | 93 +++++++++++++++++++ .../scribblings/ts-reference.scrbl | 32 +++++++ collects/typed-scheme/typed-scheme.ss | 8 +- collects/typed-scheme/types/utils.ss | 2 +- collects/typed/scheme/base.ss | 2 +- 10 files changed, 173 insertions(+), 19 deletions(-) create mode 100644 collects/tests/typed-scheme/fail/with-type1.ss create mode 100644 collects/tests/typed-scheme/fail/with-type2.ss create mode 100644 collects/tests/typed-scheme/succeed/with-type.ss create mode 100644 collects/typed-scheme/private/with-types.ss diff --git a/collects/tests/typed-scheme/fail/with-type1.ss b/collects/tests/typed-scheme/fail/with-type1.ss new file mode 100644 index 0000000000..4acf56ae35 --- /dev/null +++ b/collects/tests/typed-scheme/fail/with-type1.ss @@ -0,0 +1,8 @@ +#; +(exn-pred exn:fail:contract?) +#lang scheme +(require typed/scheme) + +((with-type (Number -> Number) + (lambda: ([x : Number]) (add1 x))) + #f) diff --git a/collects/tests/typed-scheme/fail/with-type2.ss b/collects/tests/typed-scheme/fail/with-type2.ss new file mode 100644 index 0000000000..75824a07bd --- /dev/null +++ b/collects/tests/typed-scheme/fail/with-type2.ss @@ -0,0 +1,10 @@ +#; +(exn-pred exn:fail:contract?) +#lang scheme + +(require typed/scheme) + +(let ([x 'hello]) + (with-type String + #:freevars ([x String]) + (string-append x ", world"))) \ No newline at end of file diff --git a/collects/tests/typed-scheme/succeed/with-type.ss b/collects/tests/typed-scheme/succeed/with-type.ss new file mode 100644 index 0000000000..2ce8853dc6 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/with-type.ss @@ -0,0 +1,9 @@ +#lang scheme +(require typed/scheme) + +(with-type Number 3) + +(let ([x "hello"]) + (with-type String + #:freevars ([x String]) + (string-append x ", world"))) diff --git a/collects/typed-scheme/env/type-env.ss b/collects/typed-scheme/env/type-env.ss index 7aaf08ac58..8521f8ecd6 100644 --- a/collects/typed-scheme/env/type-env.ss +++ b/collects/typed-scheme/env/type-env.ss @@ -1,7 +1,7 @@ #lang scheme/base (require "../utils/utils.ss" - syntax/boundmap + syntax/id-table (utils tc-utils) (types utils)) @@ -11,21 +11,22 @@ register-type/undefined lookup-type register-types + unregister-type check-all-registered-types type-env-map) -;; module-identifier-mapping from id -> type or Box[type] +;; free-id-table from id -> type or Box[type] ;; where id is a variable, and type is the type of the variable ;; if the result is a box, then the type has not actually been defined, just registered -(define the-mapping (make-module-identifier-mapping)) +(define the-mapping (make-free-id-table)) ;; add a single type to the mapping ;; identifier type -> void (define (register-type id type) - (module-identifier-mapping-put! the-mapping id type)) + (free-id-table-set! the-mapping id type)) (define (register-type-if-undefined id type) - (if (module-identifier-mapping-get the-mapping id (lambda _ #f)) + (if (free-id-table-ref the-mapping id (lambda _ #f)) (tc-error/stx id "Duplicate type annotation for ~a" (syntax-e id)) (register-type id type))) @@ -33,9 +34,9 @@ ;; identifier type -> void (define (register-type/undefined id type) ;(printf "register-type/undef ~a~n" (syntax-e id)) - (if (module-identifier-mapping-get the-mapping id (lambda _ #f)) + (if (free-id-table-ref the-mapping id (lambda _ #f)) (tc-error/stx id "Duplicate type annotation for ~a" (syntax-e id)) - (module-identifier-mapping-put! the-mapping id (box type)))) + (free-id-table-set! the-mapping id (box type)))) ;; add a bunch of types to the mapping ;; listof[id] listof[type] -> void @@ -46,21 +47,24 @@ ;; if none found, calls lookup-fail ;; identifier -> type (define (lookup-type id [fail-handler (lambda () (lookup-type-fail id))]) - (let ([v (module-identifier-mapping-get the-mapping id fail-handler)]) + (let ([v (free-id-table-ref the-mapping id fail-handler)]) (if (box? v) (unbox v) v))) (define (maybe-finish-register-type id) - (let ([v (module-identifier-mapping-get the-mapping id)]) + (let ([v (free-id-table-ref the-mapping id)]) (if (box? v) (register-type id (unbox v)) #f))) +(define (unregister-type id) + (free-id-table-remove! the-mapping id)) + (define (finish-register-type id) (unless (maybe-finish-register-type id) (tc-error/stx id "Duplicate defintion for ~a" (syntax-e id)))) (define (check-all-registered-types) - (module-identifier-mapping-for-each + (free-id-table-for-each the-mapping (lambda (id e) (when (box? e) @@ -74,4 +78,4 @@ ;; map over the-mapping, producing a list ;; (id type -> T) -> listof[T] (define (type-env-map f) - (module-identifier-mapping-map the-mapping f)) + (free-id-table-map the-mapping f)) diff --git a/collects/typed-scheme/main.ss b/collects/typed-scheme/main.ss index a072bfdbb1..1ce6926eac 100644 --- a/collects/typed-scheme/main.ss +++ b/collects/typed-scheme/main.ss @@ -18,4 +18,4 @@ (for-syntax "private/base-types-extra.ss")) (provide (rename-out [with-handlers: with-handlers] [real? number?]) (for-syntax (all-from-out "private/base-types-extra.ss")) - assert) + assert with-type) diff --git a/collects/typed-scheme/private/with-types.ss b/collects/typed-scheme/private/with-types.ss new file mode 100644 index 0000000000..dfaf470fc1 --- /dev/null +++ b/collects/typed-scheme/private/with-types.ss @@ -0,0 +1,93 @@ +#lang scheme/base + +(require (for-syntax scheme/base syntax/parse mzlib/etc scheme/match) + scheme/require + "base-env.ss" + "base-special-env.ss" + "base-env-numeric.ss" + "base-env-indexing-old.ss" + "extra-procs.ss" + "prims.ss" + "base-types.ss" + scheme/contract/regions scheme/contract/base + (for-syntax "base-types-extra.ss") + (for-syntax (except-in (path-up "utils/utils.ss") infer) + (path-up "utils/tc-utils.ss") + (except-in (combine-in (path-up "types/convenience.ss") (path-up "types/abbrev.ss")) ->) + (path-up "types/utils.ss") + (path-up "infer/infer.ss") + (path-up "env/type-env.ss") + (path-up "env/type-environments.ss") + (path-up "env/type-name-env.ss") + (path-up "env/type-alias-env.ss") + (path-up "infer/infer-dummy.ss") + (path-up "private/parse-type.ss") + (path-up "private/type-contract.ss") + (path-up "typecheck/typechecker.ss"))) + +(provide with-type) +(define-syntax (with-type stx) + (define-splicing-syntax-class free-vars + #:attributes ((id 1) (ty 1)) + [pattern (~seq #:freevars ([id ty] ...))] + [pattern (~seq) + #:with (id ...) null + #:with (ty ...) null]) + (syntax-parse stx + [(_ region-ty-stx fv:free-vars . body) + (begin-with-definitions + (define old-context (unbox typed-context?)) + (set-box! typed-context? #t) + (define region-tc-result (parse-tc-results #'region-ty-stx)) + (define region-cnt (match region-tc-result + [(tc-result1: t) (type->contract + t + (lambda () (tc-error/stx #'region-ty-stx "Type ~a could not be converted to a contract." t)))])) + (define fv-types (for/list ([t (syntax->list #'(fv.ty ...))]) + (parse-type t))) + (define fv-cnts (for/list ([t (in-list fv-types)] + [stx (in-list (syntax->list #'(fv.ty ...)))]) + (type->contract t #:typed-side #f + (lambda () (tc-error/stx stx "Type ~a could not be converted to a contract." t))))) + (for ([i (in-list (syntax->list #'(fv.id ...)))] + [ty (in-list fv-types)]) + (register-type i ty)) + (define expanded-body (local-expand #'(let () . body) 'expression null)) + (parameterize (;; disable fancy printing? + [custom-printer #t] + ;; a cheat to avoid units + [infer-param infer] + ;; do we report multiple errors + [delay-errors? #t] + ;; this parameter is for parsing types + [current-tvars initial-tvar-env] + ;; this parameter is just for printing types + ;; this is a parameter to avoid dependency issues + [current-type-names + (lambda () + (append + (type-name-env-map (lambda (id ty) + (cons (syntax-e id) ty))) + (type-alias-env-map (lambda (id ty) + (cons (syntax-e id) ty)))))] + ;; reinitialize seen type variables + [type-name-references null] + ;; for error reporting + [orig-module-stx stx] + [expanded-module-stx expanded-body]) + (tc-expr/check expanded-body region-tc-result)) + (report-all-errors) + (set-box! typed-context? old-context) + ;; then clear the new entries from the env ht + (for ([i (in-list (syntax->list #'(fv.id ...)))]) + (unregister-type i)) + (with-syntax ([(cnt ...) fv-cnts] + [region-cnt region-cnt] + [check-syntax-help (syntax-property #'(void) 'disappeared-use (type-name-references))]) + (quasisyntax/loc stx + (begin check-syntax-help + (with-contract typed-region + #:result region-cnt + #:freevars ([fv.id cnt] ...) + . body)))))])) + \ No newline at end of file diff --git a/collects/typed-scheme/scribblings/ts-reference.scrbl b/collects/typed-scheme/scribblings/ts-reference.scrbl index 6387cf5622..5b7bd3d2cb 100644 --- a/collects/typed-scheme/scribblings/ts-reference.scrbl +++ b/collects/typed-scheme/scribblings/ts-reference.scrbl @@ -6,6 +6,8 @@ scheme/list srfi/14 version/check))] +@(define the-eval (make-base-eval)) +@(the-eval '(require (except-in typed/scheme #%top-interaction #%module-begin))) @title[#:tag "top"]{The Typed Scheme Reference} @@ -330,3 +332,33 @@ Examples: @schememod[typed-scheme/no-check (: x Number) (define x "not-a-number")] + +@section{Typed Regions} + +The @scheme[with-type] for allows for localized Typed Scheme regions in otherwise untyped code. + +@defform/subs[(with-type type fv-clause body ...+) + ([fv-clause code:blank + (code:line #:freevars ([id fv-type] ...))])]{ +Checks that @scheme[body ...+] has the type @scheme[type]. The @scheme[id]s are assumed to +have the types ascribed to them; these types are converted to contracts and checked dynamically. +Uses of the result value are also appropriately checked by a contract generated from +@scheme[type]. + +@examples[#:eval the-eval +(with-type Number 3) + +((with-type (Number -> Number) + (lambda: ([x : Number]) (add1 x))) + #f) + +(let ([x "hello"]) + (with-type String + #:freevars ([x String]) + (string-append x ", world"))) + +(let ([x 'hello]) + (with-type String + #:freevars ([x String]) + (string-append x ", world")))] +} diff --git a/collects/typed-scheme/typed-scheme.ss b/collects/typed-scheme/typed-scheme.ss index 0e1b5832eb..9dc8e20e4c 100644 --- a/collects/typed-scheme/typed-scheme.ss +++ b/collects/typed-scheme/typed-scheme.ss @@ -2,7 +2,7 @@ (require (rename-in "utils/utils.ss" [infer r:infer])) -(require (private base-types) +(require (private base-types with-types) (for-syntax (except-in syntax/parse id) scheme/base @@ -19,14 +19,12 @@ syntax/kerncase scheme/match)) - - - (provide (rename-out [module-begin #%module-begin] [top-interaction #%top-interaction] [#%plain-lambda lambda] [#%app #%app] - [require require])) + [require require]) + with-type) (define-for-syntax catch-errors? #f) diff --git a/collects/typed-scheme/types/utils.ss b/collects/typed-scheme/types/utils.ss index 85d4aa5b97..03a5262728 100644 --- a/collects/typed-scheme/types/utils.ss +++ b/collects/typed-scheme/types/utils.ss @@ -295,7 +295,7 @@ ;; error for unbound variables (define (lookup-fail e) (match (identifier-binding e) - ['lexical (int-err "untyped lexical variable ~a" (syntax-e e))] + ['lexical (tc-error/expr "untyped lexical variable ~a" (syntax-e e))] [#f (tc-error/expr "untyped top-level identifier ~a" (syntax-e e))] [(list _ _ nominal-source-mod nominal-source-id _ _ _) (let-values ([(x y) (module-path-index-split nominal-source-mod)]) diff --git a/collects/typed/scheme/base.ss b/collects/typed/scheme/base.ss index be07061154..c37fa0e4d3 100644 --- a/collects/typed/scheme/base.ss +++ b/collects/typed/scheme/base.ss @@ -17,5 +17,5 @@ typed-scheme/private/extra-procs (for-syntax typed-scheme/private/base-types-extra)) (provide (rename-out [with-handlers: with-handlers]) - assert + assert with-type (for-syntax (all-from-out typed-scheme/private/base-types-extra))) From 831dcc0c2cda0db788ff6dd18355fa53b52c54d0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 27 Feb 2010 03:22:33 +0000 Subject: [PATCH 05/14] fix problem visiting available modules; improve backtrace in JIT mode to include module visits; fix use-before-def error to show correct phase (when it's not 0) svn: r18375 --- src/mzscheme/src/error.c | 4 ++-- src/mzscheme/src/fun.c | 2 ++ src/mzscheme/src/jit.c | 43 +++++++++++++++++++++++++++++++++++++- src/mzscheme/src/module.c | 32 ++++++++++++++++++++++++---- src/mzscheme/src/schpriv.h | 2 ++ 5 files changed, 76 insertions(+), 7 deletions(-) diff --git a/src/mzscheme/src/error.c b/src/mzscheme/src/error.c index 6f41f371ec..ac46d04000 100644 --- a/src/mzscheme/src/error.c +++ b/src/mzscheme/src/error.c @@ -1928,8 +1928,8 @@ void scheme_unbound_global(Scheme_Bucket *b) else errmsg = "reference to an identifier before its definition: %S%_%s"; - if (SCHEME_INT_VAL(((Scheme_Bucket_With_Home *)b)->home->phase)) { - sprintf(phase_buf, " phase: %ld", SCHEME_INT_VAL(((Scheme_Bucket_With_Home *)b)->home->phase)); + if (((Scheme_Bucket_With_Home *)b)->home->phase) { + sprintf(phase_buf, " phase: %ld", ((Scheme_Bucket_With_Home *)b)->home->phase); phase = phase_buf; } else phase = ""; diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c index b2a3a21a44..f9f6646870 100644 --- a/src/mzscheme/src/fun.c +++ b/src/mzscheme/src/fun.c @@ -7399,6 +7399,8 @@ scheme_get_stack_trace(Scheme_Object *mark_set) if (SCHEME_FALSEP(SCHEME_CDR(name))) what = "[traversing imports]"; + else if (SCHEME_VOIDP(SCHEME_CDR(name))) + what = "[running expand-time body]"; else what = "[running body]"; diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index f6c17b8e2a..593a7ee31a 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -166,7 +166,7 @@ SHARED_OK static void *struct_proc_extract_code; SHARED_OK static void *bad_app_vals_target; SHARED_OK static void *app_values_slow_code, *app_values_multi_slow_code, *app_values_tail_slow_code; SHARED_OK static void *finish_tail_call_code, *finish_tail_call_fixup_code; -SHARED_OK static void *module_run_start_code, *module_start_start_code; +SHARED_OK static void *module_run_start_code, *module_exprun_start_code, *module_start_start_code; SHARED_OK static void *box_flonum_from_stack_code; SHARED_OK static void *fl1_fail_code, *fl2rr_fail_code[2], *fl2fr_fail_code[2], *fl2rf_fail_code[2]; @@ -11555,6 +11555,37 @@ static int do_generate_more_common(mz_jit_state *jitter, void *_data) register_sub_func(jitter, module_run_start_code, scheme_eof); } + /* *** module_exprun_start_code *** */ + /* Pushes a module name onto the stack for stack traces. */ + { + int in; + + module_exprun_start_code = jit_get_ip().ptr; + jit_prolog(3); + in = jit_arg_p(); + jit_getarg_p(JIT_R0, in); /* menv */ + in = jit_arg_p(); + jit_getarg_i(JIT_R1, in); /* set_ns */ + in = jit_arg_p(); + jit_getarg_p(JIT_R2, in); /* &name */ + CHECK_LIMIT(); + + /* Store the name where we can find it */ + mz_push_locals(); + mz_set_local_p(JIT_R2, JIT_LOCAL2); + + jit_prepare(2); + jit_pusharg_i(JIT_R1); + jit_pusharg_p(JIT_R0); + (void)mz_finish(scheme_module_exprun_finish); + CHECK_LIMIT(); + mz_pop_locals(); + jit_ret(); + CHECK_LIMIT(); + + register_sub_func(jitter, module_exprun_start_code, scheme_eof); + } + /* *** module_start_start_code *** */ /* Pushes a module name onto the stack for stack traces. */ { @@ -12822,6 +12853,7 @@ static void release_native_code(void *fnlized, void *p) #endif typedef void *(*Module_Run_Proc)(Scheme_Env *menv, Scheme_Env *env, Scheme_Object **name); +typedef void *(*Module_Exprun_Proc)(Scheme_Env *menv, int set_ns, Scheme_Object **name); typedef void *(*Module_Start_Proc)(struct Start_Module_Args *a, Scheme_Object **name); void *scheme_module_run_start(Scheme_Env *menv, Scheme_Env *env, Scheme_Object *name) @@ -12833,6 +12865,15 @@ void *scheme_module_run_start(Scheme_Env *menv, Scheme_Env *env, Scheme_Object * return scheme_module_run_finish(menv, env); } +void *scheme_module_exprun_start(Scheme_Env *menv, int set_ns, Scheme_Object *name) +{ + Module_Exprun_Proc proc = (Module_Exprun_Proc)module_exprun_start_code; + if (proc) + return proc(menv, set_ns, &name); + else + return scheme_module_exprun_finish(menv, set_ns); +} + void *scheme_module_start_start(struct Start_Module_Args *a, Scheme_Object *name) { Module_Start_Proc proc = (Module_Start_Proc)module_start_start_code; diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index 8c24c7ab9c..75c976daa5 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -4164,6 +4164,15 @@ static void expstart_module(Scheme_Env *menv, Scheme_Env *env, int restart) } static void run_module_exptime(Scheme_Env *menv, int set_ns) +{ +#ifdef MZ_USE_JIT + (void)scheme_module_exprun_start(menv, set_ns, scheme_make_pair(menv->module->modname, scheme_void)); +#else + (void)scheme_module_exprun_finish(menv, set_ns); +#endif +} + +void *scheme_module_exprun_finish(Scheme_Env *menv, int set_ns) { int let_depth, for_stx; Scheme_Object *names, *e; @@ -4176,17 +4185,17 @@ static void run_module_exptime(Scheme_Env *menv, int set_ns) Scheme_Config *config; if (menv->module->primitive) - return; + return NULL; if (!SCHEME_VEC_SIZE(menv->module->et_body)) - return; + return NULL; syntax = menv->syntax; exp_env = menv->exp_env; if (!exp_env) - return; + return NULL; for_stx_globals = exp_env->toplevel; @@ -4222,6 +4231,8 @@ static void run_module_exptime(Scheme_Env *menv, int set_ns) if (set_ns) { scheme_pop_continuation_frame(&cframe); } + + return NULL; } static void do_start_module(Scheme_Module *m, Scheme_Env *menv, Scheme_Env *env, int restart) @@ -4350,12 +4361,25 @@ static void start_module(Scheme_Module *m, Scheme_Env *env, int restart, static void do_prepare_compile_env(Scheme_Env *env, int base_phase, int pos) { - Scheme_Object *v; + Scheme_Object *v, *prev; Scheme_Env *menv; v = MODCHAIN_AVAIL(env->modchain, pos); if (!SCHEME_FALSEP(v)) { MODCHAIN_AVAIL(env->modchain, pos) = scheme_false; + + /* Reverse order of the list; if X requires Y, Y + has been pushed onto the front of the list + before X. */ + prev = scheme_false; + while (SCHEME_NAMESPACEP(v)) { + menv = (Scheme_Env *)v; + v = menv->available_next[pos]; + menv->available_next[pos] = prev; + prev = (Scheme_Object *)menv; + } + v = prev; + while (SCHEME_NAMESPACEP(v)) { menv = (Scheme_Env *)v; v = menv->available_next[pos]; diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index e006fd44a9..a166835415 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -2475,9 +2475,11 @@ struct Start_Module_Args; #ifdef MZ_USE_JIT void *scheme_module_run_start(Scheme_Env *menv, Scheme_Env *env, Scheme_Object *name); +void *scheme_module_exprun_start(Scheme_Env *menv, int set_ns, Scheme_Object *name); void *scheme_module_start_start(struct Start_Module_Args *a, Scheme_Object *name); #endif void *scheme_module_run_finish(Scheme_Env *menv, Scheme_Env *env); +void *scheme_module_exprun_finish(Scheme_Env *menv, int set_ns); void *scheme_module_start_finish(struct Start_Module_Args *a); Scheme_Object *scheme_build_closure_name(Scheme_Object *code, Scheme_Compile_Info *rec, int drec); From 2caaf05ca64ae2a777cc1f99d207f7538d506d4e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 27 Feb 2010 03:40:15 +0000 Subject: [PATCH 06/14] doc addition and prose tweaks svn: r18376 --- collects/scribblings/guide/scripts.scrbl | 8 ++++---- collects/scribblings/reference/numbers.scrbl | 10 +++++----- collects/scribblings/reference/sets.scrbl | 6 ++++++ 3 files changed, 15 insertions(+), 9 deletions(-) diff --git a/collects/scribblings/guide/scripts.scrbl b/collects/scribblings/guide/scripts.scrbl index cfea9dd0f8..5647b65e65 100644 --- a/collects/scribblings/guide/scripts.scrbl +++ b/collects/scribblings/guide/scripts.scrbl @@ -5,9 +5,9 @@ @title[#:tag "scripts"]{Scripts} -Scheme files can be turned into executable scripts on Unix and Mac OS -X. On Windows, one option is to use a compatibility layer like Cygwin, -or write scripts as batch files. +Scheme files can be turned into executable scripts under Unix and Mac +OS X. Under Windows, a compatibility layer like Cygwin support the +same kind of scripts, or scripts can be implemented as batch files. @section{Unix Scripts} @@ -119,7 +119,7 @@ the script file turns out to be valid input to both @exec{/bin/sh} and @section{Windows Batch Files} A similar trick can be used to write Scheme code in Windows -@as-index{@tt{batch}} files: +@as-index{@tt{.bat}} batch files: @verbatim[#:indent 2]|{ ; @echo off diff --git a/collects/scribblings/reference/numbers.scrbl b/collects/scribblings/reference/numbers.scrbl index 631b168062..b10430ef4c 100644 --- a/collects/scribblings/reference/numbers.scrbl +++ b/collects/scribblings/reference/numbers.scrbl @@ -589,9 +589,9 @@ produces @scheme[+nan.0] in the case that neither @scheme[y] nor Returns @scheme[#t] when the @scheme[m]th bit of @scheme[n] is set in @scheme[n]'s (semi-infinite) two's complement representation. -This is equivalent to +This operation is equivalent to @scheme[(not (zero? (bitwise-and n (arithmetic-shift 1 m))))], -but is faster and runs in constant time when @scheme[n] is positive. +but it is faster and runs in constant time when @scheme[n] is positive. @mz-examples[(bitwise-bit-set? 5 0) (bitwise-bit-set? 5 2) (bitwise-bit-set? -5 (expt 2 700))]} @@ -605,7 +605,7 @@ but is faster and runs in constant time when @scheme[n] is positive. Extracts the bits between position @scheme[start] and @scheme[(- end 1)] (inclusive) from @scheme[n] and shifts them down to the least significant portion of the number. -This is equivalent to this computation, +This operation is equivalent to the computation @schemeblock[ (bitwise-and (sub1 (arithmetic-shift 1 (- end start))) @@ -616,8 +616,8 @@ but it runs in constant time when @scheme[n] is positive, @scheme[start] and @scheme[end] are fixnums, and @scheme[(- end start)] is no more than the maximum width of a fixnum. -Each pair of examples below uses the same numbers, but shows the result in -both binary and as integers. +Each pair of examples below uses the same numbers, showing the result +both in binary and as integers. @mz-examples[(format "~b" (bitwise-bit-field (string->number "1101" 2) 1 1)) (bitwise-bit-field 13 1 1) diff --git a/collects/scribblings/reference/sets.scrbl b/collects/scribblings/reference/sets.scrbl index 1a6f35560c..5a137b6d7a 100644 --- a/collects/scribblings/reference/sets.scrbl +++ b/collects/scribblings/reference/sets.scrbl @@ -48,6 +48,12 @@ that they appear as @scheme[v]s, so in the first two cases, an earlier element that is @scheme[equal?] or @scheme[eqv?] but not @scheme[eq?] to a later element takes precedence over the later element.} + +@defproc[(set-empty? [set set?]) boolean?]{ + +Returns @scheme[#t] if @scheme[set] has no members, @scheme[@f] +otherwise.} + @defproc[(set-member? [set set?] [v any/c]) boolean?]{ Returns @scheme[#t] if @scheme[v] is in @scheme[set], @scheme[#f] From 508b2ca2698875b558d028fa6f63007e6e7a17a1 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 27 Feb 2010 08:50:29 +0000 Subject: [PATCH 07/14] Welcome to a new PLT day. svn: r18377 --- collects/repos-time-stamp/stamp.ss | 2 +- src/worksp/mred/mred.manifest | 2 +- src/worksp/mred/mred.rc | 8 ++++---- src/worksp/mzcom/mzcom.rc | 8 ++++---- src/worksp/mzcom/mzobj.rgs | 6 +++--- src/worksp/mzscheme/mzscheme.rc | 8 ++++---- src/worksp/starters/start.rc | 8 ++++---- 7 files changed, 21 insertions(+), 21 deletions(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 07b24d081c..ab65a58665 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "26feb2010") +#lang scheme/base (provide stamp) (define stamp "27feb2010") diff --git a/src/worksp/mred/mred.manifest b/src/worksp/mred/mred.manifest index fecbe2aab6..b2c49b0525 100644 --- a/src/worksp/mred/mred.manifest +++ b/src/worksp/mred/mred.manifest @@ -1,7 +1,7 @@ Date: Sat, 27 Feb 2010 12:40:38 +0000 Subject: [PATCH 08/14] PR 10786 svn: r18378 --- collects/drscheme/private/unit.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss index fb4a99923c..67c1f52236 100644 --- a/collects/drscheme/private/unit.ss +++ b/collects/drscheme/private/unit.ss @@ -3247,7 +3247,7 @@ module browser threading seems wrong. [lang (drscheme:language-configuration:language-settings-language lang/config)] [strs (send lang get-language-position)] [can-browse? - (or (regexp-match #rx"Module" (last strs)) + (or (is-a? lang drscheme:module-language:module-language<%>) (ormap (λ (x) (regexp-match #rx"PLT" x)) strs))]) (unless can-browse? From 183823033af9c75c09c5b5d03e0c45d43cb56cfb Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 27 Feb 2010 12:46:40 +0000 Subject: [PATCH 09/14] added an underlined M to the Module Browser menu item in the Scheme menu svn: r18379 --- collects/string-constants/english-string-constants.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/string-constants/english-string-constants.ss b/collects/string-constants/english-string-constants.ss index dca99cda5a..800f3990f4 100644 --- a/collects/string-constants/english-string-constants.ss +++ b/collects/string-constants/english-string-constants.ss @@ -1185,7 +1185,7 @@ please adhere to these guidelines: (module-browser-laying-out-graph-label "Laying out graph") (module-browser-open-file-format "Open ~a") (module-browser "Module Browser") ;; frame title - (module-browser... "Module Browser...") ;; menu item title + (module-browser... "&Module Browser...") ;; menu item title (module-browser-error-expanding "Error expanding the program:\n\n~a") (module-browser-show-lib-paths "Show files loaded by (lib ..) paths") (module-browser-progress "Module Browser: ~a") ;; prefix in the status line From 92f9725593bef797fdc61bf9e9bb107dc4a19ffb Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 27 Feb 2010 12:59:19 +0000 Subject: [PATCH 10/14] added support for showing the phases to the module browser you get from the Scheme menu svn: r18380 --- collects/drscheme/private/module-browser.ss | 33 ++++++++++++++++++++- 1 file changed, 32 insertions(+), 1 deletion(-) diff --git a/collects/drscheme/private/module-browser.ss b/collects/drscheme/private/module-browser.ss index 9da23f68cb..d58fd4da64 100644 --- a/collects/drscheme/private/module-browser.ss +++ b/collects/drscheme/private/module-browser.ss @@ -712,16 +712,41 @@ (label "") (parent vp) (stretchable-width #t))) + (define font/label-panel (new horizontal-panel% + [parent vp] + [stretchable-height #f])) (define font-size-gauge (instantiate slider% () (label font-size-gauge-label) (min-value 1) (max-value 72) (init-value (preferences:get 'drscheme:module-overview:label-font-size)) - (parent vp) + (parent font/label-panel) (callback (λ (x y) (send pasteboard set-label-font-size (send font-size-gauge get-value)))))) + (define module-browser-name-length-choice + (new choice% + (parent font/label-panel) + (label (string-constant module-browser-name-length)) + (choices (list (string-constant module-browser-name-long) + (string-constant module-browser-name-very-long))) + (selection (case (preferences:get 'drscheme:module-browser:name-length) + [(0) 0] + [(1) 0] + [(2) 0] + [(3) 1])) + (callback + (λ (x y) + ;; note: the preference drscheme:module-browser:name-length is also used for the View|Show Module Browser version of the module browser + ;; here we just treat any pref value except '3' as if it were for the long names. + (let ([selection (send module-browser-name-length-choice get-selection)]) + (preferences:set 'drscheme:module-browser:name-length (+ 2 selection)) + (send pasteboard set-name-length + (case selection + [(0) 'long] + [(1) 'very-long]))))))) + (define lib-paths-checkbox (instantiate check-box% () (label lib-paths-checkbox-constant) @@ -746,6 +771,12 @@ (format filename-constant fn lines)))) (send label-message set-label "")))) + (send pasteboard set-name-length + (case (preferences:get 'drscheme:module-browser:name-length) + [(0) 'long] + [(1) 'long] + [(2) 'long] + [(3) 'very-long])) ;; shouldn't be necessary here -- need to find callback on editor (send pasteboard render-snips) From 31f0b5e305f95af45772ff11e4b04bf332ead59a Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 27 Feb 2010 15:07:45 +0000 Subject: [PATCH 11/14] Fix tests to use `test-suite' to delay execution. Move hiding of errors down in stack. svn: r18381 --- collects/tests/typed-scheme/main.ss | 11 ++++++----- collects/tests/typed-scheme/run.ss | 3 +-- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/collects/tests/typed-scheme/main.ss b/collects/tests/typed-scheme/main.ss index 339df30763..bbd37489cb 100644 --- a/collects/tests/typed-scheme/main.ss +++ b/collects/tests/typed-scheme/main.ss @@ -48,7 +48,7 @@ #:when (scheme-file? p) ;; skip backup files #:when (not (regexp-match #rx".*~" (path->string p)))) - (test-case + (test-suite (path->string p) (test (build-path path p) @@ -72,9 +72,10 @@ dr (lambda (p thnk) (define-values (pred info) (exn-pred p)) - (with-check-info - (['predicates info]) - (check-exn pred thnk))))) + (parameterize ([error-display-handler void]) + (with-check-info + (['predicates info]) + (check-exn pred thnk)))))) (define int-tests (test-suite "Integration tests" @@ -86,7 +87,7 @@ unit-tests int-tests)) (define (go) (test/gui tests)) -(define (go/text) (run-tests tests)) +(define (go/text) (run-tests tests 'verbose)) (provide go go/text) diff --git a/collects/tests/typed-scheme/run.ss b/collects/tests/typed-scheme/run.ss index af3dda3bc7..d892dd3466 100644 --- a/collects/tests/typed-scheme/run.ss +++ b/collects/tests/typed-scheme/run.ss @@ -2,6 +2,5 @@ (require "main.ss") (current-namespace (make-base-namespace)) -(unless (= 0 (parameterize ([error-display-handler void]) - (go/text))) +(unless (= 0 (go/text)) (error "Typed Scheme Tests did not pass.")) From 6c4b1234bf7545fded38270fed92c886a0e49b48 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 27 Feb 2010 16:24:22 +0000 Subject: [PATCH 12/14] remove obsolete doc files eliminate repeated expansion svn: r18382 --- .../typed-scheme/private/base-special-env.ss | 30 +- collects/typed-scheme/ts-guide.scrbl | 406 ------------------ collects/typed-scheme/ts-reference.scrbl | 331 -------------- 3 files changed, 17 insertions(+), 750 deletions(-) delete mode 100644 collects/typed-scheme/ts-guide.scrbl delete mode 100644 collects/typed-scheme/ts-reference.scrbl diff --git a/collects/typed-scheme/private/base-special-env.ss b/collects/typed-scheme/private/base-special-env.ss index 76178e1109..b631a4d78c 100644 --- a/collects/typed-scheme/private/base-special-env.ss +++ b/collects/typed-scheme/private/base-special-env.ss @@ -12,7 +12,8 @@ string-constants/string-constant ;(prefix-in ce: test-engine/scheme-tests) (for-syntax - scheme/base syntax/parse mzlib/etc + scheme/base syntax/parse + (only-in unstable/syntax syntax-local-eval) (utils tc-utils) (env init-envs) (except-in (rep filter-rep object-rep type-rep) make-arr) @@ -106,7 +107,8 @@ (define-syntax (define-initial-env stx) (syntax-case stx () - [(_ initial-env make-promise-ty language-ty qq-append-ty cl ...) + [(_ initial-env make-promise-ty language-ty qq-append-ty + [id-expr ty] ...) (with-syntax ([(_ make-promise . _) (local-expand #'(delay 3) 'expression @@ -118,13 +120,16 @@ [(_ qq-append . _) (local-expand #'`(,@'() 1) 'expression - null)]) + null)] + [(id ...) + (for/list ([expr (syntax->list #'(id-expr ...))]) + (syntax-local-eval expr))]) #`(define-for-syntax initial-env (make-env [make-promise make-promise-ty] [language language-ty] [qq-append qq-append-ty] - cl ...)))])) + [id ty] ...)))])) @@ -140,12 +145,11 @@ (-> (-lst a) (-val '()) (-lst a)) (-> (-lst a) (-lst b) (-lst (*Un a b))))) ;; make-sequence - [(begin-lifted - (syntax-parse (local-expand #'(for ([x '()]) x) 'expression #f) - #:context #'make-sequence - #:literals (let-values quote) - [(let-values ([_ (m-s '(_) '())]) . _) - #'m-s])) + [(syntax-parse (local-expand #'(for ([x '()]) x) 'expression #f) + #:context #'make-sequence + #:literals (let-values quote) + [(let-values ([_ (m-s '(_) '())]) . _) + #'m-s]) (-poly (a) (let ([seq-vals (lambda ([a a]) @@ -161,9 +165,9 @@ (-> Univ -String (seq-vals -Char)) (-> Univ -Bytes (seq-vals -Nat)) (-> Univ -Input-Port (seq-vals -Nat)))))]) - - - + + + (begin-for-syntax (initialize-type-env initial-env/special-case) diff --git a/collects/typed-scheme/ts-guide.scrbl b/collects/typed-scheme/ts-guide.scrbl deleted file mode 100644 index 75c0b713bb..0000000000 --- a/collects/typed-scheme/ts-guide.scrbl +++ /dev/null @@ -1,406 +0,0 @@ -#lang scribble/doc - -@begin[(require scribble/manual) - (require (for-label typed-scheme))] - -@begin[ -(define (item* header . args) (apply item @bold[header]{: } args)) -(define-syntax-rule (tmod forms ...) (schememod typed-scheme forms ...)) -(define (gtech . x) (apply tech x #:doc '(lib "scribblings/guide/guide.scrbl"))) -(define (rtech . x) (apply tech x #:doc '(lib "scribblings/reference/reference.scrbl"))) -] - -@title[#:tag "top"]{@bold{Typed Scheme}: Scheme with Static Types} - -@author["Sam Tobin-Hochstadt"] - -@section-index["typechecking"] - -Typed Scheme is a Scheme-like language, with a type system that -supports common Scheme programming idioms. Explicit type declarations -are required --- that is, there is no type inference. The language -supports a number of features from previous work on type systems that -make it easier to type Scheme programs, as well as a novel idea dubbed -@italic{occurrence typing} for case discrimination. - -Typed Scheme is also designed to integrate with the rest of your PLT -Scheme system. It is possible to convert a single module to Typed -Scheme, while leaving the rest of the program unchanged. The typed -module is protected from the untyped code base via -automatically-synthesized contracts. - -Further information on Typed Scheme is available from -@link["http://www.ccs.neu.edu/home/samth/typed-scheme"]{the homepage}. - -@section{Starting with Typed Scheme} - -If you already know PLT Scheme, or even some other Scheme, it should be -easy to start using Typed Scheme. - -@subsection{A First Function} - -The following program defines the Fibonacci function in PLT Scheme: - -@schememod[ -scheme -(define (fib n) - (cond [(= 0 n) 1] - [(= 1 n) 1] - [else (+ (fib (- n 1)) (fib (- n 2)))])) -] - -This program defines the same program using Typed Scheme. - -@schememod[ -typed-scheme -(: fib (Number -> Number)) -(define (fib n) - (cond [(= 0 n) 1] - [(= 1 n) 1] - [else (+ (fib (- n 1)) (fib (- n 2)))])) -] - -There are two differences between these programs: - -@itemize[ - @item*[@elem{The Language}]{@schememodname[scheme] has been replaced by @schememodname[typed-scheme].} - - @item*[@elem{The Type Annotation}]{We have added a type annotation -for the @scheme[fib] function, using the @scheme[:] form.} ] - -In general, these are most of the changes that have to be made to a -PLT Scheme program to transform it into a Typed Scheme program. -@margin-note{Changes to uses of @scheme[require] may also be necessary -- these are described later.} - -@subsection[#:tag "complex"]{Adding more complexity} - -Other typed binding forms are also available. For example, we could have -rewritten our fibonacci program as follows: - -@schememod[ -typed-scheme -(: fib (Number -> Number)) -(define (fib n) - (let ([base? (or (= 0 n) (= 1 n))]) - (if base? - 1 - (+ (fib (- n 1)) (fib (- n 2)))))) -] - -This program uses the @scheme[let] binding form, but no new type -annotations are required. Typed Scheme infers the type of -@scheme[base?]. - -We can also define mutually-recursive functions: - -@schememod[ -typed-scheme -(: my-odd? (Number -> Boolean)) -(define (my-odd? n) - (if (= 0 n) #f - (my-even? (- n 1)))) - -(: my-even? (Number -> Boolean)) -(define (my-even? n) - (if (= 0 n) #t - (my-odd? (- n 1)))) - -(my-even? 12) -] - -As expected, this program prints @schemeresult[#t]. - - -@subsection{Defining New Datatypes} - -If our program requires anything more than atomic data, we must define -new datatypes. In Typed Scheme, structures can be defined, similarly -to PLT Scheme structures. The following program defines a date -structure and a function that formats a date as a string, using PLT -Scheme's built-in @scheme[format] function. - -@schememod[ -typed-scheme -(define-struct: Date ([day : Number] [month : String] [year : Number])) - -(: format-date (Date -> String)) -(define (format-date d) - (format "Today is day ~a of ~a in the year ~a" - (Date-day d) (Date-month d) (Date-year d))) - -(format-date (make-Date 28 "November" 2006)) -] - -Here we see the built-in type @scheme[String] as well as a definition -of the new user-defined type @scheme[Date]. To define -@scheme[Date], we provide all the information usually found in a -@scheme[define-struct], but added type annotations to the fields using -the @scheme[define-struct:] form. -Then we can use the functions that this declaration creates, just as -we would have with @scheme[define-struct]. - - -@subsection{Recursive Datatypes and Unions} - -Many data structures involve multiple variants. In Typed Scheme, we -represent these using @italic{union types}, written @scheme[(U t1 t2 ...)]. - -@schememod[ -typed-scheme -(define-type-alias Tree (U leaf node)) -(define-struct: leaf ([val : Number])) -(define-struct: node ([left : Tree] [right : Tree])) - -(: tree-height (Tree -> Number)) -(define (tree-height t) - (cond [(leaf? t) 1] - [else (max (+ 1 (tree-height (node-left t))) - (+ 1 (tree-height (node-right t))))])) - -(: tree-sum (Tree -> Number)) -(define (tree-sum t) - (cond [(leaf? t) (leaf-val t)] - [else (+ (tree-sum (node-left t)) - (tree-sum (node-right t)))])) -] - -In this module, we have defined two new datatypes: @scheme[leaf] and -@scheme[node]. We've also defined the type alias @scheme[Tree] to be -@scheme[(U node leaf)], which represents a binary tree of numbers. In -essence, we are saying that the @scheme[tree-height] function accepts -a @scheme[Tree], which is either a @scheme[node] or a @scheme[leaf], -and produces a number. - -In order to calculate interesting facts about trees, we have to take -them apart and get at their contents. But since accessors such as -@scheme[node-left] require a @scheme[node] as input, not a -@scheme[Tree], we have to determine which kind of input we -were passed. - -For this purpose, we use the predicates that come with each defined -structure. For example, the @scheme[leaf?] predicate distinguishes -@scheme[leaf]s from all other Typed Scheme values. Therefore, in the -first branch of the @scheme[cond] clause in @scheme[tree-sum], we know -that @scheme[t] is a @scheme[leaf], and therefore we can get its value -with the @scheme[leaf-val] function. - -In the else clauses of both functions, we know that @scheme[t] is not -a @scheme[leaf], and since the type of @scheme[t] was @scheme[Tree] by -process of elimination we can determine that @scheme[t] must be a -@scheme[node]. Therefore, we can use accessors such as -@scheme[node-left] and @scheme[node-right] with @scheme[t] as input. - -@section{Polymorphism} - -Typed Scheme offers abstraction over types as well as values. - -@subsection{Polymorphic Data Structures} - -Virtually every Scheme program uses lists and sexpressions. Fortunately, Typed -Scheme can handle these as well. A simple list processing program can be -written like this: - -@schememod[ -typed-scheme -(: sum-list ((Listof Number) -> Number)) -(define (sum-list l) - (cond [(null? l) 0] - [else (+ (car l) (sum-list (cdr l)))])) -] - -This looks similar to our earlier programs --- except for the type -of @scheme[l], which looks like a function application. In fact, it's -a use of the @italic{type constructor} @scheme[Listof], which takes -another type as its input, here @scheme[Number]. We can use -@scheme[Listof] to construct the type of any kind of list we might -want. - -We can define our own type constructors as well. For example, here is -an analog of the @tt{Maybe} type constructor from Haskell: - -@schememod[ -typed-scheme -(define-struct: Nothing ()) -(define-struct: (a) Just ([v : a])) - -(define-type-alias (Maybe a) (U Nothing (Just a))) - -(: find (Number (Listof Number) -> (Maybe Number))) -(define (find v l) - (cond [(null? l) (make-Nothing)] - [(= v (car l)) (make-Just v)] - [else (find v (cdr l))])) -] - -The first @scheme[define-struct:] defines @scheme[Nothing] to be -a structure with no contents. - -The second definition - -@schemeblock[ -(define-struct: (a) Just ([v : a])) -] - -creates a parameterized type, @scheme[Just], which is a structure with -one element, whose type is that of the type argument to -@scheme[Just]. Here the type parameters (only one, @scheme[a], in -this case) are written before the type name, and can be referred to in -the types of the fields. - -The type alias definiton -@schemeblock[ - (define-type-alias (Maybe a) (U Nothing (Just a))) -] -creates a parameterized alias --- @scheme[Maybe] is a potential -container for whatever type is supplied. - -The @scheme[find] function takes a number @scheme[v] and list, and -produces @scheme[(make-Just v)] when the number is found in the list, -and @scheme[(make-Nothing)] otherwise. Therefore, it produces a -@scheme[(Maybe Number)], just as the annotation specified. - -@subsection{Polymorphic Functions} - -Sometimes functions over polymorphic data structures only concern -themselves with the form of the structure. For example, one might -write a function that takes the length of a list of numbers: - -@schememod[ -typed-scheme -(: list-number-length ((Listof Number) -> Integer)) -(define (list-number-length l) - (if (null? l) - 0 - (add1 (list-number-length (cdr l)))))] - -and also a function that takes the length of a list of strings: - -@schememod[ -typed-scheme -(: list-string-length ((Listof String) -> Integer)) -(define (list-string-length l) - (if (null? l) - 0 - (add1 (list-string-length (cdr l)))))] - -Notice that both of these functions have almost exactly the same -definition; the only difference is the name of the function. This -is because neither function uses the type of the elements in the -definition. - -We can abstract over the type of the element as follows: - -@schememod[ -typed-scheme -(: list-length (All (A) ((Listof A) -> Integer))) -(define (list-length l) - (if (null? l) - 0 - (add1 (list-length (cdr l)))))] - -The new type constructor @scheme[All] takes a list of type -variables and a body type. The type variables are allowed to -appear free in the body of the @scheme[All] form. - -@section{Variable-Arity Functions: Programming with Rest Arguments} - -Typed Scheme can handle some uses of rest arguments. - -@subsection{Uniform Variable-Arity Functions} - -In Scheme, one can write a function that takes an arbitrary -number of arguments as follows: - -@schememod[ -scheme -(define (sum . xs) - (if (null? xs) - 0 - (+ (car xs) (apply sum (cdr xs))))) - -(sum) -(sum 1 2 3 4) -(sum 1 3)] - -The arguments to the function that are in excess to the -non-rest arguments are converted to a list which is assigned -to the rest parameter. So the examples above evaluate to -@schemeresult[0], @schemeresult[10], and @schemeresult[4]. - -We can define such functions in Typed Scheme as well: - -@schememod[ -typed-scheme -(: sum (Number * -> Number)) -(define (sum . xs) - (if (null? xs) - 0 - (+ (car xs) (apply sum (cdr xs)))))] - -This type can be assigned to the function when each element -of the rest parameter is used at the same type. - -@subsection{Non-Uniform Variable-Arity Functions} - -However, the rest argument may be used as a heterogeneous list. -Take this (simplified) definition of the Scheme function @scheme[map]: - -@schememod[ -scheme -(define (map f as . bss) - (if (or (null? as) - (ormap null? bss)) - null - (cons (apply f (car as) (map car bss)) - (apply map f (cdr as) (map cdr bss))))) - -(map add1 (list 1 2 3 4)) -(map cons (list 1 2 3) (list (list 4) (list 5) (list 6))) -(map + (list 1 2 3) (list 2 3 4) (list 3 4 5) (list 4 5 6))] - -Here the different lists that make up the rest argument @scheme[bss] -can be of different types, but the type of each list in @scheme[bss] -corresponds to the type of the corresponding argument of @scheme[f]. -We also know that, in order to avoid arity errors, the length of -@scheme[bss] must be one less than the arity of @scheme[f] (as -@scheme[as] corresponds to the first argument of @scheme[f]). - -The example uses of @scheme[map] evaluate to @schemeresult[(list 2 3 4 5)], -@schemeresult[(list (list 1 4) (list 2 5) (list 3 6))], and -@schemeresult[(list 10 14 18)]. - -In Typed Scheme, we can define @scheme[map] as follows: - -@schememod[ -typed-scheme -(: map - (All (C A B ...) - ((A B ... B -> C) (Listof A) (Listof B) ... B - -> - (Listof C)))) -(define (map f as . bss) - (if (or (null? as) - (ormap null? bss)) - null - (cons (apply f (car as) (map car bss)) - (apply map f (cdr as) (map cdr bss)))))] - -Note that the type variable @scheme[B] is followed by an -ellipsis. This denotes that B is a dotted type variable -which corresponds to a list of types, much as a rest -argument corresponds to a list of values. When the type -of @scheme[map] is instantiated at a list of types, then -each type @scheme[t] which is bound by @scheme[B] (notated by -the dotted pre-type @scheme[t ... B]) is expanded to a number -of copies of @scheme[t] equal to the length of the sequence -assigned to @scheme[B]. Then @scheme[B] in each copy is -replaced with the corresponding type from the sequence. - -So the type of @scheme[(inst map Integer Boolean String Number)] -is - -@scheme[((Boolean String Number -> Integer) - (Listof Boolean) (Listof String) (Listof Number) - -> - (Listof Integer))]. diff --git a/collects/typed-scheme/ts-reference.scrbl b/collects/typed-scheme/ts-reference.scrbl deleted file mode 100644 index 33cf0ded30..0000000000 --- a/collects/typed-scheme/ts-reference.scrbl +++ /dev/null @@ -1,331 +0,0 @@ -#lang scribble/doc - -@begin[(require scribble/manual scribble/eval - scheme/sandbox) - (require (for-label typed-scheme - scheme/list srfi/14 - version/check))] - -@begin[ -(define (item* header . args) (apply item @bold[header]{: } args)) -(define-syntax-rule (tmod forms ...) (schememod typed-scheme forms ...)) -(define (gtech . x) (apply tech x #:doc '(lib "scribblings/guide/guide.scrbl"))) -(define (rtech . x) (apply tech x #:doc '(lib "scribblings/reference/reference.scrbl"))) -] - -@title[#:tag "top"]{The Typed Scheme Reference} - -@author["Sam Tobin-Hochstadt"] - -@(defmodulelang typed-scheme) - -@section[#:tag "type-ref"]{Type Reference} - -@subsubsub*section{Base Types} -@deftogether[( -@defidform[Number] -@defidform[Integer] -@defidform[Boolean] -@defidform[String] -@defidform[Keyword] -@defidform[Symbol] -@defidform[Void] -@defidform[Input-Port] -@defidform[Output-Port] -@defidform[Path] -@defidform[Regexp] -@defidform[PRegexp] -@defidform[Syntax] -@defidform[Identifier] -@defidform[Bytes] -@defidform[Namespace] -@defidform[EOF] -@defidform[Continuation-Mark-Set] -@defidform[Char])]{ -These types represent primitive Scheme data. Note that @scheme[Integer] represents exact integers.} - -@defidform[Any]{Any Scheme value. All other types are subtypes of @scheme[Any].} - -@defidform[Nothing]{The type with no members.} - -The following base types are parameteric in their type arguments. - -@defform[(Listof t)]{Homogenous @rtech{lists} of @scheme[t]} -@defform[(Boxof t)]{A @rtech{box} of @scheme[t]} -@defform[(Syntaxof t)]{A @rtech{syntax object} containing a @scheme[t]} -@defform[(Vectorof t)]{Homogenous @rtech{vectors} of @scheme[t]} -@defform[(Option t)]{Either @scheme[t] of @scheme[#f]} -@defform*[[(Parameter t) - (Parameter s t)]]{A @rtech{parameter} of @scheme[t]. If two type arguments are supplied, - the first is the type the parameter accepts, and the second is the type returned.} -@defform[(Pair s t)]{is the pair containing @scheme[s] as the @scheme[car] - and @scheme[t] as the @scheme[cdr]} -@defform[(HashTable k v)]{is the type of a @rtech{hash table} with key type - @scheme[k] and value type @scheme[v].} - -@subsubsub*section{Type Constructors} - -@defform*[#:id -> #:literals (* ...) - [(dom ... -> rng) - (dom ... rest * -> rng) - (dom ... rest ... bound -> rng) - (dom -> rng : pred)]]{is the type of functions from the (possibly-empty) - sequence @scheme[dom ...] to the @scheme[rng] type. The second form - specifies a uniform rest argument of type @scheme[rest], and the - third form specifies a non-uniform rest argument of type - @scheme[rest] with bound @scheme[bound]. In the third form, the - second occurrence of @scheme[...] is literal, and @scheme[bound] - must be an identifier denoting a type variable. In the fourth form, - there must be only one @scheme[dom] and @scheme[pred] is the type - checked by the predicate.} -@defform[(U t ...)]{is the union of the types @scheme[t ...]} -@defform[(case-lambda fun-ty ...)]{is a function that behaves like all of - the @scheme[fun-ty]s. The @scheme[fun-ty]s must all be function - types constructed with @scheme[->].} -@defform/none[(t t1 t2 ...)]{is the instantiation of the parametric type - @scheme[t] at types @scheme[t1 t2 ...]} -@defform[(All (v ...) t)]{is a parameterization of type @scheme[t], with - type variables @scheme[v ...]} -@defform[(List t ...)]{is the type of the list with one element, in order, - for each type provided to the @scheme[List] type constructor.} -@defform[(values t ...)]{is the type of a sequence of multiple values, with -types @scheme[t ...]. This can only appear as the return type of a -function.} -@defform/none[v]{where @scheme[v] is a number, boolean or string, is the singleton type containing only that value} -@defform/none[(quote val)]{where @scheme[val] is a Scheme value, is the singleton type containing only that value} -@defform/none[i]{where @scheme[i] is an identifier can be a reference to a type -name or a type variable} -@defform[(Rec n t)]{is a recursive type where @scheme[n] is bound to the -recursive type in the body @scheme[t]} - -Other types cannot be written by the programmer, but are used -internally and may appear in error messages. - -@defform/none[(struct:n (t ...))]{is the type of structures named -@scheme[n] with field types @scheme[t]. There may be multiple such -types with the same printed representation.} -@defform/none[]{is the printed representation of a reference to the -type variable @scheme[n]} - -@section[#:tag "special-forms"]{Special Form Reference} - -Typed Scheme provides a variety of special forms above and beyond -those in PLT Scheme. They are used for annotating variables with types, -creating new types, and annotating expressions. - -@subsection{Binding Forms} - -@scheme[_loop], @scheme[_f], @scheme[_a], and @scheme[_v] are names, @scheme[_t] is a type. - @scheme[_e] is an expression and @scheme[_body] is a block. - -@defform*[[ - (let: ([v : t e] ...) . body) - (let: loop : t0 ([v : t e] ...) . body)]]{ -Local bindings, like @scheme[let], each with -associated types. In the second form, @scheme[_t0] is the type of the -result of @scheme[_loop] (and thus the result of the entire - expression as well as the final - expression in @scheme[body]).} -@deftogether[[ -@defform[(letrec: ([v : t e] ...) . body)] -@defform[(let*: ([v : t e] ...) . body)]]]{Type-annotated versions of -@scheme[letrec] and @scheme[let*].} - -@deftogether[[ -@defform[(let/cc: v : t . body)] -@defform[(let/ec: v : t . body)]]]{Type-annotated versions of -@scheme[let/cc] and @scheme[let/ec]. @scheme[t] is the type that will be provided to the continuation @scheme[v].} - -@subsection{Anonymous Functions} - -@defform/subs[(lambda: formals . body) -([formals ([v : t] ...) - ([v : t] ... . [v : t])])]{ -A function of the formal arguments @scheme[v], where each formal -argument has the associated type. If a rest argument is present, then -it has type @scheme[(Listof t)].} -@defform[(λ: formals . body)]{ -An alias for the same form using @scheme[lambda:].} -@defform[(plambda: (a ...) formals . body)]{ -A polymorphic function, abstracted over the type variables -@scheme[a]. The type variables @scheme[a] are bound in both the types -of the formal, and in any type expressions in the @scheme[body].} -@defform[(case-lambda: [formals body] ...)]{ -A function of multiple arities. Note that each @scheme[formals] must have a -different arity.} -@defform[(pcase-lambda: (a ...) [formals body] ...)]{ -A polymorphic function of multiple arities.} - -@subsection{Loops} - -@defform/subs[(do: : u ([id : t init-expr step-expr-maybe] ...) - (stop?-expr finish-expr ...) - expr ...+) - ([step-expr-maybe code:blank - step-expr])]{ -Like @scheme[do], but each @scheme[id] having the associated type @scheme[t], and -the final body @scheme[expr] having the type @scheme[u]. -} - - -@subsection{Definitions} - -@defform*[[(define: v : t e) - (define: (f . formals) : t . body) - (define: (a ...) (f . formals) : t . body)]]{ -These forms define variables, with annotated types. The first form -defines @scheme[v] with type @scheme[t] and value @scheme[e]. The -second and third forms defines a function @scheme[f] with appropriate -types. In most cases, use of @scheme[:] is preferred to use of @scheme[define:].} - - - -@subsection{Structure Definitions} -@defform/subs[ -(define-struct: maybe-type-vars name-spec ([f : t] ...)) -([maybe-type-vars code:blank (v ...)] - [name-spec name (name parent)])]{ - Defines a @rtech{structure} with the name @scheme[name], where the - fields @scheme[f] have types @scheme[t]. When @scheme[parent], the -structure is a substructure of @scheme[parent]. When -@scheme[maybe-type-vars] is present, the structure is polymorphic in the type - variables @scheme[v].} - -@defform/subs[ -(define-struct/exec: name-spec ([f : t] ...) [e : proc-t]) -([name-spec name (name parent)])]{ - Like @scheme[define-struct:], but defines an procedural structure. - The procdure @scheme[e] is used as the value for @scheme[prop:procedure], and must have type @scheme[proc-t].} - -@subsection{Type Aliases} -@defform*[[(define-type-alias name t) - (define-type-alias (name v ...) t)]]{ -The first form defines @scheme[name] as type, with the same meaning as -@scheme[t]. The second form is equivalent to -@scheme[(define-type-alias name (All (v ...) t))]. Type aliases may -refer to other type aliases or types defined in the same module, but -cycles among type aliases are prohibited.} - - -@subsection{Type Annotation and Instantiation} - -@defform[(: v t)]{This declares that @scheme[v] has type @scheme[t]. -The definition of @scheme[v] must appear after this declaration. This -can be used anywhere a definition form may be used.} - -@defform[(provide: [v t] ...)]{This declares that the @scheme[v]s have -the types @scheme[t], and also provides all of the @scheme[v]s.} - -@litchar{#{v : t}} This declares that the variable @scheme[v] has type -@scheme[t]. This is legal only for binding occurences of @scheme[_v]. - -@defform[(ann e t)]{Ensure that @scheme[e] has type @scheme[t], or -some subtype. The entire expression has type @scheme[t]. -This is legal only in expression contexts.} - -@litchar{#{e :: t}} This is identical to @scheme[(ann e t)]. - -@defform[(inst e t ...)]{Instantiate the type of @scheme[e] with types -@scheme[t ...]. @scheme[e] must have a polymorphic type with the -appropriate number of type variables. This is legal only in expression -contexts.} - -@litchar|{#{e @ t ...}}| This is identical to @scheme[(inst e t ...)]. - -@subsection{Require} - -Here, @scheme[_m] is a module spec, @scheme[_pred] is an identifier -naming a predicate, and @scheme[_r] is an optionally-renamed identifier. - -@defform/subs[#:literals (struct opaque) -(require/typed m rt-clause ...) -([rt-clause [r t] - [struct name ([f : t] ...)] - [struct (name parent) ([f : t] ...)] - [opaque t pred]]) -]{This form requires identifiers from the module @scheme[m], giving -them the specified types. - -The first form requires @scheme[r], giving it type @scheme[t]. - -@index["struct"]{The second and third forms} require the struct with name @scheme[name] -with fields @scheme[f ...], where each field has type @scheme[t]. The -third form allows a @scheme[parent] structure type to be specified. -The parent type must already be a structure type known to Typed -Scheme, either built-in or via @scheme[require/typed]. The -structure predicate has the appropriate Typed Scheme filter type so -that it may be used as a predicate in @scheme[if] expressions in Typed -Scheme. - -@index["opaque"]{The fourth case} defines a new type @scheme[t]. @scheme[pred], imported from -module @scheme[m], is a predicate for this type. The type is defined -as precisely those values to which @scheme[pred] produces -@scheme[#t]. @scheme[pred] must have type @scheme[(Any -> Boolean)]. -Opaque types must be required lexically before they are used. - -In all cases, the identifiers are protected with @rtech{contracts} which -enforce the specified types. If this contract fails, the module -@scheme[m] is blamed. - -Some types, notably polymorphic types constructed with @scheme[All], -cannot be converted to contracts and raise a static error when used in -a @scheme[require/typed] form.} - -@section{Libraries Provided With Typed Scheme} - -The @schememodname[typed-scheme] language corresponds to the -@schememodname[scheme/base] language---that is, any identifier provided -by @schememodname[scheme/base], such as @scheme[modulo] is available by default in -@schememodname[typed-scheme]. - -@schememod[typed-scheme -(modulo 12 2) -] - -Any value provided by @schememodname[scheme] is available by simply -@scheme[require]ing it; use of @scheme[require/typed] is not -neccessary. - -@schememod[typed-scheme -(require scheme/list) -(display (first (list 1 2 3))) -] - -Some libraries have counterparts in the @schemeidfont{typed} -collection, which provide the same exports as the untyped versions. -Such libraries include @schememodname[srfi/14], -@schememodname[net/url], and many others. - -@schememod[typed-scheme -(require typed/srfi/14) -(char-set= (string->char-set "hello") - (string->char-set "olleh")) -] - -To participate in making more libraries available, please visit -@link["http://www.ccs.neu.edu/home/samth/adapt/"]{here}. - - -Other libraries can be used with Typed Scheme via -@scheme[require/typed]. - -@schememod[typed-scheme -(require/typed version/check - [check-version (-> (U Symbol (Listof Any)))]) -(check-version) -] - -@section{Typed Scheme Syntax Without Type Checking} - -@defmodulelang[typed-scheme/no-check] - -On occasions where the Typed Scheme syntax is useful, but actual -typechecking is not desired, the @schememodname[typed-scheme/no-check] -language is useful. It provides the same bindings and syntax as Typed -Scheme, but does no type checking. - -Examples: - -@schememod[typed-scheme/no-check -(: x Number) -(define x "not-a-number")] From 9f17622e1a2ae1f5eb8e8bd153144041cb213053 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sat, 27 Feb 2010 17:41:43 +0000 Subject: [PATCH 13/14] Cleanups here, moving some of the other parts to syntax-parse. svn: r18383 --- collects/scheme/contract/regions.ss | 138 ++++++++++++---------------- 1 file changed, 61 insertions(+), 77 deletions(-) diff --git a/collects/scheme/contract/regions.ss b/collects/scheme/contract/regions.ss index 2d5c6726b2..ecf99dc84a 100644 --- a/collects/scheme/contract/regions.ss +++ b/collects/scheme/contract/regions.ss @@ -48,55 +48,50 @@ ;; defines `id' with `contract'; initially binding ;; it to the result of `expr'. These variables may not be set!'d. (define-syntax (define/contract define-stx) - (when (eq? (syntax-local-context) 'expression) + (define-splicing-syntax-class fv-clause + #:description "a free variable clause" + #:attributes ([var 1] [ctc 1]) + [pattern (~seq #:freevars ([var:id ctc:expr] ...))] + [pattern (~seq #:freevar v:id c:expr) + #:with (var ...) (list #'v) + #:with (ctc ...) (list #'c)]) + (define-splicing-syntax-class fvs + #:description "a sequence of free variable clauses" + #:attributes ([var 1] [ctc 1]) + [pattern (~seq f:fv-clause ...) + #:with (var ...) #'(f.var ... ...) + #:with (ctc ...) #'(f.ctc ... ...) + #:fail-when (check-duplicate-identifier (syntax->list #'(var ...))) + (format "duplicate imported name ~a" + (syntax-e (check-duplicate-identifier (syntax->list #'(var ...)))))]) + (when (memq (syntax-local-context) '(expression module-begin)) (raise-syntax-error 'define/contract - "used in expression context" + "not used in definition context" define-stx)) - (syntax-case define-stx () - [(_ name) - (raise-syntax-error 'define/contract - "no contract or body" - define-stx)] - [(_ name contract-expr) - (raise-syntax-error 'define/contract - "expected a contract expression and a definition body, but found only one expression" - define-stx)] - [(_ name+arg-list contract #:freevars args . body) - (identifier? #'args) - (raise-syntax-error 'define/contract - "expected list of identifier/contract pairs" - #'args)] - [(_ name+arg-list contract #:freevars (arg ...) #:freevar x c . body) + (syntax-parse define-stx + [(_ name:id contract fv:fvs body) (syntax/loc define-stx - (define/contract name+arg-list contract #:freevars (arg ... [x c]) . body))] - [(_ name+arg-list contract #:freevar x c . body) - (syntax/loc define-stx - (define/contract name+arg-list contract #:freevars () #:freevar x c . body))] - [(_ name+arg-list contract #:freevars args body0 body ...) - (begin - (when (and (identifier? #'name+arg-list) - (not (null? (syntax->list #'(body ...))))) - (raise-syntax-error 'define/contract - "multiple expressions after identifier and contract" - #'(body ...))) - (let-values ([(name body-expr) - (if (identifier? #'name+arg-list) - (values #'name+arg-list #'body0) - (normalize-definition - (datum->syntax #'define-stx (list* 'define/contract #'name+arg-list - #'body0 #'(body ...))) - #'lambda #t #t))]) - (with-syntax ([name name] - [body-expr body-expr] - [type (if (identifier? #'name+arg-list) 'definition 'function)]) - (syntax/loc define-stx - (with-contract #:region type name - ([name contract]) - #:freevars args - (define name body-expr))))))] - [(_ name+arg-list contract body0 body ...) - (syntax/loc define-stx - (define/contract name+arg-list contract #:freevars () body0 body ...))])) + (with-contract #:region definition name + ([name contract]) + #:freevars ([fv.var fv.ctc] ...) + (define name body)))] + [(_ name:id contract fv:fvs body0 body ...) + (raise-syntax-error 'define/contract + "multiple expressions after identifier and contract" + #'(body ...))] + [(_ name+arg-list contract fv:fvs body0 body ...) + (let-values ([(name body-expr) + (normalize-definition + (datum->syntax #'define-stx (list* 'define/contract #'name+arg-list + #'body0 #'(body ...))) + #'lambda #t #t)]) + (with-syntax ([name name] + [body-expr body-expr]) + (syntax/loc define-stx + (with-contract #:region function name + ([name contract]) + #:freevars ([fv.var fv.ctc] ...) + (define name body-expr)))))])) (define-syntax (define-struct/contract stx) (define-struct field-info (stx ctc [mutable? #:mutable] auto?)) @@ -375,37 +370,26 @@ ; ; -(define-for-syntax (make-contracted-id-transformer id contract-stx pos-blame-id neg-blame-id) - (make-set!-transformer - (lambda (stx) - (syntax-case stx (set!) - [(set! i arg) - (quasisyntax/loc stx - (set! #,id - (contract #,contract-stx - arg - #,neg-blame-id - #,pos-blame-id - (quote #,id) - (quote-syntax #,id))))] - [(f arg ...) - (quasisyntax/loc stx - ((contract #,contract-stx - #,id - #,pos-blame-id - #,neg-blame-id - (quote #,id) - (quote-syntax #,id)) - arg ...))] - [ident - (identifier? (syntax ident)) - (quasisyntax/loc stx - (contract #,contract-stx - #,id - #,pos-blame-id - #,neg-blame-id - (quote #,id) - (quote-syntax #,id)))])))) +(define-for-syntax (make-contracted-id-transformer id contract-stx pos-blame-stx neg-blame-stx) + (with-syntax ([ctc contract-stx] + [id id] + [pos pos-blame-stx] + [neg neg-blame-stx]) + (make-set!-transformer + (lambda (stx) + (syntax-case stx (set!) + [(set! i arg) + (quasisyntax/loc stx + (set! #,id + (contract ctc arg neg pos (quote id) (quote-syntax id))))] + [(f arg ...) + (quasisyntax/loc stx + ((contract ctc id pos neg (quote id) (quote-syntax id)) + arg ...))] + [ident + (identifier? (syntax ident)) + (quasisyntax/loc stx + (contract ctc id pos neg (quote id) (quote-syntax id)))]))))) (define-syntax (with-contract-helper stx) (syntax-case stx () From 54b81b3bdb68d6cdc650d913b63e8165873ce0de Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sat, 27 Feb 2010 18:04:47 +0000 Subject: [PATCH 14/14] Fix bug introduced by last commit. svn: r18385 --- collects/scheme/contract/regions.ss | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/collects/scheme/contract/regions.ss b/collects/scheme/contract/regions.ss index ecf99dc84a..f101081d90 100644 --- a/collects/scheme/contract/regions.ss +++ b/collects/scheme/contract/regions.ss @@ -380,8 +380,7 @@ (syntax-case stx (set!) [(set! i arg) (quasisyntax/loc stx - (set! #,id - (contract ctc arg neg pos (quote id) (quote-syntax id))))] + (set! id (contract ctc arg neg pos (quote id) (quote-syntax id))))] [(f arg ...) (quasisyntax/loc stx ((contract ctc id pos neg (quote id) (quote-syntax id))