From 9944d8d1e895d520cfd9792edbc6faabc1901fd0 Mon Sep 17 00:00:00 2001 From: Chris Hanson 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