From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 14 Mar 2003 20:02:18 +0000 (+0000)
Subject: Implement THUNK?.
X-Git-Tag: 20090517-FFI~1950
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=031b12968c0e97850a997e7352bb554148a09794;p=mit-scheme.git

Implement THUNK?.
---

diff --git a/v7/src/runtime/uproc.scm b/v7/src/runtime/uproc.scm
index 6579a6134..da55a1d1d 100644
--- a/v7/src/runtime/uproc.scm
+++ b/v7/src/runtime/uproc.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: uproc.scm,v 1.14 2003/02/14 18:28:34 cph Exp $
+$Id: uproc.scm,v 1.15 2003/03/14 20:02:18 cph Exp $
 
 Copyright 1990,1991,1992,1995,1996,2003 Massachusetts Institute of Technology
 
@@ -102,10 +102,10 @@ USA.
   (let loop ((p procedure) (e 0))
     (cond ((%primitive-procedure? p)
 	   (let ((arity (primitive-procedure-arity p)))
-	     (cond ((< arity 0)
+	     (cond ((fix:< arity 0)
 		    (cons 0 #f))
-		   ((<= e arity)
-		    (let ((arity (- arity e)))
+		   ((fix:<= e arity)
+		    (let ((arity (fix:- arity e)))
 		      (cons arity arity)))
 		   (else
 		    (error "Illegal arity for entity:" procedure)))))
@@ -113,39 +113,44 @@ USA.
 	   (lambda-components (%compound-procedure-lambda p)
 	     (lambda (name required optional rest auxiliary decl body)
 	       name auxiliary decl body
-	       (let ((r (- (length required) e)))
+	       (let ((r (fix:- (length required) e)))
 		 (cond (rest
-			(cons (max 0 r) #f))
-		       ((>= r 0)
-			(cons r (+ r (length optional))))
+			(cons (fix:max 0 r) #f))
+		       ((fix:>= r 0)
+			(cons r (fix:+ r (length optional))))
 		       (else
 			(error "Illegal arity for entity:" procedure)))))))
 	  ((%compiled-procedure? p)
 	   (let ((info (compiled-entry-kind p))
-		 (e+1 (+ e 1)))
+		 (e+1 (fix:+ e 1)))
 	     ;; max = (-1)^tail? * (1 + req + opt + tail?)
 	     ;; min = (1 + req)
-	     (let ((min (- (system-hunk3-cxr1 info) e+1))
+	     (let ((min (fix:- (system-hunk3-cxr1 info) e+1))
 		   (max (system-hunk3-cxr2 info)))
-	       (cond ((< max 0)
-		      (cons (if (negative? min) 0 min) #f))
-		     ((>= min 0)
-		      (cons min (- max e+1)))
+	       (cond ((fix:< max 0)
+		      (cons (if (fix:< min 0) 0 min) #f))
+		     ((fix:>= min 0)
+		      (cons min (fix:- max e+1)))
 		     (else
 		      (error "Illegal arity for entity:" procedure))))))
 	  ((%entity? p)
 	   (if (%entity-is-apply-hook? p)
 	       (loop (apply-hook-procedure p) e)
-	       (loop (entity-procedure p) (+ e 1))))
+	       (loop (entity-procedure p) (fix:+ e 1))))
 	  (else
 	   (error:wrong-type-argument procedure "procedure"
 				      'PROCEDURE-ARITY)))))
 
 (define (procedure-arity-valid? procedure n-arguments)
+  (guarantee-index-fixnum n-arguments 'PROCEDURE-ARITY-VALID?)
   (let ((arity (procedure-arity procedure)))
     (and (<= (car arity) n-arguments)
 	 (or (not (cdr arity))
 	     (<= n-arguments (cdr arity))))))
+
+(define (thunk? object)
+  (and (procedure? object)
+       (procedure-arity-valid? object 0)))
 
 ;;;; Interpreted Procedures