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

Make tc-app code match using label phase.

Browse Source 
original commit: 3d0cadf0a8baedf75df55be810cb4437734ea7e0
This commit is contained in:
Eric Dobson 2013-11-16 11:36:35 -08:00
parent e068dda6a1
commit fdb60234ed
9 changed files with 71 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-apply.rkt
View File

@ -8,10 +8,7 @@
(types abbrev utils)
(rep type-rep)
;; fixme - don't need to be bound in this phase - only to make tests work
(only-in '#%kernel [apply k:apply])
;; end fixme
(for-template
(for-label
racket/base
(only-in '#%kernel [apply k:apply])))
@ -19,8 +16,12 @@
(import tc-expr^ tc-apply^)
(export tc-app-apply^)
(define-literal-set apply-literals
#:for-label
(k:apply apply values))
(define-tc/app-syntax-class (tc/app-apply expected)
#:literals (k:apply apply values)
#:literal-sets (apply-literals)
(pattern ((~or apply k:apply) values e)
(match (single-value #'e)
[(tc-result1: (ListDots: dty dbound))

26
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-eq.rkt
View File

@ -8,21 +8,20 @@
(types abbrev union utils)
(rep type-rep)
;; fixme - don't need to be bound in this phase - only to make tests work
racket/bool
;; end fixme
(for-template racket/base racket/bool))
(for-label racket/base racket/bool))
(import tc-expr^)
(export tc-app-eq^)
(define-literal-set eq-literals
#:for-label
(eq? equal? eqv? string=? symbol=? memq member memv))
;; comparators that inform the type system
;; `=' is not included. Its type is more useful than this typing rule.
(define-syntax-class comparator
#:literals (eq? equal? eqv? string=? symbol=? memq member memv)
(pattern eq?) (pattern equal?) (pattern eqv?) (pattern string=?) (pattern symbol=?)
(pattern member) (pattern memq) (pattern memv))
#:literal-sets (eq-literals)
(pattern (~or eq? equal? eqv? string=? symbol=? member memq memv)))
(define-tc/app-syntax-class (tc/app-eq expected)
@ -42,9 +41,12 @@
(define (eq?-able e) (or (boolean? e) (keyword? e) (symbol? e) (eof-object? e)))
(define (eqv?-able e) (or (eq?-able e) (number? e) (char? e)))
(define (equal?-able e) #t)
(define (id=? a b)
(free-identifier=? a b #f (syntax-local-phase-level)))
(define (ok? val)
(define-syntax-rule (alt nm pred ...)
(and (free-identifier=? #'nm comparator) (or (pred val) ...)))
(and (id=? #'nm comparator)
(or (pred val) ...)))
(or (alt symbol=? symbol?)
(alt string=? string?)
(alt eq? eq?-able)
@ -60,11 +62,11 @@
(-FS (-filter-at (-val val) o)
(-not-filter-at (-val val) o)))]
[((tc-result1: t _ o)
(or (and (? (lambda _ (free-identifier=? #'member comparator)))
(or (and (? (lambda _ (id=? #'member comparator)))
(tc-result1: (app untuple (list (and ts (Value: _)) ...))))
(and (? (lambda _ (free-identifier=? #'memv comparator)))
(and (? (lambda _ (id=? #'memv comparator)))
(tc-result1: (app untuple (list (and ts (Value: (? eqv?-able))) ...))))
(and (? (lambda _ (free-identifier=? #'memq comparator)))
(and (? (lambda _ (id=? #'memq comparator)))
(tc-result1: (app untuple (list (and ts (Value: (? eq?-able))) ...))))))
(let ([ty (apply Un ts)])
(ret (Un (-val #f) t)

22
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-hetero.rkt
View File

@ -4,22 +4,26 @@
syntax/parse syntax/stx racket/match unstable/sequence unstable/syntax
"signatures.rkt"
"utils.rkt"
;; fixme - don't need to be bound in this phase - only to make tests work
racket/unsafe/ops
;; end fixme
(types utils abbrev numeric-tower union resolve type-table generalize)
(typecheck signatures check-below)
(rep type-rep rep-utils)
(for-template racket/unsafe/ops racket/base))
(for-label racket/unsafe/ops racket/base))
(import tc-expr^ tc-app^ tc-literal^)
(export tc-app-hetero^)
(define-literal-set hetero-literals
#:for-label
(vector-ref unsafe-vector-ref unsafe-vector*-ref
vector-set! unsafe-vector-set! unsafe-vector*-set!
unsafe-struct-ref unsafe-struct*-ref
unsafe-struct-set! unsafe-struct*-set!
vector-immutable vector))
(define (tc/index expr)
(syntax-parse expr
[((~literal quote) i:number)
#:literal-sets (kernel-literals)
[(quote i:number)
(let ((type (tc-literal #'i)))
(add-typeof-expr expr (ret type))
(syntax-e #'i))]
@ -73,11 +77,7 @@
(index-error i-val i-bound i-e vec-t expected name)]))
(define-tc/app-syntax-class (tc/app-hetero expected)
#:literals (vector-ref unsafe-vector-ref unsafe-vector*-ref
vector-set! unsafe-vector-set! unsafe-vector*-set!
unsafe-struct-ref unsafe-struct*-ref
unsafe-struct-set! unsafe-struct*-set!
vector-immutable vector)
#:literal-sets (hetero-literals)
(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 _ _) ...) _ _ _))))

7
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-keywords.rkt
View File

@ -10,15 +10,16 @@
(rep type-rep)
(utils tc-utils)
(r:infer infer)
(for-template racket/base))
(for-label racket/base))
(import tc-expr^)
(export tc-app-keywords^)
(define-literal-set keyword-literals #:for-label (list))
(define-tc/app-syntax-class (tc/app-keywords expected)
#:literals (#%plain-app list)
#:literal-sets (kernel-literals keyword-literals)
(pattern (~and form
((#%plain-app cpce s-kp fn kpe kws num)
kw-list

27
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-lambda.rkt
View File

@ -8,33 +8,38 @@
(typecheck signatures find-annotation)
(types abbrev utils generalize type-table)
(private type-annotation)
(for-template racket/base))
;; Needed to construct args to tc/let-values
(for-template racket/base)
(for-label racket/base))
(import tc-expr^ tc-let^ tc-lambda^)
(export tc-app-lambda^)
(define-literal-set lambda-literals
#:for-label
(null? pair? null))
(define-tc/app-syntax-class (tc/app-lambda expected)
#:literals (#%plain-app #%plain-lambda letrec-values)
#:literal-sets (kernel-literals)
;; let loop
(pattern ((letrec-values ([(lp) (~and lam (#%plain-lambda (args ...) . body))]) lp*) . actuals)
#:fail-unless expected #f
#:fail-unless (not (andmap type-annotation (syntax->list #'(lp args ...)))) #f
#:fail-unless (free-identifier=? #'lp #'lp*) #f
#:when expected
#:when (not (andmap type-annotation (syntax->list #'(lp args ...))))
#:when (free-identifier=? #'lp #'lp*)
(let-loop-check #'lam #'lp #'actuals #'(args ...) #'body expected))
;; inference for ((lambda
(pattern ((#%plain-lambda (x ...) . body) args ...)
#:fail-unless (= (syntax-length #'(x ...))
(syntax-length #'(args ...))) #f
#:when (= (syntax-length #'(x ...))
(syntax-length #'(args ...)))
#:fail-when (andmap type-annotation (syntax->list #'(x ...))) #f
(tc/let-values #'((x) ...) #'(args ...) #'body
#'(let-values ([(x) args] ...) . body)
expected))
;; inference for ((lambda with dotted rest
(pattern ((#%plain-lambda (x ... . rst:id) . body) args ...)
#:fail-unless (<= (syntax-length #'(x ...))
(syntax-length #'(args ...))) #f
#:when (<= (syntax-length #'(x ...))
(syntax-length #'(args ...)))
;; FIXME - remove this restriction - doesn't work because the annotation
;; on rst is not a normal annotation, may have * or ...
#:fail-when (type-annotation #'rst) #f
@ -50,7 +55,7 @@
(define (let-loop-check lam lp actuals args body expected)
(syntax-parse #`(#,args #,body #,actuals)
#:literals (#%plain-app if null? pair? null)
#:literal-sets (kernel-literals lambda-literals)
[((val acc ...)
((~and inner-body (if (#%plain-app (~or pair? null?) val*) thn els)))
(actual actuals ...))

16
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-list.rkt
View File

@ -10,11 +10,7 @@
(rep type-rep)
(env tvar-env)
;; fixme - don't need to be bound in this phase - only to make tests work
(only-in '#%kernel [reverse k:reverse])
;; end fixme
(for-template
(for-label
racket/base
(only-in '#%kernel [reverse k:reverse])))
@ -22,10 +18,12 @@
(import tc-expr^ tc-app^)
(export tc-app-list^)
(define-literal-set list-literals
#:for-label
(reverse k:reverse list list* cons map andmap ormap))
(define-tc/app-syntax-class (tc/app-list expected)
#:literals (reverse k:reverse list list*
cons map andmap ormap)
#:literal-sets (list-literals)
(pattern (~and form (map f arg0 arg ...))
(match* ((single-value #'arg0) (stx-map single-value #'(arg ...)))
;; if the argument is a ListDots
@ -97,7 +95,7 @@
(match-let* ([(list tys ... last) (stx-map tc-expr/t #'args)])
(ret (foldr -pair last tys))))
;; special case for `reverse' to propagate expected type info
(pattern ((~or reverse k:reverse) arg)
(pattern ((~and fun (~or reverse k:reverse)) arg)
(match expected
[(tc-result1: (Listof: _))
(tc-expr/check #'arg expected)]
@ -109,4 +107,4 @@
[(tc-result1: (List: ts))
(ret (-Tuple (reverse ts)))]
[arg-ty
(tc/funapp #'reverse #'(arg) (single-value #'reverse) (list arg-ty) expected)])])))
(tc/funapp #'fun #'(arg) (single-value #'fun) (list arg-ty) expected)])])))

6
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt
View File

@ -10,15 +10,17 @@
(rep type-rep)
(utils tc-utils)
(for-template racket/base))
(for-label racket/base))
(import tc-expr^)
(export tc-app-objects^)
(define-literal-set object-literals #:for-label (list cons))
(define-tc/app-syntax-class (tc/app-objects expected)
#:literals (#%plain-app list cons quote)
#:literal-sets (kernel-literals object-literals)
(pattern (dmo b cl
(#%plain-app list . pos-args)
(#%plain-app list (#%plain-app cons (quote names) named-args) ...))

13
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-special.rkt
View File

@ -11,20 +11,17 @@
(rep type-rep filter-rep)
(utils tc-utils)
;; fixme - don't need to be bound in this phase - only to make tests work
racket/bool
'#%paramz
;; end fixme
(for-template racket/base racket/bool '#%paramz))
(for-label racket/base racket/bool '#%paramz))
(import tc-expr^)
(export tc-app-special^)
(define-literal-set special-literals #:for-label
(extend-parameterization false? not call-with-values list))
(define-tc/app-syntax-class (tc/app-special expected)
#:literals (#%plain-app #%plain-lambda extend-parameterization quote
false? not call-with-values list)
#:literal-sets (kernel-literals special-literals)
;; parameterize
(pattern (extend-parameterization pmz args ...)
(let loop ([args (syntax->list #'(args ...))])

6
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-values.rkt
View File

@ -7,14 +7,16 @@
(typecheck signatures tc-funapp)
(types utils)
(for-template racket/base))
(for-label racket/base))
(import tc-expr^ tc-app^)
(export tc-app-values^)
(define-literal-set values-literals #:for-label (values call-with-values))
(define-tc/app-syntax-class (tc/app-values expected)
#:literals (values call-with-values)
#:literal-sets (values-literals)
;; call-with-values
(pattern (call-with-values prod con)
(match (tc/funapp #'prod #'() (single-value #'prod) null #f)