From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 16 Apr 2005 04:26:35 +0000 (+0000)
Subject: Force arity folding for GENERIC-PROCEDURE-ARITY.
X-Git-Tag: 20090517-FFI~1321
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=888b8b10bcf03bfaebed92ad60b97ea90f0f4bf2;p=mit-scheme.git

Force arity folding for GENERIC-PROCEDURE-ARITY.
---

diff --git a/v7/src/runtime/generic.scm b/v7/src/runtime/generic.scm
index 496e93f33..8d854e38f 100644
--- a/v7/src/runtime/generic.scm
+++ b/v7/src/runtime/generic.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: generic.scm,v 1.12 2005/04/16 04:05:18 cph Exp $
+$Id: generic.scm,v 1.13 2005/04/16 04:26:35 cph Exp $
 
 Copyright 1996,2003,2005 Massachusetts Institute of Technology
 
@@ -69,11 +69,14 @@ USA.
 (define (generic-procedure? object)
   (if (eqht/get generic-procedure-records object #f) #t #f))
 
+(define (generic-record/arity record)
+  (make-procedure-arity (generic-record/arity-min record)
+			(generic-record/arity-max record)
+			#t))
+
 (define (generic-procedure-arity generic)
-  (let ((record
-	 (guarantee-generic-procedure generic 'GENERIC-PROCEDURE-ARITY)))
-    (make-procedure-arity (generic-record/arity-min record)
-			  (generic-record/arity-max record))))
+  (generic-record/arity
+   (guarantee-generic-procedure generic 'GENERIC-PROCEDURE-ARITY)))
 
 (define (generic-procedure-arity-min generic)
   (generic-record/arity-min
@@ -188,8 +191,7 @@ USA.
 	   (wna
 	    (lambda (args)
 	      (error:wrong-number-of-arguments generic
-					       (make-procedure-arity arity-min
-								     arity-max)
+					       (generic-record/arity record)
 					       args))))
 	generic))))