merged.
;;; -*-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
;;;
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?)
;;; -*-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
;;;
(integrate-primitive-procedures set-fixed-objects-vector!))
\f
(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
(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))
(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
\f
;;;; 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.
"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)
\f
;;; -*-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
;;;
(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"))))
;;; -*-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
;;;
;; ...
;; <body>))
(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
(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.
;;; -*-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
;;;
(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)
;;; -*-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
;;;
(*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
;;; -*-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
;;;
(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))))
;;; -*-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
;;;
(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)
(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))
\f
;;;; Fixed Objects Vector
(EXTENDED-PROCEDURE . PROCEDURE)
(COMPILED-PROCEDURE . PROCEDURE)
(PRIMITIVE . PRIMITIVE-PROCEDURE)
- (PRIMITIVE-EXTERNAL . PRIMITIVE-PROCEDURE)
(LEXPR . LAMBDA)
(EXTENDED-LAMBDA . LAMBDA)
(COMBINATION-1 . COMBINATION)
\f
;;;; 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))))
\f
(define (name->code slot type name)
(or (and (pair? name)
(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)))))
\f
;;;; Initialization
(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))
;; 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)))))
projects / mit-scheme.git / commitdiff