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

Clean up contracts in TR.

Browse Source
This commit is contained in:
Eric Dobson 2012-09-01 16:26:27 -07:00 committed by Sam Tobin-Hochstadt
parent 2a8512ed72
commit 6fe850ce39
4 changed files with 8 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/typed-racket/rep/type-rep.rkt
View File

@ -307,7 +307,7 @@
;; acc-ids : names of the accessors ;; acc-ids : names of the accessors
;; maker-id : name of the constructor ;; maker-id : name of the constructor
(def-type Struct ([name identifier?] (def-type Struct ([name identifier?]
[parent (or/c #f Struct? Name?)] [parent (or/c #f Struct?)]
[flds (listof fld?)] [flds (listof fld?)]
[proc (or/c #f Function?)] [proc (or/c #f Function?)]
[poly? (or/c #f (listof symbol?))] [poly? (or/c #f (listof symbol?))]

2
collects/typed-racket/typecheck/signatures.rkt
View File

@ -30,7 +30,7 @@
(define-signature tc-app^ (define-signature tc-app^
([cond-contracted tc/app (syntax? . -> . tc-results?)] ([cond-contracted tc/app (syntax? . -> . tc-results?)]
[cond-contracted tc/app/check (syntax? tc-results? . -> . tc-results?)] [cond-contracted tc/app/check (syntax? tc-results? . -> . tc-results?)]
[cond-contracted tc/app-regular (syntax? . -> . tc-results?)])) [cond-contracted tc/app-regular (syntax? (or/c tc-results? #f) . -> . tc-results?)]))
(define-signature tc-apply^ (define-signature tc-apply^
([cond-contracted tc/apply (syntax? syntax? . -> . tc-results?)])) ([cond-contracted tc/apply (syntax? syntax? . -> . tc-results?)]))

3
collects/typed-racket/typecheck/tc-app/signatures.rkt
View File

@ -1,11 +1,12 @@
#lang racket/base #lang racket/base
(require racket/unit (require racket/unit
"../../utils/utils.rkt" "../../utils/unit-utils.rkt" "../../utils/utils.rkt" "../../utils/unit-utils.rkt"
syntax/parse/experimental/reflect
racket/contract racket/contract
(types utils)) (types utils))
(provide (except-out (all-defined-out) checker/c)) (provide (except-out (all-defined-out) checker/c))
(define checker/c (syntax? (or/c #f tc-results?). -> . (or/c #f tc-results?))) (define checker/c reified-syntax-class?)
(define-signature tc-app-hetero^ (define-signature tc-app-hetero^
([cond-contracted tc/app-hetero checker/c])) ([cond-contracted tc/app-hetero checker/c]))

7
collects/typed-racket/typecheck/tc-structs.rkt
View File

@ -277,7 +277,7 @@
;; create the actual structure type, and the types of the fields ;; create the actual structure type, and the types of the fields
;; that the outside world will see ;; that the outside world will see
(mk/register-sty nm flds parent-name (get-parent-flds parent) types (mk/register-sty nm flds parent (get-parent-flds parent) types
;; procedure ;; procedure
#:proc-ty proc-ty-parsed #:proc-ty proc-ty-parsed
#:maker maker #:maker maker
@ -295,10 +295,11 @@
(c-> identifier? (or/c #f identifier?) (listof identifier?) (c-> identifier? (or/c #f identifier?) (listof identifier?)
(listof Type/c) (or/c #f identifier?) (listof Type/c) (or/c #f identifier?)
any/c) any/c)
(define parent-name (if parent (make-Name parent) #f)) (define parent-name (and parent (make-Name parent)))
(define parent-type (and parent (lookup-type-name parent)))
(define parent-flds (if parent (get-parent-flds parent-name) null)) (define parent-flds (if parent (get-parent-flds parent-name) null))
(define parent-tys (map fld-t parent-flds)) (define parent-tys (map fld-t parent-flds))
(define defs (mk/register-sty nm flds parent-name parent-flds tys #:mutable #t)) (define defs (mk/register-sty nm flds parent-type parent-flds tys #:mutable #t))
(when kernel-maker (when kernel-maker
(register-type kernel-maker (λ () (->* (append parent-tys tys) (lookup-type-name nm)))))) (register-type kernel-maker (λ () (->* (append parent-tys tys) (lookup-type-name nm))))))