From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 10 Feb 2003 01:54:05 +0000 (+0000)
Subject: Add GUARANTEE- procedures.  Clean up a little, and update copyright
X-Git-Tag: 20090517-FFI~2042
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9944d8d1e895d520cfd9792edbc6faabc1901fd0;p=mit-scheme.git

Add GUARANTEE- procedures.  Clean up a little, and update copyright
dates.
---

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 764253317..e615e97aa 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.424 2003/02/06 19:48:32 cph Exp $
+$Id: runtime.pkg,v 14.425 2003/02/10 01:54:05 cph Exp $
 
 Copyright (c) 1988,1989,1990,1991,1992 Massachusetts Institute of Technology
 Copyright (c) 1993,1994,1995,1996,1997 Massachusetts Institute of Technology
@@ -1277,6 +1277,10 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 	  entity-extra
 	  entity-procedure
 	  entity?
+	  guarantee-compiled-procedure
+	  guarantee-compound-procedure
+	  guarantee-primitive-procedure
+	  guarantee-procedure
 	  implemented-primitive-procedure?
 	  make-apply-hook
 	  make-arity-dispatched-procedure
diff --git a/v7/src/runtime/uproc.scm b/v7/src/runtime/uproc.scm
index cbabba68a..5e5aae041 100644
--- a/v7/src/runtime/uproc.scm
+++ b/v7/src/runtime/uproc.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: uproc.scm,v 1.12 2002/11/20 19:46:24 cph Exp $
+$Id: uproc.scm,v 1.13 2003/02/10 01:53:47 cph Exp $
 
-Copyright (c) 1990-1999 Massachusetts Institute of Technology
+Copyright 1990,1991,1992,1995,1996,2003 Massachusetts Institute of Technology
 
 This file is part of MIT Scheme.
 
@@ -35,38 +35,60 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 	(%primitive-procedure? object)
 	(%compiled-procedure? object))))
 
