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 764253317a4ec3beb0ef32cdb1ef4db19bc8b8d3..e615e97aa3effc1915dc57290acd72a5dc87916c 100644 (file)
--- 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 cbabba68a3164907f8d37bc1d99331f3e48933f1..5e5aae04169ad790d149d8a6fc96e9d19dd2796f 100644 (file)
--- 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))))))
 \f
 ;;;; 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)))
 \f
 ;;;; 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))
-\f
+
 ;;;; 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