diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-apply.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-apply.rkt index aea5a3fd..e5f9f0b6 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-apply.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-apply.rkt @@ -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)) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-eq.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-eq.rkt index acc989d8..b980e687 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-eq.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-eq.rkt @@ -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) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-hetero.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-hetero.rkt index b012c1af..1f010b41 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-hetero.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-hetero.rkt @@ -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 _ _) ...) _ _ _)))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-keywords.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-keywords.rkt index 13a4f0ea..f3e21805 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-keywords.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-keywords.rkt @@ -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 diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-lambda.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-lambda.rkt index 99a1b0e1..661fca83 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-lambda.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-lambda.rkt @@ -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 ...)) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-list.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-list.rkt index 910203ea..87b372c5 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-list.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-list.rkt @@ -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)])]))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt index 1c731a8c..737b5f9f 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt @@ -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) ...)) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-special.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-special.rkt index 0ca5e1f8..d6f515ff 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-special.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-special.rkt @@ -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 ...))]) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-values.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-values.rkt index e4f853da..9466d6aa 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-values.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-values.rkt @@ -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)