MAKE-PROCEDURE-ARITY must not simplify the result by default.

diff --git a/v7/src/runtime/uproc.scm b/v7/src/runtime/uproc.scm
index 61a30a37119cf0d63c1c2f9056263a8486d68f44..a70fa8608919bf241b46467f2d8951799209b34f 100644 (file)
--- a/v7/src/runtime/uproc.scm
+++ b/v7/src/runtime/uproc.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: uproc.scm,v 1.17 2005/04/16 03:39:35 cph Exp $
+$Id: uproc.scm,v 1.18 2005/04/16 04:22:35 cph Exp $
 
 Copyright 1990,1991,1992,1995,1996,2003 Massachusetts Institute of Technology
 Copyright 2005 Massachusetts Institute of Technology
@@ -153,16 +153,22 @@ USA.
   (if (not (procedure-arity-valid? object arity))
       (error:bad-range-argument object caller)))
 \f
-(define (make-procedure-arity min #!optional max)
+(define (make-procedure-arity min #!optional max simple-ok?)
   (guarantee-index-fixnum min 'MAKE-PROCEDURE-ARITY)
-  (if (or (default-object? max) (eqv? max min))
-      min
-      (begin
-       (if max
-           (begin
-             (guarantee-index-fixnum max 'MAKE-PROCEDURE-ARITY)
-             (if (not (fix:> max min))
-                 (error:bad-range-argument max 'MAKE-PROCEDURE-ARITY))))
+  (let ((max
+        (if (default-object? max)
+            min
+            (begin
+              (if max
+                  (begin
+                    (guarantee-index-fixnum max 'MAKE-PROCEDURE-ARITY)
+                    (if (not (fix:>= max min))
+                        (error:bad-range-argument max
+                                                  'MAKE-PROCEDURE-ARITY))))
+              max))))
+    (if (and (eqv? min max)
+            (if (default-object? simple-ok?) #f simple-ok?))
+       min
        (cons min max))))
 
 (define (procedure-arity? object)