From 9944d8d1e895d520cfd9792edbc6faabc1901fd0 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 10 Feb 2003 01:54:05 +0000
Subject: [PATCH] Add GUARANTEE- procedures. Clean up a little, and update
copyright dates.
---
v7/src/runtime/runtime.pkg | 6 +-
v7/src/runtime/uproc.scm | 138 +++++++++++++++++++++----------------
2 files changed, 85 insertions(+), 59 deletions(-)
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
--
2.25.1