From 54cf4c7f16d66ceaffc1342232405df7cd322b39 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 20 Jul 2015 06:39:18 -0600
Subject: [PATCH] racket/generics: fix generated <gen>/c

The revised implementation of `define-generics` for the new macro
expander wasn't right, because the macro attached to `<gen>/c` for a
given `<gen>` used a macro-introduced reference to the generic to
match up method names with the generic's methods.
---
 pkgs/racket-test/tests/generic/contract.rkt | 16 +++++++++++
 racket/collects/racket/generic.rkt          | 32 +++++++++++----------
 2 files changed, 33 insertions(+), 15 deletions(-)

diff --git a/pkgs/racket-test/tests/generic/contract.rkt b/pkgs/racket-test/tests/generic/contract.rkt
index 3a7ca9cccc..8b8618c344 100644
--- a/pkgs/racket-test/tests/generic/contract.rkt
+++ b/pkgs/racket-test/tests/generic/contract.rkt
@@ -51,3 +51,19 @@
              (λ () (dict-set dict "bad" 5))))
 
 (require 'c)
+
+;; ----------------------------------------
+
+(module contract-on-method racket
+  (require racket/generic)
+  (provide gen:foo foo? foo/c (contract-out [bar (foo? . -> . any/c)]))
+  (define-generics foo
+    (bar foo)))
+
+(module make-generic-contract racket
+  (require 'contract-on-method)
+  (define (foo/c* c)
+    (foo/c
+     [bar (foo? . -> . c)])))
+
+
diff --git a/racket/collects/racket/generic.rkt b/racket/collects/racket/generic.rkt
index 5974c3147d..af8e535ab8 100644
--- a/racket/collects/racket/generic.rkt
+++ b/racket/collects/racket/generic.rkt
@@ -169,7 +169,7 @@
 
 (define-syntax (redirect-generics/derived stx)
   (syntax-case stx ()
-    [(_ orig mode gen-name val-expr [method-name proc-expr] ... props-expr)
+    [(_ orig mode gen-name ref-gen-id val-expr [method-name proc-expr] ... props-expr)
      (parameterize ([current-syntax-context #'orig])
        (define gen-id #'gen-name)
        (unless (identifier? gen-id)
@@ -177,7 +177,7 @@
        (define gen-info (syntax-local-value gen-id (lambda () #f)))
        (unless (generic-info? gen-info)
          (wrong-syntax gen-id "expected a name for a generic interface"))
-       (define delta (make-method-delta gen-id (generic-info-name gen-info)))
+       (define delta (make-method-delta #'ref-gen-id (generic-info-name gen-info)))
        (define predicate (generic-info-predicate gen-info))
        (define accessor (generic-info-accessor gen-info))
        (define method-ids (syntax->list #'(method-name ...)))
@@ -198,23 +198,23 @@
 (define-syntax (redirect-generics stx)
   (syntax-case stx ()
     [(_ mode gen-name val-expr [id expr] ...)
-     #`(redirect-generics/derived #,stx mode gen-name val-expr [id expr] ... null)]
+     #`(redirect-generics/derived #,stx mode gen-name gen-name val-expr [id expr] ... null)]
     [(_ mode gen-name val-expr [id expr] ... #:properties props-expr)
-     #`(redirect-generics/derived #,stx mode gen-name val-expr [id expr] ... props-expr)]))
+     #`(redirect-generics/derived #,stx mode gen-name gen-name val-expr [id expr] ... props-expr)]))
 
 (define-syntax (chaperone-generics stx)
   (syntax-case stx ()
     [(_ gen-name val-expr [id expr] ...)
-     #`(redirect-generics/derived #,stx #t gen-name val-expr [id expr] ... null)]
+     #`(redirect-generics/derived #,stx #t gen-name gen-name val-expr [id expr] ... null)]
     [(_ gen-name val-expr [id expr] ... #:properties props-expr)
-     #`(redirect-generics/derived #,stx #t gen-name val-expr [id expr] ... props-expr)]))
+     #`(redirect-generics/derived #,stx #t gen-name gen-name val-expr [id expr] ... props-expr)]))
 
 (define-syntax (impersonate-generics stx)
   (syntax-case stx ()
     [(_ gen-name val-expr [id expr] ...)
-     #`(redirect-generics/derived #,stx #f gen-name val-expr [id expr] ... null)]
+     #`(redirect-generics/derived #,stx #f gen-name gen-name val-expr [id expr] ... null)]
     [(_ gen-name val-expr [id expr] ... #:properties props-expr)
-     #`(redirect-generics/derived #,stx #f gen-name val-expr [id expr] ... props-expr)]))
+     #`(redirect-generics/derived #,stx #f gen-name gen-name val-expr [id expr] ... props-expr)]))
 
 (define (redirect-generics-proc name chaperoning? pred ref x proc props)
   (unless (pred x)
@@ -241,10 +241,10 @@
 (define-syntax-rule (define-generics-contract ctc-name gen-name)
   (define-syntax (ctc-name stx)
     (syntax-case stx ()
-      [(_ [id expr] (... ...))
+      [(ref-id [id expr] (... ...))
        #`(generic-instance/c/derived #,stx
                                      [ctc-name]
-                                     gen-name
+                                     gen-name ref-id
                                      [id expr]
                                      (... ...))])))
 
@@ -253,13 +253,13 @@
     [(_ gen-name [id expr] ...)
      #`(generic-instance/c/derived #,stx
                                    [generic-instance/c gen-name]
-                                   gen-name
+                                   gen-name gen-name
                                    [id expr]
                                    ...)]))
 
 (define-syntax (generic-instance/c/derived stx)
   (syntax-case stx ()
-    [(_ original [prefix ...] gen-name [method-id ctc-expr] ...)
+    [(_ original [prefix ...] gen-name ref-gen-id [method-id ctc-expr] ...)
      (parameterize ([current-syntax-context #'original])
        (define gen-id #'gen-name)
        (unless (identifier? gen-id)
@@ -281,16 +281,18 @@
             '(method-id ...)
             (list ctc-id ...)
             (lambda (b x mode)
-              (redirect-generics
+              (redirect-generics/derived
+               original
                mode
-               gen-name
+               gen-name ref-gen-id
                x
                [method-id
                 (lambda (m)
                   (define b2
                     (blame-add-context b (format "method ~a" 'method-id)))
                   (((contract-projection ctc-id) b2) m))]
-               ...)))))]))
+               ...
+               null)))))]))
 
 (define (make-generics-contract ifc pfx pred mths ctcs proc)
   (define chaperoning?