From: Guillermo J. Rozas Date: Tue, 17 Nov 1987 20:12:41 +0000 (+0000) Subject: There is now a single kind of primitive. Both mechanisms have been X-Git-Tag: 20090517-FFI~13056 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=90c260b90dd6911155ba68d156f7d5d3c8879e76;p=mit-scheme.git There is now a single kind of primitive. Both mechanisms have been merged. --- diff --git a/v7/src/runtime/emacs.scm b/v7/src/runtime/emacs.scm index cda909e82..77ed540e2 100644 --- a/v7/src/runtime/emacs.scm +++ b/v7/src/runtime/emacs.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/emacs.scm,v 13.47 1987/10/09 14:41:00 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/emacs.scm,v 13.48 1987/11/17 20:09:38 jinx Exp $ ;;; ;;; Copyright (c) 1987 Massachusetts Institute of Technology ;;; @@ -189,7 +189,7 @@ normal-check-and-clean-up-input-channel)) (define under-emacs? - (make-primitive-procedure 'UNDER-EMACS?)) + (make-primitive-procedure 'UNDER-EMACS? 0)) (define (install!) ((if (under-emacs?) diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm index 58b268187..aa5c68a66 100644 --- a/v7/src/runtime/error.scm +++ b/v7/src/runtime/error.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 13.48 1987/06/11 21:30:21 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 13.49 1987/11/17 20:09:48 jinx Rel $ ;;; ;;; Copyright (c) 1987 Massachusetts Institute of Technology ;;; @@ -43,7 +43,7 @@ (integrate-primitive-procedures set-fixed-objects-vector!)) (define error-procedure - (make-primitive-procedure 'ERROR-PROCEDURE)) + (make-primitive-procedure 'ERROR-PROCEDURE 3)) (define (error-from-compiled-code message . irritant-info) (error-procedure message @@ -340,12 +340,12 @@ using the current read-eval-print environment.")) (define-unbound-variable-error assignment? assignment-name) (define-unbound-variable-error combination-operator? combination-operator-name) (define-unbound-variable-error - (list (make-primitive-procedure 'LEXICAL-REFERENCE) - (make-primitive-procedure 'LEXICAL-ASSIGNMENT)) + (list (make-primitive-procedure 'LEXICAL-REFERENCE 2) + (make-primitive-procedure 'LEXICAL-ASSIGNMENT 3)) combination-second-operand) (define-unbound-variable-error - (list (make-primitive-procedure 'ADD-FLUID-BINDING! true)) + (list (make-primitive-procedure 'ADD-FLUID-BINDING! 3)) (lambda (obj) (let ((object (combination-second-operand obj))) (cond ((variable? object) (variable-name object)) @@ -361,7 +361,7 @@ using the current read-eval-print environment.")) (define-unassigned-variable-error combination-operator? combination-operator-name) (define-unassigned-variable-error - (list (make-primitive-procedure 'LEXICAL-REFERENCE)) + (list (make-primitive-procedure 'LEXICAL-REFERENCE 2)) combination-second-operand) (define define-bad-frame-error @@ -421,22 +421,27 @@ using the current read-eval-print environment.")) ;;;; Primitive Operator Errors -(define-operation-specific-error 'FASL-FILE-TOO-BIG - (list (make-primitive-procedure 'BINARY-FASLOAD)) - "Not enough room to Fasload" - combination-first-operand) +(let ((fasload (make-primitive-procedure 'BINARY-FASLOAD 1))) -(define-operation-specific-error 'FASL-FILE-BAD-DATA - (list (make-primitive-procedure 'BINARY-FASLOAD)) - "Fasload file would not relocate correctly" - combination-first-operand) + (define-operation-specific-error 'FASL-FILE-TOO-BIG + (list fasload) + "FASLOAD: Not enough room" + combination-first-operand) -#| -(define-operation-specific-error 'RAN-OUT-OF-HASH-NUMBERS - (list (make-primitive-procedure 'OBJECT-HASH)) - "Hashed too many objects -- get a wizard" - combination-first-operand) -|# + (define-operation-specific-error 'FASL-FILE-BAD-DATA + (list fasload) + "FASLOAD: Bad binary file" + combination-first-operand) + + (define-operation-specific-error 'IO-ERROR + (list fasload) + "FASLOAD: I/O error" + combination-first-operand) + + (define-operation-specific-error 'WRONG-ARITY-PRIMITIVES + (list fasload) + "FASLOAD: Primitives in binary file have the wrong arity" + combination-first-operand)) ;;; This will trap any external-primitive errors that ;;; aren't caught by special handlers. @@ -445,12 +450,12 @@ using the current read-eval-print environment.")) "Error during External Application") (define-operation-specific-error 'EXTERNAL-RETURN - (list (make-primitive-procedure 'FILE-OPEN-CHANNEL)) + (list (make-primitive-procedure 'FILE-OPEN-CHANNEL 2)) "Unable to open file" combination-first-operand) (define-operation-specific-error 'OUT-OF-FILE-HANDLES - (list (make-primitive-procedure 'FILE-OPEN-CHANNEL)) + (list (make-primitive-procedure 'FILE-OPEN-CHANNEL 2)) "Too many open files" combination-first-operand) diff --git a/v7/src/runtime/intrpt.scm b/v7/src/runtime/intrpt.scm index a41479058..d0bfe3517 100644 --- a/v7/src/runtime/intrpt.scm +++ b/v7/src/runtime/intrpt.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/intrpt.scm,v 13.44 1987/05/27 14:58:22 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/intrpt.scm,v 13.45 1987/11/17 20:10:00 jinx Exp $ ;;; ;;; Copyright (c) 1987 Massachusetts Institute of Technology ;;; @@ -46,7 +46,7 @@ (define timer-interrupt (let ((setup-timer-interrupt - (make-primitive-procedure 'SETUP-TIMER-INTERRUPT true))) + (make-primitive-procedure 'SETUP-TIMER-INTERRUPT 2))) (named-lambda (timer-interrupt) (setup-timer-interrupt '() '()) (error "Unhandled Timer interrupt received")))) diff --git a/v7/src/runtime/syntax.scm b/v7/src/runtime/syntax.scm index 4a0f77717..617ebaab5 100644 --- a/v7/src/runtime/syntax.scm +++ b/v7/src/runtime/syntax.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 13.50 1987/07/07 20:27:14 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 13.51 1987/11/17 20:11:13 jinx Rel $ ;;; ;;; Copyright (c) 1987 Massachusetts Institute of Technology ;;; @@ -612,7 +612,7 @@ ;; ... ;; )) (let ((with-saved-fluid-bindings - (make-primitive-procedure 'WITH-SAVED-FLUID-BINDINGS true))) + (make-primitive-procedure 'WITH-SAVED-FLUID-BINDINGS 1))) (spread-arguments (lambda (bindings . body) (syntax-fluid-bindings bindings @@ -664,12 +664,12 @@ (syntax-error "Binding not a pair" binding))))))) (set! syntax-FLUID-LET-form-deep - (make-fluid-let (make-primitive-procedure 'ADD-FLUID-BINDING! true) + (make-fluid-let (make-primitive-procedure 'ADD-FLUID-BINDING! 3) lambda-tag:deep-fluid-let)) (set! syntax-FLUID-LET-form-common-lisp ;; This -- groan -- is for Common Lisp support - (make-fluid-let (make-primitive-procedure 'MAKE-FLUID-BINDING! true) + (make-fluid-let (make-primitive-procedure 'MAKE-FLUID-BINDING! 3) lambda-tag:common-lisp-fluid-let)) ;;; end special FLUID-LETs. diff --git a/v7/src/runtime/system.scm b/v7/src/runtime/system.scm index 33f5130fa..e2e1d2005 100644 --- a/v7/src/runtime/system.scm +++ b/v7/src/runtime/system.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/system.scm,v 13.50 1987/06/05 20:41:54 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/system.scm,v 13.51 1987/11/17 20:11:40 jinx Rel $ ;;; ;;; Copyright (c) 1987 Massachusetts Institute of Technology ;;; @@ -105,7 +105,7 @@ (set! dump-world (setup-image - (let ((primitive (make-primitive-procedure 'DUMP-WORLD true))) + (let ((primitive (make-primitive-procedure 'DUMP-WORLD 1))) (lambda (filename after-dumping after-restoring) (let ((ie (set-interrupt-enables! interrupt-mask-none))) ((if (primitive filename) diff --git a/v7/src/runtime/unpars.scm b/v7/src/runtime/unpars.scm index f5a93978f..a23d5b41b 100644 --- a/v7/src/runtime/unpars.scm +++ b/v7/src/runtime/unpars.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unpars.scm,v 13.52 1987/08/01 09:17:54 jinx Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unpars.scm,v 13.53 1987/11/17 20:11:54 jinx Rel $ ;;; ;;; Copyright (c) 1987 Massachusetts Institute of Technology ;;; @@ -319,7 +319,6 @@ (*unparse-object (primitive-procedure-name proc))))) (define-type 'PRIMITIVE unparse-primitive-procedure) -(define-type 'PRIMITIVE-EXTERNAL unparse-primitive-procedure) (define (unparse-compiled-procedure procedure) (unparse-with-brackets diff --git a/v7/src/runtime/unsyn.scm b/v7/src/runtime/unsyn.scm index 73657d2ba..1ebc1e0d1 100644 --- a/v7/src/runtime/unsyn.scm +++ b/v7/src/runtime/unsyn.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unsyn.scm,v 13.47 1987/06/02 13:24:17 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unsyn.scm,v 13.48 1987/11/17 20:12:08 jinx Rel $ ;;; ;;; Copyright (c) 1987 Massachusetts Institute of Technology ;;; @@ -405,11 +405,11 @@ (define unsyntax-deep-FLUID-LET (unsyntax-deep-or-common-FLUID-LET - 'FLUID-LET (make-primitive-procedure 'add-fluid-binding! true))) + 'FLUID-LET (make-primitive-procedure 'add-fluid-binding! 3))) (define unsyntax-common-lisp-FLUID-LET (unsyntax-deep-or-common-FLUID-LET - 'FLUID-BIND (make-primitive-procedure 'make-fluid-binding! true))) + 'FLUID-BIND (make-primitive-procedure 'make-fluid-binding! 3))) (define (unsyntax-MAKE-ENVIRONMENT names values body) `(MAKE-ENVIRONMENT ,@(except-last-pair (unsyntax-sequence body)))) diff --git a/v7/src/runtime/utabs.scm b/v7/src/runtime/utabs.scm index e41ddf3cb..e6511e1e7 100644 --- a/v7/src/runtime/utabs.scm +++ b/v7/src/runtime/utabs.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/utabs.scm,v 13.46 1987/04/29 15:41:59 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/utabs.scm,v 13.47 1987/11/17 20:12:41 jinx Rel $ ;;; ;;; Copyright (c) 1987 Massachusetts Institute of Technology ;;; @@ -63,8 +63,6 @@ (define microcode-termination) (define microcode-termination-name) -(define number-of-internal-primitive-procedures) -(define number-of-external-primitive-procedures) (define make-primitive-procedure) (define primitive-procedure?) (define primitive-procedure-name) @@ -84,16 +82,16 @@ (define :release) (let-syntax ((define-primitive - (macro (name) - `(DEFINE ,name ,(make-primitive-procedure name))))) - (define-primitive binary-fasload) - (define-primitive microcode-identify) - (define-primitive microcode-tables-filename) - (define-primitive map-machine-address-to-code) - (define-primitive map-code-to-machine-address) - (define-primitive get-external-counts) - (define-primitive get-external-number) - (define-primitive get-external-name)) + (macro (name arity) + `(DEFINE ,name ,(make-primitive-procedure name arity))))) + (define-primitive binary-fasload 1) + (define-primitive microcode-identify 0) + (define-primitive microcode-tables-filename 0) + (define-primitive map-machine-address-to-code 2) + (define-primitive map-code-to-machine-address 2) + (define-primitive get-primitive-address 2) + (define-primitive get-primitive-name 1) + (define-primitive get-primitive-counts 0)) ;;;; Fixed Objects Vector @@ -139,7 +137,6 @@ (EXTENDED-PROCEDURE . PROCEDURE) (COMPILED-PROCEDURE . PROCEDURE) (PRIMITIVE . PRIMITIVE-PROCEDURE) - (PRIMITIVE-EXTERNAL . PRIMITIVE-PROCEDURE) (LEXPR . LAMBDA) (EXTENDED-LAMBDA . LAMBDA) (COMBINATION-1 . COMBINATION) @@ -230,45 +227,56 @@ ;;;; Microcode Primitives -(define primitives-slot) (define primitive-type-code) -(define external-type-code) + +(define renamed-user-primitives + '((NOT . NULL?) + (FALSE? . NULL?) + (FIRST . CAR) + (FIRST-TAIL . CDR) + (SET-FIRST! . SET-CAR!) + (SET-FIRST-TAIL! . SET-CDR!) + (VECTOR-SIZE . VECTOR-LENGTH) + (STRING-SIZE . VECTOR-8B-SIZE) + (&OBJECT-REF . SYSTEM-MEMORY-REF) + (&OBJECT-SET! . SYSTEM-MEMORY-SET!))) (set! primitive-procedure? (named-lambda (primitive-procedure? object) - (or (primitive-type? primitive-type-code object) - (primitive-type? external-type-code object)))) + (primitive-type? primitive-type-code object))) (set! make-primitive-procedure -(named-lambda (make-primitive-procedure name #!optional force?) - (let ((code (name->code primitives-slot 'PRIMITIVE name))) - (if code - (map-code-to-machine-address primitive-type-code code) - (or (get-external-number name (if (unassigned? force?) #f force?)) - (error "MAKE-PRIMITIVE-PROCEDURE: Unknown name" name)))))) +(named-lambda (make-primitive-procedure name #!optional arity) + (if (unassigned? arity) + (set! arity false)) + (let* ((name (let ((place (assq name renamed-user-primitives))) + (if (not (null? place)) + (cdr place) + name))) + (result (get-primitive-address name arity))) + (cond ((or (primitive-type? primitive-type-code result) + (eq? arity true)) + result) + ((false? result) + (error "MAKE-PRIMITIVE-PROCEDURE: Unknown name" name)) + (else + (error "MAKE-PRIMITIVE-PROCEDURE: Inconsistent arity" + `(,name new: ,arity old: ,result))))))) (set! implemented-primitive-procedure? (named-lambda (implemented-primitive-procedure? object) - (cond ((primitive-type? primitive-type-code object) true) - ((primitive-type? external-type-code object) - (get-external-number (external-code->name (primitive-datum object)) - false)) - (else - (error "Not a primitive procedure" implemented-primitive-procedure? - object))))) + (if (primitive-type? primitive-type-code object) + (get-primitive-address (get-primitive-name (primitive-datum object)) + false) + (error "Not a primitive procedure" implemented-primitive-procedure? + object)))) (set! primitive-procedure-name (named-lambda (primitive-procedure-name primitive-procedure) - (cond ((primitive-type? primitive-type-code primitive-procedure) - (code->name primitives-slot - 'PRIMITIVE - (map-machine-address-to-code primitive-type-code - primitive-procedure))) - ((primitive-type? external-type-code primitive-procedure) - (external-code->name (primitive-datum primitive-procedure))) - (else - (error "Not a primitive procedure" primitive-procedure-name - primitive-procedure))))) + (if (primitive-type? primitive-type-code primitive-procedure) + (get-primitive-name (primitive-datum primitive-procedure)) + (error "Not a primitive procedure" primitive-procedure-name + primitive-procedure)))) (define (name->code slot type name) (or (and (pair? name) @@ -285,15 +293,6 @@ (or (and (not (negative? code)) (microcode-table-ref slot code)) (list type code))) - -(define (external-code->name code) - (let ((current-counts (get-external-counts))) - (cond ((< code (car current-counts)) (get-external-name code)) - ((< code (+ (car current-counts) (cdr current-counts))) - (get-external-name code)) ;Maybe should warn about undefined - (else - (error "Not an external procedure name" external-code->name - code))))) ;;;; Initialization @@ -321,15 +320,7 @@ (set! number-of-microcode-errors (vector-length (vector-ref fixed-objects errors-slot))) - (set! primitives-slot - (fixed-objects-vector-slot 'MICROCODE-PRIMITIVES-VECTOR)) (set! primitive-type-code (microcode-type 'PRIMITIVE)) - (set! number-of-internal-primitive-procedures - (vector-length (vector-ref fixed-objects primitives-slot))) - (set! number-of-external-primitive-procedures - (car (get-external-counts))) - - (set! external-type-code (microcode-type 'PRIMITIVE-EXTERNAL)) (set! termination-vector-slot (fixed-objects-vector-slot 'MICROCODE-TERMINATIONS-VECTOR)) @@ -344,7 +335,7 @@ ;; Predicate to test if object is a future without touching it. (set! future? - (let ((primitive (make-primitive-procedure 'FUTURE? true))) + (let ((primitive (make-primitive-procedure 'FUTURE? 1))) (if (implemented-primitive-procedure? primitive) primitive (lambda (object) false)))))