From a49df31fedaf8f5a9a0d05af23f3b52f51637f83 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Sat, 16 Nov 2013 10:39:23 -0800 Subject: [PATCH] Make typechecking code use label instead of template for binding. original commit: 93e9aaf99664e1bcf1da7337158352494f878d1e --- .../typed-racket/typecheck/def-export.rkt | 15 ++++++++------- .../typecheck/find-annotation.rkt | 13 +++++++------ .../typed-racket/typecheck/internal-forms.rkt | 7 ++++--- .../typecheck/provide-handling.rkt | 5 +++-- .../typed-racket/typecheck/tc-expr-unit.rkt | 19 +++++++++++-------- .../typed-racket/typecheck/tc-lambda-unit.rkt | 7 +++---- .../typed-racket/typecheck/tc-let-unit.rkt | 5 +++-- .../typed-racket/typecheck/tc-structs.rkt | 3 +-- .../typed-racket/typecheck/tc-toplevel.rkt | 10 ++++------ 9 files changed, 44 insertions(+), 40 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/def-export.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/def-export.rkt index 3dd3621c..7197e7ac 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/def-export.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/def-export.rkt @@ -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))))])) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/find-annotation.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/find-annotation.rkt index 1bc8cc29..a6a72177 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/find-annotation.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/find-annotation.rkt @@ -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))] diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt index dee21614..b7ae7172 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt @@ -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) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/provide-handling.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/provide-handling.rkt index 0d22b0b2..37f4652b 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/provide-handling.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/provide-handling.rkt @@ -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])) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt index e23e1b88..a1238399 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt @@ -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) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt index 049ef9a3..a38d3e52 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt @@ -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) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt index 13ce18e7..5c048bb2 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt @@ -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))))] diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt index 007284d2..8b210618 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt @@ -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! diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt index 48f0b4de..c0b7b564 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt @@ -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])