+(define (guarantee-procedure object procedure)
+  (if (not (procedure? object))
+      (error:wrong-type-argument object "procedure" procedure)))
+
+(define (guarantee-compound-procedure object procedure)
+  (if (not (compound-procedure? object))
+      (error:wrong-type-argument object "compound procedure" procedure)))
+
+(define (guarantee-primitive-procedure object procedure)
+  (if (not (primitive-procedure? object))
+      (error:wrong-type-argument object "primitive procedure" procedure)))
+
+(define (guarantee-compiled-procedure object procedure)
+  (if (not (compiled-procedure? object))
+      (error:wrong-type-argument object "compiled procedure" procedure)))
+
 (define (procedure-lambda procedure)
   (discriminate-procedure procedure
-			  (lambda (procedure) procedure false)
+			  (lambda (procedure) procedure #f)
 			  %compound-procedure-lambda
-			  compiled-procedure/lambda))
+			  compiled-procedure/lambda
+			  'PROCEDURE-LAMBDA))
 
 (define (procedure-environment procedure)
-  (discriminate-procedure
-   procedure
-   (lambda (procedure)
-     (error "primitive procedures have no closing environment" procedure))
-   %compound-procedure-environment
-   compiled-procedure/environment))
+  (discriminate-procedure procedure
+			  (lambda (procedure)
+			    (error:bad-range-argument procedure
+						      'PROCEDURE-ENVIRONMENT))
+			  %compound-procedure-environment
+			  compiled-procedure/environment
+			  'PROCEDURE-ENVIRONMENT))
 
 (define (procedure-components procedure receiver)
-  (discriminate-procedure
-   procedure
-   (lambda (procedure)
-     (error "primitive procedures have no components" procedure))
-   (lambda (procedure)
-     (receiver (%compound-procedure-lambda procedure)
-	       (%compound-procedure-environment procedure)))
-   (lambda (procedure)
-     (receiver (compiled-procedure/lambda procedure)
-	       (compiled-procedure/environment procedure)))))
-
-(define (discriminate-procedure procedure if-primitive if-compound if-compiled)
+  (discriminate-procedure procedure
+			  (lambda (procedure)
+			    (error:bad-range-argument procedure
+						      'PROCEDURE-COMPONENTS))
+			  (lambda (procedure)
+			    (receiver
+			     (%compound-procedure-lambda procedure)
+			     (%compound-procedure-environment procedure)))
+			  (lambda (procedure)
+			    (receiver
+			     (compiled-procedure/lambda procedure)
+			     (compiled-procedure/environment procedure)))
+			  'PROCEDURE-COMPONENTS))
+
+(define (discriminate-procedure procedure if-primitive if-compound if-compiled
+				caller)
   (let ((procedure* (skip-entities procedure)))
     (cond ((%primitive-procedure? procedure*) (if-primitive procedure*))
 	  ((%compound-procedure? procedure*) (if-compound procedure*))
 	  ((%compiled-procedure? procedure*) (if-compiled procedure*))
-	  (else (error:wrong-type-argument procedure "procedure" #F)))))
+	  (else (error:wrong-type-argument procedure "procedure" caller)))))
 
 (define (skip-entities object)
   (if (%entity? object)
@@ -79,41 +101,41 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
   (let loop ((p procedure) (e 0))
     (cond ((%primitive-procedure? p)
 	   (let ((arity (primitive-procedure-arity p)))
-	     (cond ((negative? arity)
-		    (cons 0 false))
+	     (cond ((< arity 0)
+		    (cons 0 #f))
 		   ((<= e arity)
 		    (let ((arity (- arity e)))
 		      (cons arity arity)))
 		   (else
-		    (error "illegal arity for entity" procedure)))))
+		    (error "Illegal arity for entity:" procedure)))))
 	  ((%compound-procedure? p)
 	   (lambda-components (%compound-procedure-lambda p)
 	     (lambda (name required optional rest auxiliary decl body)
 	       name auxiliary decl body
 	       (let ((r (- (length required) e)))
 		 (cond (rest
-			(cons (if (negative? r) 0 r) false))
-		       ((not (negative? r))
+			(cons (max 0 r) #f))
+		       ((>= r 0)
 			(cons r (+ r (length optional))))
 		       (else
-			(error "illegal arity for entity" procedure)))))))
+			(error "Illegal arity for entity:" procedure)))))))
 	  ((%compiled-procedure? p)
 	   (let ((info (compiled-entry-kind p))
-		 (e+1 (1+ e)))
+		 (e+1 (+ e 1)))
 	     ;; max = (-1)^tail? * (1 + req + opt + tail?)
 	     ;; min = (1 + req)
 	     (let ((min (- (system-hunk3-cxr1 info) e+1))
 		   (max (system-hunk3-cxr2 info)))
-	       (cond ((negative? max)
-		      (cons (if (negative? min) 0 min) false))
-		     ((not (negative? min))
+	       (cond ((< max 0)
+		      (cons (if (negative? min) 0 min) #f))
+		     ((>= min 0)
 		      (cons min (- max e+1)))
 		     (else
-		      (error "illegal arity for entity" procedure))))))
+		      (error "Illegal arity for entity:" procedure))))))
 	  ((%entity? p)
 	   (if (%entity-is-apply-hook? p)
 	       (loop (apply-hook-procedure p) e)
-	       (loop (entity-procedure p) (1+ e))))
+	       (loop (entity-procedure p) (+ e 1))))
 	  (else
 	   (error:wrong-type-argument procedure "procedure"
 				      'PROCEDURE-ARITY)))))
@@ -121,9 +143,8 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 (define (procedure-arity-valid? procedure n-arguments)
   (let ((arity (procedure-arity procedure)))
     (and (<= (car arity) n-arguments)
-	 (if (cdr arity)
-	     (<= n-arguments (cdr arity))
-	     true))))
+	 (or (not (cdr arity))
+	     (<= n-arguments (cdr arity))))))
 
 ;;;; Interpreted Procedures
 
@@ -136,36 +157,38 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 (define-integrable (%primitive-procedure-implemented? procedure)
   ((ucode-primitive get-primitive-address)
    (%primitive-procedure-name procedure)
-   false))
+   #f))
 
 (define (primitive-procedure? object)
   (%primitive-procedure? (skip-entities object)))
 
 (define (make-primitive-procedure name #!optional arity)
-  (let ((arity (if (default-object? arity) false arity)))
+  (let ((arity (if (default-object? arity) #f arity)))
     (let ((result ((ucode-primitive get-primitive-address) name arity)))
       (if (not (or (object-type? (ucode-type primitive) result)
-		   (eq? arity true)))
-	  (if (false? result)
-	      (error "MAKE-PRIMITIVE-PROCEDURE: unknown name" name)
+		   (eq? arity #t)))
+	  (if result
 	      (error "MAKE-PRIMITIVE-PROCEDURE: inconsistent arity" name
 		     (error-irritant/noise " new:") arity
-		     (error-irritant/noise " old:") result)))
+		     (error-irritant/noise " old:") result)
+	      (error "MAKE-PRIMITIVE-PROCEDURE: unknown name" name)))
       result)))
 
 (define (primitive-procedure-name procedure)
-  (%primitive-procedure-name (%primitive-procedure-arg procedure)))
+  (%primitive-procedure-name
+   (%primitive-procedure-arg procedure 'PRIMITIVE-PROCEDURE-NAME)))
 
 (define (implemented-primitive-procedure? procedure)
-  (%primitive-procedure-implemented? (%primitive-procedure-arg procedure)))
+  (%primitive-procedure-implemented?
+   (%primitive-procedure-arg procedure 'IMPLEMENTED-PRIMITIVE-PROCEDURE?)))
 
-(define (%primitive-procedure-arg procedure)
+(define (%primitive-procedure-arg procedure caller)
   (let ((procedure* (skip-entities procedure)))
-    (if (not (%primitive-procedure? procedure*))
-	(error:wrong-type-datum  procedure "primitive procedure"))
+    (guarantee-primitive-procedure procedure* caller)
     procedure*))
 
-(define-integrable (%compound-procedure? object)
+(declare (integrate-operator %compound-procedure?))
+(define (%compound-procedure? object)
   (or (object-type? (ucode-type procedure) object)
       (object-type? (ucode-type extended-procedure) object)))
 
@@ -176,8 +199,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
   (system-pair-cdr procedure))
 
 (define (compound-procedure? object)
-  (let ((object (skip-entities object)))
-    (%compound-procedure? object)))
+  (%compound-procedure? (skip-entities object)))
 
 ;;;; Compiled Procedures
 
@@ -198,13 +220,13 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 	   (let ((max (system-hunk3-cxr2 (compiled-entry-kind p))))
 	     ;; max = (-1)^tail? * (1 + req + opt + tail?)
 	     ;; frame = req + opt + tail?
-	     (if (negative? max)
+	     (if (< max 0)
 		 (- -1 max)
-		 (-1+ max))))
+		 (- max 1))))
 	  ((%entity? p)
 	   (if (%entity-is-apply-hook? p)
 	       (loop (apply-hook-procedure p))
-	       (1+ (loop (entity-procedure p)))))
+	       (+ (loop (entity-procedure p)) 1)))
 	  (else
 	   (error:wrong-type-argument procedure "compiled procedure"
 				      'COMPILED-PROCEDURE-FRAME-SIZE)))))
@@ -290,7 +312,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
   (%entity-extra/apply-hook? (entity-extra object)))
 
 (define (%entity-extra/apply-hook? extra)
-  ;; Ziggy cares about this one.
+  ;; The wabbit cares about this one.
   (and (object-type? (ucode-type hunk3) extra)
        (eq? apply-hook-tag (system-hunk3-cxr0 extra))))
 
@@ -308,7 +330,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 (define-integrable (set-apply-hook-extra! apply-hook procedure)
   (system-hunk3-set-cxr2! (entity-extra apply-hook) procedure))
-
+
 ;;;; Arity dispatched entities
 
 (define (make-arity-dispatched-procedure default . dispatched-cases)
@@ -323,6 +345,6 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 (define (arity-dispatched-procedure? object)
   (and (%entity? object)
        (vector? (entity-extra object))
-       (< 0 (vector-length (entity-extra object)))
+       (fix:< 0 (vector-length (entity-extra object)))
        (eq? (vector-ref (entity-extra object) 0)
 	    (fixed-objects-item 'ARITY-DISPATCHER-TAG))))
\ No newline at end of file