From 6c75c22e2002e1ce0759b01ed18da4f3bbb90755 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 16 Apr 2005 03:39:35 +0000
Subject: [PATCH] Add abstraction for procedure-arity objects.

---
 v7/src/runtime/runtime.pkg |  8 +++++++-
 v7/src/runtime/uproc.scm   | 42 +++++++++++++++++++++++++++++++++++++-
 2 files changed, 48 insertions(+), 2 deletions(-)

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 88eadb5b1..34c598a39 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.538 2005/04/14 04:42:45 cph Exp $
+$Id: runtime.pkg,v 14.539 2005/04/16 03:39:25 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -1365,20 +1365,26 @@ USA.
 	  error:not-compound-procedure
 	  error:not-primitive-procedure
 	  error:not-procedure
+	  error:not-procedure-arity
 	  guarantee-compiled-procedure
 	  guarantee-compound-procedure
 	  guarantee-primitive-procedure
 	  guarantee-procedure
+	  guarantee-procedure-arity
 	  guarantee-procedure-of-arity
 	  implemented-primitive-procedure?
 	  make-apply-hook
 	  make-arity-dispatched-procedure
 	  make-entity
 	  make-primitive-procedure
+	  make-procedure-arity
 	  primitive-procedure-name
 	  primitive-procedure?
 	  procedure-arity
+	  procedure-arity-max
+	  procedure-arity-min
 	  procedure-arity-valid?
+	  procedure-arity?
 	  procedure-components
 	  procedure-environment
 	  procedure-lambda
diff --git a/v7/src/runtime/uproc.scm b/v7/src/runtime/uproc.scm
index 8267e70e0..61a30a371 100644
--- a/v7/src/runtime/uproc.scm
+++ b/v7/src/runtime/uproc.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: uproc.scm,v 1.16 2005/03/29 03:39:23 cph Exp $
+$Id: uproc.scm,v 1.17 2005/04/16 03:39:35 cph Exp $
 
 Copyright 1990,1991,1992,1995,1996,2003 Massachusetts Institute of Technology
 Copyright 2005 Massachusetts Institute of Technology
@@ -153,6 +153,46 @@ USA.
   (if (not (procedure-arity-valid? object arity))
       (error:bad-range-argument object caller)))
 
+(define (make-procedure-arity min #!optional max)
+  (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))))
+	(cons min max))))
+
+(define (procedure-arity? object)
+  (if (simple-arity? object)
+      #t
+      (general-arity? object)))
+
+(define-guarantee procedure-arity "procedure arity")
+
+(define (procedure-arity-min arity)
+  (cond ((simple-arity? arity) arity)
+	((general-arity? arity) (car arity))
+	(else (error:not-procedure-arity arity 'PROCEDURE-ARITY-MIN))))
+
+(define (procedure-arity-max arity)
+  (cond ((simple-arity? arity) arity)
+	((general-arity? arity) (cdr arity))
+	(else (error:not-procedure-arity arity 'PROCEDURE-ARITY-MAX))))
+
+(define-integrable (simple-arity? object)
+  (index-fixnum? object))
+
+(define-integrable (general-arity? object)
+  (and (pair? object)
+       (index-fixnum? (car object))
+       (if (cdr object)
+	   (and (index-fixnum? (cdr object))
+		(fix:>= (cdr object) (car object)))
+	   #t)))
+
 ;;;; Interpreted Procedures
 
 (define-integrable (%primitive-procedure? object)
-- 
2.25.1