adjust class/c so the expansion is slightly smaller

that is, instead of (class/c [m (->m integer? integer?)] n) turning
into a call to a constructor that has calls to coerce-contract for
the 'm' method, it instead expands the 'n' method contract into an
identifier reference (that isnt' bound to #f, since #f is coercable to
a contract) and the 'm' contract argument just sits there in the expansion

racket/collects/racket/private/class-c-new.rkt

@@ -6,7 +6,8 @@
          (only-in "../contract/private/guts.rkt"
                   wrapped-extra-arg-arrow?)
          (for-syntax racket/base
-                     syntax/name))
+                     syntax/name
+                     syntax/stx))
 
 (provide class/c2)
 
@@ -17,7 +18,13 @@
       [(_ #:opaque args ...)
        (values #t #'(args ...))]
       [(_ args ...)
-       (values #f #'(args ...))]))
+       (let ()
+         (define stx-args #'(args ...))
+         (define l (syntax->list stx-args))
+         (printf "l ~\n" l)
+         (when (and (pair? l) (keyword? (syntax-e (car l))))
+           (raise-syntax-error #f "unrecognized keyword" stx (car l)))
+         (values #f stx-args))]))
   (syntax-case args ()
     [(clauses ...)
      (let loop ([clauses (syntax->list #'(clauses ...))]
@@ -96,12 +103,7 @@
                      (cons #`[x ctc] let-bindings)))]
             [else (give-up)])]))]))
 
-(define-values (just-check-existence just-check-existence?)
-  (let ()
-    (struct just-check-existence ())
-    (values (just-check-existence) 
-            just-check-existence?)))
-
+#;
 (define-syntax (class/c2 stx)
   (define-values (opaque? mths flds inits let-bindings) (parse-class/c stx))
   (cond
@@ -118,15 +120,85 @@
               (make-an-ext-class/c-contract '#,opaque?
                                             (list `lmth-name ...)
                                             (list mth-ctc ...)
+                                            '() '()
                                             (list 'init-name ...)
                                             (list init-ctc ...)
-                                            'name)))])]
+                                            'name
+                                            empty-internal/c)))])]
     [else
      ;(printf "nope: ~a:~a\n" (syntax-source stx) (syntax-line stx))
      (syntax-case stx ()
        [(_ args ...)
         #'(class/c args ...)])]))
 
+(define-syntax (class/c2 stx)
+  (define-values (opaque? args)
+    (syntax-case stx ()
+      [(_ #:opaque args ...)
+       (values #t (syntax->list #'(args ...)))]
+      [(_ args ...)
+       (let ()
+         (define stx-args (syntax->list #'(args ...)))
+         (when (and (pair? stx-args) (keyword? (syntax-e (car stx-args))))
+           (raise-syntax-error #f "unrecognized keyword" stx (car stx-args)))
+         (values #f stx-args))]))
+  (define-values (bindings pfs) (parse-class/c-specs args #f))
+  (printf ">> ~s ~s\n" bindings (hash-ref pfs 'methods null))
+  (with-syntax ([methods #`(list #,@(reverse (hash-ref pfs 'methods null)))]
+                [method-ctcs #`(list #,@(reverse (hash-ref pfs 'method-contracts null)))]
+                [fields #`(list #,@(reverse (hash-ref pfs 'fields null)))]
+                [field-ctcs #`(list #,@(reverse (hash-ref pfs 'field-contracts null)))]
+                [(i ...) (reverse (hash-ref pfs 'inits null))]
+                [(i-c ...) (reverse (hash-ref pfs 'init-contracts null))]
+                [inherits #`(list #,@(reverse (hash-ref pfs 'inherits null)))]
+                [inherit-ctcs #`(list #,@(reverse (hash-ref pfs 'inherit-contracts null)))]
+                [inherit-fields #`(list #,@(reverse (hash-ref pfs 'inherit-fields null)))]
+                [inherit-field-ctcs #`(list #,@(reverse (hash-ref pfs 'inherit-field-contracts
+                                                                  null)))]
+                [supers #`(list #,@(reverse (hash-ref pfs 'supers null)))]
+                [super-ctcs #`(list #,@(reverse (hash-ref pfs 'super-contracts null)))]
+                [inners #`(list #,@(reverse (hash-ref pfs 'inners null)))]
+                [inner-ctcs #`(list #,@(reverse (hash-ref pfs 'inner-contracts null)))]
+                [overrides #`(list #,@(reverse (hash-ref pfs 'overrides null)))]
+                [override-ctcs #`(list #,@(reverse (hash-ref pfs 'override-contracts null)))]
+                [augments #`(list #,@(reverse (hash-ref pfs 'augments null)))]
+                [augment-ctcs #`(list #,@(reverse (hash-ref pfs 'augment-contracts null)))]
+                [augrides #`(list #,@(reverse (hash-ref pfs 'augrides null)))]
+                [augride-ctcs #`(list #,@(reverse (hash-ref pfs 'augride-contracts null)))]
+                [absents #`(list #,@(reverse (hash-ref pfs 'absents null)))]
+                [absent-fields #`(list #,@(reverse (hash-ref pfs 'absent-fields null)))])
+    (with-syntax ([name 
+                   ;; same as syntax-local-infer-name, except doesn't
+                   ;; make a name up from the src loc; in that case,
+                   ;; we just use the big ole (class/c  ...)-based name
+                   (or (let loop ([prop (syntax-property stx 'inferred-name)])
+                         (cond
+                           [(symbol? prop) prop]
+                           [(pair? prop) (or (loop (car prop))
+                                             (loop (cdr prop)))]
+                           [else #f]))
+                       (syntax-local-name))]
+                  [bindings bindings]
+                  [opaque? opaque?])
+      (syntax/loc stx
+        (let bindings
+;          (let-values ([(inits init-ctcs) (sort-inits+contracts (list (cons i i-c) ...))])
+            (make-an-ext-class/c-contract
+             'opaque?
+             methods method-ctcs
+             fields field-ctcs
+             (list 'i ...)
+             (list i-c ...)
+             'name
+             (internal-class/c
+              inherits inherit-ctcs
+              inherit-fields inherit-field-ctcs
+              supers super-ctcs
+              inners inner-ctcs
+              overrides override-ctcs
+              augments augment-ctcs
+              augrides augride-ctcs)))))))
+
 (define (class/c2-proj this)
   (λ (blame)
     (λ (cls)
@@ -169,16 +241,11 @@
                             ctc))
                       (ext-class/c-contract-init-ctc-pairs this))
                  
-                 
-                 '() '() ;; inherit
-                 '() '() ;; inherit fields
-                 '() '() ;; super
-                 '() '() ;; inner
-                 '() '() ;; override
-                 '() '() ;; augment
-                 '() '() ;; augride
                  '() '() ;; absent
-                 #f #f))
+                 empty-internal-class/c
+                 #f ;; opaque?
+                 #f ;; name
+                 ))
               (λ (neg-party)
                 (((class/c-proj ctc) (blame-add-missing-party blame neg-party)) cls))]
              [else (build-neg-acceptor-proc this maybe-err blame cls (make-hash) '())])]
@@ -207,6 +274,16 @@
                blame #:missing-party neg-party cls
                '(expected: "a class"))))])))))
 
+(define empty-internal-class/c
+  (internal-class/c
+   '() '() ;; inherit
+   '() '() ;; inherit fields
+   '() '() ;; super
+   '() '() ;; inner
+   '() '() ;; override
+   '() '() ;; augment
+   '() '())) ;; augride
+
 (define (build-neg-acceptor-proc this maybe-err blame cls new-mths-ht old-init-pairs)
   (define mth->idx (class-method-ht cls))
   (define mtd-vec (class-methods cls))
@@ -329,7 +406,11 @@
             [else
              (cons new (loop olds (cdr news)))])]))]))
 
-(define (make-an-ext-class/c-contract opaque? mth-names mth-ctcs init-names init-ctcs ctc-name)
+(define (make-an-ext-class/c-contract opaque? 
+                                      mth-names mth-ctcs
+                                      fld-names fld-ctcs
+                                      init-names init-ctcs 
+                                      ctc-name internal-ctc)
   (define ctc-hash
     (make-hash (for/list ([raw-ctc (in-list mth-ctcs)]
                           [name (in-list mth-names)])

racket/collects/racket/private/class-c-old.rkt

@@ -12,7 +12,9 @@
          blame-add-method-context blame-add-init-context
          class/c ->m ->*m ->dm case->m object/c instanceof/c
          make-wrapper-object
-         check-object-contract)
+         check-object-contract
+         (for-syntax parse-class/c-specs)
+         (struct-out internal-class/c))
 
 (define undefined (letrec ([x x]) x))
 
@@ -721,12 +723,38 @@
      (blame-add-context blame "an unnamed method in")]
     [else (error 'blame-add-method-context "uhoh ~s" name)]))
 
+(define (build-internal-class/c inherits inherit-contracts inherit-fields inherit-field-contracts
+                                supers super-contracts inners inner-contracts
+                                overrides override-contracts augments augment-contracts
+                                augrides augride-contracts)
+  (internal-class/c inherits (adjust-jce inherit-contracts)
+                    inherit-fields (adjust-jce inherit-field-contracts)
+                    supers (adjust-jce super-contracts)
+                    inners (adjust-jce inner-contracts)
+                    overrides (adjust-jce override-contracts)
+                    augments (adjust-jce augment-contracts)
+                    augrides (adjust-jce augride-contracts)))
 (struct internal-class/c
   (inherits inherit-contracts inherit-fields inherit-field-contracts
    supers super-contracts inners inner-contracts
    overrides override-contracts augments augment-contracts
    augrides augride-contracts))
 
+(define (build-class/c methods method-contracts fields field-contracts inits init-contracts
+                       absents absent-fields 
+                       internal opaque? name)
+  (make-class/c
+   methods (adjust-jce method-contracts)
+   fields (adjust-jce field-contracts)
+   inits (adjust-jce init-contracts)
+   absents absent-fields
+   internal opaque? name))
+(define (adjust-jce objs)
+  (for/list ([obj (in-list objs)])
+    (cond
+      [(just-check-existence? obj) #f]
+      [else (coerce-contract 'class/c obj)])))
+
 (define-struct class/c 
   (methods method-contracts fields field-contracts inits init-contracts
    absents absent-fields 
@@ -800,6 +828,12 @@
          (and (class/c-check-first-order ctc cls (λ args (ret #f)))
               (internal-class/c-check-first-order (class/c-internal ctc) cls (λ args (ret #f)))))))))
 
+(define-values (just-check-existence just-check-existence?)
+  (let ()
+    (struct just-check-existence ())
+    (values (just-check-existence) 
+            just-check-existence?)))
+
 (define-for-syntax (parse-class/c-specs forms object/c?)
   (define parsed-forms (make-hasheq))
   (define bindings '())
@@ -809,12 +843,11 @@
       [x
        (identifier? #'x)
        (with-syntax ([id (localize #'x)])
-         (values #'`id #f))]
+         (values #'`id #'just-check-existence))]
       [(x ctc)
        (identifier? #'x)
        (with-syntax ([id (localize #'x)])
-         (values #'`id
-                 #`(coerce-contract '#,form-name (let ([x ctc]) x))))]
+         (values #'`id #'ctc))]
       [_
        (raise-syntax-error form-name "expected identifier or (id contract)" stx)]))
   (define (parse-names-ctcs stx)
@@ -1025,20 +1058,20 @@
            (syntax/loc stx
              (let bindings
                (let-values ([(inits init-ctcs) (sort-inits+contracts (list (cons i i-c) ...))])
-                 (make-class/c methods method-ctcs
-                               fields field-ctcs
-                               inits init-ctcs
-                               absents absent-fields
-                               (internal-class/c
-                                inherits inherit-ctcs
-                                inherit-fields inherit-field-ctcs
-                                supers super-ctcs
-                                inners inner-ctcs
-                                overrides override-ctcs
-                                augments augment-ctcs
-                                augrides augride-ctcs)
-                               opaque?
-                               'name)))))))]))
+                 (build-class/c methods method-ctcs
+                                fields field-ctcs
+                                inits init-ctcs
+                                absents absent-fields
+                                (build-internal-class/c
+                                 inherits inherit-ctcs
+                                 inherit-fields inherit-field-ctcs
+                                 supers super-ctcs
+                                 inners inner-ctcs
+                                 overrides override-ctcs
+                                 augments augment-ctcs
+                                 augrides augride-ctcs)
+                                opaque?
+                                'name)))))))]))
 
 (define (sort-inits+contracts lst)
   (define sorted