Eliminate use of potential generic procedures in implementation of

generic-procedure dispatch.

diff --git a/v7/src/runtime/generic.scm b/v7/src/runtime/generic.scm
index 97c892d94541413c377ed535327df595ce49656d..f15e53c43e4e4e0bde0594b4d176e3798f48211a 100644 (file)
--- a/v7/src/runtime/generic.scm
+++ b/v7/src/runtime/generic.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: generic.scm,v 1.7 2003/07/22 02:12:56 cph Exp $
+$Id: generic.scm,v 1.8 2005/04/12 18:36:32 cph Exp $
 
-Copyright 1996,2003 Massachusetts Institute of Technology
+Copyright 1996,2003,2005 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -269,7 +269,13 @@ USA.
          (compute-method-and-store record (list a1 a2 a3 a4))))))
 
 (define (compute-method-and-store record args)
-  (let ((tags (map dispatch-tag args)))
+  (let ((tags
+        (let ((p (list 'TAGS)))
+          (do ((args args (cdr args))
+               (p p (cdr p)))
+              ((not (pair? args)))
+            (set-cdr! p (list (dispatch-tag (car args)))))
+          (cdr p))))
     (let ((procedure
           (let ((generator (generic-record/generator record))
                 (generic (generic-record/procedure record)))
@@ -296,7 +302,8 @@ USA.
           (%record? (%record-ref object 0))
           (eq? dispatch-tag-marker (%record-ref (%record-ref object 0) 0)))
       (%record-ref object 0)
-      (or (vector-ref microcode-type-tag-table (object-type object))
+      (if (vector-ref microcode-type-tag-table (object-type object))
+         (vector-ref microcode-type-tag-table (object-type object))
          ((vector-ref microcode-type-method-table (object-type object))
           object))))
 
@@ -389,26 +396,18 @@ USA.
             ((2) expression-tag)
             (else default-tag))))))
     (let ((boolean-tag (make-built-in-tag 'BOOLEAN)))
-      (if (fix:= (object-type #f) (object-type #t))
-         (assign-type 'CONSTANT
-                      (lambda (default-tag)
-                        (lambda (object)
-                          (if (or (eq? #f object) (eq? #t object))
-                              boolean-tag
-                              default-tag))))
-         (begin
-           (assign-type 'FALSE
-                        (lambda (default-tag)
-                          (lambda (object)
-                            (if (eq? #f object)
-                                boolean-tag
-                                default-tag))))
-           (assign-type 'CONSTANT
-                        (lambda (default-tag)
-                          (lambda (object)
-                            (if (eq? #t object)
-                                boolean-tag
-                                default-tag)))))))
+      (assign-type 'FALSE
+                  (lambda (default-tag)
+                    (lambda (object)
+                      (if (eq? #f object)
+                          boolean-tag
+                          default-tag))))
+      (assign-type 'CONSTANT
+                  (lambda (default-tag)
+                    (lambda (object)
+                      (if (eq? #t object)
+                          boolean-tag
+                          default-tag)))))
     (assign-type 'FLONUM
                 (let ((flonum-vector-tag
                        (make-built-in-tag 'FLONUM-VECTOR)))

diff --git a/v7/src/runtime/genmult.scm b/v7/src/runtime/genmult.scm
index 25d0ad5f4b280bb8c84591849f0c41aec7913425..b7eb10159d01cc0d2c0c35e57812efbd46699e57 100644 (file)
--- a/v7/src/runtime/genmult.scm
+++ b/v7/src/runtime/genmult.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: genmult.scm,v 1.5 2003/02/14 18:28:32 cph Exp $
+$Id: genmult.scm,v 1.6 2005/04/12 18:36:35 cph Exp $
 
-Copyright 1995-1999 Massachusetts Institute of Technology
+Copyright 1996,2005 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -64,16 +64,26 @@ USA.
     (if (multiplexer? m)
        (begin
          (purge-generic-procedure-cache generic)
-         (set-multiplexer-list! m (delq! generator (multiplexer-list m)))
+         (do ((this (multiplexer-list m) (cdr this))
+              (prev #f
+                    (if (eq? (car this) generator)
+                        (begin
+                          (if prev
+                              (set-cdr! prev (cdr this))
+                              (set-multiplexer-list! m (cdr this)))
+                          prev)
+                        this)))
+             ((not (pair? this))))
          (maybe-deinstall-multiplexer generic))
        (if (eq? generator m)
            (set-generic-procedure-generator! generic #f)))))
 
 (define (remove-generic-procedure-generators generic tags)
-  (for-each (lambda (generator)
-             (if (generator generic tags)
-                 (remove-generic-procedure-generator generic generator)))
-           (generic-procedure-generator-list generic)))
+  (do ((gens (generic-procedure-generator-list generic) (cdr gens)))
+      ((not (pair? gens)))
+    (let ((generator (car gens)))
+      (if (generator generic tags)
+         (remove-generic-procedure-generator generic generator)))))
 
 (define (generic-procedure-default-generator generic)
   (let ((m (generic-procedure-generator generic)))
@@ -104,10 +114,10 @@ USA.
 (define (maybe-deinstall-multiplexer generic)
   (let* ((m (generic-procedure-generator generic))
         (generators (multiplexer-list m)))
-    (cond ((and (null? generators)
+    (cond ((and (not (pair? generators))
                (not (multiplexer-default m)))
           (set-generic-procedure-generator! generic #f))
-         ((and (null? (cdr generators))
+         ((and (not (pair? (cdr generators)))
                (not (multiplexer-default m)))
           (set-generic-procedure-generator! generic (car generators))))))
 \f
@@ -138,28 +148,29 @@ USA.
 
 (define (multiplexer-dispatch multiplexer generic tags)
   (let loop ((generators (multiplexer-list multiplexer)))
-    (if (null? generators)
+    (if (pair? generators)
+       (let ((procedure ((car generators) generic tags)))
+         (if procedure
+             (if (let find-extra ((generators (cdr generators)))
+                   (if (pair? generators)
+                       (if ((car generators) generic tags)
+                           #t
+                           (find-extra (cdr generators)))
+                       #f))
+                 (lambda args
+                   (error:extra-applicable-methods generic args))
+                 procedure)
+             (loop (cdr generators))))
        (let ((default (multiplexer-default multiplexer)))
          (and default
-              (default generic tags)))
-       (let ((procedure ((car generators) generic tags)))
-         (cond ((not procedure)
-                (loop (cdr generators)))
-               ((there-exists? (cdr generators)
-                  (lambda (generator)
-                    (generator generic tags)))
-                (lambda args
-                  (error:extra-applicable-methods generic args)))
-               (else procedure))))))
+              (default generic tags))))))
 
 (define multiplexer-tag)
-(define del-rassq)
 (define condition-type:extra-applicable-methods)
 (define error:extra-applicable-methods)
 
 (define (initialize-multiplexer!)
   (set! multiplexer-tag (list 'GENERIC-PROCEDURE-MULTIPLEXER))
-  (set! del-rassq (delete-association-procedure list-deletor eq? cdr))
   unspecific)
 
 (define (initialize-conditions!)