From: Guillermo J. Rozas Date: Wed, 31 May 1989 20:02:25 +0000 (+0000) Subject: Remove the concept of safe primitives since the microcode now takes X-Git-Tag: 20090517-FFI~12032 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=32198b20edc17f2838c9a819a496bcd38b4d6b9b;p=mit-scheme.git Remove the concept of safe primitives since the microcode now takes care of them. Add primitive uuo link unparsing to the disassembler. --- diff --git a/v7/src/compiler/base/utils.scm b/v7/src/compiler/base/utils.scm index 7ec9eec12..fdf1004e4 100644 --- a/v7/src/compiler/base/utils.scm +++ b/v7/src/compiler/base/utils.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 4.11 1989/04/15 18:05:57 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 4.12 1989/05/31 20:01:36 jinx Rel $ Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology @@ -169,65 +169,19 @@ MIT in each case. |# type-code:extended-procedure) (else (error "SCODE/PROCEDURE-TYPE-CODE: Unknown lambda type" *lambda)))) - -;;;; Primitive Procedures + +;;; Primitive Procedures (define (primitive-procedure? object) (or (eq? compiled-error-procedure object) (scode/primitive-procedure? object))) -(define (normal-primitive-procedure? object) - (or (eq? compiled-error-procedure object) - (and (scode/primitive-procedure? object) - (primitive-procedure-safe? object)))) - (define (primitive-arity-correct? primitive argument-count) (if (eq? primitive compiled-error-procedure) (positive? argument-count) (let ((arity (primitive-procedure-arity primitive))) (or (= arity -1) (= arity argument-count))))) - -(define (primitive-procedure-safe? object) - (and (object-type? (ucode-type primitive) object) - (not (memq object unsafe-primitive-procedures)))) - -(define unsafe-primitive-procedures - (let-syntax ((primitives - (macro names - `'(,@(map (lambda (spec) - (if (pair? spec) - (apply make-primitive-procedure spec) - (make-primitive-procedure spec))) - names))))) - (primitives scode-eval - apply - force - error-procedure - within-control-point - call-with-current-continuation - non-reentrant-call-with-current-continuation - with-interrupt-mask - with-interrupts-reduced - execute-at-new-state-point - translate-to-state-point - set-current-history! - with-history-disabled - garbage-collect - primitive-purify - primitive-impurify - primitive-fasdump - dump-band - load-band - (primitive-eval-step 3) - (primitive-apply-step 3) - (primitive-return-step 2) - (dump-world 1) - (complete-garbage-collect 1) - (with-saved-fluid-bindings 1) - (global-interrupt 3) - (get-work 1) - (master-gc-loop 1)))) ;;;; Special Compiler Support diff --git a/v7/src/compiler/fgopt/order.scm b/v7/src/compiler/fgopt/order.scm index 78dfd934b..e9ea55903 100644 --- a/v7/src/compiler/fgopt/order.scm +++ b/v7/src/compiler/fgopt/order.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/order.scm,v 4.11 1989/04/21 16:32:10 markf Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/order.scm,v 4.12 1989/05/31 20:01:50 jinx Rel $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -456,7 +456,7 @@ MIT in each case. |# (or (not (reference? operator)) (reference-to-known-location? operator))) ((rvalue/constant? callee) - (not (normal-primitive-procedure? (constant-value callee)))) + (not (primitive-procedure? (constant-value callee)))) ((rvalue/procedure? callee) (case (procedure/type callee) ((OPEN-EXTERNAL OPEN-INTERNAL) false) diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040 index e8bb992a2..59b072ce3 100644 --- a/v7/src/compiler/machines/bobcat/make.scm-68040 +++ b/v7/src/compiler/machines/bobcat/make.scm-68040 @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.44 1989/05/21 14:52:30 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.45 1989/05/31 20:01:20 jinx Rel $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -41,4 +41,4 @@ MIT in each case. |# ((package/reference (find-package name) 'INITIALIZE-PACKAGE!))) '((COMPILER MACROS) (COMPILER DECLARATIONS))) -(add-system! (make-system "Liar (Motorola MC68020)" 4 44 '())) \ No newline at end of file +(add-system! (make-system "Liar (Motorola MC68020)" 4 45 '())) \ No newline at end of file diff --git a/v7/src/compiler/rtlgen/rgcomb.scm b/v7/src/compiler/rtlgen/rgcomb.scm index 45ebb48dc..f3362f999 100644 --- a/v7/src/compiler/rtlgen/rgcomb.scm +++ b/v7/src/compiler/rtlgen/rgcomb.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 4.9 1988/12/12 21:52:32 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 4.10 1989/05/31 20:02:11 jinx Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -45,7 +45,7 @@ MIT in each case. |# invocation/reference invocation/apply)) ((rvalue/constant? model) - (if (normal-primitive-procedure? (constant-value model)) + (if (primitive-procedure? (constant-value model)) invocation/primitive invocation/apply)) ((rvalue/procedure? model) diff --git a/v7/src/compiler/rtlgen/rtlgen.scm b/v7/src/compiler/rtlgen/rtlgen.scm index 0728040db..9a2d52777 100644 --- a/v7/src/compiler/rtlgen/rtlgen.scm +++ b/v7/src/compiler/rtlgen/rtlgen.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.17 1989/04/15 18:04:34 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.18 1989/05/31 20:02:25 jinx Rel $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -169,7 +169,7 @@ MIT in each case. |# (define (operator/needs-no-heap-check? op) (and (rvalue/constant? op) (let ((obj (constant-value op))) - (and (normal-primitive-procedure? obj) + (and (primitive-procedure? obj) (special-primitive-handler obj))))) (define (wrap-with-continuation-entry context scfg)