Make tc-app code match using label phase.

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
+         (for-label
-         (only-in '#%kernel [apply k:apply])
-         ;; end fixme
-         (for-template
           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))

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
+         (for-label racket/base racket/bool))
-         racket/bool
-         ;; end fixme
-
-         (for-template 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)
+  #:literal-sets (eq-literals)
-  (pattern eq?) (pattern equal?) (pattern eqv?) (pattern string=?) (pattern symbol=?)
+  (pattern (~or eq? equal? eqv? string=? symbol=? member memq memv)))
-  (pattern member) (pattern memq) (pattern 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)

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
+  #:literal-sets (hetero-literals)
-              vector-set! unsafe-vector-set! unsafe-vector*-set!
-              unsafe-struct-ref unsafe-struct*-ref
-              unsafe-struct-set! unsafe-struct*-set!
-              vector-immutable vector)
   (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 _ _) ...) _ _ _))))

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-label racket/base))
-         (for-template 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

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)
-
+         ;; Needed to construct args to tc/let-values
-         (for-template racket/base))
+         (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
+    #:when expected
-    #:fail-unless (not (andmap type-annotation (syntax->list #'(lp args ...)))) #f
+    #:when (not (andmap type-annotation (syntax->list #'(lp args ...))))
-    #:fail-unless (free-identifier=? #'lp #'lp*) #f
+    #: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 ...))
+   #:when (= (syntax-length #'(x ...))
-                    (syntax-length #'(args ...))) #f
+             (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 ...))
+   #:when (<= (syntax-length #'(x ...))
-                     (syntax-length #'(args ...))) #f
+              (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 ...))

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
+         (for-label
-         (only-in '#%kernel [reverse k:reverse])
-         ;; end fixme
-
-         (for-template
           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*
+  #:literal-sets (list-literals)
-              cons map andmap ormap)
   (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)])])))

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) ...))

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
+         (for-label racket/base racket/bool '#%paramz))
-         racket/bool
-         '#%paramz
-         ;; end fixme
-
-         (for-template 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
+  #:literal-sets (kernel-literals special-literals)
-              false? not call-with-values list)
   ;; parameterize
   (pattern (extend-parameterization pmz args ...)
     (let loop ([args (syntax->list #'(args ...))])

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)