From: Chris Hanson 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!)