From 076ba784f75d6c9bb8ed2ed14b70ccf3ebe5bf2a Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 16 Apr 2005 04:22:35 +0000
Subject: [PATCH] MAKE-PROCEDURE-ARITY must not simplify the result by default.
---
v7/src/runtime/uproc.scm | 26 ++++++++++++++++----------
1 file changed, 16 insertions(+), 10 deletions(-)
diff --git a/v7/src/runtime/uproc.scm b/v7/src/runtime/uproc.scm
index 61a30a371..a70fa8608 100644
--- 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)))
-(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)
--
2.25.1