From e3b7640528d6d6e9ec5fa5d21f87dfded7e3d0c4 Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Tue, 8 May 2012 17:21:36 -0400
Subject: [PATCH] Let provider of generics check if a method exists

This change adds an additional argument to define-generics
that binds a procedure to check if a given method is defined
for an instance of the generic.
---
 collects/generics/generics.rkt | 18 ++++++++++++++++--
 1 file changed, 16 insertions(+), 2 deletions(-)

diff --git a/collects/generics/generics.rkt b/collects/generics/generics.rkt
index 83f03d4056..553affc82c 100644
--- a/collects/generics/generics.rkt
+++ b/collects/generics/generics.rkt
@@ -23,10 +23,16 @@
 (provide define-generics)
 (define-syntax (define-generics stx)
   (syntax-case stx ()
-    [(_ (name prop:name name?) (generic . generic-args) ...)
+    ;; defined-table binding is optional, so if it's not provided just
+    ;; hygienically generate some name to bind it to.
+    [(_ (name prop:name name?) (generic . generics-args) ...)
+     #'(define-generics (name prop:name name? defined-table)
+         (generic . generics-args) ...)]
+    [(_ (name prop:name name? defined-table) (generic . generic-args) ...)
      (and (identifier? #'name)
           (identifier? #'prop:name)
           (identifier? #'name?)
+          (identifier? #'defined-table)
           (let ([generics (syntax->list #'(generic ...))])
             (and (pair? generics) (andmap identifier? generics))))
      (let ([idxs (for/list ([i (in-naturals 0)]
@@ -85,7 +91,7 @@
                              #'id]
                             [()
                              #'()])))])
-         #'(begin
+         #`(begin
              (define-syntax name (list #'generic ...))
              ; XXX optimize no kws or opts
              (define generic-arity-coerce
@@ -113,6 +119,14 @@
                             (and mthd-generic
                                  (generic-arity-coerce mthd-generic)))
                           ...))))
+             ;; Hash table mapping method name symbols to
+             ;; whether the given method is implemented
+             (define (defined-table this)
+               (unless (name? this)
+                 (raise-type-error 'defined-table name-str this))
+               (for/hash ([name (in-list '(#,@(map syntax->datum generics)))]
+                          [gen (in-vector (get-generics this))])
+                 (values name (not (not gen)))))
              (define generic
                (generic-arity-coerce
                 (make-keyword-procedure