Add abstraction for procedure-arity objects.

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 88eadb5b17b14d0b86e8ce00256a38ee349b64fb..34c598a3988ed57603ef43a409608a3959aa3e7e 100644 (file)
--- 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 8267e70e0f758e3b06048162387fe4d67759ff7a..61a30a37119cf0d63c1c2f9056263a8486d68f44 100644 (file)
--- 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)))
 \f
+(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)))
+\f
 ;;;; Interpreted Procedures
 
 (define-integrable (%primitive-procedure? object)