From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 12 Apr 2005 18:36:35 +0000 (+0000)
Subject: Eliminate use of potential generic procedures in implementation of
X-Git-Tag: 20090517-FFI~1333
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=46d903af5e74e24affea2452655c67ec4d7c124e;p=mit-scheme.git
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 97c892d94..f15e53c43 100644
--- 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 25d0ad5f4..b7eb10159 100644
--- 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))))))
@@ -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!)