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

Fix errors in tc/app-hetero, cleanup tc/app.

Browse Source 
original commit: 1e15d4496e3cefc6853d1a843a13b8f11bc55fd5
This commit is contained in:
Eric Dobson 2012-08-23 21:13:30 -07:00 committed by Sam Tobin-Hochstadt
parent 696b463b46
commit 933db45b14
2 changed files with 42 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2,6 +2,7 @@
(require "../utils/utils.rkt"
"tc-app/signatures.rkt"
"tc-app/utils.rkt"
syntax/parse racket/match
syntax/parse/experimental/reflect
(typecheck signatures check-below tc-funapp)
@ -15,38 +16,46 @@
(export tc-app^)
;; the main dispatching function
;; syntax tc-results? -> tc-results?
(define (tc/app/internal form expected)
(syntax-parse form
[(#%plain-app .
(~or (~var v (tc/app-annotated expected))
(~reflect v (tc/app-list expected) #:attributes (check))
(~reflect v (tc/app-apply expected) #:attributes (check))
(~reflect v (tc/app-eq expected) #:attributes (check))
(~reflect v (tc/app-hetero expected) #:attributes (check))
(~reflect v (tc/app-values expected) #:attributes (check))
(~reflect v (tc/app-keywords expected) #:attributes (check))
(~reflect v (tc/app-objects expected) #:attributes (check))
(~reflect v (tc/app-lambda expected) #:attributes (check))
(~reflect v (tc/app-special expected) #:attributes (check))
(~var v (tc/app-regular* expected))))
((attribute v.check))]))
(define-syntax-class annotated-op
(pattern i:identifier
#:when (or (syntax-property #'i 'type-inst)
(syntax-property #'i 'type-ascription))))
(define-syntax-class (tc/app-annotated expected)
(define-tc/app-syntax-class (tc/app-annotated expected)
;; Just do regular typechecking if we have one of these.
(pattern (~and form (rator:annotated-op . rands))
#:attr check (lambda () (tc/app-regular #'form expected))))
(tc/app-regular #'form expected)))
(define-tc/app-syntax-class (tc/app-regular* expected)
(pattern form (tc/app-regular #'form expected)))
(define-syntax-rule (combine-tc/app-syntax-classes class-name case ...)
(define-syntax-class (class-name expected)
#:attributes (check)
(pattern (~reflect v (case expected) #:attributes (check))
#:attr check (attribute v.check)) ...))
(combine-tc/app-syntax-classes tc/app-special-cases
tc/app-annotated
tc/app-list
tc/app-apply
tc/app-eq
tc/app-hetero
tc/app-values
tc/app-keywords
tc/app-objects
tc/app-lambda
tc/app-special
tc/app-regular*)
;; the main dispatching function
;; syntax tc-results? -> tc-results?
(define (tc/app/internal form expected)
(syntax-parse form
[(#%plain-app . (~var v (tc/app-special-cases expected)))
((attribute v.check))]))
(define-syntax-class (tc/app-regular* expected)
(pattern form
#:attr check (lambda () (tc/app-regular #'form expected))))
(define (tc/app-regular form expected)
(syntax-parse form

18
collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt
View File

@ -83,32 +83,32 @@
unsafe-struct-ref unsafe-struct*-ref
unsafe-struct-set! unsafe-struct*-set!
vector-immutable vector)
(pattern ((~or unsafe-struct-ref unsafe-struct*-ref) struct:expr index:expr)
(pattern (~and form ((~or unsafe-struct-ref unsafe-struct*-ref) struct:expr index:expr))
(match (single-value #'struct)
[(tc-result1: (and struct-t (app resolve (Struct: _ _ (list (fld: flds _ _) ...) _ _ _ _ _))))
(tc/hetero-ref #'index flds struct-t expected "struct")]
[s-ty #f]))
[s-ty (tc/app-regular #'form expected)]))
;; vector-ref on het vectors
(pattern ((~or vector-ref unsafe-vector-ref unsafe-vector*-ref) vec:expr index:expr)
(pattern (~and form ((~or vector-ref unsafe-vector-ref unsafe-vector*-ref) vec:expr index:expr))
(match (single-value #'vec)
[(tc-result1: (and vec-t (app resolve (HeterogenousVector: es))))
(tc/hetero-ref #'index es vec-t expected "vector")]
[v-ty #f]))
[v-ty (tc/app-regular #'form expected)]))
;; unsafe struct-set!
(pattern ((~or unsafe-struct-set! unsafe-struct*-set!) s:expr index:expr val:expr)
(pattern (~and form ((~or unsafe-struct-set! unsafe-struct*-set!) s:expr index:expr val:expr))
(match (single-value #'s)
[(tc-result1: (and struct-t (app resolve (Struct: _ _ (list (fld: flds _ _) ...) _ _ _ _ _))))
(tc/hetero-set! #'index flds #'val struct-t expected "struct")]
[s-ty #f]))
[s-ty (tc/app-regular #'form expected)]))
;; vector-set! on het vectors
(pattern ((~or vector-set! unsafe-vector-set! unsafe-vector*-set!) v:expr index:expr val:expr)
(pattern (~and form ((~or vector-set! unsafe-vector-set! unsafe-vector*-set!) v:expr index:expr val:expr))
(match (single-value #'v)
[(tc-result1: (and vec-t (app resolve (HeterogenousVector: es))))
(tc/hetero-set! #'index es #'val vec-t expected "vector")]
[v-ty #f]))
[v-ty (tc/app-regular #'form expected)]))
(pattern (~and form ((~or vector-immutable vector) args:expr ...))
(match expected
[(tc-result1: (app resolve (Vector: t))) #f]
[(tc-result1: (app resolve (Vector: t))) (tc/app-regular #'form expected)]
[(tc-result1: (app resolve (HeterogenousVector: ts)))
(unless (= (length ts) (length (syntax->list #'(args ...))))
(tc-error/expr "expected vector with ~a elements, but got ~a"