From c0ce55afb4134e45240eb9c53203859837020663 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 22 Aug 2006 01:26:58 +0000
Subject: [PATCH] make generic smarterabout final methods

svn: r4105
---
 collects/mzlib/class.ss                  |  2 +-
 collects/mzlib/private/class-internal.ss | 41 ++++++++++++++++--------
 2 files changed, 29 insertions(+), 14 deletions(-)

diff --git a/collects/mzlib/class.ss b/collects/mzlib/class.ss
index 8868ec0b42..4360026cdb 100644
--- a/collects/mzlib/class.ss
+++ b/collects/mzlib/class.ss
@@ -22,7 +22,7 @@
 	   define/override define/overment
 	   define/augride define/augment
 	   define/public-final define/override-final define/augment-final
-	   define-local-member-name define-member-name member-name-key generate-member-key
+	   define-local-member-name define-member-name member-name-key generate-member-key member-name-key=?
 	   generic make-generic send-generic
 	   is-a? subclass? implementation? interface-extension?
 	   object-interface object-info object->vector
diff --git a/collects/mzlib/private/class-internal.ss b/collects/mzlib/private/class-internal.ss
index 7a32a4c6a2..098581d74f 100644
--- a/collects/mzlib/private/class-internal.ss
+++ b/collects/mzlib/private/class-internal.ss
@@ -1565,6 +1565,12 @@
   (define (generate-member-key)
     (make-member-key (generate-local-member-name (gensym 'member))))
 
+  (define (member-name-key=? a b)
+    (if (and (member-key? a)
+             (member-key? b))
+        (eq? (member-key-id a) (member-key-id b))
+        (eq? a b)))
+
   ;;--------------------------------------------------------------------
   ;;  class implementation
   ;;--------------------------------------------------------------------
@@ -2664,18 +2670,27 @@
 			 obj))
 		      (let-values ([(mth ths) (find-method/who 'make-generic obj name)])
                         mth)))
-		  (let ([pos (hash-table-get (class-method-ht class) name
-					     (lambda ()
-					       (obj-error 'make-generic "no such method: ~a~a"
-							  name
-							  (for-class (class-name class)))))])
-		    (lambda (obj)
-		      (unless ((class-object? class) obj)
-			(raise-type-error 
-			 (string->symbol (format "generic:~a~a" name (for-class (class-name class))))
-			 (format "instance~a" (for-class (class-name class)))
-			 obj))
-		      (vector-ref (class-methods (object-ref obj)) pos))))))])
+		  (let* ([pos (hash-table-get (class-method-ht class) name
+                                              (lambda ()
+                                                (obj-error 'make-generic "no such method: ~a~a"
+                                                           name
+                                                           (for-class (class-name class)))))]
+                         [instance? (class-object? class)]
+                         [dynamic-generic
+                          (lambda (obj)
+                            (unless (instance? obj)
+                              (raise-type-error 
+                               (string->symbol (format "generic:~a~a" name (for-class (class-name class))))
+                               (format "instance~a" (for-class (class-name class)))
+                               obj))
+                            (vector-ref (class-methods (object-ref obj)) pos))])
+                    (if (eq? 'final (vector-ref (class-meth-flags class) pos))
+                        (let ([method (vector-ref (class-methods class) pos)])
+                          (lambda (obj)
+                            (unless (instance? obj)
+                              (dynamic-generic obj))
+                            method))
+                        dynamic-generic)))))])
       make-generic))
 
   (define-syntax send-generic
@@ -3396,7 +3411,7 @@
 	   define/override define/overment
 	   define/augride define/augment
 	   define/public-final define/override-final define/augment-final
-	   define-local-member-name define-member-name member-name-key generate-member-key
+	   define-local-member-name define-member-name member-name-key generate-member-key member-name-key=?
 	   (rename generic/form generic) (rename make-generic/proc make-generic) send-generic
 	   is-a? subclass? implementation? interface-extension?
 	   object-interface object-info object->vector