Use new procedure-arity abstraction to simplify logic.

diff --git a/v7/src/runtime/generic.scm b/v7/src/runtime/generic.scm
index 4c7cf29955b9c78ae7275b1558f96d4dcc6ab65c..496e93f3312d595ee5f5238878282cf27d2fddce 100644 (file)
--- a/v7/src/runtime/generic.scm
+++ b/v7/src/runtime/generic.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: generic.scm,v 1.11 2005/04/16 03:17:26 cph Exp $
+$Id: generic.scm,v 1.12 2005/04/16 04:05:18 cph Exp $
 
 Copyright 1996,2003,2005 Massachusetts Institute of Technology
 
@@ -37,27 +37,17 @@ USA.
     (if (and name (not (symbol? name)))
        (error:wrong-type-argument name "symbol" 'MAKE-GENERIC-PROCEDURE))
     (if tag (guarantee-dispatch-tag tag 'MAKE-GENERIC-PROCEDURE))
-    (if (not (or (exact-positive-integer? arity)
-                (and (pair? arity)
-                     (exact-positive-integer? (car arity))
-                     (or (not (cdr arity))
-                         (and (exact-integer? (cdr arity))
-                              (>= (cdr arity) (car arity)))))))
-       (error:wrong-type-argument arity "arity"
-                                  'MAKE-GENERIC-PROCEDURE))
+    (guarantee-procedure-arity arity 'MAKE-GENERIC-PROCEDURE)
+    (if (not (fix:> (procedure-arity-min arity) 0))
+       (error:bad-range-argument arity 'MAKE-GENERIC-PROCEDURE))
     (guarantee-generator generator 'MAKE-GENERIC-PROCEDURE)
     (let ((record
           (make-generic-record (or tag standard-generic-procedure-tag)
-                               (if (and (pair? arity)
-                                        (eqv? (car arity) (cdr arity)))
-                                   (car arity)
-                                   arity)
+                               (procedure-arity-min arity)
+                               (procedure-arity-max arity)
                                generator
                                name
-                               (new-cache
-                                (if (pair? arity)
-                                    (car arity)
-                                    arity)))))
+                               (new-cache (procedure-arity-min arity)))))
       (let ((generic (compute-apply-generic record)))
        (set-generic-record/procedure! record generic)
        (eqht/put! generic-procedure-records generic record)
@@ -66,32 +56,32 @@ USA.
 (define-structure (generic-record
                   (conc-name generic-record/)
                   (constructor make-generic-record
-                               (tag arity generator name cache)))
+                               (tag arity-min arity-max generator name
+                                    cache)))
   (tag #f read-only #t)
-  (arity #f read-only #t)
+  (arity-min #f read-only #t)
+  (arity-max #f read-only #t)
   (generator #f)
   (name #f read-only #t)
   cache
   procedure)
 
-(define (generic-record/min-arity record)
-  (arity-min (generic-record/arity record)))
-
-(define (generic-record/max-arity record)
-  (arity-max (generic-record/arity record)))
-
-(define (arity-min arity)
-  (if (pair? arity) (car arity) arity))
-
-(define (arity-max arity)
-  (if (pair? arity) (cdr arity) arity))
-
 (define (generic-procedure? object)
   (if (eqht/get generic-procedure-records object #f) #t #f))
 
 (define (generic-procedure-arity generic)
-  (generic-record/arity
-   (guarantee-generic-procedure generic 'GENERIC-PROCEDURE-ARITY)))
+  (let ((record
+        (guarantee-generic-procedure generic 'GENERIC-PROCEDURE-ARITY)))
+    (make-procedure-arity (generic-record/arity-min record)
+                         (generic-record/arity-max record))))
+
+(define (generic-procedure-arity-min generic)
+  (generic-record/arity-min
+   (guarantee-generic-procedure generic 'GENERIC-PROCEDURE-ARITY-MIN)))
+
+(define (generic-procedure-arity-max generic)
+  (generic-record/arity-max
+   (guarantee-generic-procedure generic 'GENERIC-PROCEDURE-ARITY-MAX)))
 
 (define (generic-procedure-name generic)
   (generic-record/name
@@ -129,7 +119,7 @@ USA.
 
 (define (%reset-generic-procedure-cache! record)
   (set-generic-record/cache! record
-                            (new-cache (generic-record/min-arity record))))
+                            (new-cache (generic-record/arity-min record))))
 
 (define (%purge-generic-procedure-cache! generic record filter)
   ;; This might have interrupts locked for a long time, and thus is an
@@ -156,22 +146,24 @@ USA.
 ;;;; Generic Procedure Application
 
 (define (compute-apply-generic record)
-  (let ((arity (generic-record/arity record)))
-    (cond ((pair? arity) (apply-generic record))
-         ((= 1 arity) (apply-generic-1 record))
-         ((= 2 arity) (apply-generic-2 record))
-         ((= 3 arity) (apply-generic-3 record))
-         ((= 4 arity) (apply-generic-4 record))
-         (else (apply-generic record)))))
+  (let ((arity (generic-record/arity-min record)))
+    (if (and (eqv? arity (generic-record/arity-max record))
+            (fix:<= arity 4))
+       (case arity
+         ((1) (apply-generic-1 record))
+         ((2) (apply-generic-2 record))
+         ((3) (apply-generic-3 record))
+         (else (apply-generic-4 record)))
+       (apply-generic record))))
 
 (define (apply-generic record)
-  (let ((min-arity (generic-record/min-arity record))
-       (max-arity (generic-record/max-arity record)))
-    (let ((extra (and max-arity (- max-arity min-arity))))
+  (let ((arity-min (generic-record/arity-min record))
+       (arity-max (generic-record/arity-max record)))
+    (let ((extra (and arity-max (fix:- arity-max arity-min))))
       (letrec
          ((generic
            (lambda args
-             (let loop ((args* args) (n min-arity) (tags '()))
+             (let loop ((args* args) (n arity-min) (tags '()))
                (if (fix:= n 0)
                    (begin
                      (if (and extra
@@ -182,7 +174,8 @@ USA.
                                                (fix:- n 1))))))
                          (wna args))
                      (let ((procedure
-                            (probe-cache (generic-record/cache record) tags)))
+                            (probe-cache (generic-record/cache record)
+                                         tags)))
                        (if procedure
                            (apply procedure args)
                            (compute-method-and-store record args))))
@@ -195,7 +188,8 @@ USA.
           (wna
            (lambda (args)
              (error:wrong-number-of-arguments generic
-                                              (generic-record/arity record)
+                                              (make-procedure-arity arity-min
+                                                                    arity-max)
                                               args))))
        generic))))
 
@@ -205,20 +199,16 @@ USA.
                                      'GENERIC-PROCEDURE-APPLICABLE?))
        (tags (map dispatch-tag arguments)))
     (let ((generator (generic-record/generator record))
-         (arity (generic-record/arity record))
+         (arity-min (generic-record/arity-min record))
+         (arity-max (generic-record/arity-max record))
          (n-args (length tags)))
       (and generator
-          (if (pair? arity)
-              (let ((min-arity (arity-min arity))
-                    (max-arity (arity-max arity)))
-                (if (fix:= n-args min-arity)
-                    (generator procedure tags)
-                    (and (fix:> n-args min-arity)
-                         (or (not max-arity)
-                             (fix:<= n-args max-arity))
-                         (generator procedure (list-head tags min-arity)))))
-              (and (fix:= arity n-args)
-                   (generator procedure tags)))))))
+          (if (fix:= n-args arity-min)
+              (generator procedure tags)
+              (and (fix:> n-args arity-min)
+                   (or (not arity-max)
+                       (fix:<= n-args arity-max))
+                   (generator procedure (list-head tags arity-min))))))))
 \f
 (define (apply-generic-1 record)
   (lambda (a1)

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 34c598a3988ed57603ef43a409608a3959aa3e7e..9a0404835e4c7d9f4e864fd1fcf67e81634210f4 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.539 2005/04/16 03:39:25 cph Exp $
+$Id: runtime.pkg,v 14.540 2005/04/16 04:05:27 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -4309,8 +4309,6 @@ USA.
          make-dispatch-tag
 
          ;; generic.scm:
-         arity-max
-         arity-min
          built-in-dispatch-tag
          built-in-dispatch-tags
          condition-type:no-applicable-methods
@@ -4318,6 +4316,8 @@ USA.
          error:no-applicable-methods
          generic-procedure-applicable?
          generic-procedure-arity
+         generic-procedure-arity-max
+         generic-procedure-arity-min
          generic-procedure-name
          generic-procedure?
          guarantee-generic-procedure

diff --git a/v7/src/sos/method.scm b/v7/src/sos/method.scm
index c794aebec523c6c842a5108a9f8959ea0cde3e8b..b9fd23d4193500b88b55988028170326733cfe78 100644 (file)
--- a/v7/src/sos/method.scm
+++ b/v7/src/sos/method.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: method.scm,v 1.15 2003/03/08 02:16:14 cph Exp $
+$Id: method.scm,v 1.16 2005/04/16 04:05:39 cph Exp $
 
-Copyright 1995,1997,2003 Massachusetts Institute of Technology
+Copyright 1995,1997,2003,2005 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -83,8 +83,8 @@ USA.
   (guarantee-generic-procedure generic name)
   ;; Assumes that method instantiation has guaranteed that there is at
   ;; least one specializer.  This is handled by GUARANTEE-SPECIALIZERS.
-  (if (< (arity-min (generic-procedure-arity generic))
-        (length (method-specializers method)))
+  (if (fix:< (generic-procedure-arity-min generic)
+            (length (method-specializers method)))
       (error:bad-range-argument method name)))
 
 (define (guarantee-method method name)