Add ->dm and case->m, which are the implicit method versions of ->d and

case->.

This should be included in the release.

svn: r18579

collects/scheme/contract/private/arrow.ss

@@ -39,6 +39,10 @@ v4 todo:
          check-procedure/more)
 
 (define-syntax-parameter making-a-method #f)
+(define-for-syntax (make-this-parameters id)
+  (if (syntax-parameter-value #'making-a-method)
+     (list id)
+     null))
 
 (define-struct contracted-function (proc ctc)
   #:property prop:procedure 0
@@ -301,9 +305,7 @@ v4 todo:
                        [(args ...) (generate-temporaries (syntax (doms ...)))]
                        [(dom-ctc ...) (generate-temporaries (syntax (doms ...)))]
                        [(this-parameter ...)
-                        (if (syntax-parameter-value #'making-a-method)
+                        (make-this-parameters (car (generate-temporaries '(this))))])
-                            (generate-temporaries '(this))
-                            '())])
            (syntax-case* #'last-one (-> any values) module-or-top-identifier=?
              [any
               (with-syntax ([(ignored) (generate-temporaries (syntax (rng)))])
@@ -369,7 +371,7 @@ v4 todo:
         (with-syntax ([outer-lambda
                        #`(lambda (chk ctc dom-names ... kwd-names ... rng-names ...)
                             (lambda (val)
-                              (chk val #,(syntax-parameter-value #'making-a-method))
+                              (chk val #,(and (syntax-parameter-value #'making-a-method) #t))
                               (make-contracted-function inner-lambda ctc)))])
           (values
            (syntax 
@@ -607,9 +609,7 @@ v4 todo:
                (with-syntax ([(rng-proj ...) (generate-temporaries (or rng-ctc '()))]
                              [(rng ...) (generate-temporaries (or rng-ctc '()))]
                              [(this-parameter ...)
-                              (if (syntax-parameter-value #'making-a-method)
+                              (make-this-parameters (car (generate-temporaries '(this))))])
-                                  (generate-temporaries '(this))
-                                  '())])
                  #`(build-->
                     '->*
                     (list mandatory-dom ...)
@@ -634,7 +634,7 @@ v4 todo:
                             optional-dom-kwd-proj ... 
                             rng-proj ...)
                       (λ (f)
-                        (chk f #,(syntax-parameter-value #'making-a-method))
+                        (chk f #,(and (syntax-parameter-value #'making-a-method) #t))
                         (make-contracted-function
                          #,(maybe-a-method/name
                             (add-name-prop
@@ -756,6 +756,21 @@ v4 todo:
         (syntax->list #'(kwd ...))))])
   doms)
 
+(define-for-syntax (make-this-transformer this-arg)
+  (with-syntax ([this-arg this-arg])
+    (make-set!-transformer
+     (λ (sstx)
+       (syntax-case sstx (set!)
+         [(set! id arg)
+          (raise-syntax-error #f 
+                              "can't mutate this"
+                              sstx)]
+         [id
+          (identifier? #'id)
+          (syntax/loc sstx this-arg)]
+         [(id . args)
+          (datum->syntax sstx (cons #'this-arg #'args) sstx)])))))
+
 (define-syntax (->d stx)
   (syntax-case stx ()
     [(_ (raw-mandatory-doms ...)
@@ -773,9 +788,9 @@ v4 todo:
                         #'((optional-kwd optional-kwd-id) ...
                            (mandatory-kwd mandatory-kwd-id) ...)))]
                      [(this-parameter ...)
-                      (if (syntax-parameter-value #'making-a-method)
+                      (make-this-parameters (if (syntax? (syntax-parameter-value #'making-a-method))
-                          (list (datum->syntax stx 'this #f))
+                                                (car (generate-temporaries '(this)))
-                          '())])
+                                                (datum->syntax stx 'this #f)))])
          (let-values ([(id/rest pre-cond range post-cond) (parse-leftover stx #'leftover)])
            (with-syntax ([(dom-params ...)
                           #`(this-parameter ...
@@ -793,7 +808,7 @@ v4 todo:
                               [any #'(() #f)]
                               [[id ctc] #'((id) (ctc))]
                               [x (raise-syntax-error #f "expected binding pair or any" stx #'x)])]
-                           [mtd? (syntax-parameter-value #'making-a-method)])
+                           [mtd? (and (syntax-parameter-value #'making-a-method) #t)])
                (let ([rng-underscores? 
                       (let ([is-underscore?
                              (λ (x) 
@@ -819,35 +834,57 @@ v4 todo:
                                      (syntax->list #'(dom-params ...))))])
                    (when dup
                      (raise-syntax-error #f "duplicate identifier" stx dup)))
-                 #`(syntax-parameterize 
+                 #`(let-syntax ([parameterize-this
-                    ((making-a-method #f)) 
+                                 (let ([old-param (syntax-parameter-value #'making-a-method)])
-                    (build-->d mtd? 
+                                   (λ (stx)
-                               (list (λ (dom-params ...) mandatory-doms) ...)
+                                     (syntax-case stx ()
-                               (list (λ (dom-params ...) optional-doms) ...)
+                                       [(_ body) #'body]
-                               (list (λ (dom-params ...) mandatory-kwd-dom) ...)
+                                       [(_ id body)
-                               (list (λ (dom-params ...) optional-kwd-dom) ...)
+                                        (if (syntax? old-param)
-                               #,(if id/rest 
+                                            (with-syntax ([param old-param])
-                                     (with-syntax ([(id rst-ctc) id/rest])
+                                              (syntax/loc stx
-                                       #`(λ (dom-params ...) rst-ctc))
+                                                (syntax-parameterize
-                                     #f)
+                                                    ([param (make-this-transformer #'id)])
-                               #,(if pre-cond
+                                                  body)))
-                                     #`(λ (dom-params ...) #,pre-cond)
+                                            #'body)])))])
-                                     #f)
+                     (syntax-parameterize 
-                               #,(syntax-case #'rng-ctcs ()
+                         ((making-a-method #f)) 
-                                   [#f #f]
+                       (build-->d mtd? 
-                                   [(ctc ...) 
+                                  (list (λ (dom-params ...)
-                                    (if rng-underscores?
+                                          (parameterize-this this-parameter ... mandatory-doms)) ...)
-                                        #'(box (list (λ (dom-params ...) ctc) ...))
+                                  (list (λ (dom-params ...) 
-                                        #'(list (λ (rng-params ... dom-params ...) ctc) ...))])
+                                          (parameterize-this this-parameter ... optional-doms)) ...)
-                               #,(if post-cond
+                                  (list (λ (dom-params ...) 
-                                     #`(λ (rng-params ... dom-params ...) #,post-cond)
+                                          (parameterize-this this-parameter ... mandatory-kwd-dom)) ...)
-                                     #f)
+                                  (list (λ (dom-params ...) 
-                               '(mandatory-kwd ...)
+                                          (parameterize-this this-parameter ... optional-kwd-dom)) ...)
-                               '(optional-kwd ...)
+                                  #,(if id/rest 
-                               (λ (f) 
+                                        (with-syntax ([(id rst-ctc) id/rest])
-                                 #,(add-name-prop
+                                          #`(λ (dom-params ...)
-                                    (syntax-local-infer-name stx)
+                                              (parameterize-this this-parameter ... rst-ctc)))
-                                    #`(λ args (apply f args))))))))))))]))
+                                        #f)
+                                  #,(if pre-cond
+                                        #`(λ (dom-params ...)
+                                            (parameterize-this this-parameter ... #,pre-cond))
+                                        #f)
+                                  #,(syntax-case #'rng-ctcs ()
+                                      [#f #f]
+                                      [(ctc ...) 
+                                       (if rng-underscores?
+                                           #'(box (list (λ (dom-params ...) 
+                                                          (parameterize-this this-parameter ... ctc)) ...))
+                                           #'(list (λ (rng-params ... dom-params ...)
+                                                     (parameterize-this this-parameter ... ctc)) ...))])
+                                  #,(if post-cond
+                                        #`(λ (rng-params ... dom-params ...)
+                                            (parameterize-this this-parameter ... #,post-cond))
+                                        #f)
+                                  '(mandatory-kwd ...)
+                                  '(optional-kwd ...)
+                                  (λ (f) 
+                                    #,(add-name-prop
+                                       (syntax-local-infer-name stx)
+                                       #`(λ args (apply f args)))))))))))))]))
 
 (define ->d-tail-key (gensym '->d-tail-key))
 
@@ -1200,9 +1237,7 @@ v4 todo:
                                       (generate-temporaries rng)
                                       '())]
                     [(this-parameter ...)
-                     (if (syntax-parameter-value #'making-a-method)
+                     (make-this-parameters (car (generate-temporaries '(this))))])
-                         (generate-temporaries '(this))
-                         '())])
         #`(#,doms
            #,rst
            #,(if rng #`(list #,@rng) #f)
@@ -1250,7 +1285,7 @@ v4 todo:
                               #,@(apply append (map syntax->list (syntax->list #'((dom-proj-x ...) ...))))
                               #,@(apply append (map syntax->list (syntax->list #'((rng-proj-x ...) ...)))))
                             (λ (f)
-                              (chk f #,(syntax-parameter-value #'making-a-method))
+                              (chk f #,(and (syntax-parameter-value #'making-a-method) #t))
                               (make-contracted-function
                                (case-lambda
                                 [formals body] ...)

collects/scheme/private/class-internal.ss

@@ -56,7 +56,7 @@
            method-in-interface? interface->method-names class->interface class-info
            (struct-out exn:fail:object)
            make-primitive-class
-           class/c ->m ->*m object/c
+           class/c ->m ->*m ->dm case->m object/c
            
            ;; "keywords":
            private public override augment
@@ -2503,6 +2503,12 @@
 (define-syntax-rule (->*m . stx)
   (syntax-parameterize ([making-a-method #t]) (->* . stx)))
 
+(define-syntax-rule (case->m . stx)
+  (syntax-parameterize ([making-a-method #t]) (case-> . stx)))
+
+(define-syntax-rule (->dm . stx)
+  (syntax-parameterize ([making-a-method #'this-param]) (->d . stx)))
+
 (define (class/c-check-first-order ctc cls blame)
   (let/ec return
     (define (failed str . args)
@@ -4737,5 +4743,5 @@
          method-in-interface? interface->method-names class->interface class-info
          (struct-out exn:fail:object)
          make-primitive-class
-         class/c ->m ->*m object/c)
+         class/c ->m ->*m ->dm case->m object/c)
 

collects/scribblings/reference/class.scrbl

@@ -1512,8 +1512,8 @@ 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
 contracts which discuss the state of the object when the method is called
-(or, for dependent contracts, in other parts of the contract).  Two alternative
+(or, for dependent contracts, in other parts of the contract).  Alternative
-contract forms, @scheme[->m] and @scheme[->*m], are provided as a shorthand
+contract forms, such as @scheme[->m], are provided as a shorthand
 for writing method contracts.
 
 The external contracts are as follows:
@@ -1583,6 +1583,23 @@ more element than the stated domain, where the first (implicit) argument is cont
 @scheme[any/c]. This contract is useful for writing simpler method contracts when no properties
 of @scheme[this] need to be checked.}
 
+@defform[(case->m (-> dom ... rest range) ...)]{
+Similar to @scheme[case->], except that the mandatory domain of each case of the resulting contract
+contains one more element than the stated domain, where the first (implicit) argument is contracted
+with @scheme[any/c]. This contract is useful for writing simpler method contracts when no properties
+of @scheme[this] need to be checked.}
+
+@defform[(->dm (mandatory-dependent-dom ...)
+               (optional-dependent-dom ...)
+               dependent-rest
+               pre-cond
+               dep-range)]{
+Similar to @scheme[->d], except that the mandatory domain of the resulting contract
+contains one more element than the stated domain, where the first (implicit) argument is contracted
+with @scheme[any/c]. In addition, @scheme[this] is appropriately bound in the body of the contract.
+This contract is useful for writing simpler method contracts when no properties
+of @scheme[this] need to be checked.}
+
 @defform/subs[
 #:literals (field)
 

collects/tests/mzscheme/contract-test.ss

@@ -5279,6 +5279,120 @@
               (class object% (super-new) (define/public (m x [f "foo"]) x))
               'pos
               'neg))
+  
+  (test/spec-passed
+   '->dm-first-order-1
+   '(contract (class/c [pop (->dm () () #:pre-cond (not (send this empty?)) [_ number?])]
+                       [push (->dm ([arg number?]) () [_ void?] #:post-cond (not (send this empty?)))]
+                       [empty? (->m boolean?)])
+              (class object% (super-new)
+                (define stack null)
+                (define/public (empty?) (null? stack))
+                (define/public (push v) (set! stack (cons v stack)))
+                (define/public (pop) (let ([res (car stack)]) (set! stack (cdr stack)) res)))
+              'pos
+              'neg))
+
+  (test/pos-blame
+   '->dm-first-order-1
+   '(contract (class/c [pop (->dm () () #:pre-cond (not (send this empty?)) [_ number?])]
+                       [push (->dm ([arg number?]) () [_ void?] #:post-cond (not (send this empty?)))]
+                       [empty? (->m boolean?)])
+              (class object% (super-new)
+                (define stack null)
+                (define/public (empty?) (null? stack))
+                (define/public (push v) (set! stack (cons v stack)))
+                (define/public (pop v) (let ([res (car stack)]) (set! stack (cdr stack)) res)))
+              'pos
+              'neg))
+
+  (test/spec-passed
+   '->dm-higher-order-1
+   '(let* ([stack% (contract (class/c [pop (->dm () () #:pre-cond (not (send this empty?)) [_ number?])]
+                                      [push (->dm ([arg number?]) () [_ void?] #:post-cond (not (send this empty?)))]
+                                      [empty? (->m boolean?)])
+                             (class object% (super-new)
+                               (define stack null)
+                               (define/public (empty?) (null? stack))
+                               (define/public (push v) (set! stack (cons v stack)))
+                               (define/public (pop) (let ([res (car stack)]) (set! stack (cdr stack)) res)))
+                             'pos
+                             'neg)]
+           [o (new stack%)])
+      (send o push 4)
+      (send o empty?)
+      (send o pop)))
+
+  (test/pos-blame
+   '->dm-higher-order-2
+   '(let* ([stack% (contract (class/c [pop (->dm () () #:pre-cond (not (send this empty?)) [_ number?])]
+                                      [push (->dm ([arg number?]) () [_ void?] #:post-cond (not (send this empty?)))]
+                                      [empty? (->m boolean?)])
+                             (class object% (super-new)
+                               (define stack null)
+                               (define/public (empty?) (null? stack))
+                               (define/public (push v) (void))
+                               (define/public (pop) (let ([res (car stack)]) (set! stack (cdr stack)) res)))
+                             'pos
+                             'neg)]
+           [o (new stack%)])
+      (send o push 4)
+      (send o empty?)
+      (send o pop)))
+
+  (test/neg-blame
+   '->dm-higher-order-3
+   '(let* ([stack% (contract (class/c [pop (->dm () () #:pre-cond (not (send this empty?)) [_ number?])]
+                                      [push (->dm ([arg number?]) () [_ void?] #:post-cond (not (send this empty?)))]
+                                      [empty? (->m boolean?)])
+                             (class object% (super-new)
+                               (define stack null)
+                               (define/public (empty?) (null? stack))
+                               (define/public (push v) (set! stack (cons v stack)))
+                               (define/public (pop) (let ([res (car stack)]) (set! stack (cdr stack)) res)))
+                             'pos
+                             'neg)]
+           [o (new stack%)])
+      (send o pop)))
+  
+  (test/spec-passed
+   'case->m-first-order-1
+   '(contract (class/c [m (case->m (-> number? number?) (-> number? number? number?))])
+              (class object% (super-new) (define/public (m x [y 3]) (+ x y)))
+              'pos
+              'neg))
+
+  (test/pos-blame
+   'case->m-first-order-2
+   '(contract (class/c [m (case->m (-> number? number?) (-> number? number? number?))])
+              (class object% (super-new) (define/public (m x) (+ x y)))
+              'pos
+              'neg))
+
+  (test/spec-passed
+   'case->m-higher-order-1
+   '(let ([cls% (contract (class/c [m (case->m (-> number? number?) (-> number? number? number?))])
+                          (class object% (super-new) (define/public (m x [y 3]) (+ x y)))
+                          'pos
+                          'neg)])
+      (send (new cls%) m 3)
+      (send (new cls%) m 3 4)))
+
+  (test/neg-blame
+   'case->m-higher-order-2
+   '(let ([cls% (contract (class/c [m (case->m (-> number? number?) (-> number? number? number?))])
+                          (class object% (super-new) (define/public (m x [y 3]) (+ x y)))
+                          'pos
+                          'neg)])
+      (send (new cls%) m #t)))
+
+  (test/neg-blame
+   'case->m-higher-order-3
+   '(let ([cls% (contract (class/c [m (case->m (-> number? number?) (-> number? number? number?))])
+                          (class object% (super-new) (define/public (m x [y 3]) (+ x y)))
+                          'pos
+                          'neg)])
+      (send (new cls%) m 3 #t)))
 
 ;                                                              
 ;