From c711cac3d0eda009a2d63060d9dcde3fb32d8bd0 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 15 Mar 2001 04:20:35 +0000
Subject: [PATCH] .

original commit: db81df56ddf981a637eff54bdd6432b07019f05a
---
 collects/mzlib/class.ss | 94 +++++++++++++++++++++++++----------------
 1 file changed, 57 insertions(+), 37 deletions(-)

diff --git a/collects/mzlib/class.ss b/collects/mzlib/class.ss
index e16bf32..2fe5920 100644
--- a/collects/mzlib/class.ss
+++ b/collects/mzlib/class.ss
@@ -687,7 +687,7 @@
 
 			init           ; initializer
 
-			no-super-init?)    ; #t => no super-init needed
+			no-super-init?); #t => no super-init needed
                     insp)
 
   (define (compose-class name               ; symbol
@@ -719,7 +719,14 @@
 			   (not (eq? super object%))
 			   (if (symbol? s)
 			       (format "derived-from-~a" s)
-			       s))))])
+			       s))))]
+	  ;; Mis utilities
+	  [no-new-methods? (null? public-names)]
+	  [no-method-changes? (and (null? public-names)
+				   (null? override-names))]
+	  [no-new-fields? (zero? num-fields)]
+	  [xappend (lambda (a b) (if (null? b) a (append a b)))])
+
       ;; -- Check interfaces ---
       (for-each
        (lambda (intf)
@@ -730,39 +737,47 @@
        interfaces)
 
       ;; -- Match method and field names to indices --
-      (let ([method-ht (make-hash-table)]
-	    [field-ht (make-hash-table)]
+      (let ([method-ht (if no-new-methods?
+			   (class-method-ht super)
+			   (make-hash-table))]
+	    [field-ht (if no-new-fields?
+			  (class-field-ht super)
+			  (make-hash-table))]
 	    [super-method-ids (class-method-ids super)]
 	    [super-field-ids (class-field-ids super)]
 	    [super-field-ht (class-field-ht super)])
 
 	;; Put superclass ids in tables, with pos
-	(let loop ([ids super-method-ids][p 0])
-	  (unless (null? ids)
-	    (hash-table-put! method-ht (car ids) p)
-	    (loop (cdr ids) (add1 p))))
-	(let loop ([ids super-field-ids])
-	  (unless (null? ids)
-	    (hash-table-put! field-ht (car ids) (hash-table-get super-field-ht (car ids)))
-	    (loop (cdr ids))))
+	(unless no-new-methods?
+	  (let loop ([ids super-method-ids][p 0])
+	    (unless (null? ids)
+	      (hash-table-put! method-ht (car ids) p)
+	      (loop (cdr ids) (add1 p)))))
+	(unless no-new-fields?
+	  (let loop ([ids super-field-ids])
+	    (unless (null? ids)
+	      (hash-table-put! field-ht (car ids) (hash-table-get super-field-ht (car ids)))
+	      (loop (cdr ids)))))
 
 	;; Put new ids in table, with pos (replace field pos with accessor later)
-	(let loop ([ids public-names][p (class-method-width super)])
-	  (unless (null? ids)
-	    (when (hash-table-get method-ht (car ids) (lambda () #f))
-	      (obj-error 'class*/names "superclass already contains method: ~a~a" 
-			 (car ids)
-			 (for-class name)))
-	    (hash-table-put! method-ht (car ids) p)
-	    (loop (cdr ids) (add1 p))))
-	(let loop ([ids public-field-names][p (class-field-width super)])
-	  (unless (null? ids)
-	    (when (hash-table-get field-ht (car ids) (lambda () #f))
-	      (obj-error 'class*/names "superclass already contains field: ~a~a" 
-			 (car ids)
-			 (for-class name)))
-	    (hash-table-put! field-ht (car ids) p)
-	    (loop (cdr ids) (add1 p))))
+	(unless no-new-methods?
+	  (let loop ([ids public-names][p (class-method-width super)])
+	    (unless (null? ids)
+	      (when (hash-table-get method-ht (car ids) (lambda () #f))
+		(obj-error 'class*/names "superclass already contains method: ~a~a" 
+			   (car ids)
+			   (for-class name)))
+	      (hash-table-put! method-ht (car ids) p)
+	      (loop (cdr ids) (add1 p)))))
+	(unless no-new-fields?
+	  (let loop ([ids public-field-names][p (class-field-width super)])
+	    (unless (null? ids)
+	      (when (hash-table-get field-ht (car ids) (lambda () #f))
+		(obj-error 'class*/names "superclass already contains field: ~a~a" 
+			   (car ids)
+			   (for-class name)))
+	      (hash-table-put! field-ht (car ids) p)
+	      (loop (cdr ids) (add1 p)))))
 
 	;; Check that superclass has expected methods, and get indices
 	(let ([get-indices
@@ -818,12 +833,16 @@
 					struct:interface
 					(string->symbol (format "interface:~a" name)))
 				       make-interface)]
-		   [method-names (append super-method-ids public-names)]
-		   [field-names (append super-field-ids public-field-names)]
+		   [method-names (xappend super-method-ids public-names)]
+		   [field-names (xappend super-field-ids public-field-names)]
 		   [super-interfaces (cons (class->interface super) interfaces)]
 		   [i (interface-make name super-interfaces method-names #f)]
-		   [methods (make-vector method-width)]
-		   [prim-flags (make-vector method-width)]
+		   [methods (if no-method-changes?
+				(class-methods super)
+				(make-vector method-width))]
+		   [prim-flags (if no-method-changes?
+				   (class-prim-flags super)
+				   (make-vector method-width))]
 		   [c (class-make name
 				  (add1 (class-pos super))
 				  (list->vector (append (vector->list (class-supers super)) (list #f)))
@@ -939,11 +958,12 @@
 						   method-accessors))])
 			;; -- Fill in method tables --
 			;;  First copy old methods
-			(hash-table-for-each
-			 (class-method-ht super)
-			 (lambda (name index)
-			   (vector-set! methods index (vector-ref (class-methods super) index))
-			   (vector-set! prim-flags index (vector-ref (class-prim-flags super) index))))
+			(unless no-method-changes?
+			  (hash-table-for-each
+			   (class-method-ht super)
+			   (lambda (name index)
+			     (vector-set! methods index (vector-ref (class-methods super) index))
+			     (vector-set! prim-flags index (vector-ref (class-prim-flags super) index)))))
 			;; Add new methods:
 			(for-each (lambda (index method)
 				    (vector-set! methods index method)