From b0a08fe0b8597ccbc7a8ebd43d6bd52bea5e757a Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 19 Feb 2010 23:27:06 +0000 Subject: [PATCH] providing static struct information to untyped code works svn: r18198 original commit: 33c18b3985bce1bab5028c67e06eec5335722eb4 --- .../tests/typed-scheme/fail/cnt-struct-err.ss | 18 ++ .../tests/typed-scheme/fail/struct-provide.ss | 3 +- .../succeed/provide-struct-untyped.ss | 16 ++ collects/typed-scheme/private/prims.ss | 27 ++- .../typed-scheme/private/type-contract.ss | 8 +- collects/typed-scheme/rep/type-rep.ss | 4 + .../typed-scheme/typecheck/def-binding.ss | 10 +- .../typecheck/provide-handling.ss | 218 ++++++++++-------- collects/typed-scheme/typecheck/tc-structs.ss | 31 ++- collects/typed-scheme/types/subtype.ss | 6 + collects/typed-scheme/utils/utils.ss | 6 +- 11 files changed, 227 insertions(+), 120 deletions(-) create mode 100644 collects/tests/typed-scheme/fail/cnt-struct-err.ss create mode 100644 collects/tests/typed-scheme/succeed/provide-struct-untyped.ss diff --git a/collects/tests/typed-scheme/fail/cnt-struct-err.ss b/collects/tests/typed-scheme/fail/cnt-struct-err.ss new file mode 100644 index 00000000..1630775f --- /dev/null +++ b/collects/tests/typed-scheme/fail/cnt-struct-err.ss @@ -0,0 +1,18 @@ +#; +(exn-pred exn:fail:contract?) +#lang scheme/load + +(module m typed-scheme + (define-struct: x ([f : (Number -> Number)])) + (: my-x x) + (define my-x (make-x (lambda: ([z : Number]) z))) + (provide (all-defined-out))) + +(module n2 scheme/base + + (require 'm scheme/match) + (match my-x + [(struct x (f)) (f #f)])) + + +(require 'n2) \ No newline at end of file diff --git a/collects/tests/typed-scheme/fail/struct-provide.ss b/collects/tests/typed-scheme/fail/struct-provide.ss index 2e4f65b7..41c9b777 100644 --- a/collects/tests/typed-scheme/fail/struct-provide.ss +++ b/collects/tests/typed-scheme/fail/struct-provide.ss @@ -3,7 +3,8 @@ #lang scheme/load (module m typed-scheme - (define-struct: q ()) + (require (for-syntax scheme/base)) + (define-syntax (q stx) #'#f) (provide (all-defined-out))) (module n scheme diff --git a/collects/tests/typed-scheme/succeed/provide-struct-untyped.ss b/collects/tests/typed-scheme/succeed/provide-struct-untyped.ss new file mode 100644 index 00000000..57adf8c2 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/provide-struct-untyped.ss @@ -0,0 +1,16 @@ +#lang scheme/load + +(module m typed-scheme + (define-struct: x ([f : (Number -> Number)])) + (: my-x x) + (define my-x (make-x (lambda: ([z : Number]) z))) + (provide (all-defined-out))) + +(module n2 scheme/base + + (require 'm scheme/match) + (match my-x + [(struct x (f)) (f 7)])) + + +(require 'n2) \ No newline at end of file diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss index 81f9e014..c85eb34c 100644 --- a/collects/typed-scheme/private/prims.ss +++ b/collects/typed-scheme/private/prims.ss @@ -241,6 +241,25 @@ This file defines two sorts of primitives. All of them are provided into any mod 'typechecker:with-handlers #t))])) +(define-syntax (dtsi* stx) + (define-syntax-class struct-name + #:description "struct name (with optional super-struct name)" + #:attributes (name super value) + (pattern ((~var name (static struct-info? "struct name")) super:id) + #:attr value (attribute name.value)) + (pattern (~var name (static struct-info? "struct name")) + #:attr value (attribute name.value) + #:with super #f)) + (syntax-parse stx + [(_ () nm:struct-name . rest) + (internal (quasisyntax/loc stx + (define-typed-struct-internal + #,(syntax-property #'nm 'struct-info (attribute nm.value)) . rest)))] + [(_ (vars:id ...) nm:struct-name . rest) + (internal (quasisyntax/loc stx + (define-typed-struct-internal (vars ...) + #,(syntax-property #'nm 'struct-info (attribute nm.value)) . rest)))])) + (define-syntax (define-typed-struct stx) (define-syntax-class fld-spec #:literals (:) @@ -259,12 +278,12 @@ This file defines two sorts of primitives. All of them are provided into any mod '())]) (with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fs.fld ...) . opts)) 'typechecker:ignore #t)] - [dtsi (internal (quasisyntax/loc stx (define-typed-struct-internal nm (fs ...) #,@mutable)))]) + [dtsi (quasisyntax/loc stx (dtsi* () nm (fs ...) #,@mutable))]) #'(begin d-s dtsi)))] [(_ (vars:id ...) nm:struct-name (fs:fld-spec ...) . opts) (with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fs.fld ...) . opts)) 'typechecker:ignore #t)] - [dtsi (internal (syntax/loc stx (define-typed-struct-internal (vars ...) nm (fs ...))))]) + [dtsi (syntax/loc stx (dtsi* (vars ...) nm (fs ...)))]) #'(begin d-s dtsi))])) (define-syntax (require-typed-struct stx) @@ -283,7 +302,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (reverse (list #'sel ...)) (list mut ...) #f)))) - #,(internal #'(define-typed-struct-internal nm ([fld : ty] ...) #:type-only)) + (dtsi* () nm ([fld : ty] ...) #:type-only) #,(ignore #'(require/contract pred (any/c . c-> . boolean?) lib)) #,(internal #'(require/typed-internal pred (Any -> Boolean : nm))) (require/typed maker nm lib #:struct-maker #f) @@ -304,7 +323,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (list #'sel ...) (list mut ...) #f)))) - #,(internal #'(define-typed-struct-internal (nm parent) ([fld : ty] ...) #:type-only)) + (dtsi* () (nm parent) ([fld : ty] ...) #:type-only) #,(ignore #'(require/contract pred (any/c . c-> . boolean?) lib)) #,(internal #'(require/typed-internal pred (Any -> Boolean : nm))) (require/typed maker nm lib #:struct-maker parent) diff --git a/collects/typed-scheme/private/type-contract.ss b/collects/typed-scheme/private/type-contract.ss index b50bea92..6b6f3c59 100644 --- a/collects/typed-scheme/private/type-contract.ss +++ b/collects/typed-scheme/private/type-contract.ss @@ -13,7 +13,8 @@ (private parse-type) scheme/match syntax/struct syntax/stx mzlib/trace unstable/syntax scheme/list (only-in scheme/contract -> ->* case-> cons/c flat-rec-contract provide/contract any/c) - (for-template scheme/base scheme/contract unstable/poly-c (utils any-wrap) (only-in scheme/class object% is-a?/c subclass?/c))) + (for-template scheme/base scheme/contract unstable/poly-c (utils any-wrap) + (only-in scheme/class object% is-a?/c subclass?/c object-contract))) (define (define/fixup-contract? stx) (or (syntax-property stx 'typechecker:contract-def) @@ -135,7 +136,10 @@ (parameterize ([vars (cons (list n #'n* #'n*) (vars))]) #`(flat-rec-contract n* #,(t->c b)))))] [(Value: #f) #'false/c] - [(Instance: _) #'(is-a?/c object%)] + [(Instance: (Class: _ _ (list (list name fcn) ...))) + (with-syntax ([(fcn-cnts ...) (map t->c fcn)] + [(names ...) name]) + #'(object-contract (names fcn-cnts) ...))] [(Class: _ _ _) #'(subclass?/c object%)] [(Value: '()) #'null?] [(Struct: nm par flds proc poly? pred? cert acc-ids) diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index e9355e4d..fe192c15 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -222,6 +222,10 @@ acc-ids)] [#:key #f]) +;; A structure type descriptor +;; s : struct +(dt StructType ([s Struct?]) [#:key 'struct-type]) + ;; the supertype of all of these values (dt BoxTop () [#:fold-rhs #:base] [#:key 'box]) (dt VectorTop () [#:fold-rhs #:base] [#:key 'vector]) diff --git a/collects/typed-scheme/typecheck/def-binding.ss b/collects/typed-scheme/typecheck/def-binding.ss index 0b383b22..e8c976e0 100644 --- a/collects/typed-scheme/typecheck/def-binding.ss +++ b/collects/typed-scheme/typecheck/def-binding.ss @@ -1,11 +1,13 @@ #lang scheme/base -(require scheme/contract) +(require scheme/contract "../utils/utils.ss" scheme/struct-info) (define-struct binding (name) #:transparent) (define-struct (def-binding binding) (ty) #:transparent) (define-struct (def-stx-binding binding) () #:transparent) +(define-struct (def-struct-stx-binding def-stx-binding) (static-info) #:transparent) -(provide/contract (struct binding ([name identifier?])) - (struct (def-binding binding) ([name identifier?] [ty any/c])) - (struct (def-stx-binding binding) ([name identifier?]))) +(p/c (struct binding ([name identifier?])) + (struct (def-binding binding) ([name identifier?] [ty any/c])) + (struct (def-stx-binding binding) ([name identifier?])) + (struct (def-struct-stx-binding binding) ([name identifier?] [static-info (or/c #f struct-info?)]))) diff --git a/collects/typed-scheme/typecheck/provide-handling.ss b/collects/typed-scheme/typecheck/provide-handling.ss index f6d75334..ecfc7a92 100644 --- a/collects/typed-scheme/typecheck/provide-handling.ss +++ b/collects/typed-scheme/typecheck/provide-handling.ss @@ -9,9 +9,10 @@ (private typed-renaming) (rep type-rep) (utils tc-utils) - scheme/contract/private/provide - unstable/syntax - "def-binding.ss") + scheme/contract/private/provide unstable/list + unstable/debug + unstable/syntax scheme/struct-info scheme/match + "def-binding.ss" syntax/parse) (require (for-template scheme/base scheme/contract)) @@ -20,105 +21,136 @@ get-alternate) (define (provide? form) - (kernel-syntax-case form #f + (syntax-parse form + #:literals (#%provide) [(#%provide . rest) form] [_ #f])) - (define (remove-provides forms) (filter (lambda (e) (not (provide? e))) (syntax->list forms))) - (define (renamer id #:alt [alt #f]) (if alt (make-typed-renaming (syntax-property id 'not-free-identifier=? #t) alt) (make-rename-transformer (syntax-property id 'not-free-identifier=? #t)))) -(define (generate-prov stx-defs val-defs pos-blame-id) - (define mapping (make-free-identifier-mapping)) - (lambda (form) - (define (mem? i vd) - (cond [(s:member i vd (lambda (i j) (free-identifier=? i (binding-name j)))) => car] - [else #f])) - (define (lookup-id i vd) - (def-binding-ty (mem? i vd))) - (define (mk internal-id external-id) - (cond - ;; if it's already done, do nothing - [(free-identifier-mapping-get mapping internal-id - ;; if it wasn't there, put it in, and skip this case - (lambda () - (free-identifier-mapping-put! mapping internal-id #t) - #f)) - #'(begin)] - [(mem? internal-id val-defs) - => - (lambda (b) - (with-syntax ([id internal-id] - [out-id external-id]) - (cond [(type->contract (def-binding-ty b) (lambda () #f) #:out #t) - => - (lambda (cnt) - (with-syntax ([(export-id cnt-id) (generate-temporaries #'(id id))] - [module-source pos-blame-id] - [the-contract (generate-temporary 'generated-contract)]) - #`(begin - (define the-contract #,cnt) - (define-syntax cnt-id - (make-provide/contract-transformer - (quote-syntax the-contract) - (quote-syntax id) - (quote-syntax out-id) - (quote-syntax module-source))) - (define-syntax export-id - (if (unbox typed-context?) - (renamer #'id #:alt #'cnt-id) - (renamer #'cnt-id))) - (#%provide (rename export-id out-id)))))] - [else - (with-syntax ([(export-id error-id) (generate-temporaries #'(id id))]) - #`(begin - (define-syntax error-id - (lambda (stx) (tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id)))) - (define-syntax export-id - (if (unbox typed-context?) - (renamer #'id #:alt #'error-id) - (renamer #'error-id))) - (provide (rename-out [export-id out-id]))))])))] - [(mem? internal-id stx-defs) - => - (lambda (b) - (with-syntax ([id internal-id] - [out-id external-id]) - (with-syntax ([(export-id error-id) (generate-temporaries #'(id id))]) - #`(begin - (define-syntax error-id - (lambda (stx) - (tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'out-id)))) - (define-syntax export-id - (if (unbox typed-context?) - (begin - (add-alias #'export-id #'id) - (renamer #'id #:alt #'error-id)) - (renamer #'error-id))) - (provide (rename-out [export-id out-id]))))))] - [(eq? (syntax-e internal-id) (syntax-e external-id)) - #`(provide #,internal-id)] - [else #`(provide (rename-out [#,internal-id #,external-id]))])) - (kernel-syntax-case form #f +;; maps ids defined in this module to an identifier which is the possibly-contracted version of the key +(define mapping (make-free-identifier-mapping)) + +(define (mem? i vd) + (cond [(s:member i vd (lambda (i j) (free-identifier=? i (binding-name j)))) => car] + [else #f])) + +;; generate-contract-defs : listof[def-binding] listof[def-binding] id -> syntax -> syntax +;; val-defs: define-values in this module +;; stx-defs: define-syntaxes in this module +;; pos-blame-id: a #%variable-reference for the module + +;; internal-id : the id being provided +;; if `internal-id' is defined in this module, we will produce a (begin def ... provide) block +;; and a name to provide instead of internal-id + +;; anything already recorded in the mapping is given an empty (begin) and the already-recorded id +;; otherwise, we will map internal-id to the fresh id in `mapping' +(define ((generate-prov stx-defs val-defs pos-blame-id) form) + ;; mk : id [id] -> (values syntax id) + (define (mk internal-id [new-id (generate-temporary internal-id)]) + (cond + ;; if it's already done, do nothing + [(free-identifier-mapping-get mapping internal-id + ;; if it wasn't there, put it in, and skip this case + (lambda () + (free-identifier-mapping-put! mapping internal-id new-id) + #f)) + => (lambda (mapped-id) + (values #'(begin) mapped-id))] + [(mem? internal-id val-defs) + => + (lambda (b) + (values + (with-syntax ([id internal-id]) + (cond [(type->contract (def-binding-ty b) (lambda () #f) #:out #t) + => + (lambda (cnt) + (with-syntax ([(cnt-id) (generate-temporaries #'(id))] + [export-id new-id] + [module-source pos-blame-id] + [the-contract (generate-temporary 'generated-contract)]) + #`(begin + (define the-contract #,cnt) + (define-syntax cnt-id + (make-provide/contract-transformer + (quote-syntax the-contract) + (quote-syntax id) + (quote-syntax out-id) + (quote-syntax module-source))) + (define-syntax export-id + (if (unbox typed-context?) + (renamer #'id #:alt #'cnt-id) + (renamer #'cnt-id))))))] + [else + (with-syntax ([(error-id) (generate-temporaries #'(id))] + [export-id new-id]) + #`(begin + (define-syntax error-id + (lambda (stx) (tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id)))) + (define-syntax export-id + (if (unbox typed-context?) + (renamer #'id #:alt #'error-id) + (renamer #'error-id)))))])) + new-id))] + [(mem? internal-id stx-defs) + => + (lambda (b) + (define (mk-untyped-syntax defn-id internal-id) + (match b + [(struct def-struct-stx-binding (_ (? struct-info? si))) + (match-let ([(list type-desc constr pred (list accs ...) muts super) (extract-struct-info si)]) + (let-values ([(defns new-ids) (map/values 2 (lambda (e) (if (identifier? e) + (mk e) + (values #'(begin) e))) + (list* type-desc constr pred super accs))]) + (with-syntax ([(type-desc* constr* pred* super* accs* ...) (for/list ([i new-ids]) + (if (identifier? i) + #`(syntax #,i) + i))]) + #`(begin + #,@defns + (define-syntax #,defn-id + (list type-desc* constr* pred* (list accs* ...) (list #,@(map (lambda x #'#f) accs)) super*))))))] + [_ + #`(define-syntax #,defn-id + (lambda (stx) + (tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'#,internal-id))))])) + (with-syntax* ([id internal-id] + [export-id new-id] + [(untyped-id) (generate-temporaries #'(id))]) + (values + #`(begin + #,(mk-untyped-syntax #'untyped-id internal-id) + (define-syntax export-id + (if (unbox typed-context?) + (begin + (add-alias #'export-id #'id) + (renamer #'id #:alt #'untyped-id)) + (renamer #'untyped-id)))) + new-id)))] + ;; otherwise, not defined in this module, not our problem + [else (values #'(begin) internal-id)])) + ;; do-one : id [id] -> syntax + (define (do-one internal-id [external-id internal-id]) + (define-values (defs id) (mk internal-id)) + #`(begin #,defs (provide (rename-out [#,id #,external-id])))) + (syntax-parse form #:literals (#%provide) [(#%provide form ...) - (map - (lambda (f) - (parameterize ([current-orig-stx f]) - (syntax-case* f (struct rename all-defined protect all-defined-except all-from all-from-except) - (lambda (a b) (eq? (syntax-e a) (syntax-e b))) - [id - (identifier? #'id) - (mk #'id #'id)] - [(rename in out) - (mk #'in #'out)] - [(protect . _) - (tc-error "provide: protect not supported by Typed Scheme")] - [_ (int-err "unknown provide form")]))) - (syntax->list #'(form ...)))] - [_ (int-err "non-provide form! ~a" (syntax->datum form))]))) + (for/list ([f (syntax->list #'(form ...))]) + (parameterize ([current-orig-stx f]) + (syntax-parse f + [i:id + (do-one #'i)] + [((~datum rename) in out) + (do-one #'in #'out)] + [((~datum protect) . _) + (tc-error "provide: protect not supported by Typed Scheme")] + [_ (int-err "unknown provide form")])))] + [_ (int-err "non-provide form! ~a" (syntax->datum form))])) diff --git a/collects/typed-scheme/typecheck/tc-structs.ss b/collects/typed-scheme/typecheck/tc-structs.ss index cbbdd5bb..424cb02e 100644 --- a/collects/typed-scheme/typecheck/tc-structs.ss +++ b/collects/typed-scheme/typecheck/tc-structs.ss @@ -66,11 +66,11 @@ (values (reverse getters) (reverse setters)) (loop (cddr l) (cons (car l) getters) (cons (cadr l) setters))))) (match (build-struct-names nm flds #f (not setters?) nm) - [(list _ maker pred getters/setters ...) + [(list sty maker pred getters/setters ...) (if setters? (let-values ([(getters setters) (split getters/setters)]) - (values maker pred getters setters)) - (values maker pred getters/setters #f))])) + (values sty maker pred getters setters)) + (values sty maker pred getters/setters #f))])) ;; gets the fields of the parent type, if they exist ;; Option[Struct-Ty] -> Listof[Type] @@ -88,6 +88,7 @@ #:type-wrapper [type-wrapper values] #:pred-wrapper [pred-wrapper values] #:mutable [setters? #f] + #:struct-info [si #f] #:proc-ty [proc-ty #f] #:maker [maker* #f] #:predicate [pred* #f] @@ -95,7 +96,7 @@ #:poly? [poly? #f] #:type-only [type-only #f]) ;; create the approriate names that define-struct will bind - (define-values (maker pred getters setters) (struct-names nm flds setters?)) + (define-values (struct-type-id maker pred getters setters) (struct-names nm flds setters?)) (let* ([name (syntax-e nm)] [fld-types (append parent-field-types types)] [sty (make-Struct name parent fld-types proc-ty poly? pred (syntax-local-certifier) getters)] @@ -109,6 +110,7 @@ #:pred-wrapper pred-wrapper #:maker (or maker* maker) #:predicate (or pred* pred) + #:struct-info si #:constructor-return cret)))) ;; generate names, and register the approriate types give field types and structure type @@ -116,24 +118,28 @@ ;; identifier Type Listof[identifer] Listof[Type] Listof[Type] #:wrapper (Type -> Type) #:maker identifier (define (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters? #:wrapper [wrapper values] + #:struct-info [si #f] #:type-wrapper [type-wrapper values] #:pred-wrapper [pred-wrapper values] #:maker [maker* #f] #:predicate [pred* #f] #:constructor-return [cret #f]) ;; create the approriate names that define-struct will bind - (define-values (maker pred getters setters) (struct-names nm flds setters?)) + (define-values (struct-type-id maker pred getters setters) (struct-names nm flds setters?)) ;; the type name that is used in all the types (define name (type-wrapper (make-Name nm))) ;; the list of names w/ types (define bindings (append - (list (cons (or maker* maker) - (wrapper (->* external-fld-types (if cret cret name)))) - (cons (or pred* pred) - (make-pred-ty (if setters? - (make-StructTop sty) - (pred-wrapper name))))) + (list + (cons struct-type-id + (make-StructType sty)) + (cons (or maker* maker) + (wrapper (->* external-fld-types (if cret cret name)))) + (cons (or pred* pred) + (make-pred-ty (if setters? + (make-StructTop sty) + (pred-wrapper name))))) (for/list ([g (in-list getters)] [t (in-list external-fld-types/no-parent)] [i (in-naturals)]) (let ([func (if setters? (->* (list name) t) @@ -146,7 +152,7 @@ null))) (register-type-name nm (wrapper sty)) (cons - (make-def-stx-binding nm) + (make-def-struct-stx-binding nm si) (for/list ([e bindings]) (let ([nm (car e)] [t (cdr e)]) @@ -207,6 +213,7 @@ #:proc-ty proc-ty-parsed #:maker maker #:predicate pred + #:struct-info (syntax-property nm/par 'struct-info) #:constructor-return (and cret (parse-type cret)) #:mutable mutable #:type-only type-only)) diff --git a/collects/typed-scheme/types/subtype.ss b/collects/typed-scheme/types/subtype.ss index bf018ad1..de10ce7f 100644 --- a/collects/typed-scheme/types/subtype.ss +++ b/collects/typed-scheme/types/subtype.ss @@ -333,6 +333,12 @@ (subtype* A0 t t*)] [((Instance: t) (Instance: t*)) (subtype* A0 t t*)] + [((Class: '() '() (list (and s (list names meths )) ...)) + (Class: '() '() (list (and s* (list names* meths*)) ...))) + (for/fold ([A A0]) + ([n names*] [m meths*]) + (cond [(assq n s) => (lambda (spec) (subtype* A (cadr spec) m))] + [else (fail! s t)]))] ;; otherwise, not a subtype [(_ _) (fail! s t) #;(printf "failed")])))])))) diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index f56fb8b3..d51753ad 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -172,11 +172,9 @@ at least theoretically. (define-syntax-class clause #:literals () #:attributes (i) - (pattern [struct nm:id (flds ...)] - #:fail-unless (eq? (syntax-e #'struct) 'struct) #f + (pattern [(~datum struct) (~or nm:id (nm:id super:id)) (flds ...)] #:with i #'(struct-out nm)) - (pattern [rename out:id in:id cnt:expr] - #:fail-unless (eq? (syntax-e #'rename) 'rename) #f + (pattern [(~datum rename) out:id in:id cnt:expr] #:with i #'(rename-out [out in])) (pattern [i:id cnt:expr])) (syntax-parse stx