Add some handling of by-name inits to class/c, though we can't do any useful

first-order checks without more invasive changes.

svn: r18546

collects/scheme/private/class-internal.ss

@@ -2581,11 +2581,13 @@
     (λ (cls)
       (class/c-check-first-order ctc cls blame)
       (let* ([name (class-name cls)]
+             [never-wrapped? (eq? (class-orig-cls cls) cls)]
              ;; Only add a new slot if we're not projecting an already contracted class.
-             [supers (if (eq? (class-orig-cls cls) cls)
+             [supers (if never-wrapped?
-                         (list->vector (append (vector->list (class-supers cls)) (list #f)))
+                         (list->vector (append (vector->list (class-supers cls))
+                                               (list #f)))                           
                          (list->vector (vector->list (class-supers cls))))]
-             [pos (if (eq? (class-orig-cls cls) cls)
+             [pos (if never-wrapped?
                       (add1 (class-pos cls))
                       (class-pos cls))]
              [method-width (class-method-width cls)]
@@ -2632,6 +2634,7 @@
              [ext-field-sets (if (null? (class/c-fields ctc))
                                  (class-ext-field-sets cls)
                                  (make-vector field-pub-width))]
+             [init (class-init cls)]
              [class-make (if name
                              (make-naming-constructor 
                               struct:class
@@ -2670,13 +2673,14 @@
                             'struct:object 'object? 'make-object
                             'field-ref 'field-set!
                             
-                            (class-init-args cls)
+                            ;; class/c introduced subclasses do not consume init args
-                            (class-init-mode cls)
+                            null
-                            (class-init cls)
+                            'normal
+                            #f
                             
                             (class-orig-cls cls)
                             #f #f ; serializer is never set
-                            (class-no-super-init? cls))]
+                            #f)]
              [obj-name (if name
                            (string->symbol (format "object:~a" name))
                            'object)])
@@ -2858,11 +2862,70 @@
                        [int-vec (vector-ref int-methods i)])
                   (vector-set! int-vec new-idx
                                (make-method (p (vector-ref int-vec new-idx)) m)))))))
+
+        ;; Unlike the others, we always want to do this, even if there are no init contracts,
+        ;; since we still need to handle either calling the previous class/c's init or
+        ;; calling continue-make-super appropriately.
+        (let ()
+          ;; zip the inits and contracts together for ordered selection
+          (define inits+contracts (map cons (class/c-inits ctc) (class/c-init-contracts ctc)))
+          ;; grab all the inits+contracts that involve the same init arg
+          ;; (assumes that inits and contracts were sorted in class/c creation)
+          (define (grab-same-inits lst)
+            (if (null? lst)
+                (values null null)
+                (let loop ([inits/c (cdr lst)]
+                           [prefix (list (car lst))])
+                  (cond
+                    [(null? inits/c) 
+                     (values (reverse prefix) inits/c)]
+                    [(eq? (car (car inits/c)) (car (car prefix)))
+                     (loop (cdr inits/c)
+                           (cons (car inits/c) prefix))]
+                    [else (values (reverse prefix) inits/c)]))))
+          ;; run through the list of init-args and apply contracts for same-named
+          ;; init args
+          (define (apply-contracts inits/c init-args)
+            (let loop ([init-args init-args]
+                       [inits/c inits/c]
+                       [handled-args null])
+              (cond
+                [(null? init-args)
+                 (reverse handled-args)]
+                [(null? inits/c)
+                 (append (reverse handled-args) init-args)]
+                [(eq? (car (car inits/c)) (car (car init-args)))
+                 (let ([init-arg (car init-args)]
+                       [p ((contract-projection (cdr (car inits/c))) 
+                           (blame-swap blame))])
+                   (loop (cdr init-args)
+                         (cdr inits/c)
+                         (cons (cons (car init-arg) (p (cdr init-arg)))
+                               handled-args)))]
+                [else (loop (cdr init-args)
+                            inits/c
+                            (cons (car init-args) handled-args))])))
+          (set-class-init! 
+           c
+           (lambda (the-obj super-go si_c si_inited? si_leftovers init-args)
+             (let ([init-args
+                    (let loop ([inits/c inits+contracts]
+                               [handled-args init-args])
+                      (if (null? inits/c)
+                          handled-args
+                          (let-values ([(prefix suffix) (grab-same-inits inits/c)])
+                            (loop suffix
+                                  (apply-contracts prefix init-args)))))])
+               ;; Since we never consume init args, we can ignore si_leftovers
+               ;; since init-args is the same.
+               (if never-wrapped?
+                   (super-go the-obj si_c si_inited? init-args null null)
+                   (init the-obj super-go si_c si_inited? init-args init-args))))))
         
         c))))
 
 (define-struct class/c 
-  (methods method-contracts fields field-contracts
+  (methods method-contracts fields field-contracts inits init-contracts
    inherits inherit-contracts inherit-fields inherit-field-contracts
    supers super-contracts inners inner-contracts
    overrides override-contracts augments augment-contracts
@@ -2895,6 +2958,7 @@
               'class/c 
               (append
                handled-methods
+               (handle-optional 'init (class/c-inits ctc) (class/c-init-contracts ctc))
                (handle-optional 'field (class/c-fields ctc) (class/c-field-contracts ctc))
                (handle-optional 'inherit (class/c-inherits ctc) (class/c-inherit-contracts ctc))
                (handle-optional 'inherit-field (class/c-inherit-fields ctc) (class/c-inherit-field-contracts ctc))
@@ -2929,13 +2993,29 @@
       (let-values ([(name ctc) (parse-name-ctc stx)])
         (values (cons name names) (cons ctc ctcs)))))
   (define (parse-spec stx)
-    (syntax-case stx (field inherit inherit-field init super inner override augment augride)
+    (syntax-case stx (field inherit inherit-field init init-field super inner override augment augride)
       [(field f-spec ...)
        (let-values ([(names ctcs) (parse-names-ctcs #'(f-spec ...))])
          (hash-set! parsed-forms 'fields
                     (append names (hash-ref parsed-forms 'fields null)))
          (hash-set! parsed-forms 'field-contracts
                     (append ctcs (hash-ref parsed-forms 'field-contracts null))))]
+      [(init i-spec ...)
+       (let-values ([(names ctcs) (parse-names-ctcs #'(i-spec ...))])
+         (hash-set! parsed-forms 'inits
+                    (append names (hash-ref parsed-forms 'inits null)))
+         (hash-set! parsed-forms 'init-contracts
+                    (append ctcs (hash-ref parsed-forms 'init-contracts null))))]
+      [(init-field i-spec ...)
+       (let-values ([(names ctcs) (parse-names-ctcs #'(i-spec ...))])
+         (hash-set! parsed-forms 'inits
+                    (append names (hash-ref parsed-forms 'inits null)))
+         (hash-set! parsed-forms 'init-contracts
+                    (append ctcs (hash-ref parsed-forms 'init-contracts null)))
+         (hash-set! parsed-forms 'fields
+                    (append names (hash-ref parsed-forms 'fields null)))
+         (hash-set! parsed-forms 'field-contracts
+                    (append ctcs (hash-ref parsed-forms 'field-contracts null))))]
       [(inherit m-spec ...)
        (begin
          (when object/c?
@@ -3019,6 +3099,8 @@
                      [method-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'method-contracts null)))]
                      [fields #`(list #,@(reverse (hash-ref parsed-forms 'fields null)))]
                      [field-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'field-contracts null)))]
+                     [(i ...) (reverse (hash-ref parsed-forms 'inits null))]
+                     [(i-c ...) (reverse (hash-ref parsed-forms 'init-contracts null))]
                      [inherits #`(list #,@(reverse (hash-ref parsed-forms 'inherits null)))]
                      [inherit-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'inherit-contracts null)))]
                      [inherit-fields #`(list #,@(reverse (hash-ref parsed-forms 'inherit-fields null)))]
@@ -3034,15 +3116,20 @@
                      [augrides #`(list #,@(reverse (hash-ref parsed-forms 'augrides null)))]
                      [augride-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'augride-contracts null)))])
          (syntax/loc stx
-           (make-class/c methods method-ctcs
+           (let* ([inits+contracts (sort (list (cons i i-c) ...)
-                         fields field-ctcs
+                                         (lambda (s1 s2) 
-                         inherits inherit-ctcs
+                                           (string<? (symbol->string s1) (symbol->string s2)))
-                         inherit-fields inherit-field-ctcs
+                                         #:key car)])
-                         supers super-ctcs
+             (make-class/c methods method-ctcs
-                         inners inner-ctcs
+                           fields field-ctcs
-                         overrides override-ctcs
+                           (map car inits+contracts) (map cdr inits+contracts)
-                         augments augment-ctcs
+                           inherits inherit-ctcs
-                         augrides augride-ctcs))))]))
+                           inherit-fields inherit-field-ctcs
+                           supers super-ctcs
+                           inners inner-ctcs
+                           overrides override-ctcs
+                           augments augment-ctcs
+                           augrides augride-ctcs)))))]))
 
 (define (check-object-contract obj blame methods fields)
   (let/ec return

collects/scribblings/reference/class.scrbl

@@ -1476,13 +1476,15 @@ resulting trait is the same as for @scheme[trait-sum], otherwise the
 @section{Object and Class Contracts}
 
 @defform/subs[
-#:literals (field inherit inherit-field super inner override augment augride)
+#:literals (field init init-field inherit inherit-field super inner override augment augride)
 
 (class/c member-spec ...)
 
 ([member-spec
   method-spec
   (field field-spec ...)
+  (init field-spec ...)
+  (init-field field-spec ...)
   (inherit method-spec ...)
   (inherit-field field-spec ...)
   (super method-spec ...)
@@ -1501,10 +1503,11 @@ Produces a contract for a class.
 
 There are two major categories of contracts listed in a @scheme[class/c]
 form: external and internal contracts. External contracts govern behavior
-when methods or fields are accessed via an object of that class. Internal
+when an object is instantiated from a class or when methods or fields are
-contracts govern behavior when method or fields are accessed within the
+accessed via an object of that class. Internal contracts govern behavior
-class hierarchy.  This separation allows for stronger contracts for class
+when method or fields are accessed within the class hierarchy.  This
-clients and weaker contracts for subclasses.
+separation allows for stronger contracts for class clients and weaker
+contracts for subclasses.
 
 Method contracts must contain an additional initial argument which corresponds
 to the implicit @scheme[this] parameter of the method.  This allows for
@@ -1525,6 +1528,13 @@ The external contracts are as follows:
    value contained in that field when accessed via an object of that class.  Since
    fields may be mutated, these contracts are checked on any external access and/or
    mutation of the field.}
+ @item{An initialization argument contract, tagged with @scheme[init], describes the
+   expected behavior of the value paired with that name during class instantiation.
+   The same name can be provided more than once, in which case the first such contract
+   in the @scheme[class/c] form is applied to the first value tagged with that name in
+   the list of initialization arguments, and so on.}
+ @item{The contracts listed in an @scheme[init-field] section are treated as if each
+   contract appeared in an @scheme[init] section and a @scheme[field] section.}
 ]
 
 The internal contracts are as follows:

collects/tests/mzscheme/contract-test.ss

@@ -4227,6 +4227,31 @@
               (class object% (super-new) (field [n 3]))
               'pos
               'neg))
+  
+  ;; No true first-order tests here, other than just to make
+  ;; sure they're accepted.  For init-field, we can at least
+  ;; make sure the given field is public (which happens
+  ;; naturally by splitting an init-field into init and field).
+  (test/spec-passed
+   'class/c-first-order-init-1
+   '(contract (class/c (init [a number?]))
+              (class object% (super-new) (init a))
+              'pos
+              'neg))
+  
+  (test/spec-passed
+   'class/c-first-order-init-field-1
+   '(contract (class/c (init-field [a number?]))
+              (class object% (super-new) (init-field a))
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'class/c-first-order-init-field-2
+   '(contract (class/c (init-field [a number?]))
+              object%
+              'pos
+              'neg))
 
   (test/pos-blame
    'class/c-first-order-inherit-field-1
@@ -4625,6 +4650,109 @@
                          'neg)]
            [d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))])
       (send (new d%) f)))
+  
+  (test/spec-passed
+   'class/c-higher-order-init-1
+   '(let ([c% (contract (class/c (init [a number?]))
+                        (class object% (super-new) (init a))
+                        'pos
+                        'neg)])
+      (new c% [a 3])))
+  
+  (test/neg-blame
+   'class/c-higher-order-init-2
+   '(let ([c% (contract (class/c (init [a number?]))
+                        (class object% (super-new) (init a))
+                        'pos
+                        'neg)])
+      (new c% [a #t])))
+  
+  (test/spec-passed
+   'class/c-higher-order-init-3
+   '(let* ([c% (class object% (super-new) (init a))]
+           [d% (contract (class/c (init [a number?] [a string?]))
+                         (class c% (super-new) (init a))
+                         'pos
+                         'neg)])
+      (new d% [a 3] [a "foo"])))
+  
+  (test/neg-blame
+   'class/c-higher-order-init-4
+   '(let* ([c% (class object% (super-new) (init a))]
+           [d% (contract (class/c (init [a number?] [a string?]))
+                         (class c% (super-new) (init a))
+                         'pos
+                         'neg)])
+      (new d% [a 3] [a 4])))
+  
+  (test/neg-blame
+   'class/c-higher-order-init-5
+   '(let* ([c% (class object% (super-new) (init a))]
+           [d% (contract (class/c (init [a number?] [a string?]))
+                         (class c% (super-new) (init a))
+                         'pos
+                         'neg)])
+      (new d% [a "bar"] [a "foo"])))
+  
+  (test/spec-passed
+   'class/c-higher-order-init-6
+   '(let* ([c% (class object% (super-new) (init a))]
+           [d% (class c% (super-new) (init a))]
+           [d%/c (contract (class/c (init [a integer?] [a string?])) d% 'pos 'neg1)]
+           [d%/c/c (contract (class/c (init [a number?])) d%/c 'pos1 'neg)])
+      (new d%/c/c [a 3] [a "foo"])))
+  
+  (test/neg-blame
+   'class/c-higher-order-init-7
+   '(let* ([c% (class object% (super-new) (init a))]
+           [d% (class c% (super-new) (init a))]
+           [d%/c (contract (class/c (init [a integer?] [a string?])) d% 'pos1 'neg)]
+           [d%/c/c (contract (class/c (init [a number?])) d%/c 'pos 'neg1)])
+      (new d%/c/c [a 3.5] [a "foo"])))
+  
+  (test/neg-blame
+   'class/c-higher-order-init-8
+   '(let* ([c% (class object% (super-new) (init a))]
+           [d% (class c% (super-new) (init a))]
+           [d%/c (contract (class/c (init [a integer?] [a string?])) d% 'pos 'neg)]
+           [d%/c/c (contract (class/c (init [a number?])) d%/c 'pos 'neg)])
+      (new d%/c/c [a #t] [a "foo"])))
+  
+  (test/spec-passed
+   'class/c-higher-order-init-field-1
+   '(let ([c% (contract (class/c (init-field [f (-> number? number?)]))
+                        (class object% (super-new) (init-field f) (f 3))
+                        'pos
+                        'neg)])
+      (new c% [f (lambda (x) x)])))
+
+  (test/pos-blame
+   'class/c-higher-order-init-field-2
+   '(let ([c% (contract (class/c (init-field [f (-> number? number?)]))
+                        (class object% (super-new) (init-field f) (f #t))
+                        'pos
+                        'neg)])
+      (new c% [f (lambda (x) x)])))
+
+  (test/neg-blame
+   'class/c-higher-order-init-field-3
+   '(let ([c% (contract (class/c (init-field [f (-> number? number?)]))
+                        (class object% (super-new) (init-field f) (f 3))
+                        'pos
+                        'neg)])
+      (new c% [f (lambda (x) (zero? x))])))
+  
+  ;; Make sure that the original provider of the value is blamed if an
+  ;; init arg is given an invalid value, and then that is retrieved by
+  ;; an external client.
+  (test/neg-blame
+   'class/c-higher-order-init-field-4
+   '(let* ([c% (contract (class/c (init-field [f (-> number? number?)]))
+                         (class object% (super-new) (init-field f))
+                         'pos
+                         'neg)]
+           [o (new c% [f (lambda (x) (zero? x))])])
+      ((get-field f o) 3)))
 
   (test/spec-passed
    'class/c-higher-order-method-1

collects/typed-scheme/private/type-contract.ss

@@ -15,7 +15,7 @@
  scheme/match syntax/struct syntax/stx mzlib/trace unstable/syntax scheme/list 
  (only-in scheme/contract -> ->* case-> cons/c flat-rec-contract provide/contract any/c)
  (for-template scheme/base scheme/contract unstable/poly-c (utils any-wrap)
-	       (only-in scheme/class object% is-a?/c subclass?/c object-contract class/c object/c class?)))
+	       (only-in scheme/class object% is-a?/c subclass?/c object-contract class/c init object/c class?)))
 
 (define (define/fixup-contract? stx)
   (or (syntax-property stx 'typechecker:contract-def)
@@ -151,13 +151,15 @@
                        [(names ...) name])
            #'(object/c (names fcn-cnts) ...))]
         ;; init args not currently handled by class/c
-        [(Class: _ _ (list (list name fcn) ...))
+        [(Class: _ (list (list by-name-init by-name-init-ty _) ...) (list (list name fcn) ...))
          (when flat? (exit (fail)))
-         (with-syntax ([(fcn-cnts ...) (for/list ([f fcn]) (t->c/fun f #:method #t))]
+         (with-syntax ([(fcn-cnt ...) (for/list ([f fcn]) (t->c/fun f #:method #t))]
-                       [(names ...) name])
+                       [(name ...) name]
+                       [(by-name-cnt ...) (for/list ([t by-name-init-ty]) (t->c/neg t))]
+                       [(by-name-init ...) by-name-init])
            #'class?
            #;
-           #'(class/c (names fcn-cnts) ...))]
+           #'(class/c (name fcn-cnt) ... (init [by-name-init by-name-cnt] ...)))]
         [(Value: '()) #'null?]
         [(Struct: nm par flds proc poly? pred? cert acc-ids)
          (cond