First cut of working interface contracts.

- still need to fine-tune code (maybe avoid lists)
  - is the blame story correct?
  - weak hash table for new class copy
  - interaction with class/c

collects/racket/private/class-internal.rkt

@@ -2422,6 +2422,17 @@
                                   (let ([index (hash-ref method-ht id)])
                                     (vector-set! meth-flags index 'final)))
                                 final-names)
+                      ;; Handle interface contracted methods:
+                      (for-each (lambda (id)
+                                  (let ([index (hash-ref method-ht id)])
+                                    ;; Store blame information that will be instantiated later
+                                    (define ictc-infos (get-interface-contract-info
+                                                         (class-self-interface c) id))
+                                    (vector-set! methods index
+                                                 (list (vector-ref methods index)
+                                                       ;; Make positive parties this class
+                                                       (replace-ictc-blame ictc-infos #t name)))))
+                                (class-method-ictcs c))
                       
                       ;; --- Install serialize info into class --
                       (set-class-serializer!
@@ -2569,6 +2580,15 @@ An example
                                 info))
                          dedup-infos))]))
 
+;; infos bool blame -> infos
+;; replace either positive or negative parties that are #f with blame
+(define (replace-ictc-blame infos pos? blame)
+  (if pos?
+      (for/list ([info infos])
+        (list (car info) (cadr info) (or (caddr info) blame) (cadddr info)))
+      (for/list ([info infos])
+        (list (car info) (cadr info) (caddr info) (or (cadddr info) blame)))))
+
 (define (check-still-unique name syms what)
   (let ([ht (make-hasheq)])
     (for-each (lambda (s)
@@ -3745,7 +3765,95 @@ An example
 ;; class blame -> class
 ;; takes a class and concretize interface ctc methods
 (define (fetch-concrete-class cls blame)
-  cls)
+  (if (null? (class-method-ictcs cls))
+      cls
+      ;; if there are contracted methods to concretize, do so
+      (let* ([name (class-name cls)]
+             [method-width (class-method-width cls)]
+             [method-ht (class-method-ht cls)]
+             [meths (class-methods cls)]
+             [ictc-meths (class-method-ictcs cls)]
+             [field-pub-width (class-field-pub-width cls)]
+             [field-ht (class-field-ht cls)]
+             [class-make (if name
+                             (make-naming-constructor
+                              struct:class
+                              (string->symbol (format "class:~a" name)))
+                             make-class)]
+             [c (class-make name
+                            (class-pos cls)
+                            (list->vector (vector->list (class-supers cls)))
+                            (class-self-interface cls)
+                            void ;; No inspecting
+
+                            method-width
+                            method-ht
+                            (class-method-ids cls)
+                            null
+
+                            meths
+                            (class-super-methods cls)
+                            (class-int-methods cls)
+                            (class-beta-methods cls)
+                            (class-meth-flags cls)
+
+                            (class-inner-projs cls)
+                            (class-dynamic-idxs cls)
+                            (class-dynamic-projs cls)
+
+                            (class-field-width cls)
+                            field-pub-width
+                            field-ht
+                            (class-field-ids cls)
+
+                            'struct:object 'object? 'make-object
+                            'field-ref 'field-set!
+
+                            (class-init-args cls)
+                            (class-init-mode cls)
+                            (class-init cls)
+
+                            (class-orig-cls cls)
+                            #f #f       ; serializer is never set
+                            #f)]
+             [obj-name (if name
+                           (string->symbol (format "wrapper-object:~a" name))
+                           'object)])
+
+        (vector-set! (class-supers c) (class-pos c) c)
+
+        ;; --- Make the new object struct ---
+        (let-values ([(struct:object object-make object? object-field-ref object-field-set!)
+                      (make-struct-type obj-name
+                                        (class-struct:object cls)
+                                        0 ;; No init fields
+                                        0 ;; No new fields in this class replacement
+                                        undefined
+                                        ;; Map object property to class:
+                                        (list (cons prop:object c)))])
+          (set-class-struct:object! c struct:object)
+          (set-class-object?! c object?)
+          (set-class-make-object! c object-make)
+          (set-class-field-ref! c object-field-ref)
+          (set-class-field-set!! c object-field-set!))
+
+        ;; then apply the projections to get the concrete method
+        (vector-copy! meths 0 (class-methods cls))
+        (for ([m (in-list ictc-meths)])
+          (define index (hash-ref method-ht m))
+          (define entry (vector-ref meths index))
+          (define meth (car entry))
+          (define ictc-infos (replace-ictc-blame (cadr entry) #f blame))
+          (define wrapped-meth
+            (for/fold ([meth meth])
+                      ([info ictc-infos])
+              (define ctc (car info))
+              (define ifc-name (cadr info))
+              (define pos-blame (caddr info))
+              (define neg-blame (cadddr info))
+              (contract ctc meth pos-blame neg-blame)))
+          (vector-set! meths index wrapped-meth))
+        c)))
 
 (define (do-make-object blame class by-pos-args named-args)
   (unless (class? class)

collects/tests/racket/contract-test.rktl

@@ -8477,6 +8477,55 @@
    'interface-9
     '(interface ((interface () [x number?])) x)
    exn:fail?)
+
+  (test/spec-passed
+   'interface-first-order-1
+   '(let* ([i<%> (interface () [m (->m number? number?)])]
+           [c% (class* object% (i<%>) (super-new) (define/public (m x) x))])
+      (new c%)))
+
+  (test/spec-failed
+   'interface-first-order-2
+   '(let* ([i<%> (interface () [m (->m number? number?)])]
+           [c% (class* object% (i<%>) (super-new) (define/public (m) x))])
+      (new c%))
+   "c%")
+
+  (test/spec-passed
+   'interface-higher-order-1
+   '(let* ([i<%> (interface () [m (->m number? number?)])]
+           [c% (class* object% (i<%>) (super-new) (define/public (m x) x))])
+      (send (new c%) m 3)))
+
+  (test/spec-failed
+   'interface-higher-order-2
+   '(let* ([i<%> (interface () [m (->m number? number?)])]
+           [c% (class* object% (i<%>) (super-new) (define/public (m x) x))])
+      (send (new c%) m "wrong"))
+   "top-level")
+
+  (test/spec-failed
+   'interface-higher-order-3
+   '(let* ([i<%> (interface () [m (->m number? number?)])]
+           [c% (class* object% (i<%>) (super-new) (define/public (m x) "bad"))])
+      (send (new c%) m 3))
+   "c%")
+
+  (test/spec-failed
+   'interface-higher-order-4
+   '(let* ([i1<%> (interface () [m (->m number? number?)])]
+           [i2<%> (interface (i1<%>) [m (->m integer? integer?)])]
+           [c% (class* object% (i2<%>) (super-new) (define/public (m x) x))])
+      (send (new c%) m 3.14))
+   "i1<%>")
+
+  (test/spec-failed
+   'interface-higher-order-5
+   '(let* ([i1<%> (interface () [m (->m number? number?)])]
+           [i2<%> (interface (i1<%>) [m (->m integer? integer?)])]
+           [c% (class* object% (i2<%>) (super-new) (define/public (m x) 3.14))])
+      (send (new c%) m 3))
+   "c%")
     
 ;                                                                                    
 ;