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

Make typechecking code use label instead of template for binding.

Browse Source 
original commit: 93e9aaf99664e1bcf1da7337158352494f878d1e
This commit is contained in:
Eric Dobson 2013-11-16 10:39:23 -08:00
parent e461393ea8
commit a49df31fed
9 changed files with 44 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/def-export.rkt
View File

@ -1,15 +1,16 @@
#lang racket/base
(require racket/require (for-template "renamer.rkt") "renamer.rkt"
(for-syntax syntax/parse racket/base "renamer.rkt"
(path-up "utils/tc-utils.rkt")))
(require
(for-syntax syntax/parse racket/base
"renamer.rkt"
"../utils/tc-utils.rkt"))
(provide def-export)
(define-syntax (def-export stx)
(syntax-parse stx
[(def-export export-id:identifier id:identifier cnt-id:identifier)
#'(define-syntax export-id
(let ([c #'cnt-id])
(if (unbox typed-context?)
(renamer #'id c)
(renamer c))))]))
(let ([c #'cnt-id])
(if (unbox typed-context?)
(renamer #'id c)
(renamer c))))]))

13
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/find-annotation.rkt
View File

@ -5,7 +5,7 @@
(rep type-rep)
(env lexical-env)
(private type-annotation)
(for-template racket/base))
(for-label racket/base))
(provide/cond-contract [find-annotation (syntax? identifier? . -> . (or/c #f Type/c))])
@ -20,9 +20,7 @@
#:with (vs ...) #'((cl.v ...) ...)))
(define-syntax-class core-expr
#:literals (reverse letrec-syntaxes+values let-values #%plain-app
if letrec-values begin #%plain-lambda set! case-lambda
begin0 with-continuation-mark)
#:literal-sets (kernel-literals)
#:transparent
(pattern (let-values cls:lv-clauses body)
#:with (expr ...) #'(cls.e ... body))
@ -43,6 +41,9 @@
(pattern _
#:with (expr ...) #'()))
(define-literal-set find-annotation-literals #:for-label
(reverse))
;; expr id -> type or #f
;; if there is a binding in stx of the form:
;; (let ([x (reverse name)]) e) or
@ -52,7 +53,7 @@
(define (find s) (find-annotation s name))
(define (match? b)
(syntax-parse b
#:literals (#%plain-app reverse)
#:literal-sets (kernel-literals find-annotation-literals)
[c:lv-clause
#:with n:id #'c.e
#:with (v) #'(c.v ...)
@ -65,7 +66,7 @@
(or (type-annotation #'v) (lookup-type/lexical #'v #:fail (lambda _ #f)))]
[_ #f]))
(syntax-parse stx
#:literals (let-values)
#:literal-sets (kernel-literals)
[(let-values cls:lv-clauses body)
(or (ormap match? (syntax->list #'cls))
(find #'body))]

7
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt
View File

@ -4,7 +4,7 @@
syntax/parse
(for-syntax racket/base racket/syntax
syntax/parse syntax/parse/experimental/template)
(for-template racket/base))
(for-label racket/base))
(provide
(for-syntax internal)
@ -69,11 +69,12 @@
;;; Internal form syntax matching
(define-literal-set internal-form-literals #:for-label
(values))
(define-syntax-class internal^
#:attributes (value)
#:literals (values)
#:literal-sets (kernel-literals)
#:literal-sets (kernel-literals internal-form-literals)
(pattern (define-values () (begin (quote-syntax value:expr) (#%plain-app values)))))
(define-syntax (define-internal-classes stx)

5
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/provide-handling.rkt
View File

@ -7,13 +7,14 @@
(typecheck renamer def-binding)
(utils tc-utils)
(for-syntax racket/base)
(for-template racket/base "def-export.rkt" racket/contract))
(for-template racket/base "def-export.rkt"
(only-in racket/contract/base define-module-boundary-contract)))
(provide remove-provides provide? generate-prov get-alternate)
(define (provide? form)
(syntax-parse form
#:literals (#%provide)
#:literal-sets (kernel-literals)
[(#%provide . rest) form]
[_ #f]))

19
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt
View File

@ -15,13 +15,18 @@
unstable/syntax
(only-in racket/list split-at)
(typecheck internal-forms)
(for-template (only-in '#%paramz [parameterization-key pz:pk])))
;; Needed for current implementation of typechecking letrec-syntax+values
(for-template (only-in racket/base letrec-values))
(require (for-template racket/base racket/private/class-internal))
(for-label (only-in '#%paramz [parameterization-key pz:pk])
(only-in racket/private/class-internal find-method/who)))
(import tc-if^ tc-lambda^ tc-app^ tc-let^ tc-send^ check-subforms^ tc-literal^)
(export tc-expr^)
(define-literal-set tc-expr-literals #:for-label
(find-method/who))
;; do-inst : syntax type -> type
(define (do-inst stx ty)
(define inst (type-inst-property stx))
@ -178,8 +183,7 @@
(unless (syntax? form)
(int-err "bad form input to tc-expr: ~a" form))
(syntax-parse form
#:literal-sets (kernel-literals)
#:literals (find-method/who)
#:literal-sets (kernel-literals tc-expr-literals)
[stx:exn-handlers^
(check-subforms/with-handlers/check form expected)]
[stx:ignore-some^
@ -222,7 +226,7 @@
(tc-expr/check #'e3 expected)]
[(? (λ (result)
(and (identifier? #'e1)
(free-identifier=? #'pz:pk #'e1))))
(free-identifier=? #'pz:pk #'e1 #f (syntax-local-phase-level)))))
(tc-expr/check/type #'e2 Univ)
(tc-expr/check #'e3 expected)]
[(tc-result1: key-t)
@ -314,8 +318,7 @@
;; internal-tc-expr : syntax -> Type
(define (internal-tc-expr form)
(syntax-parse form
#:literal-sets (kernel-literals)
#:literals (#%app lambda find-method/who)
#:literal-sets (kernel-literals tc-expr-literals)
;;
[stx:exn-handlers^
(check-subforms/with-handlers form) ]
@ -341,7 +344,7 @@
(tc-expr #'e3)]
[(? (λ (result)
(and (identifier? #'e1)
(free-identifier=? #'pz:pk #'e1))))
(free-identifier=? #'pz:pk #'e1 #f (syntax-local-phase-level)))))
(tc-expr/check/type #'e2 Univ)
(tc-expr #'e3)]
[(tc-result1: key-t)

7
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt
View File

@ -11,8 +11,7 @@
(types type-table)
(typecheck signatures tc-metafunctions tc-subst)
(env lexical-env tvar-env index-env scoped-tvar-env)
(utils tc-utils)
(for-template racket/base))
(utils tc-utils))
(import tc-expr^)
(export tc-lambda^)
@ -39,13 +38,13 @@
#:drest (and drest (second drest))))]))
(define-syntax-class cl-rhs
#:literals (if)
#:literal-sets (kernel-literals)
#:attributes (i cond)
[pattern i:id #:attr cond #f]
[pattern (if cond:id i:id e:expr)])
(define-syntax-class rebuild-let*
#:literals (let-values)
#:literal-sets (kernel-literals)
#:attributes (mapping flag-mapping)
(pattern (let-values ([(new-id) e:cl-rhs]) body:rebuild-let*)
#:attr mapping (dict-set (attribute body.mapping) #'e.i #'new-id)

5
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt
View File

@ -10,7 +10,8 @@
(typecheck signatures tc-metafunctions tc-subst internal-forms)
racket/match (contract-req)
syntax/parse syntax/stx
(for-template racket/base))
;; For internal type forms
(for-template (only-in racket/base define-values)))
(import tc-expr^)
@ -197,7 +198,7 @@
;; this is so match can provide us with a syntax property to
;; say that this binding is only called in tail position
(define ((tc-expr-t/maybe-expected expected) e)
(syntax-parse e #:literals (#%plain-lambda)
(syntax-parse e #:literal-sets (kernel-literals)
[(~and (#%plain-lambda () _) _:tail-position^)
#:when expected
(tc-expr/check e (ret (t:-> (tc-results->values expected))))]

3
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt
View File

@ -11,8 +11,7 @@
(env global-env type-name-env tvar-env)
(utils tc-utils)
(typecheck def-binding internal-forms)
(for-syntax syntax/parse racket/base)
(for-template racket/base))
(for-syntax syntax/parse racket/base))
(provide tc/struct name-of-struct d-s
refine-struct-variance!

10
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt
View File

@ -13,12 +13,10 @@
(typecheck provide-handling def-binding tc-structs
typechecker internal-forms)
syntax/location
(for-template
syntax/location
racket/base
(env env-req)))
(for-template
(only-in syntax/location quote-module-name)
racket/base))
(provide/cond-contract
[tc-module (syntax? . c:-> . (values syntax? syntax?))]
@ -296,7 +294,7 @@
(~datum all-defined) (~datum all-defined-except)
(~datum prefix-all-defined) (~datum prefix-all-defined-except)
(~datum expand)))))
(syntax-parse p #:literals (#%provide)
(syntax-parse p #:literal-sets (kernel-literals)
[(#%provide form ...)
(for/fold ([h h]) ([f (in-syntax #'(form ...))])
(parameterize ([current-orig-stx f])