suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

providing static struct information to untyped code works

Browse Source 
svn: r18198
This commit is contained in:
Sam Tobin-Hochstadt 2010-02-19 23:27:06 +00:00
parent d9fabc314b
commit 33c18b3985
11 changed files with 227 additions and 120 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
collects/tests/typed-scheme/fail/cnt-struct-err.ss Normal file
View File

@ -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)

3
collects/tests/typed-scheme/fail/struct-provide.ss
View File

@ -3,7 +3,8 @@
#lang scheme/load #lang scheme/load
(module m typed-scheme (module m typed-scheme
(define-struct: q ()) (require (for-syntax scheme/base))
(define-syntax (q stx) #'#f)
(provide (all-defined-out))) (provide (all-defined-out)))
(module n scheme (module n scheme

16
collects/tests/typed-scheme/succeed/provide-struct-untyped.ss Normal file
View File

@ -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)

27
collects/typed-scheme/private/prims.ss
View File

@ -241,6 +241,25 @@ This file defines two sorts of primitives. All of them are provided into any mod
'typechecker:with-handlers 'typechecker:with-handlers
#t))])) #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 (define-typed-struct stx)
(define-syntax-class fld-spec (define-syntax-class fld-spec
#:literals (:) #: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)) (with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fs.fld ...) . opts))
'typechecker:ignore #t)] '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)))] #'(begin d-s dtsi)))]
[(_ (vars:id ...) nm:struct-name (fs:fld-spec ...) . opts) [(_ (vars:id ...) nm:struct-name (fs:fld-spec ...) . opts)
(with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fs.fld ...) . opts)) (with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fs.fld ...) . opts))
'typechecker:ignore #t)] '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))])) #'(begin d-s dtsi))]))
(define-syntax (require-typed-struct stx) (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 ...)) (reverse (list #'sel ...))
(list mut ...) (list mut ...)
#f)))) #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)) #,(ignore #'(require/contract pred (any/c . c-> . boolean?) lib))
#,(internal #'(require/typed-internal pred (Any -> Boolean : nm))) #,(internal #'(require/typed-internal pred (Any -> Boolean : nm)))
(require/typed maker nm lib #:struct-maker #f) (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 #'sel ...)
(list mut ...) (list mut ...)
#f)))) #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)) #,(ignore #'(require/contract pred (any/c . c-> . boolean?) lib))
#,(internal #'(require/typed-internal pred (Any -> Boolean : nm))) #,(internal #'(require/typed-internal pred (Any -> Boolean : nm)))
(require/typed maker nm lib #:struct-maker parent) (require/typed maker nm lib #:struct-maker parent)

8
collects/typed-scheme/private/type-contract.ss
View File

@ -13,7 +13,8 @@
(private parse-type) (private parse-type)
scheme/match syntax/struct syntax/stx mzlib/trace unstable/syntax scheme/list 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) (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) (define (define/fixup-contract? stx)
(or (syntax-property stx 'typechecker:contract-def) (or (syntax-property stx 'typechecker:contract-def)
@ -135,7 +136,10 @@
(parameterize ([vars (cons (list n #'n* #'n*) (vars))]) (parameterize ([vars (cons (list n #'n* #'n*) (vars))])
#`(flat-rec-contract n* #,(t->c b)))))] #`(flat-rec-contract n* #,(t->c b)))))]
[(Value: #f) #'false/c] [(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%)] [(Class: _ _ _) #'(subclass?/c object%)]
[(Value: '()) #'null?] [(Value: '()) #'null?]
[(Struct: nm par flds proc poly? pred? cert acc-ids) [(Struct: nm par flds proc poly? pred? cert acc-ids)

4
collects/typed-scheme/rep/type-rep.ss
View File

@ -222,6 +222,10 @@
acc-ids)] acc-ids)]
[#:key #f]) [#:key #f])
;; A structure type descriptor
;; s : struct
(dt StructType ([s Struct?]) [#:key 'struct-type])
;; the supertype of all of these values ;; the supertype of all of these values
(dt BoxTop () [#:fold-rhs #:base] [#:key 'box]) (dt BoxTop () [#:fold-rhs #:base] [#:key 'box])
(dt VectorTop () [#:fold-rhs #:base] [#:key 'vector]) (dt VectorTop () [#:fold-rhs #:base] [#:key 'vector])

10
collects/typed-scheme/typecheck/def-binding.ss
View File

@ -1,11 +1,13 @@
#lang scheme/base #lang scheme/base
(require scheme/contract) (require scheme/contract "../utils/utils.ss" scheme/struct-info)
(define-struct binding (name) #:transparent) (define-struct binding (name) #:transparent)
(define-struct (def-binding binding) (ty) #:transparent) (define-struct (def-binding binding) (ty) #:transparent)
(define-struct (def-stx-binding binding) () #: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?])) (p/c (struct binding ([name identifier?]))
(struct (def-binding binding) ([name identifier?] [ty any/c])) (struct (def-binding binding) ([name identifier?] [ty any/c]))
(struct (def-stx-binding binding) ([name identifier?]))) (struct (def-stx-binding binding) ([name identifier?]))
(struct (def-struct-stx-binding binding) ([name identifier?] [static-info (or/c #f struct-info?)])))

218
collects/typed-scheme/typecheck/provide-handling.ss
View File

@ -9,9 +9,10 @@
(private typed-renaming) (private typed-renaming)
(rep type-rep) (rep type-rep)
(utils tc-utils) (utils tc-utils)
scheme/contract/private/provide scheme/contract/private/provide unstable/list
unstable/syntax unstable/debug
"def-binding.ss") unstable/syntax scheme/struct-info scheme/match
"def-binding.ss" syntax/parse)
(require (for-template scheme/base (require (for-template scheme/base
scheme/contract)) scheme/contract))
@ -20,105 +21,136 @@
get-alternate) get-alternate)
(define (provide? form) (define (provide? form)
(kernel-syntax-case form #f (syntax-parse form
#:literals (#%provide)
[(#%provide . rest) form] [(#%provide . rest) form]
[_ #f])) [_ #f]))
(define (remove-provides forms) (define (remove-provides forms)
(filter (lambda (e) (not (provide? e))) (syntax->list forms))) (filter (lambda (e) (not (provide? e))) (syntax->list forms)))
(define (renamer id #:alt [alt #f]) (define (renamer id #:alt [alt #f])
(if alt (if alt
(make-typed-renaming (syntax-property id 'not-free-identifier=? #t) alt) (make-typed-renaming (syntax-property id 'not-free-identifier=? #t) alt)
(make-rename-transformer (syntax-property id 'not-free-identifier=? #t)))) (make-rename-transformer (syntax-property id 'not-free-identifier=? #t))))
(define (generate-prov stx-defs val-defs pos-blame-id) ;; 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 mapping (make-free-identifier-mapping))
(lambda (form)
(define (mem? i vd) (define (mem? i vd)
(cond [(s:member i vd (lambda (i j) (free-identifier=? i (binding-name j)))) => car] (cond [(s:member i vd (lambda (i j) (free-identifier=? i (binding-name j)))) => car]
[else #f])) [else #f]))
(define (lookup-id i vd)
(def-binding-ty (mem? i vd))) ;; generate-contract-defs : listof[def-binding] listof[def-binding] id -> syntax -> syntax
(define (mk internal-id external-id) ;; val-defs: define-values in this module
(cond ;; stx-defs: define-syntaxes in this module
;; if it's already done, do nothing ;; pos-blame-id: a #%variable-reference for the module
[(free-identifier-mapping-get mapping internal-id
;; if it wasn't there, put it in, and skip this case ;; internal-id : the id being provided
(lambda () ;; if `internal-id' is defined in this module, we will produce a (begin def ... provide) block
(free-identifier-mapping-put! mapping internal-id #t) ;; and a name to provide instead of internal-id
#f))
#'(begin)] ;; anything already recorded in the mapping is given an empty (begin) and the already-recorded id
[(mem? internal-id val-defs) ;; otherwise, we will map internal-id to the fresh id in `mapping'
=> (define ((generate-prov stx-defs val-defs pos-blame-id) form)
(lambda (b) ;; mk : id [id] -> (values syntax id)
(with-syntax ([id internal-id] (define (mk internal-id [new-id (generate-temporary internal-id)])
[out-id external-id]) (cond
(cond [(type->contract (def-binding-ty b) (lambda () #f) #:out #t) ;; if it's already done, do nothing
=> [(free-identifier-mapping-get mapping internal-id
(lambda (cnt) ;; if it wasn't there, put it in, and skip this case
(with-syntax ([(export-id cnt-id) (generate-temporaries #'(id id))] (lambda ()
[module-source pos-blame-id] (free-identifier-mapping-put! mapping internal-id new-id)
[the-contract (generate-temporary 'generated-contract)]) #f))
#`(begin => (lambda (mapped-id)
(define the-contract #,cnt) (values #'(begin) mapped-id))]
(define-syntax cnt-id [(mem? internal-id val-defs)
(make-provide/contract-transformer =>
(quote-syntax the-contract) (lambda (b)
(quote-syntax id) (values
(quote-syntax out-id) (with-syntax ([id internal-id])
(quote-syntax module-source))) (cond [(type->contract (def-binding-ty b) (lambda () #f) #:out #t)
(define-syntax export-id =>
(if (unbox typed-context?) (lambda (cnt)
(renamer #'id #:alt #'cnt-id) (with-syntax ([(cnt-id) (generate-temporaries #'(id))]
(renamer #'cnt-id))) [export-id new-id]
(#%provide (rename export-id out-id)))))] [module-source pos-blame-id]
[else [the-contract (generate-temporary 'generated-contract)])
(with-syntax ([(export-id error-id) (generate-temporaries #'(id id))]) #`(begin
#`(begin (define the-contract #,cnt)
(define-syntax error-id (define-syntax cnt-id
(lambda (stx) (tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id)))) (make-provide/contract-transformer
(define-syntax export-id (quote-syntax the-contract)
(if (unbox typed-context?) (quote-syntax id)
(renamer #'id #:alt #'error-id) (quote-syntax out-id)
(renamer #'error-id))) (quote-syntax module-source)))
(provide (rename-out [export-id out-id]))))])))] (define-syntax export-id
[(mem? internal-id stx-defs) (if (unbox typed-context?)
=> (renamer #'id #:alt #'cnt-id)
(lambda (b) (renamer #'cnt-id))))))]
(with-syntax ([id internal-id] [else
[out-id external-id]) (with-syntax ([(error-id) (generate-temporaries #'(id))]
(with-syntax ([(export-id error-id) (generate-temporaries #'(id id))]) [export-id new-id])
#`(begin #`(begin
(define-syntax error-id (define-syntax error-id
(lambda (stx) (lambda (stx) (tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id))))
(tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'out-id)))) (define-syntax export-id
(define-syntax export-id (if (unbox typed-context?)
(if (unbox typed-context?) (renamer #'id #:alt #'error-id)
(begin (renamer #'error-id)))))]))
(add-alias #'export-id #'id) new-id))]
(renamer #'id #:alt #'error-id)) [(mem? internal-id stx-defs)
(renamer #'error-id))) =>
(provide (rename-out [export-id out-id]))))))] (lambda (b)
[(eq? (syntax-e internal-id) (syntax-e external-id)) (define (mk-untyped-syntax defn-id internal-id)
#`(provide #,internal-id)] (match b
[else #`(provide (rename-out [#,internal-id #,external-id]))])) [(struct def-struct-stx-binding (_ (? struct-info? si)))
(kernel-syntax-case form #f (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 ...) [(#%provide form ...)
(map (for/list ([f (syntax->list #'(form ...))])
(lambda (f) (parameterize ([current-orig-stx f])
(parameterize ([current-orig-stx f]) (syntax-parse f
(syntax-case* f (struct rename all-defined protect all-defined-except all-from all-from-except) [i:id
(lambda (a b) (eq? (syntax-e a) (syntax-e b))) (do-one #'i)]
[id [((~datum rename) in out)
(identifier? #'id) (do-one #'in #'out)]
(mk #'id #'id)] [((~datum protect) . _)
[(rename in out) (tc-error "provide: protect not supported by Typed Scheme")]
(mk #'in #'out)] [_ (int-err "unknown provide form")])))]
[(protect . _) [_ (int-err "non-provide form! ~a" (syntax->datum form))]))
(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))])))

31
collects/typed-scheme/typecheck/tc-structs.ss
View File

@ -66,11 +66,11 @@
(values (reverse getters) (reverse setters)) (values (reverse getters) (reverse setters))
(loop (cddr l) (cons (car l) getters) (cons (cadr l) setters))))) (loop (cddr l) (cons (car l) getters) (cons (cadr l) setters)))))
(match (build-struct-names nm flds #f (not setters?) nm) (match (build-struct-names nm flds #f (not setters?) nm)
[(list _ maker pred getters/setters ...) [(list sty maker pred getters/setters ...)
(if setters? (if setters?
(let-values ([(getters setters) (split getters/setters)]) (let-values ([(getters setters) (split getters/setters)])
(values maker pred getters setters)) (values sty maker pred getters setters))
(values maker pred getters/setters #f))])) (values sty maker pred getters/setters #f))]))
;; gets the fields of the parent type, if they exist ;; gets the fields of the parent type, if they exist
;; Option[Struct-Ty] -> Listof[Type] ;; Option[Struct-Ty] -> Listof[Type]
@ -88,6 +88,7 @@
#:type-wrapper [type-wrapper values] #:type-wrapper [type-wrapper values]
#:pred-wrapper [pred-wrapper values] #:pred-wrapper [pred-wrapper values]
#:mutable [setters? #f] #:mutable [setters? #f]
#:struct-info [si #f]
#:proc-ty [proc-ty #f] #:proc-ty [proc-ty #f]
#:maker [maker* #f] #:maker [maker* #f]
#:predicate [pred* #f] #:predicate [pred* #f]
@ -95,7 +96,7 @@
#:poly? [poly? #f] #:poly? [poly? #f]
#:type-only [type-only #f]) #:type-only [type-only #f])
;; create the approriate names that define-struct will bind ;; 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)] (let* ([name (syntax-e nm)]
[fld-types (append parent-field-types types)] [fld-types (append parent-field-types types)]
[sty (make-Struct name parent fld-types proc-ty poly? pred (syntax-local-certifier) getters)] [sty (make-Struct name parent fld-types proc-ty poly? pred (syntax-local-certifier) getters)]
@ -109,6 +110,7 @@
#:pred-wrapper pred-wrapper #:pred-wrapper pred-wrapper
#:maker (or maker* maker) #:maker (or maker* maker)
#:predicate (or pred* pred) #:predicate (or pred* pred)
#:struct-info si
#:constructor-return cret)))) #:constructor-return cret))))
;; generate names, and register the approriate types give field types and structure type ;; 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 ;; 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? (define (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters?
#:wrapper [wrapper values] #:wrapper [wrapper values]
#:struct-info [si #f]
#:type-wrapper [type-wrapper values] #:type-wrapper [type-wrapper values]
#:pred-wrapper [pred-wrapper values] #:pred-wrapper [pred-wrapper values]
#:maker [maker* #f] #:maker [maker* #f]
#:predicate [pred* #f] #:predicate [pred* #f]
#:constructor-return [cret #f]) #:constructor-return [cret #f])
;; create the approriate names that define-struct will bind ;; 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 ;; the type name that is used in all the types
(define name (type-wrapper (make-Name nm))) (define name (type-wrapper (make-Name nm)))
;; the list of names w/ types ;; the list of names w/ types
(define bindings (define bindings
(append (append
(list (cons (or maker* maker) (list
(wrapper (->* external-fld-types (if cret cret name)))) (cons struct-type-id
(cons (or pred* pred) (make-StructType sty))
(make-pred-ty (if setters? (cons (or maker* maker)
(make-StructTop sty) (wrapper (->* external-fld-types (if cret cret name))))
(pred-wrapper 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)]) (for/list ([g (in-list getters)] [t (in-list external-fld-types/no-parent)] [i (in-naturals)])
(let ([func (if setters? (let ([func (if setters?
(->* (list name) t) (->* (list name) t)
@ -146,7 +152,7 @@
null))) null)))
(register-type-name nm (wrapper sty)) (register-type-name nm (wrapper sty))
(cons (cons
(make-def-stx-binding nm) (make-def-struct-stx-binding nm si)
(for/list ([e bindings]) (for/list ([e bindings])
(let ([nm (car e)] (let ([nm (car e)]
[t (cdr e)]) [t (cdr e)])
@ -207,6 +213,7 @@
#:proc-ty proc-ty-parsed #:proc-ty proc-ty-parsed
#:maker maker #:maker maker
#:predicate pred #:predicate pred
#:struct-info (syntax-property nm/par 'struct-info)
#:constructor-return (and cret (parse-type cret)) #:constructor-return (and cret (parse-type cret))
#:mutable mutable #:mutable mutable
#:type-only type-only)) #:type-only type-only))

6
collects/typed-scheme/types/subtype.ss
View File

@ -333,6 +333,12 @@
(subtype* A0 t t*)] (subtype* A0 t t*)]
[((Instance: t) (Instance: t*)) [((Instance: t) (Instance: t*))
(subtype* A0 t 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 ;; otherwise, not a subtype
[(_ _) (fail! s t) #;(printf "failed")])))])))) [(_ _) (fail! s t) #;(printf "failed")])))]))))

6
collects/typed-scheme/utils/utils.ss
View File

@ -172,11 +172,9 @@ at least theoretically.
(define-syntax-class clause (define-syntax-class clause
#:literals () #:literals ()
#:attributes (i) #:attributes (i)
(pattern [struct nm:id (flds ...)] (pattern [(~datum struct) (~or nm:id (nm:id super:id)) (flds ...)]
#:fail-unless (eq? (syntax-e #'struct) 'struct) #f
#:with i #'(struct-out nm)) #:with i #'(struct-out nm))
(pattern [rename out:id in:id cnt:expr] (pattern [(~datum rename) out:id in:id cnt:expr]
#:fail-unless (eq? (syntax-e #'rename) 'rename) #f
#:with i #'(rename-out [out in])) #:with i #'(rename-out [out in]))
(pattern [i:id cnt:expr])) (pattern [i:id cnt:expr]))
(syntax-parse stx (syntax-parse stx