From cd67536738fd77bc839c635f2af89da3e83409ca Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Fri, 27 Apr 2012 13:00:48 -0400
Subject: [PATCH] class/c: allow local method names

Prior to this change, a method/field name defined with
define-local-method-name was not contractable.
---
 collects/racket/private/class-internal.rkt |  14 +-
 collects/tests/racket/contract-test.rktl   | 245 ++++++++++++++++++++-
 2 files changed, 253 insertions(+), 6 deletions(-)

diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt
index 3b9460cb40..84bdf81024 100644
--- a/collects/racket/private/class-internal.rkt
+++ b/collects/racket/private/class-internal.rkt
@@ -3049,11 +3049,13 @@
     (syntax-case stx ()
       [x
        (identifier? #'x)
-       (values #'(quote x) #f)]
+       (with-syntax ([id (localize #'x)])
+         (values #'`id #f))]
       [(x ctc)
        (identifier? #'x)
-       (values #'(quote x) 
-               #`(coerce-contract '#,form-name (let ([x ctc]) x)))]
+       (with-syntax ([id (localize #'x)])
+         (values #'`id
+                 #`(coerce-contract '#,form-name (let ([x ctc]) x))))]
       [_
        (raise-syntax-error form-name "expected identifier or (id contract)" stx)]))
   (define (parse-names-ctcs stx)
@@ -3071,11 +3073,13 @@
          (let ([symbols (for/list ([id (in-list (syntax->list #'(f-id ...)))])
                           (unless (identifier? id)
                             (raise-syntax-error 'class/c "expected identifier" stx))
-                          #`(quote #,id))])
+                          (with-syntax ([id (localize id)])
+                            #'`id))])
            (values meths (append (reverse symbols) fields)))]
         [id
          (identifier? #'id)
-         (values (cons #'(quote id) meths) fields)]
+         (with-syntax ([id (localize #'id)])
+           (values (cons #'`id meths) fields))]
         [_
          (raise-syntax-error 'class/c "expected identifier or (field id ...)" stx)])))
   (define (parse-spec stx)
diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl
index e60af43bbf..cc04348813 100644
--- a/collects/tests/racket/contract-test.rktl
+++ b/collects/tests/racket/contract-test.rktl
@@ -6490,6 +6490,33 @@
               'pos
               'neg))
 
+  (test/spec-passed
+   'class/c-first-order-local-method-1
+   '(let ()
+     (define-local-member-name m)
+     (contract (class/c [m (->m number? number?)])
+               (class object% (super-new) (define/public (m x) 3))
+               'pos
+               'neg)))
+
+  (test/pos-blame
+   'class/c-first-order-local-method-2
+   '(let ()
+     (define-local-member-name m)
+     (contract (class/c [m (->m number? number? number?)])
+               (class object% (super-new) (define/public (m x) 3))
+               'pos
+               'neg)))
+
+  (test/pos-blame
+   'class/c-first-order-local-method-3
+   '(let ()
+     (define-local-member-name m)
+     (contract (class/c [m (->m number? number? number?)])
+               (class object% (super-new))
+               'pos
+               'neg)))
+
   (test/spec-passed
    'class/c-first-order-opaque-method-1
    '(contract (class/c #:opaque [m (-> any/c number? number?)])
@@ -6523,6 +6550,25 @@
       'pos
       'neg))
 
+  (test/pos-blame
+   'class/c-first-order-opaque-method-5
+   '(contract
+      (class/c #:opaque [m (-> any/c number? number?)] [n (-> any/c number?)])
+      (let ()
+        (define-local-member-name n)
+        (class object% (super-new) (define/public (m x) 3) (define/public (n) 4)))
+      'pos
+      'neg))
+
+  (test/spec-passed
+   'class/c-first-order-opaque-method-6
+   '(let ()
+      (define-local-member-name n)
+      (contract (class/c #:opaque [m (-> any/c number? number?)] [n (-> any/c number?)])
+                (class object% (super-new) (define/public (m x) 3) (define/public (n) 4))
+                'pos
+                'neg)))
+
   (test/pos-blame
    'class/c-first-order-field-1
    '(contract (class/c (field [n number?]))
@@ -6550,6 +6596,33 @@
               (class object% (super-new) (field [n 3]))
               'pos
               'neg))
+
+  (test/spec-passed
+   'class/c-first-order-local-field-1
+   '(let ()
+      (define-local-member-name n)
+      (contract (class/c (field n))
+                (class object% (super-new) (field [n 3]))
+                'pos
+                'neg)))
+
+  (test/spec-passed
+   'class/c-first-order-local-field-2
+   '(let ()
+      (define-local-member-name n)
+      (contract (class/c (field [n integer?]))
+                (class object% (super-new) (field [n 3]))
+                'pos
+                'neg)))
+
+  (test/pos-blame
+   'class/c-first-order-local-field-3
+   '(let ()
+      (define-local-member-name n)
+      (contract (class/c (field [n integer?]))
+                (class object% (super-new))
+                'pos
+                'neg)))
  
   (test/spec-passed
    'class/c-first-order-opaque-field-1
@@ -6807,6 +6880,25 @@
                 (class c% (super-new) (define/augride (m x) (add1 x))))
               'pos
               'neg))
+
+  (test/spec-passed
+   'class/c-first-order-local-inner-1
+   '(let ()
+      (define-local-member-name m)
+      (contract (class/c (inner m) m)
+                (let ([c% (class object% (super-new) (define/pubment (m x) (inner x m x)))])
+                  (class c% (super-new) (define/augride (m x) (add1 x))))
+                'pos
+                'neg)))
+
+  (test/pos-blame
+   'class/c-first-order-local-inner-2
+   '(let ()
+      (define-local-member-name m)
+      (contract (class/c (inner m))
+                object%
+                'pos
+                'neg)))
               
   (test/pos-blame
    'class/c-first-order-override-1
@@ -6893,6 +6985,25 @@
               'pos
               'neg))
 
+  (test/pos-blame
+   'class/c-first-order-local-override-1
+   '(let ()
+     (define-local-member-name m)
+     (contract (class/c (override m))
+               object%
+               'pos
+               'neg)))
+
+  (test/spec-passed
+   'class/c-first-order-local-override-2
+   '(let ()
+      (define-local-member-name m)
+      (define c% (contract (class/c (override m))
+                           (class object% (super-new) (define/public (m) 3))
+                           'pos
+                           'neg))
+      (class c% (super-new) (define/override (m) 5))))
+
   (test/pos-blame
    'class/c-first-order-augment-1
    '(contract (class/c (augment [m (-> any/c number? number?)]))
@@ -6975,6 +7086,25 @@
               (class object% (super-new) (define/pubment (m x) (add1 x)))
               'pos
               'neg))
+
+  (test/pos-blame
+   'class/c-first-order-local-augment-1
+   '(let ()
+      (define-local-member-name m)
+      (contract (class/c (augment m))
+                object%
+                'pos
+                'neg)))
+
+  (test/spec-passed
+   'class/c-first-order-local-augment-2
+   '(let ()
+      (define-local-member-name m)
+      (define c% (contract (class/c (augment m))
+                           (class object% (super-new) (define/pubment (m) 3))
+                           'pos
+                           'neg))
+      (class c% (super-new) (inherit m))))
   
   (test/pos-blame
    'class/c-first-order-augride-1
@@ -7062,6 +7192,26 @@
                 (class c% (super-new) (define/augride (m x) (add1 x))))
               'pos
               'neg))
+
+  (test/pos-blame
+   'class/c-first-order-local-augride-1
+   '(let ()
+      (define-local-member-name m)
+      (contract (class/c (augride m))
+                object%
+                'pos
+                'neg)))
+
+  (test/spec-passed
+   'class/c-first-order-local-augride-2
+   '(let ()
+      (define-local-member-name m)
+      (define c% (contract (class/c (augride m))
+                           (class (class object% (super-new) (define/pubment (m) 3))
+                             (super-new) (define/augride (m) 4))
+                           'pos
+                           'neg))
+      (class c% (super-new) (inherit m))))
   
   (test/pos-blame
    'class/c-first-order-inherit-1
@@ -7107,6 +7257,28 @@
                          'neg)]
            [d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))])
       (send (new d%) f)))
+
+  (test/pos-blame
+   'class/c-first-order-local-inherit-1
+   '(let ()
+      (define-local-member-name m)
+      (define c% (contract (class/c (inherit [m (-> any/c number? number?)]))
+                           object%
+                           'pos
+                           'neg))
+      (define d% (class c% (super-new) (inherit m) (define/public (f) (m 5))))
+      (send (new d%) f)))
+
+  (test/spec-passed
+   'class/c-first-order-local-inherit-2
+   '(let ()
+      (define-local-member-name m)
+      (define c% (contract (class/c (inherit [m (-> any/c number? number?)]))
+                           (class object% (super-new) (define/public (m x) x))
+                           'pos
+                           'neg))
+      (define d% (class c% (super-new) (inherit m) (define/public (f) (m 5))))
+      (send (new d%) f)))
   
   (test/spec-passed
    'class/c-first-order-absent-1
@@ -7129,6 +7301,21 @@
               (class object% (super-new) (field [f 3]))
               'pos
               'neg))
+
+  (test/spec-passed
+   'class/c-first-order-local-absent-1
+   '(let ()
+      (define-local-member-name f)
+      (contract (class/c (absent (field f))) object% 'pos 'neg)))
+
+  (test/pos-blame
+   'class/c-first-order-local-absent-2
+   '(let ()
+      (define-local-member-name f)
+      (contract (class/c (absent (field f)))
+                (class object% (super-new) (field [f 3]))
+                'pos
+                'neg)))
               
   (test/spec-passed
    'class/c-first-order-opaque-absent-1
@@ -7287,6 +7474,26 @@
            [d% (class c% (super-new) (define/override (m) (super m 5)))])
       (send (new d%) m)))
 
+  (test/spec-passed
+   'class/c-higher-order-local-method-1
+   '(let ()
+      (define-local-member-name m)
+      (define c% (contract (class/c [m (-> any/c number? number?)])
+                           (class object% (super-new) (define/public (m x) (add1 x)))
+                           'pos
+                           'neg))
+      (send (new c%) m 3)))
+
+  (test/neg-blame
+   'class/c-higher-order-local-method-2
+   '(let ()
+      (define-local-member-name m)
+      (define c% (contract (class/c [m (-> any/c number? number?)])
+                           (class object% (super-new) (define/public (m x) (add1 x)))
+                           'pos
+                           'neg))
+      (send (new c%) m #f)))
+
   (test/spec-passed
    'class/c-higher-order-super-1
    '(let* ([c% (contract (class/c [m (-> any/c integer? integer?)]
@@ -7936,6 +8143,24 @@
               (new (class object% (super-new) (define/public (m x) (add1 x))))
               'pos
               'neg))
+
+  (test/pos-blame
+   'object/c-first-order-local-method-1
+   '(let ()
+      (define-local-member-name m)
+      (contract (object/c [m (-> any/c number? number?)])
+                (new object%)
+                'pos
+                'neg)))
+
+  (test/spec-passed
+   'object/c-first-order-local-method-2
+   '(let ()
+      (define-local-member-name m)
+      (contract (object/c [m (-> any/c number? number?)])
+                (new (class object% (super-new) (define/public (m x) (add1 x))))
+                'pos
+                'neg)))
   
   (test/pos-blame
    'object/c-first-order-field-1
@@ -7950,7 +8175,25 @@
               (new (class object% (super-new) (field [n 3])))
               'pos
               'neg))
-  
+
+  (test/pos-blame
+   'object/c-first-order-local-field-1
+   '(let ()
+      (define-local-member-name n)
+      (contract (object/c (field [n number?]))
+                (new object%)
+                'pos
+                'neg)))
+
+  (test/spec-passed
+   'object/c-first-order-local-field-2
+   '(let ()
+      (define-local-member-name n)
+      (contract (object/c (field [n number?]))
+                (new (class object% (super-new) (field [n 3])))
+                'pos
+                'neg)))
+
   (test/spec-passed/result
    'object/c-higher-order-field-1
    '(get-field