From 2f27ebed88f465af32faa8312ea927f90cb1bf34 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 20 May 1988 01:06:12 +0000 Subject: [PATCH] *** empty log message *** --- v7/src/runtime/boole.scm | 73 +++++ v7/src/runtime/chrset.scm | 150 +++++++++++ v7/src/runtime/codwlk.scm | 212 +++++++++++++++ v7/src/runtime/conpar.scm | 489 ++++++++++++++++++++++++++++++++++ v7/src/runtime/contin.scm | 138 ++++++++++ v7/src/runtime/cpoint.scm | 127 +++++++++ v7/src/runtime/dbgcmd.scm | 130 +++++++++ v7/src/runtime/dbgutl.scm | 113 ++++++++ v7/src/runtime/framex.scm | 236 +++++++++++++++++ v7/src/runtime/gcdemn.scm | 71 +++++ v7/src/runtime/gcnote.scm | 73 +++++ v7/src/runtime/gdatab.scm | 80 ++++++ v7/src/runtime/global.scm | 280 ++++++++++++++++++++ v7/src/runtime/lambdx.scm | 82 ++++++ v7/src/runtime/load.scm | 160 +++++++++++ v7/src/runtime/make.scm | 324 +++++++++++++++++++++++ v7/src/runtime/partab.scm | 116 ++++++++ v7/src/runtime/poplat.scm | 150 +++++++++++ v7/src/runtime/prop1d.scm | 121 +++++++++ v7/src/runtime/prop2d.scm | 127 +++++++++ v7/src/runtime/queue.scm | 93 +++++++ v7/src/runtime/random.scm | 64 +++++ v7/src/runtime/savres.scm | 143 ++++++++++ v7/src/runtime/strnin.scm | 126 +++++++++ v7/src/runtime/strott.scm | 89 +++++++ v7/src/runtime/strout.scm | 64 +++++ v7/src/runtime/syntab.scm | 82 ++++++ v7/src/runtime/sysmac.scm | 129 +++++++++ v7/src/runtime/udata.scm | 308 ++++++++++++++++++++++ v7/src/runtime/uenvir.scm | 141 ++++++++++ v7/src/runtime/uerror.scm | 541 ++++++++++++++++++++++++++++++++++++++ v7/src/runtime/urtrap.scm | 114 ++++++++ v8/src/runtime/conpar.scm | 489 ++++++++++++++++++++++++++++++++++ v8/src/runtime/dbgutl.scm | 113 ++++++++ v8/src/runtime/framex.scm | 236 +++++++++++++++++ v8/src/runtime/global.scm | 280 ++++++++++++++++++++ v8/src/runtime/load.scm | 160 +++++++++++ v8/src/runtime/make.scm | 324 +++++++++++++++++++++++ v8/src/runtime/uenvir.scm | 141 ++++++++++ 39 files changed, 6889 insertions(+) create mode 100644 v7/src/runtime/boole.scm create mode 100644 v7/src/runtime/chrset.scm create mode 100644 v7/src/runtime/codwlk.scm create mode 100644 v7/src/runtime/conpar.scm create mode 100644 v7/src/runtime/contin.scm create mode 100644 v7/src/runtime/cpoint.scm create mode 100644 v7/src/runtime/dbgcmd.scm create mode 100644 v7/src/runtime/dbgutl.scm create mode 100644 v7/src/runtime/framex.scm create mode 100644 v7/src/runtime/gcdemn.scm create mode 100644 v7/src/runtime/gcnote.scm create mode 100644 v7/src/runtime/gdatab.scm create mode 100644 v7/src/runtime/global.scm create mode 100644 v7/src/runtime/lambdx.scm create mode 100644 v7/src/runtime/load.scm create mode 100644 v7/src/runtime/make.scm create mode 100644 v7/src/runtime/partab.scm create mode 100644 v7/src/runtime/poplat.scm create mode 100644 v7/src/runtime/prop1d.scm create mode 100644 v7/src/runtime/prop2d.scm create mode 100644 v7/src/runtime/queue.scm create mode 100644 v7/src/runtime/random.scm create mode 100644 v7/src/runtime/savres.scm create mode 100644 v7/src/runtime/strnin.scm create mode 100644 v7/src/runtime/strott.scm create mode 100644 v7/src/runtime/strout.scm create mode 100644 v7/src/runtime/syntab.scm create mode 100644 v7/src/runtime/sysmac.scm create mode 100644 v7/src/runtime/udata.scm create mode 100644 v7/src/runtime/uenvir.scm create mode 100644 v7/src/runtime/uerror.scm create mode 100644 v7/src/runtime/urtrap.scm create mode 100644 v8/src/runtime/conpar.scm create mode 100644 v8/src/runtime/dbgutl.scm create mode 100644 v8/src/runtime/framex.scm create mode 100644 v8/src/runtime/global.scm create mode 100644 v8/src/runtime/load.scm create mode 100644 v8/src/runtime/make.scm create mode 100644 v8/src/runtime/uenvir.scm diff --git a/v7/src/runtime/boole.scm b/v7/src/runtime/boole.scm new file mode 100644 index 000000000..225d811e6 --- /dev/null +++ b/v7/src/runtime/boole.scm @@ -0,0 +1,73 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/boole.scm,v 14.1 1988/05/20 00:51:46 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Boolean Operations + +(declare (usual-integrations)) + +(define-primitives not (false? not)) + +(define false #F) +(define true #T) + +(define (boolean? object) + (or (eq? object #F) + (eq? object #T))) + +(define (boolean=? x y) + (if x y (not y))) + +(define (boolean/or . arguments) + (let loop ((arguments arguments)) + (cond ((null? arguments) false) + ((car arguments) true) + (else (loop (cdr arguments)))))) + +(define (boolean/and . arguments) + (let loop ((arguments arguments)) + (cond ((null? arguments) true) + ((car arguments) (loop (cdr arguments))) + (else false)))) + +(define (there-exists? items predicate) + (let loop ((items items)) + (and (not (null? items)) + (or (predicate (car items)) + (loop (cdr items)))))) + +(define (for-all? items predicate) + (let loop ((items items)) + (or (null? items) + (and (predicate (car items)) + (loop (cdr items)))))) \ No newline at end of file diff --git a/v7/src/runtime/chrset.scm b/v7/src/runtime/chrset.scm new file mode 100644 index 000000000..2abe91ac2 --- /dev/null +++ b/v7/src/runtime/chrset.scm @@ -0,0 +1,150 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/chrset.scm,v 14.1 1988/05/20 00:53:47 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Character Sets + +(declare (usual-integrations)) + +(define (char-set? object) + (and (string? object) (= (string-length object) 256))) + +(define (char-set . chars) + (chars->char-set chars)) + +(define (chars->char-set chars) + (let ((char-set (string-allocate 256))) + (vector-8b-fill! char-set 0 256 0) + (for-each (lambda (char) (vector-8b-set! char-set (char->ascii char) 1)) + chars) + char-set)) + +(define (ascii-range->char-set lower upper) + (let ((char-set (string-allocate 256))) + (vector-8b-fill! char-set 0 lower 0) + (vector-8b-fill! char-set lower upper 1) + (vector-8b-fill! char-set upper 256 0) + char-set)) + +(define (predicate->char-set predicate) + (let ((char-set (string-allocate 256))) + (let loop ((code 0)) + (if (< code 256) + (begin (vector-8b-set! char-set code + (if (predicate (ascii->char code)) 1 0)) + (loop (1+ code))))) + char-set)) + +(define (char-set-members char-set) + (define (loop code) + (cond ((>= code 256) '()) + ((zero? (vector-8b-ref char-set code)) (loop (1+ code))) + (else (cons (ascii->char code) (loop (1+ code)))))) + (loop 0)) + +(define (char-set-member? char-set char) + (let ((ascii (char-ascii? char))) + (and ascii (not (zero? (vector-8b-ref char-set ascii)))))) + +(define (char-set-invert char-set) + (predicate->char-set + (lambda (char) (not (char-set-member? char-set char))))) + +(define (char-set-union char-set-1 char-set-2) + (predicate->char-set + (lambda (char) + (or (char-set-member? char-set-1 char) + (char-set-member? char-set-2 char))))) + +(define (char-set-intersection char-set-1 char-set-2) + (predicate->char-set + (lambda (char) + (and (char-set-member? char-set-1 char) + (char-set-member? char-set-2 char))))) + +(define (char-set-difference char-set-1 char-set-2) + (predicate->char-set + (lambda (char) + (and (char-set-member? char-set-1 char) + (not (char-set-member? char-set-2 char)))))) + +;;;; System Character Sets + +(define char-set:upper-case) +(define char-set:lower-case) +(define char-set:numeric) +(define char-set:graphic) +(define char-set:whitespace) +(define char-set:not-whitespace) +(define char-set:alphabetic) +(define char-set:alphanumeric) +(define char-set:standard) + +(define (initialize-package!) + (set! char-set:upper-case (ascii-range->char-set #x41 #x5B)) + (set! char-set:lower-case (ascii-range->char-set #x61 #x7B)) + (set! char-set:numeric (ascii-range->char-set #x30 #x3A)) + (set! char-set:graphic (ascii-range->char-set #x20 #x7F)) + (set! char-set:whitespace + (char-set char:newline #\Tab #\Linefeed #\Page #\Return #\Space)) + (set! char-set:not-whitespace (char-set-invert char-set:whitespace)) + (set! char-set:alphabetic + (char-set-union char-set:upper-case char-set:lower-case)) + (set! char-set:alphanumeric + (char-set-union char-set:alphabetic char-set:numeric)) + (set! char-set:standard + (char-set-union char-set:graphic (char-set char:newline)))) + +(define-integrable (char-upper-case? char) + (char-set-member? char-set:upper-case char)) + +(define-integrable (char-lower-case? char) + (char-set-member? char-set:lower-case char)) + +(define-integrable (char-numeric? char) + (char-set-member? char-set:numeric char)) + +(define-integrable (char-graphic? char) + (char-set-member? char-set:graphic char)) + +(define-integrable (char-whitespace? char) + (char-set-member? char-set:whitespace char)) + +(define-integrable (char-alphabetic? char) + (char-set-member? char-set:alphabetic char)) + +(define-integrable (char-alphanumeric? char) + (char-set-member? char-set:alphanumeric char)) + +(define-integrable (char-standard? char) + (char-set-member? char-set:standard char)) \ No newline at end of file diff --git a/v7/src/runtime/codwlk.scm b/v7/src/runtime/codwlk.scm new file mode 100644 index 000000000..f30f5c65e --- /dev/null +++ b/v7/src/runtime/codwlk.scm @@ -0,0 +1,212 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/codwlk.scm,v 14.1 1988/05/20 00:54:04 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; SCode Walker +;;; scode-walker-package + +(declare (usual-integrations)) + +(define-structure (scode-walker (constructor %make-scode-walker) + (conc-name scode-walker/)) + (access false read-only true) + (assignment false read-only true) + (combination false read-only true) + (comment false read-only true) + (conditional false read-only true) + (constant false read-only true) + (declaration false read-only true) + (definition false read-only true) + (delay false read-only true) + (disjunction false read-only true) + (error-combination false read-only true) + (in-package false read-only true) + (lambda false read-only true) + (open-block false read-only true) + (quotation false read-only true) + (sequence false read-only true) + (the-environment false read-only true) + (unassigned? false read-only true) + (variable false read-only true)) + +(define (make-scode-walker default alist) + (let ((alist + (map (lambda (entry) + (cons (car entry) (cadr entry))) + alist))) + (let ((result + (let ((lookup + (lambda (name default) + (let ((entry (assq name alist))) + (if entry + (begin (set! alist (delq! entry alist)) + (cdr entry)) + default))))) + (let ((comment-handler (lookup 'COMMENT default)) + (combination-handler (lookup 'COMBINATION default)) + (sequence-handler (lookup 'SEQUENCE default))) + (%make-scode-walker (lookup 'ACCESS default) + (lookup 'ASSIGNMENT default) + combination-handler + comment-handler + (lookup 'CONDITIONAL default) + default + (lookup 'DECLARATION comment-handler) + (lookup 'DEFINITION default) + (lookup 'DELAY default) + (lookup 'DISJUNCTION default) + (lookup 'ERROR-COMBINATION + combination-handler) + (lookup 'IN-PACKAGE default) + (lookup 'LAMBDA default) + (lookup 'OPEN-BLOCK sequence-handler) + (lookup 'QUOTATION default) + sequence-handler + (lookup 'THE-ENVIRONMENT default) + (lookup 'UNASSIGNED? combination-handler) + (lookup 'VARIABLE default)))))) + (if (not (null? alist)) + (error "MAKE-SCODE-WALKER: Unrecognized alist items" alist)) + result))) + +(define (scode-walk walker expression) + ((vector-ref dispatch-vector (object-type expression)) walker expression)) + +(define dispatch-vector) + +(define (initialize-package!) + (set! dispatch-vector + (let ((table (make-vector (microcode-type/code-limit) walk/constant))) + (for-each (lambda (entry) + (let ((kernel + (lambda (name) + (vector-set! table + (microcode-type name) + (cadr entry))))) + (if (pair? (car entry)) + (for-each kernel (car entry)) + (kernel (car entry))))) + `((ACCESS ,walk/access) + (ASSIGNMENT ,walk/assignment) + ((COMBINATION + COMBINATION-1 + COMBINATION-2 + PRIMITIVE-COMBINATION-0 + PRIMITIVE-COMBINATION-1 + PRIMITIVE-COMBINATION-2 + PRIMITIVE-COMBINATION-3) + ,walk/combination) + (COMMENT ,walk/comment) + (CONDITIONAL ,walk/conditional) + (DEFINITION ,walk/definition) + (DELAY ,walk/delay) + (DISJUNCTION ,walk/disjunction) + (IN-PACKAGE ,walk/in-package) + ((LAMBDA LEXPR EXTENDED-LAMBDA) ,walk/lambda) + (QUOTATION ,walk/quotation) + ((SEQUENCE-2 SEQUENCE-3) ,walk/sequence) + (THE-ENVIRONMENT ,walk/the-environment) + (VARIABLE ,walk/variable))) + table))) + +(define (walk/combination walker expression) + (let ((operator (combination-operator expression))) + (cond ((and (or (eq? operator (ucode-primitive lexical-unassigned?)) + (absolute-reference-to? operator 'LEXICAL-UNASSIGNED?)) + (let ((operands (combination-operands expression))) + (and (the-environment? (car operands)) + (symbol? (cadr operands))))) + (scode-walker/unassigned? walker)) + ((or (eq? operator (ucode-primitive error-procedure)) + (absolute-reference-to? operator 'ERROR-PROCEDURE)) + (scode-walker/error-combination walker)) + (else + (scode-walker/combination walker))))) + +(define (walk/comment walker expression) + (if (declaration? expression) + (scode-walker/declaration walker) + (scode-walker/comment walker))) + +(define (walk/sequence walker expression) + (if (open-block? expression) + (scode-walker/open-block walker) + (scode-walker/sequence walker))) + +(define (walk/access walker expression) + expression + (scode-walker/access walker)) + +(define (walk/assignment walker expression) + expression + (scode-walker/assignment walker)) + +(define (walk/conditional walker expression) + expression + (scode-walker/conditional walker)) + +(define (walk/constant walker expression) + expression + (scode-walker/constant walker)) + +(define (walk/definition walker expression) + expression + (scode-walker/definition walker)) + +(define (walk/delay walker expression) + expression + (scode-walker/delay walker)) + +(define (walk/disjunction walker expression) + expression + (scode-walker/disjunction walker)) + +(define (walk/in-package walker expression) + expression + (scode-walker/in-package walker)) + +(define (walk/lambda walker expression) + expression + (scode-walker/lambda walker)) + +(define (walk/quotation walker expression) + expression + (scode-walker/quotation walker)) + +(define (walk/the-environment walker expression) + expression + (scode-walker/the-environment walker)) + +(define (walk/variable walker expression) + expression + (scode-walker/variable walker)) \ No newline at end of file diff --git a/v7/src/runtime/conpar.scm b/v7/src/runtime/conpar.scm new file mode 100644 index 000000000..60ed0f09b --- /dev/null +++ b/v7/src/runtime/conpar.scm @@ -0,0 +1,489 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/conpar.scm,v 14.1 1988/05/20 00:54:26 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Continuation Parser +;;; package: continuation-parser-package + +(declare (usual-integrations)) + +;;;; Stack Frames + +(define-structure (stack-frame + (constructor make-stack-frame + (type elements dynamic-state fluid-bindings + interrupt-mask history + previous-history-offset + previous-history-control-point %next)) + (conc-name stack-frame/)) + (type false read-only true) + (elements false read-only true) + (dynamic-state false read-only true) + (fluid-bindings false read-only true) + (interrupt-mask false read-only true) + (history false read-only true) + (previous-history-offset false read-only true) + (previous-history-control-point false read-only true) + ;; %NEXT is either a parser-state object or the next frame. In the + ;; former case, the parser-state is used to compute the next frame. + %next + (properties (make-1d-table) read-only true)) + +(define (stack-frame/reductions stack-frame) + (let ((history (stack-frame/history stack-frame))) + (if (eq? history undefined-history) + '() + (history-reductions history)))) + +(define undefined-history + "no history") + +(define (stack-frame/next stack-frame) + (let ((next (stack-frame/%next stack-frame))) + (if (parser-state? next) + (let ((next (parse/start next))) + (set-stack-frame/%next! stack-frame next) + next) + next))) + +(define-integrable (continuation/first-subproblem continuation) + (stack-frame/skip-non-subproblems (continuation->stack-frame continuation))) + +(define (stack-frame/next-subproblem stack-frame) + (if (stack-frame/subproblem? stack-frame) + (let ((stack-frame (stack-frame/next stack-frame))) + (and stack-frame + (stack-frame/skip-non-subproblems stack-frame))) + (stack-frame/skip-non-subproblems stack-frame))) + +(define (stack-frame/skip-non-subproblems stack-frame) + (if (stack-frame/subproblem? stack-frame) + stack-frame + (let ((stack-frame (stack-frame/next stack-frame))) + (and stack-frame + (stack-frame/skip-non-subproblems stack-frame))))) + +(define-integrable (stack-frame/length stack-frame) + (vector-length (stack-frame/elements stack-frame))) + +(define (stack-frame/ref stack-frame index) + (map-reference-trap + (let ((elements (stack-frame/elements stack-frame))) + (lambda () + (vector-ref elements index))))) +(define-integrable (stack-frame/return-code stack-frame) + (stack-frame-type/code (stack-frame/type stack-frame))) + +(define-integrable (stack-frame/subproblem? stack-frame) + (stack-frame-type/subproblem? (stack-frame/type stack-frame))) + +;;;; Parser + +(define-structure (parser-state (constructor make-parser-state) + (conc-name parser-state/)) + (dynamic-state false read-only true) + (fluid-bindings false read-only true) + (interrupt-mask false read-only true) + (history false read-only true) + (previous-history-offset false read-only true) + (previous-history-control-point false read-only true) + (element-stream false read-only true) + (next-control-point false read-only true)) + +(define (continuation->stack-frame continuation) + (parse/control-point (continuation/control-point continuation) + (continuation/dynamic-state continuation) + (continuation/fluid-bindings continuation))) + +(define (parse/control-point control-point dynamic-state fluid-bindings) + (and control-point + (parse/start + (make-parser-state + dynamic-state + fluid-bindings + (control-point/interrupt-mask control-point) + (history-transform (control-point/history control-point)) + (control-point/previous-history-offset control-point) + (control-point/previous-history-control-point control-point) + (control-point/element-stream control-point) + (control-point/next-control-point control-point))))) + +(define (parse/start state) + (let ((stream (parser-state/element-stream state))) + (if (stream-pair? stream) + (let ((type (parse/type stream)) + (stream (stream-cdr stream))) + (let ((length (parse/length stream type))) + (with-values (lambda () (parse/elements stream length)) + (lambda (elements stream) + (parse/dispatch type + elements + (parse/next-state state length stream)))))) + (parse/control-point (parser-state/next-control-point state) + (parser-state/dynamic-state state) + (parser-state/fluid-bindings state))))) + +(define (parse/type stream) + (let ((return-address (element-stream/head stream))) + (if (not (return-address? return-address)) + (error "illegal return address" return-address)) + (let ((code (return-address/code return-address))) + (if (>= code (vector-length stack-frame-types)) + (error "return-code too large" code)) + (let ((type (vector-ref stack-frame-types code))) + (if (not type) + (error "return-code has no type" code)) + type)))) + +(define (parse/length stream type) + (let ((length (stack-frame-type/length type))) + (if (integer? length) + length + (length stream)))) + +(define (parse/elements stream length) + (let ((elements (make-vector length))) + (let loop ((stream stream) (index 0)) + (if (< index length) + (begin (if (not (stream-pair? stream)) + (error "stack too short" index)) + (vector-set! elements index (stream-car stream)) + (loop (stream-cdr stream) (1+ index))) + (values elements stream))))) + +(define (parse/dispatch type elements state) + ((stack-frame-type/parser type) type elements state)) + +(define (parse/next-state state length stream) + (let ((previous-history-control-point + (parser-state/previous-history-control-point state))) + (make-parser-state + (parser-state/dynamic-state state) + (parser-state/fluid-bindings state) + (parser-state/interrupt-mask state) + (parser-state/history state) + (if previous-history-control-point + (parser-state/previous-history-offset state) + (max (- (parser-state/previous-history-offset state) length) 0)) + previous-history-control-point + stream + (parser-state/next-control-point state)))) + +(define (make-frame type elements state element-stream) + (let ((subproblem? (stack-frame-type/subproblem? type)) + (history (parser-state/history state)) + (previous-history-offset (parser-state/previous-history-offset state)) + (previous-history-control-point + (parser-state/previous-history-control-point state))) + (make-stack-frame type + elements + (parser-state/dynamic-state state) + (parser-state/fluid-bindings state) + (parser-state/interrupt-mask state) + (if subproblem? history undefined-history) + previous-history-offset + previous-history-control-point + (make-parser-state + (parser-state/dynamic-state state) + (parser-state/fluid-bindings state) + (parser-state/interrupt-mask state) + (if subproblem? (history-superproblem history) history) + previous-history-offset + previous-history-control-point + element-stream + (parser-state/next-control-point state))))) + +(define (element-stream/head stream) + (if (not (stream-pair? stream)) (error "not a stream-pair" stream)) + (map-reference-trap (lambda () (stream-car stream)))) + +(define (element-stream/ref stream index) + (if (not (stream-pair? stream)) (error "not a stream-pair" stream)) + (if (zero? index) + (map-reference-trap (lambda () (stream-car stream))) + (element-stream/ref (stream-cdr stream) (-1+ index)))) + +;;;; Unparser + +(define (stack-frame->continuation stack-frame) + (make-continuation 'REENTRANT + (stack-frame->control-point stack-frame) + (stack-frame/dynamic-state stack-frame) + (stack-frame/fluid-bindings stack-frame))) + +(define (stack-frame->control-point stack-frame) + (with-values (lambda () (unparse/stack-frame stack-frame)) + (lambda (element-stream next-control-point) + (make-control-point + false + 0 + (stack-frame/interrupt-mask stack-frame) + (history-untransform (stack-frame/history stack-frame)) + (stack-frame/previous-history-offset stack-frame) + (stack-frame/previous-history-control-point stack-frame) + element-stream + next-control-point)))) + +(define (unparse/stack-frame stack-frame) + (let ((next (stack-frame/%next stack-frame))) + (cond ((stack-frame? next) + (with-values (lambda () (unparse/stack-frame next)) + (lambda (element-stream next-control-point) + (values (let ((type (stack-frame/type stack-frame))) + ((stack-frame-type/unparser type) + type + (stack-frame/elements stack-frame) + element-stream)) + next-control-point)))) + ((parser-state? next) + (values (parser-state/element-stream next) + (parser-state/next-control-point next))) + (else (values (stream) false))))) + +;;;; Generic Parsers/Unparsers + +(define (parser/interpreter-next type elements state) + (make-frame type elements state (parser-state/element-stream state))) + +(define (unparser/interpreter-next type elements element-stream) + (cons-stream (make-return-address (stack-frame-type/code type)) + (let ((length (vector-length elements))) + (let loop ((index 0)) + (if (< index length) + (cons-stream (vector-ref elements index) + (loop (1+ index))) + element-stream))))) + +(define (parser/compiler-next type elements state) + (make-frame type elements state + (cons-stream + (ucode-return-address reenter-compiled-code) + (cons-stream + (- (vector-ref elements 0) (vector-length elements)) + (parser-state/element-stream state))))) + +(define (unparser/compiler-next type elements element-stream) + (unparser/interpreter-next type elements (stream-tail element-stream 2))) + +(define (make-restore-frame type + elements + state + dynamic-state + fluid-bindings + interrupt-mask + history + previous-history-offset + previous-history-control-point) + (parser/interpreter-next + type + elements + (make-parser-state dynamic-state + fluid-bindings + interrupt-mask + history + previous-history-offset + previous-history-control-point + (parser-state/element-stream state) + (parser-state/next-control-point state)))) + +;;;; Specific Parsers + +(define (parser/restore-dynamic-state type elements state) + (make-restore-frame type elements state + (vector-ref elements 0) + (parser-state/fluid-bindings state) + (parser-state/interrupt-mask state) + (parser-state/history state) + (parser-state/previous-history-offset state) + (parser-state/previous-history-control-point state))) + +(define (parser/restore-fluid-bindings type elements state) + (make-restore-frame type elements state + (parser-state/dynamic-state state) + (vector-ref elements 0) + (parser-state/interrupt-mask state) + (parser-state/history state) + (parser-state/previous-history-offset state) + (parser-state/previous-history-control-point state))) + +(define (parser/restore-interrupt-mask type elements state) + (make-restore-frame type elements state + (parser-state/dynamic-state state) + (parser-state/fluid-bindings state) + (vector-ref elements 0) + (parser-state/history state) + (parser-state/previous-history-offset state) + (parser-state/previous-history-control-point state))) + +(define (parser/restore-history type elements state) + (make-restore-frame type elements state + (parser-state/dynamic-state state) + (parser-state/fluid-bindings state) + (parser-state/interrupt-mask state) + (history-transform (vector-ref elements 0)) + (vector-ref elements 1) + (vector-ref elements 2))) + +(define (length/combination-save-value stream) + (+ 2 (system-vector-length (element-stream/head stream)))) + +(define ((length/application-frame index missing) stream) + (+ index 1 (- (object-datum (element-stream/ref stream index)) missing))) + +(define (length/repeat-primitive stream) + (-1+ (primitive-procedure-arity (element-stream/head stream)))) + +(define (length/reenter-compiled-code stream) + (1+ (element-stream/head stream))) + +;;;; Stack Frame Types + +(define-structure (stack-frame-type + (constructor make-stack-frame-type + (code subproblem? length parser unparser)) + (conc-name stack-frame-type/)) + (code false read-only true) + (subproblem? false read-only true) + (properties (make-1d-table) read-only true) + (length false read-only true) + (parser false read-only true) + (unparser false read-only true)) + +(define (initialize-package!) + (set! stack-frame-types (make-stack-frame-types))) + +(define stack-frame-types) + +(define (make-stack-frame-types) + (let ((types (make-vector (microcode-return/code-limit) false))) + + (define (stack-frame-type name subproblem? length parser unparser) + (let ((code (microcode-return name))) + (vector-set! types + code + (make-stack-frame-type code subproblem? length parser + unparser)))) + + (define (interpreter-frame name length #!optional parser) + (stack-frame-type name false length + (if (default-object? parser) + parser/interpreter-next + parser) + unparser/interpreter-next)) + + (define (compiler-frame name length #!optional parser) + (stack-frame-type name false length + (if (default-object? parser) + parser/compiler-next + parser) + unparser/compiler-next)) + + (define (interpreter-subproblem name length) + (stack-frame-type name true length parser/interpreter-next + unparser/interpreter-next)) + + (define (compiler-subproblem name length) + (stack-frame-type name true length parser/compiler-next + unparser/compiler-next)) + + (interpreter-frame 'RESTORE-TO-STATE-POINT 1 parser/restore-dynamic-state) + (interpreter-frame 'RESTORE-FLUIDS 1 parser/restore-fluid-bindings) + (interpreter-frame 'RESTORE-INTERRUPT-MASK 1 parser/restore-interrupt-mask) + (interpreter-frame 'RESTORE-HISTORY 3 parser/restore-history) + (interpreter-frame 'RESTORE-DONT-COPY-HISTORY 3 parser/restore-history) + + (interpreter-frame 'NON-EXISTENT-CONTINUATION 1) + (interpreter-frame 'HALT 1) + (interpreter-frame 'JOIN-STACKLETS 1) + (interpreter-frame 'POP-RETURN-ERROR 1) + + (interpreter-subproblem 'IN-PACKAGE-CONTINUE 1) + (interpreter-subproblem 'ACCESS-CONTINUE 1) + (interpreter-subproblem 'PRIMITIVE-COMBINATION-1-APPLY 1) + (interpreter-subproblem 'FORCE-SNAP-THUNK 1) + (interpreter-subproblem 'GC-CHECK 1) + (interpreter-subproblem 'RESTORE-VALUE 1) + (interpreter-subproblem 'ASSIGNMENT-CONTINUE 2) + (interpreter-subproblem 'DEFINITION-CONTINUE 2) + (interpreter-subproblem 'SEQUENCE-2-SECOND 2) + (interpreter-subproblem 'SEQUENCE-3-SECOND 2) + (interpreter-subproblem 'SEQUENCE-3-THIRD 2) + (interpreter-subproblem 'CONDITIONAL-DECIDE 2) + (interpreter-subproblem 'DISJUNCTION-DECIDE 2) + (interpreter-subproblem 'COMBINATION-1-PROCEDURE 2) + (interpreter-subproblem 'COMBINATION-2-FIRST-OPERAND 2) + (interpreter-subproblem 'EVAL-ERROR 2) + (interpreter-subproblem 'PRIMITIVE-COMBINATION-2-FIRST-OPERAND 2) + (interpreter-subproblem 'PRIMITIVE-COMBINATION-2-APPLY 2) + (interpreter-subproblem 'PRIMITIVE-COMBINATION-3-SECOND-OPERAND 2) + (interpreter-subproblem 'COMBINATION-2-PROCEDURE 3) + (interpreter-subproblem 'REPEAT-DISPATCH 3) + (interpreter-subproblem 'PRIMITIVE-COMBINATION-3-FIRST-OPERAND 3) + (interpreter-subproblem 'PRIMITIVE-COMBINATION-3-APPLY 3) + (interpreter-subproblem 'MOVE-TO-ADJACENT-POINT 5) + + (interpreter-subproblem 'COMBINATION-SAVE-VALUE + length/combination-save-value) + + (interpreter-subproblem 'REPEAT-PRIMITIVE length/repeat-primitive) + + (let ((length (length/application-frame 1 0))) + (interpreter-subproblem 'COMBINATION-APPLY length) + (interpreter-subproblem 'INTERNAL-APPLY length)) + + (interpreter-subproblem 'REENTER-COMPILED-CODE + length/reenter-compiled-code) + + (compiler-frame 'COMPILER-INTERRUPT-RESTART 2) + (compiler-frame 'COMPILER-LINK-CACHES-RESTART 7) + + (compiler-subproblem 'COMPILER-REFERENCE-RESTART 3) + (compiler-subproblem 'COMPILER-SAFE-REFERENCE-RESTART 3) + (compiler-subproblem 'COMPILER-ACCESS-RESTART 3) + (compiler-subproblem 'COMPILER-UNASSIGNED?-RESTART 3) + (compiler-subproblem 'COMPILER-UNBOUND?-RESTART 3) + (compiler-subproblem 'COMPILER-REFERENCE-TRAP-RESTART 3) + (compiler-subproblem 'COMPILER-SAFE-REFERENCE-TRAP-RESTART 3) + (compiler-subproblem 'COMPILER-UNASSIGNED?-TRAP-RESTART 3) + (compiler-subproblem 'COMPILER-ASSIGNMENT-RESTART 4) + (compiler-subproblem 'COMPILER-DEFINITION-RESTART 4) + (compiler-subproblem 'COMPILER-ASSIGNMENT-TRAP-RESTART 4) + + (compiler-subproblem 'COMPILER-LOOKUP-APPLY-RESTART + (length/application-frame 3 1)) + + (let ((length (length/application-frame 3 0))) + (compiler-subproblem 'COMPILER-LOOKUP-APPLY-TRAP-RESTART length) + (compiler-subproblem 'COMPILER-OPERATOR-LOOKUP-TRAP-RESTART length)) + + types)) \ No newline at end of file diff --git a/v7/src/runtime/contin.scm b/v7/src/runtime/contin.scm new file mode 100644 index 000000000..1079e6fa9 --- /dev/null +++ b/v7/src/runtime/contin.scm @@ -0,0 +1,138 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/contin.scm,v 14.1 1988/05/20 00:54:50 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Continuations +;;; package: continuation-package + +(declare (usual-integrations)) + +(define (call-with-current-continuation receiver) + (call/cc (ucode-primitive call-with-current-continuation) + 'REENTRANT + receiver)) + +(define (non-reentrant-call-with-current-continuation receiver) + (call/cc (ucode-primitive non-reentrant-call-with-current-continuation) + 'UNUSED + receiver)) + +(define (call/cc primitive type receiver) + (primitive + (lambda (control-point) + (let ((continuation + (make-continuation type + control-point + (current-dynamic-state) + (get-fluid-bindings)))) + (continuation (receiver continuation)))))) + +(define (within-continuation continuation thunk) + (guarantee-continuation continuation) + (let ((dynamic-state (current-dynamic-state)) + (fluid-bindings (get-fluid-bindings))) + (translate-to-state-point (continuation/dynamic-state continuation)) + (set-fluid-bindings! (continuation/fluid-bindings continuation)) + (let ((value + ((ucode-primitive within-control-point 2) + (continuation/control-point continuation) + thunk))) + (translate-to-state-point dynamic-state) + (set-fluid-bindings! fluid-bindings) + value))) + +(define (invocation-method/reentrant continuation value) + (translate-to-state-point (continuation/dynamic-state continuation)) + (set-fluid-bindings! (continuation/fluid-bindings continuation)) + ((continuation/control-point continuation) value)) + +(define (invocation-method/unused continuation value) + (if (eq? (without-interrupts + (lambda () + (let ((method (continuation/invocation-method continuation))) + (set-continuation/invocation-method! continuation + invocation-method/used) + method))) + invocation-method/unused) + (invocation-method/reentrant continuation value) + (invocation-method/used continuation value))) + +(define (invocation-method/used continuation value) + value + (error "Reentering used continuation" continuation)) + +(define (make-continuation type control-point dynamic-state fluid-bindings) + (system-pair-cons + (ucode-type entity) + (case type + ((REENTRANT) invocation-method/reentrant) + ((UNUSED) invocation-method/unused) + ((USED) invocation-method/used) + (else (error "Illegal continuation type" type))) + (make-%continuation control-point dynamic-state fluid-bindings))) + +(define (continuation/type continuation) + (let ((invocation-method (continuation/invocation-method continuation))) + (cond ((eq? invocation-method invocation-method/reentrant) 'REENTRANT) + ((eq? invocation-method invocation-method/unused) 'UNUSED) + ((eq? invocation-method invocation-method/used) 'USED) + (else (error "Illegal invocation-method" invocation-method))))) + +(define (continuation? object) + (and (object-type? (ucode-type entity) object) + (%continuation? (system-pair-cdr object)))) + +(define (guarantee-continuation continuation) + (if (not (continuation? continuation)) + (error "Illegal continuation" continuation)) + continuation) + +(define-integrable (continuation/invocation-method continuation) + (system-pair-car continuation)) + +(define-integrable (set-continuation/invocation-method! continuation method) + (system-pair-set-car! continuation method)) + +(define-integrable (continuation/control-point continuation) + (%continuation/control-point (system-pair-cdr continuation))) + +(define-integrable (continuation/dynamic-state continuation) + (%continuation/dynamic-state (system-pair-cdr continuation))) + +(define-integrable (continuation/fluid-bindings continuation) + (%continuation/fluid-bindings (system-pair-cdr continuation))) +(define-structure (%continuation (constructor make-%continuation) + (conc-name %continuation/)) + (control-point false read-only true) + (dynamic-state false read-only true) + (fluid-bindings false read-only true)) \ No newline at end of file diff --git a/v7/src/runtime/cpoint.scm b/v7/src/runtime/cpoint.scm new file mode 100644 index 000000000..753787eda --- /dev/null +++ b/v7/src/runtime/cpoint.scm @@ -0,0 +1,127 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/cpoint.scm,v 14.1 1988/05/20 00:55:10 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Control Points +;;; package: control-point-package + +(declare (usual-integrations)) + +(define-integrable (control-point? object) + (object-type? (ucode-type control-point) object)) + +(define-integrable (control-point/reusable? control-point) + (system-vector-ref control-point 0)) + +(define-integrable (control-point/unused-length control-point) + (object-datum (system-vector-ref control-point 1))) + +(define-integrable (control-point/interrupt-mask control-point) + (control-point-ref control-point 1)) + +(define-integrable (control-point/history control-point) + (control-point-ref control-point 3)) + +(define-integrable (control-point/previous-history-offset control-point) + (control-point-ref control-point 4)) + +(define-integrable (control-point/previous-history-control-point control-point) + (control-point-ref control-point 5)) + +(define (control-point-ref control-point index) + (system-vector-ref control-point + (+ (control-point/unused-length control-point) 2 index))) + +(define (control-point/element-stream control-point) + (let ((end (system-vector-length control-point))) + (let loop ((index (+ (control-point/unused-length control-point) 8))) + (cond ((= index end) '()) + (((ucode-primitive primitive-object-type? 2) + (ucode-type manifest-nm-vector) + (system-vector-ref control-point index)) + (let ((n-skips + (object-datum (system-vector-ref control-point index)))) + (cons-stream + (make-non-pointer-object n-skips) + (let skip-loop ((n n-skips) (index (1+ index))) + (if (zero? n) + (loop index) + (cons-stream false (skip-loop (-1+ n) (1+ index)))))))) + (else + (cons-stream (system-vector-ref control-point index) + (loop (1+ index)))))))) + +(define (control-point/next-control-point control-point) + (and (control-point/next-control-point? control-point) + (system-vector-ref control-point + (-1+ (system-vector-length control-point))))) + +(define (make-control-point reusable? + unused-length + interrupt-mask + history + previous-history-offset + previous-history-control-point + element-stream + next-control-point) + (let ((unused-length + (if (eq? microcode-id/stack-type 'STACKLETS) + (max unused-length 7) + unused-length))) + (let ((result (make-vector (+ 8 + unused-length + (stream-length element-stream) + (if next-control-point 2 0))))) + (vector-set! result 0 reusable?) + (vector-set! result 1 (make-non-pointer-object unused-length)) + (vector-set! result (+ 2 unused-length) + (ucode-return-address restore-interrupt-mask)) + (vector-set! result (+ 3 unused-length) interrupt-mask) + (vector-set! result (+ 4 unused-length) + (ucode-return-address restore-history)) + (vector-set! result (+ 5 unused-length) history) + (vector-set! result (+ 6 unused-length) previous-history-offset) + (vector-set! result (+ 7 unused-length) previous-history-control-point) + (let loop ((stream element-stream) (index (+ 8 unused-length))) + (cond ((stream-pair? stream) + (vector-set! result index (stream-car stream)) + (loop (stream-cdr stream) (1+ index))) + (next-control-point + (vector-set! result index (ucode-return-address join-stacklets)) + (vector-set! result (1+ index) next-control-point)))) + (object-new-type (ucode-type control-point) result)))) + +(define (control-point/next-control-point? control-point) + ((ucode-primitive primitive-object-eq? 2) + (system-vector-ref control-point (- (system-vector-length control-point) 2)) + (ucode-return-address join-stacklets))) \ No newline at end of file diff --git a/v7/src/runtime/dbgcmd.scm b/v7/src/runtime/dbgcmd.scm new file mode 100644 index 000000000..8c880bb66 --- /dev/null +++ b/v7/src/runtime/dbgcmd.scm @@ -0,0 +1,130 @@ +;;; -*-Scheme-*- +;;; +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgcmd.scm,v 14.1 1988/05/20 00:55:29 cph Exp $ +;;; +;;; Copyright (c) 1988 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of this +;;; software shall duly acknowledge such use, in accordance with +;;; the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; + +;;;; Debugger Command Loop Support +;;; package: debugger-command-loop-package + +(declare (usual-integrations)) + +(define (make-command-set name definitions) + (let ((command-set (list name))) + (for-each (lambda (entry) + (define-letter-command command-set + (car entry) + (if (eq? standard-help-command (cadr entry)) + (standard-help-command command-set) + (cadr entry)) + (caddr entry))) + definitions) + command-set)) + +(define (define-letter-command command-set new-command function help-text) + (let ((entry (assv new-command (cdr command-set)))) + (if entry + (set-cdr! entry (list function help-text)) + (let loop ((command-set command-set)) + (if (or (null? (cdr command-set)) + (char= depth 0) + (begin (newline) + (write-string "Depth (relative to starting frame): ") + (write depth))) + (newline) + (let ((bindings (environment-bindings frame))) + (if (null? bindings) + (write-string "Has no bindings") + (begin + (write-string "Has bindings:") + (newline) + (for-each print-binding + (sort bindings + (lambda (x y) + (stringstring (car x)) + (symbol->string (car y)))))))))))) + +(define (print-binding binding) + (let ((x-size (output-port/x-size (current-output-port))) + (write->string + (lambda (object length) + (let ((x (write-to-string object length))) + (if (and (car x) (> length 4)) + (substring-move-right! " ..." 0 4 (cdr x) (- length 4))) + (cdr x))))) + (newline) + (write-string + (let ((s (write->string (car binding) (quotient x-size 2)))) + (if (null? (cdr binding)) + (string-append s " is unassigned") + (let ((s (string-append s " = "))) + (string-append s + (write->string (cadr binding) + (max (- x-size (string-length s)) + 0))))))))) \ No newline at end of file diff --git a/v7/src/runtime/framex.scm b/v7/src/runtime/framex.scm new file mode 100644 index 000000000..620fee9a0 --- /dev/null +++ b/v7/src/runtime/framex.scm @@ -0,0 +1,236 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/framex.scm,v 14.1 1988/05/20 00:57:08 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Debugging Info +;;; package: debugging-info-package + +(declare (usual-integrations)) + +(define (stack-frame/debugging-info frame) + (let ((method + (1d-table/get (stack-frame-type/properties (stack-frame/type frame)) + method-tag + false))) + (if (not method) + (error "STACK-FRAME/DEBUGGING-INFO: missing method" frame)) + (method frame))) + +(define-integrable (debugging-info/undefined-expression? expression) + (eq? expression undefined-expression)) + +(define-integrable (debugging-info/undefined-environment? environment) + (eq? environment undefined-environment)) + +(define-integrable (debugging-info/compiled-code? expression) + (eq? expression compiled-code)) + +(define-integrable (make-evaluated-object object) + (cons evaluated-object-tag object)) + +(define (debugging-info/evaluated-object? expression) + (and (pair? expression) + (eq? (car expression) evaluated-object-tag))) + +(define-integrable (debugging-info/evaluated-object-value expression) + (cdr expression)) + +(define method-tag "stack-frame/debugging-info method") +(define undefined-expression "undefined expression") +(define undefined-environment "undefined environment") +(define compiled-code "compiled code") +(define evaluated-object-tag "evaluated") + +(define (method/standard frame) + (values (stack-frame/ref frame 0) (stack-frame/ref frame 1))) + +(define (method/null frame) + frame + (values undefined-expression undefined-environment)) + +(define (method/expression-only frame) + (values (stack-frame/ref frame 0) undefined-environment)) + +(define (method/environment-only frame) + (values undefined-expression (stack-frame/ref frame 1))) + +(define (method/compiled-code frame) + frame + (values compiled-code undefined-environment)) + +(define (method/primitive-combination-3-first-operand frame) + (values (stack-frame/ref frame 0) (stack-frame/ref frame 2))) + +(define (method/force-snap-thunk frame) + (values (make-combination + (ucode-primitive force 1) + (list (make-evaluated-object (stack-frame/ref frame 0)))) + undefined-environment)) + +(define ((method/application-frame index) frame) + (values (make-combination + (make-evaluated-object (stack-frame/ref frame index)) + (stack-frame-list frame (1+ index))) + undefined-environment)) + +(define ((method/compiler-reference scode-maker) frame) + (values (scode-maker (stack-frame/ref frame 2)) + (stack-frame/ref frame 1))) + +(define ((method/compiler-assignment scode-maker) frame) + (values (scode-maker (stack-frame/ref frame 2) + (make-evaluated-object (stack-frame/ref frame 3))) + (stack-frame/ref frame 1))) + +(define ((method/compiler-reference-trap scode-maker) frame) + (values (scode-maker (stack-frame/ref frame 1)) + (stack-frame/ref frame 2))) + +(define ((method/compiler-assignment-trap scode-maker) frame) + (values (scode-maker (stack-frame/ref frame 1) + (make-evaluated-object (stack-frame/ref frame 3))) + (stack-frame/ref frame 2))) + +(define (method/compiler-lookup-apply-restart frame) + (values (make-combination (stack-frame/ref frame 2) + (stack-frame-list frame 4)) + undefined-environment)) + +(define (method/compiler-lookup-apply-trap-restart frame) + (values (make-combination (make-variable (stack-frame/ref frame 1)) + (stack-frame-list frame 5)) + (stack-frame/ref frame 2))) + +(define (stack-frame-list frame start) + (let ((end (stack-frame/length frame))) + (let loop ((index start)) + (if (< index end) + (cons (make-evaluated-object (stack-frame/ref frame index)) + (loop (1+ index))) + '())))) + +(define (initialize-package!) + (for-each (lambda (entry) + (for-each (lambda (name) + (let ((type + (or (vector-ref stack-frame-types + (microcode-return name)) + (error "Missing return type" name)))) + (1d-table/put! (stack-frame-type/properties type) + method-tag + (car entry)))) + (cdr entry))) + `((,method/standard + ASSIGNMENT-CONTINUE + COMBINATION-1-PROCEDURE + COMBINATION-2-FIRST-OPERAND + COMBINATION-2-PROCEDURE + COMBINATION-SAVE-VALUE + CONDITIONAL-DECIDE + DEFINITION-CONTINUE + DISJUNCTION-DECIDE + EVAL-ERROR + PRIMITIVE-COMBINATION-2-FIRST-OPERAND + PRIMITIVE-COMBINATION-3-SECOND-OPERAND + SEQUENCE-2-SECOND + SEQUENCE-3-SECOND + SEQUENCE-3-THIRD) + + (,method/null + COMBINATION-APPLY + GC-CHECK + MOVE-TO-ADJACENT-POINT) + + (,method/expression-only + ACCESS-CONTINUE + IN-PACKAGE-CONTINUE + PRIMITIVE-COMBINATION-1-APPLY + PRIMITIVE-COMBINATION-2-APPLY + PRIMITIVE-COMBINATION-3-APPLY) + + (,method/environment-only + REPEAT-DISPATCH) + + (,method/compiled-code + REENTER-COMPILED-CODE) + + (,method/primitive-combination-3-first-operand + PRIMITIVE-COMBINATION-3-FIRST-OPERAND) + + (,method/force-snap-thunk + FORCE-SNAP-THUNK) + + (,(method/application-frame 2) + INTERNAL-APPLY) + + (,(method/application-frame 0) + REPEAT-PRIMITIVE) + + (,(method/compiler-reference identity-procedure) + COMPILER-REFERENCE-RESTART + COMPILER-SAFE-REFERENCE-RESTART) + + (,(method/compiler-reference make-variable) + COMPILER-ACCESS-RESTART) + + (,(method/compiler-reference make-unassigned?) + COMPILER-UNASSIGNED?-RESTART) + + (,(method/compiler-reference + (lambda (name) + (make-combination (ucode-primitive lexical-unbound?) + (list (make-the-environment) name)))) + COMPILER-UNBOUND?-RESTART) + + (,(method/compiler-assignment make-assignment-from-variable) + COMPILER-ASSIGNMENT-RESTART) + + (,(method/compiler-assignment make-definition) + COMPILER-DEFINITION-RESTART) + + (,(method/compiler-reference-trap make-variable) + COMPILER-REFERENCE-TRAP-RESTART + COMPILER-SAFE-REFERENCE-TRAP-RESTART) + + (,(method/compiler-reference-trap make-unassigned?) + COMPILER-UNASSIGNED?-TRAP-RESTART) + + (,(method/compiler-assignment-trap make-assignment) + COMPILER-ASSIGNMENT-TRAP-RESTART) + + (,method/compiler-lookup-apply-restart + COMPILER-LOOKUP-APPLY-RESTART) + + (,method/compiler-lookup-apply-trap-restart + COMPILER-LOOKUP-APPLY-TRAP-RESTART + COMPILER-OPERATOR-LOOKUP-TRAP-RESTART)))) \ No newline at end of file diff --git a/v7/src/runtime/gcdemn.scm b/v7/src/runtime/gcdemn.scm new file mode 100644 index 000000000..a7b952f88 --- /dev/null +++ b/v7/src/runtime/gcdemn.scm @@ -0,0 +1,71 @@ +;;; -*-Scheme-*- +;;; +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gcdemn.scm,v 14.1 1988/05/20 00:57:31 cph Exp $ +;;; +;;; Copyright (c) 1988 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of this +;;; software shall duly acknowledge such use, in accordance with +;;; the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; + +;;;; Garbage Collector Daemons +;;; package: gc-daemons + +(declare (usual-integrations)) + +(define (initialize-package!) + (set! gc-daemons '()) + (set! secondary-gc-daemons '()) + (let ((fixed-objects (get-fixed-objects-vector))) + (vector-set! fixed-objects #x0B trigger-gc-daemons) + ((ucode-primitive set-fixed-objects-vector!) fixed-objects))) + +(define gc-daemons) +(define secondary-gc-daemons) + +(define (trigger-gc-daemons) + (trigger-daemons gc-daemons)) + +(define (trigger-secondary-gc-daemons!) + (trigger-daemons secondary-gc-daemons)) + +(define (trigger-daemons daemons . extra-args) + (let loop ((daemons daemons)) + (if (not (null? daemons)) + (begin (apply (car daemons) extra-args) + (loop (cdr daemons)))))) + +(define (add-gc-daemon! daemon) + (set! gc-daemons (cons daemon gc-daemons))) + +(define (add-secondary-gc-daemon! daemon) + (set! secondary-gc-daemons (cons daemon secondary-gc-daemons))) \ No newline at end of file diff --git a/v7/src/runtime/gcnote.scm b/v7/src/runtime/gcnote.scm new file mode 100644 index 000000000..dfb59bb8c --- /dev/null +++ b/v7/src/runtime/gcnote.scm @@ -0,0 +1,73 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gcnote.scm,v 14.1 1988/05/20 00:57:56 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; GC Notification +;;; package: gc-notification-package + +(declare (usual-integrations)) + +(define (toggle-gc-notification!) + (set! hook/record-statistic! + (let ((current hook/record-statistic!)) + (cond ((eq? current gc-notification) default/record-statistic!) + ((eq? current default/record-statistic!) gc-notification) + (else (error "Can't grab GC statistics hook"))))) + *the-non-printing-object*) + +(define (gc-notification statistic) + (with-output-to-port (cmdl/output-port (nearest-cmdl)) + (lambda () + (print-statistic statistic)))) + +(define (print-gc-statistics) (for-each print-statistic (gc-statistics))) + +(define (print-statistic statistic) + (newline) + (write-string (gc-statistic->string statistic))) + +(define (gc-statistic->string statistic) + (let ((delta-time + (- (gc-statistic/this-gc-end statistic) + (gc-statistic/this-gc-start statistic)))) + (string-append "GC #" + (number->string (gc-statistic/meter statistic)) + " took: " + (number->string (internal-time/ticks->seconds delta-time)) + " (" + (number->string + (round (* (/ delta-time + (- (gc-statistic/this-gc-end statistic) + (gc-statistic/last-gc-end statistic))) + 100))) "%) free: " + (number->string (gc-statistic/heap-left statistic))))) \ No newline at end of file diff --git a/v7/src/runtime/gdatab.scm b/v7/src/runtime/gdatab.scm new file mode 100644 index 000000000..3180977cc --- /dev/null +++ b/v7/src/runtime/gdatab.scm @@ -0,0 +1,80 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gdatab.scm,v 14.1 1988/05/20 00:58:20 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Global Databases +;;; package: global-database-package + +(declare (usual-integrations)) + +(define (initialize-package!) + (set! event:after-restore (make-event-distributor)) + (set! event:after-restart (make-event-distributor)) + (set! tagged-pair-methods (make-1d-table)) + (set! tagged-vector-methods (make-1d-table))) + +(define event:after-restore) +(define event:after-restart) +(define tagged-pair-methods) +(define tagged-vector-methods) + +(define (unparser/tagged-pair-method tag) + (1d-table/get tagged-pair-methods tag false)) + +(define (unparser/set-tagged-pair-method! tag method) + (1d-table/put! tagged-pair-methods tag method)) + +(define (unparser/tagged-vector-method tag) + (1d-table/get tagged-vector-methods tag false)) + +(define (unparser/set-tagged-vector-method! tag method) + (1d-table/put! tagged-vector-methods tag method)) + +;;; Support for old-style methods + +(define (add-unparser-special-pair! tag method) + (unparser/set-tagged-pair-method! tag (convert-old-method method))) + +(define (add-unparser-special-object! tag method) + (unparser/set-tagged-vector-method! tag (convert-old-method method))) + +(define (unparse-with-brackets thunk) + (write-string "#[") + (thunk) + (write-char #\])) + +(define (convert-old-method method) + (lambda (state object) + (with-output-to-port (unparser-state/port state) + (lambda () + (method object))))) \ No newline at end of file diff --git a/v7/src/runtime/global.scm b/v7/src/runtime/global.scm new file mode 100644 index 000000000..5ae0473a1 --- /dev/null +++ b/v7/src/runtime/global.scm @@ -0,0 +1,280 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/global.scm,v 14.1 1988/05/20 00:58:36 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Miscellaneous Global Definitions + +(declare (usual-integrations)) + +;;;; Primitive Operators + +(define-primitives + scode-eval force error-procedure + set-interrupt-enables! enable-interrupts! with-interrupt-mask + get-fixed-objects-vector with-history-disabled + primitive-procedure-arity + + ;; Environment + lexical-reference lexical-assignment local-assignment + lexical-unassigned? lexical-unbound? lexical-unreferenceable? + environment-link-name + + ;; Pointers + (object-type 1) + (object-gc-type 1) + (object-datum 1) + (object-type? 2) + (object-new-type object-set-type 2) + eq? + + ;; Cells + make-cell cell? cell-contents set-cell-contents! + + ;; System Compound Datatypes + system-pair-cons system-pair? + system-pair-car system-pair-set-car! + system-pair-cdr system-pair-set-cdr! + + hunk3-cons + system-hunk3-cxr0 system-hunk3-set-cxr0! + system-hunk3-cxr1 system-hunk3-set-cxr1! + system-hunk3-cxr2 system-hunk3-set-cxr2! + + (system-list->vector system-list-to-vector) + (system-subvector->list system-subvector-to-list) + system-vector? + (system-vector-length system-vector-size) + system-vector-ref + system-vector-set!) + +;;;; Potpourri + +(define (identity-procedure x) x) +(define (null-procedure . args) args '()) +(define (false-procedure . args) args false) +(define (true-procedure . args) args true) + +(define (apply f . args) + ((ucode-primitive apply) + f + (if (null? args) + '() + (let loop ((first-element (car args)) (rest-elements (cdr args))) + (if (null? rest-elements) + first-element + (cons first-element + (loop (car rest-elements) (cdr rest-elements)))))))) + +(define (eval expression environment) + (scode-eval (syntax expression system-global-syntax-table) environment)) +(define-integrable (system-hunk3-cons type cxr0 cxr1 cxr2) + (object-new-type type (hunk3-cons cxr0 cxr1 cxr2))) + +(define-integrable (symbol-hash symbol) + (string-hash (symbol->string symbol))) + +(define (symbol-append . symbols) + (string->symbol (apply string-append (map symbol->string symbols)))) + +(define (bind-cell-contents! cell new-value thunk) + (let ((old-value)) + (dynamic-wind (lambda () + (set! old-value (cell-contents cell)) + (set-cell-contents! cell new-value) + (set! new-value)) + thunk + (lambda () + (set! new-value (cell-contents cell)) + (set-cell-contents! cell old-value) + (set! old-value))))) + +(define (values . objects) + (lambda (receiver) + (apply receiver objects))) + +(define-integrable (with-values thunk receiver) + ((thunk) receiver)) + +(define (write-to-string object #!optional max) + (if (default-object? max) (set! max false)) + (if (not max) + (with-output-to-string + (lambda () + (write object))) + (with-output-to-truncated-string max + (lambda () + (write object))))) + +(define (pa procedure) + (if (not (compound-procedure? procedure)) + (error "Must be a compound procedure" procedure)) (pp (unsyntax-lambda-list (procedure-lambda procedure)))) + +(define (pwd) + (working-directory-pathname)) + +(define (cd pathname) + (set-working-directory-pathname! pathname)) + +;; Compatibility. +(define %pwd pwd) +(define %cd cd) + +(define (show-time thunk) + (let ((process-start (process-time-clock)) + (real-start (real-time-clock))) + (let ((value (thunk))) + (let ((process-end (process-time-clock)) + (real-end (real-time-clock))) + (newline) + (write-string "process time: ") + (write (- process-end process-start)) + (write-string "; real time: ") + (write (- real-end real-start))) + value))) + +(define (wait-interval ticks) + (let ((end (+ (real-time-clock) ticks))) + (let wait-loop () + (if (< (real-time-clock) end) + (wait-loop))))) + +(define-integrable (future? object) + ((ucode-primitive primitive-type? 2) (ucode-type future) object)) + +(define (exit) + (if (prompt-for-confirmation "Kill Scheme? ") (%exit))) + +(define (%exit) + (close-all-open-files) + ((ucode-primitive exit))) + +(define (quit) + (with-absolutely-no-interrupts (ucode-primitive halt)) + *the-non-printing-object*) + +(define (define-structure/keyword-parser argument-list default-alist) + (if (null? argument-list) + (map cdr default-alist) + (let ((alist + (map (lambda (entry) (cons (car entry) (cdr entry))) + default-alist))) + (let loop ((arguments argument-list)) + (if (not (null? arguments)) + (begin + (if (null? (cdr arguments)) + (error "Keyword list does not have even length" + argument-list)) + (set-cdr! (or (assq (car arguments) alist) + (error "Unknown keyword" (car arguments))) + (cadr arguments)) + (loop (cddr arguments))))) + (map cdr alist)))) + +(define (syntaxer/cond-=>-helper form1-result thunk2 thunk3) + (if form1-result + ((thunk2) form1-result) + (thunk3))) + +(define syntaxer/default-environment + (let () (the-environment))) + +(define user-initial-environment + (let () (the-environment))) + +(define user-initial-prompt + "]=>") +(define (copy-program exp) + (if (not (object-type? (ucode-type compiled-entry) exp)) + (error "COPY-PROGRAM: Can only copy compiled programs" exp)) + (let* ((original (compiled-code-address->block exp)) + (block + (object-new-type + (ucode-type compiled-code-block) + (vector-copy (object-new-type (ucode-type vector) original)))) + (end (system-vector-length block))) + + (define (map-entry entry) + (with-absolutely-no-interrupts + (lambda () + ((ucode-primitive primitive-object-set-type) + (object-type entry) + (+ (compiled-code-address->offset entry) + (object-datum block)))))) + + (let loop ((n (1+ (object-datum (system-vector-ref block 0))))) + (if (< n end) + (begin + (if (lambda? (system-vector-ref block n)) + (lambda-components (system-vector-ref block n) + (lambda (name required optional rest auxiliary declarations + body) + (if (and (object-type? (ucode-type compiled-entry) body) + (eq? original + (compiled-code-address->block body))) + (system-vector-set! + block + n + (make-lambda name required optional rest auxiliary + declarations (map-entry body))))))) + (loop (1+ n))))) + (map-entry exp))) + +(define-integrable (object-non-pointer? object) + (zero? (object-gc-type object))) + +(define-integrable (object-pointer? object) + (not (object-non-pointer? object))) + +(define (impurify object) + (if (and (object-pointer? object) (pure? object)) + ((ucode-primitive primitive-impurify) object)) + object) + +(define (fasdump object filename) + (let ((filename (canonicalize-output-filename filename)) + (port (cmdl/output-port (nearest-cmdl)))) + (newline port) + (write-string "FASDumping " port) (write filename port) + (if (not ((ucode-primitive primitive-fasdump) object filename false)) + (error "FASDUMP: Object is too large to be dumped" object)) + (write-string " -- done" port)) + object) + +(define (undefined-value? object) + ;; Note: the unparser takes advantage of the fact that objects + ;; satisfying this predicate also satisfy: + ;; (object-type? (microcode-type 'TRUE) object) + (or (eq? object undefined-conditional-branch) + ;; same as `undefined-conditional-branch'. + ;; (eq? object *the-non-printing-object*) + (eq? object (microcode-object/unassigned)))) \ No newline at end of file diff --git a/v7/src/runtime/lambdx.scm b/v7/src/runtime/lambdx.scm new file mode 100644 index 000000000..49ba21ce7 --- /dev/null +++ b/v7/src/runtime/lambdx.scm @@ -0,0 +1,82 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/lambdx.scm,v 14.1 1988/05/20 00:58:54 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Alternative Components for Lambda + +(declare (usual-integrations)) + +(define (make-lambda* name required optional rest body) + (scan-defines body + (lambda (auxiliary declarations body*) + (make-lambda name required optional rest auxiliary declarations body*)))) + +(define (lambda-components* lambda receiver) + (lambda-components lambda + (lambda (name required optional rest auxiliary declarations body) + (receiver name required optional rest + (make-open-block auxiliary declarations body))))) + +(define (lambda-components** lambda receiver) + (lambda-components* lambda + (lambda (name required optional rest body) + (receiver (make-lambda-pattern name required optional rest) + (append required optional (if (null? rest) '() (list rest))) + body)))) + +(define-structure (lambda-pattern (conc-name lambda-pattern/)) + (name false read-only true) + (required false read-only true) + (optional false read-only true) + (rest false read-only true)) + +(define (make-lambda** pattern bound body) + + (define (split pattern bound receiver) + (cond ((null? pattern) + (receiver '() bound)) + (else + (split (cdr pattern) (cdr bound) + (lambda (copy tail) + (receiver (cons (car bound) copy) + tail)))))) + + (split (lambda-pattern/required pattern) bound + (lambda (required tail) + (split (lambda-pattern/optional pattern) tail + (lambda (optional rest) + (make-lambda* (lambda-pattern/name pattern) + required + optional + (if (null? rest) rest (car rest)) + body)))))) \ No newline at end of file diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm new file mode 100644 index 000000000..8674a32c9 --- /dev/null +++ b/v7/src/runtime/load.scm @@ -0,0 +1,160 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.1 1988/05/20 00:59:11 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Code Loader +;;; package: load-package + +(declare (usual-integrations)) + +(define (initialize-package!) + (set! load-noisily? false) + (set! load/default-types '("com" "bin" "scm")) + (set! fasload/default-types '("com" "bin")) + (add-event-receiver! event:after-restart load-init-file)) + +(define load-noisily?) +(define load/default-types) +(define fasload/default-types) + +(define (read-file filename) + (stream->list + (call-with-input-file + (pathname-default-version (->pathname filename) 'NEWEST) + read-stream))) + +(define (fasload filename) + (fasload/internal + (find-true-filename (->pathname filename) fasload/default-types))) + +(define (fasload/internal true-filename) + (let ((port (cmdl/output-port (nearest-cmdl)))) + (newline port) + (write-string "FASLoading " port) + (write true-filename port) + (let ((value ((ucode-primitive binary-fasload) true-filename))) + (write-string " -- done" port) + value))) + +(define (load-noisily filename #!optional environment) + (fluid-let ((load-noisily? true)) + (load filename + (if (default-object? environment) default-object environment)))) + +(define (load-init-file) + (let ((truename (init-file-truename))) + (if truename + (load truename user-initial-environment))) + *the-non-printing-object*) + +;;; This is careful to do the minimum number of file existence probes +;;; before opening the input file. + +(define (load filename/s #!optional environment) + (let ((environment + ;; Kludge until optional defaulting fixed. + (if (default-object? environment) default-object environment))) + (let ((kernel + (lambda (filename last-file?) + (let ((value + (let ((pathname (->pathname filename))) + (load/internal pathname + (find-true-filename pathname + load/default-types) + environment + load-noisily?)))) + (cond (last-file? value) + (load-noisily? (write-line value))))))) + (if (pair? filename/s) + (let loop ((filenames filename/s)) + (if (null? (cdr filenames)) + (kernel (car filenames) true) + (begin (kernel (car filenames) false) + (loop (cdr filenames))))) + (kernel filename/s true))))) + +(define default-object + "default-object") + +(define (load/internal pathname true-filename environment load-noisily?) + (let ((port (open-input-file/internal pathname true-filename))) + (if (= 250 (char->ascii (peek-char port))) + (begin (close-input-port port) + (scode-eval (fasload/internal true-filename) + (if (eq? environment default-object) + (standard-repl-environment) + environment))) + (write-stream (eval-stream (read-stream port) environment) + (if load-noisily? + (lambda (value) + (hook/repl-write (nearest-repl) value)) + (lambda (value) value false)))))) +(define (find-true-filename pathname default-types) + (pathname->string + (or (let ((try + (lambda (pathname) + (pathname->input-truename + (pathname-default-version pathname 'NEWEST))))) + (if (pathname-type pathname) + (try pathname) + (or (pathname->input-truename pathname) + (let loop ((types default-types)) + (and (not (null? types)) + (or (try (pathname-new-type pathname (car types))) + (loop (cdr types)))))))) + (error "No such file" pathname)))) + +(define (read-stream port) + (parse-objects port + (current-parser-table) + (lambda (object) + (and (eof-object? object) + (begin (close-input-port port) + true))))) + +(define (eval-stream stream environment) + (stream-map stream + (lambda (s-expression) + (hook/repl-eval (nearest-repl) + s-expression + (if (eq? environment default-object) + (standard-repl-environment) + environment))))) + +(define (write-stream stream write) + (if (stream-pair? stream) + (let loop ((value (stream-car stream)) (stream (stream-cdr stream))) + (if (stream-pair? stream) + (begin (write value) + (loop (stream-car stream) (stream-cdr stream))) value)) + *the-non-printing-object*)) \ No newline at end of file diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm new file mode 100644 index 000000000..017da43fc --- /dev/null +++ b/v7/src/runtime/make.scm @@ -0,0 +1,324 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.1 1988/05/20 00:59:28 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Make Runtime System + +(declare (usual-integrations)) + +((ucode-primitive set-interrupt-enables!) 0) +(define system-global-environment (the-environment)) +(define system-packages (let () (the-environment))) + +(let () + +(define-primitives + (+ &+) + binary-fasload + exit + (file-exists? 1) + garbage-collect + get-fixed-objects-vector + get-primitive-address + get-primitive-name + lexical-reference + microcode-identify + primitive-purify + scode-eval + set-fixed-objects-vector! + set-interrupt-enables! + string->symbol + string-allocate + string-length + substring=? + substring-move-right! + substring-upcase! + tty-flush-output + tty-write-char + tty-write-string + vector-ref + vector-set! + with-interrupt-mask) + +(define microcode-identification + (microcode-identify)) + +(define newline-char + (vector-ref microcode-identification 5)) + +(define os-name-string + (vector-ref microcode-identification 8)) + +(define (fatal-error message) + (tty-write-char newline-char) + (tty-write-string message) + (tty-write-char newline-char) + (tty-flush-output) + (exit)) + +;;;; GC, Interrupts, Errors + +(define safety-margin 4500) + +(let ((condition-handler/gc + (lambda (interrupt-code interrupt-enables) + interrupt-code interrupt-enables + (with-interrupt-mask 0 + (lambda (interrupt-mask) + interrupt-mask + (garbage-collect safety-margin))))) + (condition-handler/stack-overflow + (lambda (interrupt-code interrupt-enables) + interrupt-code interrupt-enables + (fatal-error "Stack overflow!"))) + (condition-handler/hardware-trap + (lambda (escape-code) + escape-code + (fatal-error "Hardware trap!"))) + (fixed-objects (get-fixed-objects-vector))) + (let ((interrupt-vector (vector-ref fixed-objects 1))) + (vector-set! interrupt-vector 0 condition-handler/stack-overflow) + (vector-set! interrupt-vector 2 condition-handler/gc)) + (vector-set! fixed-objects #x0C condition-handler/hardware-trap) + (set-fixed-objects-vector! fixed-objects)) + +(set-interrupt-enables! #x0005) + +;;;; Utilities + +(define (fasload filename) + (tty-write-char newline-char) + (tty-write-string filename) + (tty-flush-output) + (let ((value (binary-fasload filename))) + (tty-write-string " loaded") + (tty-flush-output) + value)) + +(define (eval object environment) + (let ((value (scode-eval object environment))) + (tty-write-string " evaluated") + (tty-flush-output) + value)) + +(define (cold-load/purify object) + (if (not (car (primitive-purify object #t safety-margin))) + (fatal-error "Error! insufficient pure space")) + (tty-write-string " purified") + (tty-flush-output) + object) + +(define (implemented-primitive-procedure? primitive) + (get-primitive-address (get-primitive-name (object-datum primitive)) false)) + +(define map-filename + (if (implemented-primitive-procedure? file-exists?) + (lambda (filename) + (let ((com-file (string-append filename ".com"))) + (if (file-exists? com-file) + com-file + (string-append filename ".bin")))) + (lambda (filename) + (string-append filename ".bin")))) + +(define (string-append x y) + (let ((x-length (string-length x)) + (y-length (string-length y))) + (let ((result (string-allocate (+ x-length y-length)))) + (substring-move-right! x 0 x-length result 0) + (substring-move-right! y 0 y-length result x-length) + result))) + +(define (string-upcase string) + (let ((size (string-length string))) + (let ((result (string-allocate size))) + (substring-move-right! string 0 size result 0) + (substring-upcase! result 0 size) + result))) + +(define (string=? string1 string2) + (substring=? string1 0 (string-length string1) + string2 0 (string-length string2))) + +(define (package-initialize package-name procedure-name) + (tty-write-char newline-char) + (tty-write-string "initialize:") + (let loop ((name package-name)) + (if (not (null? name)) + (begin (tty-write-string " ") + (tty-write-string (system-pair-car (car name))) + (loop (cdr name))))) + (tty-flush-output) + ((lexical-reference (package-reference package-name) procedure-name))) + +(define (package-reference name) + (if (null? name) + system-global-environment + (let loop ((name name) (environment system-packages)) + (if (null? name) + environment + (loop (cdr name) (lexical-reference environment (car name))))))) + +(define (package-initialization-sequence packages) + (let loop ((packages packages)) + (if (not (null? packages)) + (begin (package-initialize (car packages) 'INITIALIZE-PACKAGE!) + (loop (cdr packages)))))) + +;; Construct the package structure. +(eval (fasload "runtim.bcon") system-global-environment) + +;; Global databases. Load, then initialize. + +(let loop + ((files + '(("gcdemn" . (GC-DAEMONS)) + ("poplat" . (POPULATION)) + ("prop1d" . (1D-PROPERTY)) + ("events" . (EVENT-DISTRIBUTOR)) + ("gdatab" . (GLOBAL-DATABASE)) + ("boot" . ()) + ("queue" . ()) + ("gc" . (GARBAGE-COLLECTOR))))) + (if (not (null? files)) + (begin + (eval (cold-load/purify (fasload (map-filename (car (car files))))) + (package-reference (cdr (car files)))) + (loop (cdr files))))) +(package-initialize '(GC-DAEMONS) 'INITIALIZE-PACKAGE!) +(package-initialize '(POPULATION) 'INITIALIZE-PACKAGE!) +(package-initialize '(1D-PROPERTY) 'INITIALIZE-PACKAGE!) +(package-initialize '(EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE!) +(package-initialize '(GLOBAL-DATABASE) 'INITIALIZE-PACKAGE!) +(package-initialize '(POPULATION) 'INITIALIZE-UNPARSER!) +(package-initialize '(1D-PROPERTY) 'INITIALIZE-UNPARSER!) +(package-initialize '(EVENT-DISTRIBUTOR) 'INITIALIZE-UNPARSER!) +(package-initialize '(GARBAGE-COLLECTOR) 'INITIALIZE-PACKAGE!) + +;; Load everything else. +((eval (fasload "runtim.bldr") system-global-environment) + (lambda (filename environment) + (if (not (or (string=? filename "gcdemn") + (string=? filename "poplat") + (string=? filename "prop1d") + (string=? filename "events") + (string=? filename "gdatab") + (string=? filename "boot") + (string=? filename "queue") + (string=? filename "gc"))) + (eval (purify (fasload (map-filename filename))) environment))) + `((SORT-TYPE . MERGE-SORT) + (OS-TYPE . ,(string->symbol (string-upcase os-name-string))))) + +;; Funny stuff is done. Rest of sequence is standardized. +(package-initialization-sequence + '( + ;; Microcode interface + (MICROCODE-TABLES) + (PRIMITIVE-IO) + (SAVE/RESTORE) + (STATE-SPACE) + (SYSTEM-CLOCK) + + ;; Basic data structures + (NUMBER) + (LIST) + (CHARACTER) + (CHARACTER-SET) + (GENSYM) + (STREAM) + (2D-PROPERTY) + (HASH) + (RANDOM-NUMBER) + + ;; Microcode data structures + (HISTORY) + (LAMBDA-ABSTRACTION) + (SCODE) + (SCODE-COMBINATOR) + (SCODE-SCAN) + (SCODE-WALKER) + (CONTINUATION-PARSER) + + ;; I/O ports + (CONSOLE-INPUT) + (CONSOLE-OUTPUT) + (FILE-INPUT) + (FILE-OUTPUT) + (STRING-INPUT) + (STRING-OUTPUT) + (TRUNCATED-STRING-OUTPUT) + (INPUT-PORT) + (OUTPUT-PORT) + (WORKING-DIRECTORY) + (LOAD) + + ;; Syntax + (PARSER) + (NUMBER-UNPARSER) + (UNPARSER) + (SYNTAXER) + (MACROS) + (SYSTEM-MACROS) + (DEFSTRUCT) + (UNSYNTAXER) + (PRETTY-PRINTER) + + ;; REP Loops + (ERROR-HANDLER) + (MICROCODE-ERRORS) + (INTERRUPT-HANDLER) + (GC-STATISTICS) + (REP) + + ;; Debugging + (ADVICE) + (DEBUGGER-COMMAND-LOOP) + (DEBUGGER-UTILITIES) + (ENVIRONMENT-INSPECTOR) + (DEBUGGING-INFO) + (DEBUGGER) + + ;; Emacs -- last because it grabs the kitchen sink. + (EMACS-INTERFACE) + )) + +) + +(add-system! (make-system "Microcode" + microcode-id/version + microcode-id/modification + '())) +(add-system! (make-system "Runtime" 14 0 '())) +(remove-environment-parent! system-packages) +(initial-top-level-repl) \ No newline at end of file diff --git a/v7/src/runtime/partab.scm b/v7/src/runtime/partab.scm new file mode 100644 index 000000000..8a40ead0e --- /dev/null +++ b/v7/src/runtime/partab.scm @@ -0,0 +1,116 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/partab.scm,v 14.1 1988/05/20 00:59:48 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Parser Tables +;;; package: parser-table-package + +(declare (usual-integrations)) + +(define-structure (parser-table (constructor %make-parser-table) + (conc-name parser-table/)) + (parse-object false read-only true) + (collect-list false read-only true) + (parse-object-special false read-only true) + (collect-list-special false read-only true)) + +(define (guarantee-parser-table table) + (if (not (parser-table? table)) + (error "Not a valid parser table" table)) + table) + +(define (make-parser-table parse-object + collect-list + parse-object-special + collect-list-special) + (%make-parser-table (make-vector 256 parse-object) + (make-vector 256 collect-list) + (make-vector 256 parse-object-special) + (make-vector 256 collect-list-special))) + +(define (parser-table/copy table) + (%make-parser-table (vector-copy (parser-table/parse-object table)) + (vector-copy (parser-table/collect-list table)) + (vector-copy (parser-table/parse-object-special table)) + (vector-copy (parser-table/collect-list-special table)))) + +(define-integrable (current-parser-table) + *current-parser-table*) + +(define (set-current-parser-table! table) + (guarantee-parser-table table) + (set! *current-parser-table* table)) + +(define (with-current-parser-table table thunk) + (guarantee-parser-table table) + (fluid-let ((*current-parser-table* table)) + (thunk))) + +(define *current-parser-table*) + +(define (parser-table/entry table char receiver) + (decode-parser-char table char + (lambda (index parse-object-table collect-list-table) + (receiver (vector-ref parse-object-table index) + (vector-ref collect-list-table index))))) + +(define (parser-table/set-entry! table char parse-object collect-list) + (let ((kernel + (lambda (char) + (decode-parser-char table char + (lambda (index parse-object-table collect-list-table) + (vector-set! parse-object-table index parse-object) + (vector-set! collect-list-table index collect-list)))))) + (cond ((char-set? char) (for-each kernel (char-set-members char))) + ((pair? char) (for-each kernel char)) + (else (kernel char))))) + +(define (decode-parser-char table char receiver) + (cond ((char? char) + (receiver (char->ascii char) + (parser-table/parse-object table) + (parser-table/collect-list table))) + ((string? char) + (cond ((= (string-length char) 1) + (receiver (char->ascii (string-ref char 0)) + (parser-table/parse-object table) + (parser-table/collect-list table))) + ((and (= (string-length char) 2) + (char=? #\# (string-ref char 0))) + (receiver (char->ascii (string-ref char 1)) + (parser-table/parse-object-special table) + (parser-table/collect-list-special table))) + (else + (error "Bad character" char)))) + (else + (error "Bad character" char)))) \ No newline at end of file diff --git a/v7/src/runtime/poplat.scm b/v7/src/runtime/poplat.scm new file mode 100644 index 000000000..979251857 --- /dev/null +++ b/v7/src/runtime/poplat.scm @@ -0,0 +1,150 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/poplat.scm,v 14.1 1988/05/20 01:00:04 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Populations +;;; package: population-package + +(declare (usual-integrations)) + +;;; A population is a collection of objects. This collection has the +;;; property that if one of the objects in the collection is reclaimed +;;; as garbage, then it is no longer an element of the collection. + +(define (initialize-package!) + (set! population-of-populations (cons population-tag '())) + (add-secondary-gc-daemon! gc-all-populations!)) + +(define (initialize-unparser!) + (unparser/set-tagged-pair-method! population-tag + (unparser/standard-method 'POPULATION))) + +(define bogus-false '(BOGUS-FALSE)) +(define population-tag '(POPULATION)) +(define-integrable weak-cons-type (ucode-type weak-cons)) + +(define-integrable (canonicalize object) + (if (eq? object false) bogus-false object)) + +(define-integrable (uncanonicalize object) + (if (eq? object bogus-false) false object)) + +(define (gc-population! population) + (let loop ((l1 population) (l2 (cdr population))) + (cond ((null? l2) true) + ((eq? (system-pair-car l2) false) + (system-pair-set-cdr! l1 (system-pair-cdr l2)) + (loop l1 (system-pair-cdr l1))) + (else (loop l2 (system-pair-cdr l2)))))) + +(define (gc-all-populations!) + (gc-population! population-of-populations) + (map-over-population! population-of-populations gc-population!)) + +(define population-of-populations) + +(define (make-population) + (let ((population (cons population-tag '()))) + (add-to-population! population-of-populations population) + population)) + +(define (population? object) + (and (pair? object) + (eq? (car object) population-tag))) + +(define (add-to-population! population object) + (let ((object (canonicalize object))) + (let loop ((previous population) (this (cdr population))) + (if (null? this) + (set-cdr! population + (system-pair-cons weak-cons-type + object + (cdr population))) + (let ((entry (system-pair-car this)) + (next (system-pair-cdr this))) + (cond ((not entry) + (system-pair-set-cdr! previous next) + (loop previous next)) + ((not (eq? object entry)) + (loop this next)))))))) + +(define (remove-from-population! population object) + (let ((object (canonicalize object))) + (let loop ((previous population) (this (cdr population))) + (if (not (null? this)) + (let ((entry (system-pair-car this)) + (next (system-pair-cdr this))) + (if (or (not entry) (eq? object entry)) + (begin (system-pair-set-cdr! previous next) + (loop previous next)) + (loop this next))))))) + +;;;; Higher level operations + +(define (map-over-population population procedure) + (let loop ((l1 population) (l2 (cdr population))) + (cond ((null? l2) '()) + ((eq? (system-pair-car l2) false) + (system-pair-set-cdr! l1 (system-pair-cdr l2)) + (loop l1 (system-pair-cdr l1))) + (else + (cons (procedure (uncanonicalize (system-pair-car l2))) + (loop l2 (system-pair-cdr l2))))))) + +(define (map-over-population! population procedure) + (let loop ((l1 population) (l2 (cdr population))) + (cond ((null? l2) true) + ((eq? (system-pair-car l2) false) + (system-pair-set-cdr! l1 (system-pair-cdr l2)) + (loop l1 (system-pair-cdr l1))) + (else + (procedure (uncanonicalize (system-pair-car l2))) + (loop l2 (system-pair-cdr l2)))))) + +(define (for-all-inhabitants? population predicate) + (let loop ((l1 population) (l2 (cdr population))) + (or (null? l2) + (if (eq? (system-pair-car l2) false) + (begin (system-pair-set-cdr! l1 (system-pair-cdr l2)) + (loop l1 (system-pair-cdr l1))) + (and (predicate (uncanonicalize (system-pair-car l2))) + (loop l2 (system-pair-cdr l2))))))) + +(define (exists-an-inhabitant? population predicate) + (let loop ((l1 population) (l2 (cdr population))) + (and (not (null? l2)) + (if (eq? (system-pair-car l2) false) + (begin (system-pair-set-cdr! l1 (system-pair-cdr l2)) + (loop l1 (system-pair-cdr l1))) + (or (predicate (uncanonicalize (system-pair-car l2))) + (loop l2 (system-pair-cdr l2))))))) \ No newline at end of file diff --git a/v7/src/runtime/prop1d.scm b/v7/src/runtime/prop1d.scm new file mode 100644 index 000000000..e1a588f16 --- /dev/null +++ b/v7/src/runtime/prop1d.scm @@ -0,0 +1,121 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/prop1d.scm,v 14.1 1988/05/20 01:00:22 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; One Dimensional Property Tables +;;; package: 1d-property-package + +(declare (usual-integrations)) + +(define (initialize-package!) + (set! population-of-1d-tables (make-population)) + (add-secondary-gc-daemon! gc-1d-tables!)) + +(define (initialize-unparser!) + (unparser/set-tagged-pair-method! 1d-table-tag + (unparser/standard-method '1D-TABLE))) + +(define population-of-1d-tables) + +(define (gc-1d-tables!) + (map-over-population! population-of-1d-tables 1d-table/clean!)) + +(define (make-1d-table) + (let ((table (list 1d-table-tag))) + (add-to-population! population-of-1d-tables table) + table)) + +(define (1d-table? object) + (and (pair? object) + (eq? (car object) 1d-table-tag))) + +(define 1d-table-tag + "1D table") + +(define false-key + "false key") + +(define-integrable (weak-cons car cdr) + (system-pair-cons (ucode-type weak-cons) car cdr)) + +(define (weak-assq key table) + (let loop ((previous table) (alist (cdr table))) + (and (not (null? alist)) + (let ((entry (car alist)) + (next (cdr alist))) + (let ((key* (system-pair-car entry))) + (cond ((not key*) + (set-cdr! previous next) + (loop previous next)) + ((eq? key* key) + entry) + (else + (loop alist next)))))))) + +(define (1d-table/get table key default) + (let ((entry (weak-assq (or key false-key) table))) + (if entry + (system-pair-cdr entry) + default))) + +(define (1d-table/put! table key value) + (let ((key (or key false-key))) + (let ((entry (weak-assq key table))) + (if entry + (system-pair-set-cdr! entry value) + (set-cdr! table + (cons (weak-cons key value) + (cdr table))))))) + +(define (1d-table/remove! table key) + (let ((key (or key false-key))) + (let loop ((previous table) (alist (cdr table))) + (if (not (null? alist)) + (let ((key* (system-pair-car (car alist))) + (next (cdr alist))) + (loop (if (or (not key*) (eq? key* key)) + ;; Might as well clean whole list. + (begin (set-cdr! previous next) + previous) + alist) + next)))))) + +(define (1d-table/clean! table) + (let loop ((previous table) (alist (cdr table))) + (if (not (null? alist)) + (let ((next (cdr alist))) + (loop (if (system-pair-car (car alist)) + alist + (begin (set-cdr! previous next) + previous)) + next))))) \ No newline at end of file diff --git a/v7/src/runtime/prop2d.scm b/v7/src/runtime/prop2d.scm new file mode 100644 index 000000000..785f1443b --- /dev/null +++ b/v7/src/runtime/prop2d.scm @@ -0,0 +1,127 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/prop2d.scm,v 14.1 1988/05/20 01:00:38 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Two Dimensional Property Tables +;;; package: 2D-property-package + +(declare (usual-integrations)) + +(define (initialize-package!) + (set! system-properties '()) + (set! delete-invalid-hash-numbers! (list-deletor! filter-bucket!)) + (set! delete-invalid-y! (list-deletor! filter-entry!)) + (add-secondary-gc-daemon! gc-system-properties!)) + +(define system-properties) + +(define (2D-put! x y value) + (let ((x-hash (object-hash x)) + (y-hash (object-hash y))) + (let ((bucket (assq x-hash system-properties))) + (if bucket + (let ((entry (assq y-hash (cdr bucket)))) + (if entry + (set-cdr! entry value) + (set-cdr! bucket + (cons (cons y-hash value) + (cdr bucket))))) + (set! system-properties + (cons (cons x-hash + (cons (cons y-hash value) + '())) + system-properties)))))) + +(define (2D-get x y) + (let ((bucket (assq (object-hash x) system-properties))) + (and bucket + (let ((entry (assq (object-hash y) (cdr bucket)))) + (and entry + (cdr entry)))))) + +;;; Returns TRUE iff an entry was removed. +;;; Removes the bucket if the entry removed was the only entry. + +(define (2D-remove! x y) + (let ((bucket (assq (object-hash x) system-properties))) + (and bucket + (begin (set-cdr! bucket + (del-assq! (object-hash y) + (cdr bucket))) + (if (null? (cdr bucket)) + (set! system-properties + (del-assq! (object-hash x) + system-properties))) + true)))) + +;;; This clever piece of code removes all invalid entries and buckets, +;;; and also removes any buckets which [subsequently] have no entries. + +(define (gc-system-properties!) + (set! system-properties (delete-invalid-hash-numbers! system-properties))) + +(define (filter-bucket! bucket) + (or (not (valid-hash-number? (car bucket))) + (begin (set-cdr! bucket (delete-invalid-y! (cdr bucket))) + (null? (cdr bucket))))) + +(define (filter-entry! entry) + (not (valid-hash-number? (car entry)))) + +(define delete-invalid-hash-numbers!) +(define delete-invalid-y!) + +(define (2D-get-alist-x x) + (let ((bucket (assq (object-hash x) system-properties))) + (if bucket + (let loop ((rest (cdr bucket))) + (cond ((null? rest) '()) + ((valid-hash-number? (caar rest)) + (cons (cons (object-unhash (caar rest)) + (cdar rest)) + (loop (cdr rest)))) + (else (loop (cdr rest))))) + '()))) + +(define (2D-get-alist-y y) + (let ((y-hash (object-hash y))) + (let loop ((rest system-properties)) + (cond ((null? rest) '()) + ((valid-hash-number? (caar rest)) + (let ((entry (assq y-hash (cdar rest)))) + (if entry + (cons (cons (object-unhash (caar rest)) + (cdr entry)) + (loop (cdr rest))) + (loop (cdr rest))))) + (else (loop (cdr rest))))))) \ No newline at end of file diff --git a/v7/src/runtime/queue.scm b/v7/src/runtime/queue.scm new file mode 100644 index 000000000..12473c17e --- /dev/null +++ b/v7/src/runtime/queue.scm @@ -0,0 +1,93 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/queue.scm,v 14.1 1988/05/20 01:00:54 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Simple Queue Abstraction + +(declare (usual-integrations)) + +(define-integrable (make-queue) + (cons '() '())) + +(define-integrable (queue-empty? queue) + (null? (car queue))) + +(define-integrable (queued?/unsafe queue item) + (memq item (car queue))) + +(define (enqueue!/unsafe queue object) + (let ((next (cons object '()))) + (if (null? (cdr queue)) + (set-car! queue next) + (set-cdr! (cdr queue) next)) + (set-cdr! queue next))) + +(define (dequeue!/unsafe queue) + (let ((next (car queue))) + (if (null? next) + (error "Attempt to dequeue from empty queue")) + (if (null? (cdr next)) + (begin (set-car! queue '()) + (set-cdr! queue '())) + (set-car! queue (cdr next))) + (car next))) + +(define (queue-map!/unsafe queue procedure) + (let loop () + (if (not (queue-empty? queue)) + (begin (procedure (dequeue!/unsafe queue)) + (loop))))) + +;;; Safe (interrupt locked) versions of the above operations. + +(define-integrable (queued? queue item) + (without-interrupts (lambda () (queued?/unsafe queue item)))) + +(define-integrable (enqueue! queue object) + (without-interrupts (lambda () (enqueue!/unsafe queue object)))) + +(define-integrable (dequeue! queue) + (without-interrupts (lambda () (dequeue!/unsafe queue)))) + +(define (queue-map! queue procedure) + (let ((empty "empty")) + (let loop () + (let ((item + (without-interrupts + (lambda () + (if (queue-empty? queue) + empty + (dequeue!/unsafe queue)))))) + (if (not (eq? item empty)) + (begin (procedure item) + (loop))))))) \ No newline at end of file diff --git a/v7/src/runtime/random.scm b/v7/src/runtime/random.scm new file mode 100644 index 000000000..7e8055415 --- /dev/null +++ b/v7/src/runtime/random.scm @@ -0,0 +1,64 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/random.scm,v 14.1 1988/05/20 01:01:13 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Random Number Generator +;;; package: random-number-package + +(declare (usual-integrations)) + +(define seed) +(define a) +(define m) +(define c) + +(define (initialize-package!) + (set! seed 1) + (set! a (+ (* 3141 1000 1000) (* 592 1000) 621)) + (set! m (integer-expt 2 63)) + (set! c 1)) + +(define (random k) + (if (not (integer? k)) + (error "RANDOM is valid only for integers" k)) + (if (not (and (positive? k) (<= k m))) + (error "RANDOM is valid only for integers from 1 to" m)) + (set! seed (remainder (+ (* a seed) c) m)) + (quotient (* seed k) m)) + +(define (randomize k) + (if (not (integer? k)) + (error "RANDOMIZE is valid only for integers" k)) + (if (not (and (positive? k) (<= k m))) + (error "RANDOMIZE is valid only for integers from 1 to" m)) + (set! seed k)) \ No newline at end of file diff --git a/v7/src/runtime/savres.scm b/v7/src/runtime/savres.scm new file mode 100644 index 000000000..d71249900 --- /dev/null +++ b/v7/src/runtime/savres.scm @@ -0,0 +1,143 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/savres.scm,v 14.1 1988/05/20 01:01:33 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Save/Restore World +;;; package: save/restore-package + +(declare (usual-integrations)) + +;;; (DISK-SAVE filename #!optional identify) +;;; (DUMP-WORLD filename #!optional identify) +;;; Saves a world image in FILENAME. IDENTIFY has the following meaning: +;;; +;;; [] Not supplied => ^G on restore (normal for saving band). +;;; [] String => New world ID message, and ^G on restore. +;;; [] Otherwise => Returns normally (very useful for saving bugs!). +;;; +;;; The image saved by DISK-SAVE does not include the "microcode", the +;;; one saved by DUMP-WORLD does, and is an executable file. + +(define (initialize-package!) + (set! disk-save (setup-image disk-save/kernel)) + (set! dump-world (setup-image dump-world/kernel))) + +(define disk-save) +(define dump-world) + +(define (setup-image save-image) + (lambda (filename #!optional identify) + (let ((identify + (if (default-object? identify) world-identification identify)) + (time (get-decoded-time))) + (gc-flip) + (trigger-secondary-gc-daemons!) + (save-image filename + (lambda () + (set! time-world-saved time) + *the-non-printing-object*) + (lambda () + (set! time-world-saved time) + (event-distributor/invoke! event:after-restore) + (or (not (string? identify)) + (begin + (set! world-identification identify) + (clear console-output-port) + (abort->top-level + (lambda (cmdl) + (identify-world cmdl) + (event-distributor/invoke! + event:after-restart)))))))))) + +(define (disk-save/kernel filename after-suspend after-restore) + ((without-interrupts + (lambda () + (call-with-current-continuation + (lambda (continuation) + (let ((fixed-objects (get-fixed-objects-vector)) + (dynamic-state (current-dynamic-state))) + (fluid-let () + ((ucode-primitive call-with-current-continuation) + (lambda (restart) + (gc-flip) + (let loop () + (if (not ((ucode-primitive dump-band) + restart + (canonicalize-output-filename filename))) + (begin + (error "Disk save failed: (PROCEED 0) to retry") + (loop)))) + (continuation after-suspend))) + ((ucode-primitive set-fixed-objects-vector!) fixed-objects) + (set-current-dynamic-state! dynamic-state) + ;; This instruction is a noop, so I flushed it -- cph. + ;; (enable-interrupts! interrupt-mask/none) + (read-microcode-tables!) + after-restore)))))))) + +(define (dump-world/kernel filename after-suspend after-restore) + ((with-absolutely-no-interrupts + (lambda () + (if ((ucode-primitive dump-world 1) filename) + after-restore + after-suspend))))) + +(define (disk-restore #!optional filename) + (if (default-object? filename) + (set! filename + (or ((ucode-primitive reload-band-name)) + (error "DISK-RESTORE: No default band name available")))) + (close-all-open-files) + ((ucode-primitive load-band) (canonicalize-input-filename filename))) +(define world-identification "Scheme") +(define time-world-saved) + +(define (identify-world #!optional cmdl) + (let ((cmdl (if (default-object? cmdl) (nearest-cmdl) cmdl))) + (let ((port (cmdl/output-port cmdl))) + (newline port) + (write-string world-identification port) + (if time-world-saved + (begin + (write-string " saved on " port) + (write-string (decoded-time/date-string time-world-saved) port) + (write-string " at " port) + (write-string (decoded-time/time-string time-world-saved) port))) + (newline port) + (write-string " Release " port) + (write-string microcode-id/release-string port) + (for-each-system! + (lambda (system) + (newline port) + (write-string " " port) + (write-string (system/identification-string system) port)))))) \ No newline at end of file diff --git a/v7/src/runtime/strnin.scm b/v7/src/runtime/strnin.scm new file mode 100644 index 000000000..a5982e744 --- /dev/null +++ b/v7/src/runtime/strnin.scm @@ -0,0 +1,126 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/strnin.scm,v 14.1 1988/05/20 01:01:53 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; String I/O Ports +;;; package: string-io-package + +(declare (usual-integrations)) + +(define (initialize-package!) + (set! input-string-template + (make-input-port `((CHAR-READY? ,operation/char-ready?) + (DISCARD-CHAR ,operation/discard-char) + (DISCARD-CHARS ,operation/discard-chars) + (PEEK-CHAR ,operation/peek-char) + (PRINT-SELF ,operation/print-self) + (READ-CHAR ,operation/read-char) + (READ-STRING ,operation/read-string)) + false))) + +(define (with-input-from-string string thunk) + (with-input-from-port (string->input-port string) thunk)) + +(define (string->input-port string #!optional start end) + (input-port/copy input-string-template + (make-input-string-state + string + (if (default-object? start) 0 start) + (if (default-object? end) (string-length string) end)))) + +(define input-string-template) + +(define-structure (input-string-state (type vector) + (conc-name input-string-state/)) + (string false read-only true) + start + (end false read-only true)) + +(define-integrable (input-port/string port) + (input-string-state/string (input-port/state port))) + +(define-integrable (input-port/start port) + (input-string-state/start (input-port/state port))) + +(define-integrable (set-input-port/start! port index) + (set-input-string-state/start! (input-port/state port) index)) + +(define-integrable (input-port/end port) + (input-string-state/end (input-port/state port))) + +(define (operation/char-ready? port interval) + interval + (< (input-port/start port) (input-port/end port))) + +(define (operation/peek-char port) + (and (< (input-port/start port) (input-port/end port)) + (string-ref (input-port/string port) (input-port/start port)))) + +(define (operation/discard-char port) + (set-input-port/start! port (1+ (input-port/start port)))) + +(define (operation/read-char port) + (let ((start (input-port/start port))) + (and (< start (input-port/end port)) + (begin (set-input-port/start! port (1+ start)) + (string-ref (input-port/string port) start))))) + +(define (operation/read-string port delimiters) + (let ((start (input-port/start port)) + (end (input-port/end port))) + (and (< start end) + (let ((string (input-port/string port))) + (let ((index + (or (substring-find-next-char-in-set string + start + end + delimiters) + end))) + (set-input-port/start! port index) + (substring string start index)))))) + +(define (operation/discard-chars port delimiters) + (let ((start (input-port/start port)) + (end (input-port/end port))) + (if (< start end) + (set-input-port/start! + port + (or (substring-find-next-char-in-set (input-port/string port) + start + end + delimiters) + end))))) + +(define (operation/print-self state port) + port + (unparse-string state "from string")) \ No newline at end of file diff --git a/v7/src/runtime/strott.scm b/v7/src/runtime/strott.scm new file mode 100644 index 000000000..1313b9741 --- /dev/null +++ b/v7/src/runtime/strott.scm @@ -0,0 +1,89 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/strott.scm,v 14.1 1988/05/20 01:02:10 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; String Output Ports (Truncated) +;;; package: truncated-string-output-package + +(declare (usual-integrations)) + +(define (initialize-package!) + (set! output-string-template + (make-output-port `((PRINT-SELF ,operation/print-self) + (WRITE-CHAR ,operation/write-char) + (WRITE-STRING ,operation/write-string)) + false))) + +(define (with-output-to-truncated-string max thunk) + (call-with-current-continuation + (lambda (return) + (cons false + (apply string-append + (reverse! + (let ((state + (make-output-string-state return max '() max))) + (with-output-to-port + (output-port/copy output-string-template state) + thunk) + (output-string-state/accumulator state)))))))) + +(define output-string-template) + +(define-structure (output-string-state (type vector) + (conc-name output-string-state/)) + (return false read-only true) + (max-length false read-only true) + accumulator + counter) + +(define (operation/write-string port string) + (let ((state (output-port/state port))) + (let ((accumulator (cons string (output-string-state/accumulator state))) + (counter + (- (output-string-state/counter state) (string-length string)))) + (if (negative? counter) + ((output-string-state/return state) + (cons true + (substring (apply string-append (reverse! accumulator)) + 0 + (output-string-state/max-length state)))) + (begin + (set-output-string-state/accumulator! state accumulator) + (set-output-string-state/counter! state counter)))))) + +(define (operation/write-char port char) + (operation/write-string port (char->string char))) + +(define (operation/print-self state port) + port + (unparse-string state "to string (truncated)")) \ No newline at end of file diff --git a/v7/src/runtime/strout.scm b/v7/src/runtime/strout.scm new file mode 100644 index 000000000..89147753d --- /dev/null +++ b/v7/src/runtime/strout.scm @@ -0,0 +1,64 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/strout.scm,v 14.1 1988/05/20 01:02:26 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; String Output Ports +;;; package: string-output-package + +(declare (usual-integrations)) + +(define (initialize-package!) + (set! output-string-template + (make-output-port `((PRINT-SELF ,operation/print-self) + (WRITE-CHAR ,operation/write-char) + (WRITE-STRING ,operation/write-string)) + false))) + +(define (with-output-to-string thunk) + (apply string-append + (reverse! + (let ((port (output-port/copy output-string-template '()))) + (with-output-to-port port thunk) + (output-port/state port))))) + +(define output-string-template) + +(define-integrable (operation/write-string port string) + (set-output-port/state! port (cons string (output-port/state port)))) + +(define (operation/write-char port char) + (operation/write-string port (char->string char))) + +(define (operation/print-self state port) + port + (unparse-string state "to string")) \ No newline at end of file diff --git a/v7/src/runtime/syntab.scm b/v7/src/runtime/syntab.scm new file mode 100644 index 000000000..475f22e98 --- /dev/null +++ b/v7/src/runtime/syntab.scm @@ -0,0 +1,82 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntab.scm,v 14.1 1988/05/20 01:02:42 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Syntax Table +;;; package: syntax-table-package + +(declare (usual-integrations)) + +(define-structure (syntax-table (constructor %make-syntax-table) + (conc-name syntax-table/)) + alist + (parent false read-only true)) + +(define (make-syntax-table #!optional parent) + (if (default-object? parent) + (set! parent false) + (check-syntax-table parent 'MAKE-SYNTAX-TABLE)) + (%make-syntax-table '() parent)) + +(define (check-syntax-table table name) + (if (not (syntax-table? table)) + (error "Not a syntax table" name table))) + +(define (syntax-table-ref table name) + (check-syntax-table table 'SYNTAX-TABLE-REF) + (let loop ((table table)) + (and table + (let ((entry (assq name (syntax-table/alist table)))) + (if entry + (cdr entry) + (loop (syntax-table/parent table))))))) + +(define (syntax-table-define table name transform) + (check-syntax-table table 'SYNTAX-TABLE-DEFINE) + (let ((entry (assq name (syntax-table/alist table)))) + (if entry + (set-cdr! entry transform) + (set-syntax-table/alist! table + (cons (cons name transform) + (syntax-table/alist table)))))) + +(define (syntax-table/copy table) + (check-syntax-table table 'SYNTAX-TABLE/COPY) + (let loop ((table table)) + (and table + (%make-syntax-table (alist-copy (syntax-table/alist table)) + (loop (syntax-table/parent table)))))) + +(define (syntax-table/extend table alist) + (check-syntax-table table 'SYNTAX-TABLE/EXTEND) + (%make-syntax-table (alist-copy alist) table)) \ No newline at end of file diff --git a/v7/src/runtime/sysmac.scm b/v7/src/runtime/sysmac.scm new file mode 100644 index 000000000..2b9aad691 --- /dev/null +++ b/v7/src/runtime/sysmac.scm @@ -0,0 +1,129 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sysmac.scm,v 14.1 1988/05/20 01:03:06 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; System Internal Syntax +;;; package: system-macros-package + +(declare (usual-integrations)) + +(define (initialize-package!) + (set! syntax-table/system-internal (make-system-internal-syntax-table))) + +(define syntax-table/system-internal) + +(define (make-system-internal-syntax-table) + (let ((table (make-syntax-table system-global-syntax-table))) + (for-each (lambda (entry) + (syntax-table-define table (car entry) (cadr entry))) + `((DEFINE-INTEGRABLE ,transform/define-integrable) + (DEFINE-PRIMITIVES ,transform/define-primitives) + (UCODE-PRIMITIVE ,transform/ucode-primitive) + (UCODE-RETURN-ADDRESS ,transform/ucode-return-address) + (UCODE-TYPE ,transform/ucode-type))) + table)) + +(define transform/define-primitives + (macro names + `(BEGIN ,@(map (lambda (name) + (cond ((not (pair? name)) + (primitive-definition name (list name))) + ((not (symbol? (cadr name))) + (primitive-definition (car name) name)) + (else + (primitive-definition (car name) (cdr name))))) + names)))) + +(define (primitive-definition variable-name primitive-args) + `(DEFINE-INTEGRABLE ,variable-name + ,(apply make-primitive-procedure primitive-args))) + +(define transform/ucode-type + (macro arguments + (apply microcode-type arguments))) + +(define transform/ucode-primitive + (macro arguments + (apply make-primitive-procedure arguments))) + +(define transform/ucode-return-address + (macro arguments + (make-return-address (apply microcode-return arguments)))) + +(define transform/define-integrable + (macro (pattern . body) + (parse-define-syntax pattern body + (lambda (name body) + `(BEGIN (DECLARE (INTEGRATE ,pattern)) + (DEFINE ,name ,@body))) + (lambda (pattern body) + `(BEGIN (DECLARE (INTEGRATE-OPERATOR ,(car pattern))) + (DEFINE ,pattern + ,@(if (list? (cdr pattern)) + `((DECLARE + (INTEGRATE + ,@(lambda-list->bound-names (cdr pattern))))) + '()) + ,@body)))))) + +(define (parse-define-syntax pattern body if-variable if-lambda) + (cond ((pair? pattern) + (let loop ((pattern pattern) (body body)) + (cond ((pair? (car pattern)) + (loop (car pattern) `((LAMBDA ,(cdr pattern) ,@body)))) + ((symbol? (car pattern)) + (if-lambda pattern body)) + (else + (error "Illegal name" (car pattern)))))) + ((symbol? pattern) + (if-variable pattern body)) + (else + (error "Illegal name" pattern)))) + +(define (lambda-list->bound-names lambda-list) + (cond ((null? lambda-list) + '()) + ((pair? lambda-list) + (let ((lambda-list + (if (eq? (car lambda-list) lambda-optional-tag) + (begin (if (not (pair? (cdr lambda-list))) + (error "Missing optional variable" lambda-list)) + (cdr lambda-list)) + lambda-list))) + (cons (let ((parameter (car lambda-list))) + (if (pair? parameter) (car parameter) parameter)) + (lambda-list->bound-names (cdr lambda-list))))) + (else + (if (not (symbol? lambda-list)) + (error "Illegal rest variable" lambda-list)) + (list lambda-list)))) \ No newline at end of file diff --git a/v7/src/runtime/udata.scm b/v7/src/runtime/udata.scm new file mode 100644 index 000000000..ae11be816 --- /dev/null +++ b/v7/src/runtime/udata.scm @@ -0,0 +1,308 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/udata.scm,v 14.1 1988/05/20 01:04:01 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Simple Microcode Data Structures + +(declare (usual-integrations)) + +(define-integrable (return-address? object) + (object-type? (ucode-type return-address) object)) + +(define-integrable (make-return-address code) + ((ucode-primitive map-code-to-machine-address 2) (ucode-type return-address) + code)) + +(define-integrable (return-address/code return-address) + ((ucode-primitive map-machine-address-to-code 2) (ucode-type return-address) + return-address)) + +(define (return-address/name return-address) + (microcode-return/code->name (return-address/code return-address))) + +(define (microcode-error name) + (or (microcode-error/name->code name) + (error "MICROCODE-ERROR: Unknown name" name))) + +(define (microcode-return name) + (or (microcode-return/name->code name) + (error "MICROCODE-RETURN: Unknown name" name))) + +(define (microcode-termination name) + (or (microcode-termination/name->code name) + (error "MICROCODE-TERMINATION: Unknown name" name))) + +(define (microcode-type name) + (or (microcode-type/name->code name) + (error "MICROCODE-TYPE: Unknown name" name))) + +;;;; Compiled Code Entries + +(define-integrable (compiled-code-address? object) + (object-type? (ucode-type compiled-entry) object)) + +(define (compiled-entry-type object) + (if (not (compiled-code-address? object)) + (error "COMPILED-ENTRY-TYPE: bad compiled entry" object)) + (let ((place (assq (system-hunk3-cxr0 + ((ucode-primitive compiled-entry-kind 1) object)) + '((0 . COMPILED-PROCEDURE) + (1 . COMPILED-RETURN-ADDRESS) + (2 . COMPILED-EXPRESSION))))) + (if place + (cdr place) + 'COMPILED-ENTRY))) + +(define-integrable compiled-code-address->block + (ucode-primitive compiled-code-address->block)) + +(define-integrable compiled-code-address->offset + (ucode-primitive compiled-code-address->offset)) + +(define (compiled-procedure? object) + (and (compiled-code-address? object) + (eq? (compiled-entry-type object) 'COMPILED-PROCEDURE))) + +(define (compiled-procedure-arity object) + (if (not (compiled-procedure? object)) + (error "COMPILED-PROCEDURE-ARITY: bad compiled procedure" object)) + (let ((info ((ucode-primitive compiled-entry-kind 1) object))) + (cons (-1+ (system-hunk3-cxr1 info)) + (let ((max (system-hunk3-cxr2 info))) + (and (not (negative? max)) + (-1+ max)))))) +(define-integrable (compiled-code-block? object) + (object-type? (ucode-type compiled-code-block) object)) + +(define-integrable (compiled-code-block/read-file filename) + (compiled-code-address->block (fasload filename))) + +;;; These are now pretty useless. + +(define (compiled-procedure-entry procedure) + (if (not (compiled-procedure? procedure)) + (error "Not a compiled procedure" procedure)) + procedure) + +(define (compiled-procedure-environment procedure) + (if (not (compiled-procedure? procedure)) + (error "Not a compiled procedure" procedure)) + '()) + +;;;; Compiled Code Blocks + +#| + +Compiled code blocks contain both nonmarked code and marked constants. + +Code positions are referred to as OFFSETS, which start from the +beginning of the block and are measured in bytes. The positions of +constants are referred to as INDICES, and use the normal index +numbering for vectors. The conversion between offsets and indices is +specified by COMPILED-CODE-BLOCK/BYTES-PER-OBJECT, which should be set +to the correct value before these operations are used. + +|# + +(define compiled-code-block/bytes-per-object) + +(define (compiled-code-block/index->offset index) + (* (1+ index) compiled-code-block/bytes-per-object)) + +(define (compiled-code-block/offset->index offset) + (-1+ (quotient offset compiled-code-block/bytes-per-object))) + +(define (compiled-code-block/code-length block) + (* compiled-code-block/bytes-per-object + (object-datum (system-vector-ref block 0)))) + +(define (compiled-code-block/code-start block) + block + (* compiled-code-block/bytes-per-object 2)) + +(define (compiled-code-block/code-end block) + (+ (compiled-code-block/code-start block) + (compiled-code-block/code-length block))) + +(define (compiled-code-block/constants-start block) + (1+ (object-datum (system-vector-ref block 0)))) + +(define (compiled-code-block/constants-end block) + (- (system-vector-length block) 2)) + +(define (compiled-code-block/debugging-info? block) + (not (memq (compiled-code-block/debugging-info block) '(#F DEBUGGING-INFO)))) + +(define (compiled-code-block/debugging-info block) + (system-vector-ref block (- (system-vector-length block) 2))) + +(define (set-compiled-code-block/debugging-info! block info) + (system-vector-set! block (- (system-vector-length block) 2) info)) + +(define (compiled-code-block/environment block) + (system-vector-ref block (-1+ (system-vector-length block)))) + +;;;; Environment Extensions + +(define-integrable (environment-extension? object) + (vector? object)) + +(define-integrable (environment-extension-parent extension) + (vector-ref extension 0)) + +(define-integrable (set-environment-extension-parent! extension parent) + (vector-set! extension 0 parent)) + +(define-integrable (environment-extension-procedure extension) + (vector-ref extension 1)) + +(define (environment-extension-aux-list extension) + (let filter-potentially-dangerous + ((aux-list + (let ((first-aux-slot 3)) + (subvector->list + extension + first-aux-slot + (+ first-aux-slot (object-datum (vector-ref extension 2))))))) + (cond ((null? aux-list) '()) + ((unbound-reference-trap? + (map-reference-trap (lambda () (cdar aux-list)))) + (filter-potentially-dangerous (cdr aux-list))) + (else + (cons (car aux-list) + (filter-potentially-dangerous (cdr aux-list))))))) + +;;;; Promises + +(define-integrable (promise? object) + (object-type? (ucode-type delayed) object)) + +(define-integrable (promise-forced? promise) + (eq? true (system-pair-car promise))) + +(define-integrable (promise-non-expression? promise) + (eqv? 0 (system-pair-car promise))) + +(define (promise-value promise) + (if (not (promise-forced? promise)) + (error "Promise not yet forced" promise)) + (system-pair-cdr promise)) + +(define (promise-expression promise) + (if (promise-forced? promise) + (error "Promise already forced" promise)) + (if (promise-non-expression? promise) + (error "Promise has no expression" promise)) + (system-pair-cdr promise)) + +(define (promise-environment promise) + (if (promise-forced? promise) + (error "Promise already forced" promise)) + (if (promise-non-expression? promise) + (error "Promise has no environment" promise)) + (system-pair-car promise)) + +;;;; Procedures + +(define-integrable (primitive-procedure? object) + (object-type? (ucode-type primitive) object)) + +(define (make-primitive-procedure name #!optional arity) + (let ((arity (if (default-object? arity) false 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) + (error "MAKE-PRIMITIVE-PROCEDURE: inconsistent arity" + name 'NEW: arity 'OLD: result))) + result))) + +(define (implemented-primitive-procedure? object) + ((ucode-primitive get-primitive-address) (primitive-procedure-name object) + false)) + +(define (primitive-procedure-name primitive) + (if (not (primitive-procedure? primitive)) + (error "PRIMITIVE-PROCEDURE-NAME: Not a primitive procedure" primitive)) + ((ucode-primitive get-primitive-name) (object-datum primitive))) + +(define (compound-procedure? object) + (or (object-type? (ucode-type procedure) object) + (object-type? (ucode-type extended-procedure) object))) + +(define-integrable (compound-procedure-lambda procedure) + (system-pair-car procedure)) + +(define-integrable (compound-procedure-environment procedure) + (system-pair-cdr procedure)) + +(define (procedure? object) + (or (compound-procedure? object) + (primitive-procedure? object) + (compiled-procedure? object))) + +(define (procedure-lambda procedure) + (if (not (compound-procedure? procedure)) + (error "PROCEDURE-LAMBDA: Not a compound procedure" procedure)) + (compound-procedure-lambda procedure)) + +(define (procedure-environment procedure) + (if (not (compound-procedure? procedure)) + (error "PROCEDURE-ENVIRONMENT: Not a compound procedure" procedure)) + (compound-procedure-environment procedure)) + +(define (procedure-arity procedure) + (cond ((primitive-procedure? procedure) + (let ((arity (primitive-procedure-arity procedure))) + (if (negative? arity) + (cons 0 false) + (cons arity arity)))) + ((compound-procedure? procedure) + (lambda-components (compound-procedure-lambda procedure) + (lambda (name required optional rest auxiliary decl body) + name auxiliary decl body + (let ((r (length required))) + (cons r + (and (not rest) + (+ r (length optional)))))))) + ((compiled-procedure? procedure) + (compiled-procedure-arity procedure)) + (else + (error "PROCEDURE-ARITY: not a procedure" procedure)))) +(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)))) \ No newline at end of file diff --git a/v7/src/runtime/uenvir.scm b/v7/src/runtime/uenvir.scm new file mode 100644 index 000000000..9d6394c17 --- /dev/null +++ b/v7/src/runtime/uenvir.scm @@ -0,0 +1,141 @@ +;;; -*-Scheme-*- +;;; +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uenvir.scm,v 14.1 1988/05/20 01:04:16 cph Exp $ +;;; +;;; Copyright (c) 1988 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of this +;;; software shall duly acknowledge such use, in accordance with +;;; the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; + +;;;; Microcode Environments + +(declare (usual-integrations)) + +;;;; Environment + +(define-integrable (environment? object) + (object-type? (ucode-type environment) object)) + +(define (environment-procedure environment) + (select-procedure (environment->external environment))) + +(define (environment-has-parent? environment) + (not (eq? (select-parent (environment->external environment)) + null-environment))) + +(define (environment-parent environment) + (select-parent (environment->external environment))) + +(define (environment-bindings environment) + (environment-split environment + (lambda (external internal) + (map (lambda (name) + (cons name + (if (lexical-unassigned? internal name) + '() + `(,(lexical-reference internal name))))) + (list-transform-negative + (map* (lambda-bound (select-lambda external)) + car + (let ((extension (environment-extension internal))) + (if (environment-extension? extension) + (environment-extension-aux-list extension) + '()))) + (lambda (name) + (lexical-unbound? internal name))))))) + +(define (environment-arguments environment) + (environment-split environment + (lambda (external internal) + (let ((lookup + (lambda (name) + (if (lexical-unassigned? internal name) + (make-unassigned-reference-trap) + (lexical-reference internal name))))) + (lambda-components* (select-lambda external) + (lambda (name required optional rest body) + name body + (map* (let loop ((names optional)) + (cond ((null? names) (if rest (lookup rest) '())) + ((lexical-unassigned? internal (car names)) '()) + (else + (cons (lookup (car names)) (loop (cdr names)))))) + lookup + required))))))) + +(define (set-environment-parent! environment parent) + (system-pair-set-cdr! + (let ((extension (environment-extension environment))) + (if (environment-extension? extension) + (begin (set-environment-extension-parent! extension parent) + (environment-extension-procedure extension)) + extension)) + parent)) + +(define (remove-environment-parent! environment) + (set-environment-parent! environment null-environment)) + +(define null-environment + (object-new-type (ucode-type null) 1)) + +(define (environment-split environment receiver) + (let ((procedure (select-procedure environment))) + (let ((lambda (compound-procedure-lambda procedure))) + (receiver (if (internal-lambda? lambda) + (compound-procedure-environment procedure) + environment) + environment)))) + +(define (environment->external environment) + (let ((procedure (select-procedure environment))) + (if (internal-lambda? (compound-procedure-lambda procedure)) + (compound-procedure-environment procedure) + environment))) + +(define-integrable (select-extension environment) + (system-vector-ref environment 0)) + +(define (select-procedure environment) + (let ((object (select-extension environment))) + (if (environment-extension? object) + (environment-extension-procedure object) + object))) + +(define (select-parent environment) + (compound-procedure-environment (select-procedure environment))) + +(define (select-lambda environment) + (compound-procedure-lambda (select-procedure environment))) + +(define (environment-extension environment) + (select-extension (environment->external environment))) \ No newline at end of file diff --git a/v7/src/runtime/uerror.scm b/v7/src/runtime/uerror.scm new file mode 100644 index 000000000..f6c9c7c60 --- /dev/null +++ b/v7/src/runtime/uerror.scm @@ -0,0 +1,541 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uerror.scm,v 14.1 1988/05/20 01:04:37 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Microcode Errors +;;; package: microcode-errors + +(declare (usual-integrations)) + +(define (initialize-package!) + (set! internal-apply-frame/fasload? + (internal-apply-frame/operator-filter + (ucode-primitive binary-fasload) + (ucode-primitive load-band))) + (set! internal-apply-frame/fasdump? + (internal-apply-frame/operator-filter + (ucode-primitive primitive-fasdump))) + (set! internal-apply-frame/file-open-channel? + (internal-apply-frame/operator-filter + (ucode-primitive file-open-channel))) + (build-condition-types!) + (set! microcode-error-types (make-error-types)) + (set! error-type:bad-error-code (microcode-error-type 'BAD-ERROR-CODE)) + (let ((fixed-objects (get-fixed-objects-vector))) + (vector-set! fixed-objects + (fixed-objects-vector-slot 'SYSTEM-ERROR-VECTOR) + (make-error-handlers)) + ((ucode-primitive set-fixed-objects-vector!) fixed-objects))) + +(define (make-error-handlers) + (let ((error-code-limit (microcode-error/code-limit))) + (let ((alists (make-error-alists error-code-limit))) + (make-initialized-vector error-code-limit + (lambda (index) + (let ((alist (vector-ref alists index))) + (if (procedure? alist) + alist + (let ((error-type (vector-ref microcode-error-types index))) + (if error-type + (make-error-translator alist error-type) + anomalous-microcode-error))))))))) + +(define (make-error-translator alist error-type) + (lambda (error-code interrupt-enables) + (set-interrupt-enables! interrupt-enables) + (with-proceed-point proceed-value-filter + (lambda () + (signal-condition + (let ((frame + (continuation/first-subproblem + (current-proceed-continuation)))) + (let ((translator + (let ((entry (assv (stack-frame/return-code frame) alist))) + (and entry + (let loop ((translators (cdr entry))) + (and (not (null? translators)) + (if (or (eq? (caar translators) true) + ((caar translators) frame)) + (cdar translators) + (loop (cdr translators))))))))) + (if translator + (translator error-type frame) + (make-error-condition error-type:missing-handler + (list error-type) + repl-environment))))))))) + +(define (anomalous-microcode-error error-code interrupt-enables) + (set-interrupt-enables! interrupt-enables) + (with-proceed-point proceed-value-filter + (lambda () + (signal-condition + (make-error-condition + error-type:anomalous + (list (or (microcode-error/code->name error-code) error-code)) + repl-environment))))) + +;;;; Frame Decomposition + +(define-integrable (standard-frame/expression frame) + (stack-frame/ref frame 0)) + +(define-integrable (standard-frame/environment frame) + (stack-frame/ref frame 1)) + +(define (standard-frame/variable? frame) + (variable? (standard-frame/expression frame))) + +(define-integrable (expression-only-frame/expression frame) + (stack-frame/ref frame 0)) + +(define-integrable (internal-apply-frame/operator frame) + (stack-frame/ref frame 2)) + +(define-integrable (internal-apply-frame/operand frame index) + (stack-frame/ref frame (+ 3 index))) + +(define-integrable (internal-apply-frame/n-operands frame) + (- (stack-frame/length frame) 3)) + +(define (internal-apply-frame/select frame selector) + (if (integer? selector) (internal-apply-frame/operand frame selector) + (selector frame))) + +(define ((internal-apply-frame/operator-filter . operators) frame) + (memq (internal-apply-frame/operator frame) operators)) + +(define internal-apply-frame/fasload?) +(define internal-apply-frame/fasdump?) +(define internal-apply-frame/file-open-channel?) + +(define (internal-apply-frame/add-fluid-binding-name frame) + (let ((name (internal-apply-frame/operand frame 1))) + (cond ((variable? name) (variable-name name)) + ((symbol? name) name) + (else name)))) + +;;;; Special Handlers + +(define (wrong-number-of-arguments-error condition-type frame) + (make-error-condition + condition-type + (let ((operator (internal-apply-frame/operator frame))) + (let ((arity (procedure-arity operator))) + (list (internal-apply-frame/n-operands frame) + (error-irritant/noise char:newline) + (error-irritant/noise "within procedure") + operator + (error-irritant/noise char:newline) + (error-irritant/noise "minimum/maximum number of arguments:") + (car arity) + (cdr arity)))) + repl-environment)) + +(define (open-file-error condition-type frame) + condition-type + (make-error-condition error-type:open-file + (list (internal-apply-frame/operand frame 0)) + repl-environment)) + +(define (out-of-file-handles-error condition-type frame) + (make-error-condition condition-type + (list (internal-apply-frame/operand frame 0)) + repl-environment)) + +(define (write-into-pure-space-error error-code interrupt-enables) + error-code + (set-interrupt-enables! interrupt-enables) + (let ((port (cmdl/output-port (nearest-cmdl)))) + (newline port) + (write-string "Automagically impurifying an object..." port)) + (call-with-current-continuation + (lambda (continuation) + (impurify + (internal-apply-frame/operand + (continuation/first-subproblem continuation) + 0))))) + +(define (bad-error-code-handler error-code interrupt-enables) + ;; This could be a "translator" except that it needs the error-code + ;; and "translators" don't normally get it. + (set-interrupt-enables! interrupt-enables) + (with-proceed-point proceed-value-filter + (lambda () + (signal-condition + (make-error-condition error-type:bad-error-code + (list error-code) + repl-environment))))) + +(define error-type:bad-error-code) + +(define error-type:anomalous) +(define error-type:bad-range-argument) +(define error-type:failed-argument-coercion) +(define error-type:fasdump) +(define error-type:fasload) +(define error-type:illegal-argument) +(define error-type:missing-handler) +(define error-type:open-file) +(define error-type:random-internal) +(define error-type:wrong-type-argument) + +(define (build-condition-types!) + (set! error-type:random-internal + (make-base-type "Random internal error")) + (set! error-type:illegal-argument + (make-base-type "Illegal argument")) + (set! error-type:wrong-type-argument + (make-condition-type (list error-type:illegal-argument) + "Illegal datum")) + (set! error-type:bad-range-argument + (make-condition-type (list error-type:illegal-argument) + "Datum out of range")) + (set! error-type:failed-argument-coercion + (make-base-type "Argument cannot be coerced to floating point")) + (set! error-type:open-file + (make-base-type "Unable to open file")) + (set! error-type:fasdump + (make-base-type "Fasdump error")) + (set! error-type:fasload + (make-base-type "Fasload error")) + (set! error-type:anomalous + (make-internal-type "Anomalous microcode error")) + (set! error-type:missing-handler + (make-internal-type "Missing handler for microcode error"))) + +(define (make-base-type message) + (make-condition-type (list condition-type:error) message)) + +(define (make-internal-type message) + (make-condition-type (list error-type:random-internal) + (string-append message " -- get a wizard"))) + +(define (make-bad-range-type n) + (make-condition-type (list error-type:bad-range-argument) + (string-append "Datum out of range in " + (vector-ref nth-string n) + " argument position"))) + +(define (make-wrong-type-type n) + (make-condition-type (list error-type:bad-range-argument) + (string-append "Illegal datum in " + (vector-ref nth-string n) + " argument position"))) + +(define (make-failed-arg-type n) + (make-condition-type (list error-type:failed-argument-coercion) + (string-append + (string-capitalize (vector-ref nth-string n)) + " argument cannot be coerced to floating point"))) + +(define nth-string + '#("first" "second" "third" "fourth" "fifth" "sixth" "seventh" "eighth" + "ninth" "tenth")) + +(define (microcode-error-type name) + (vector-ref microcode-error-types (microcode-error name))) + +(define microcode-error-types) + +(define (make-error-types) + (let ((types (make-vector (microcode-error/code-limit) false))) + (for-each + (lambda (entry) + (vector-set! types (microcode-error (car entry)) (cadr entry))) + `( + (BAD-ASSIGNMENT ,(make-internal-type "Bound variable")) (BAD-ERROR-CODE ,(make-internal-type "Illegal error code")) + (BAD-FRAME ,(make-internal-type "Illegal environment frame")) + (BAD-INTERRUPT-CODE ,(make-internal-type "Illegal interrupt code")) + (BAD-RANGE-ARGUMENT-0 ,(make-bad-range-type 0)) + (BAD-RANGE-ARGUMENT-1 ,(make-bad-range-type 1)) + (BAD-RANGE-ARGUMENT-2 ,(make-bad-range-type 2)) + (BAD-RANGE-ARGUMENT-3 ,(make-bad-range-type 3)) + (BAD-RANGE-ARGUMENT-4 ,(make-bad-range-type 4)) + (BAD-RANGE-ARGUMENT-5 ,(make-bad-range-type 5)) + (BAD-RANGE-ARGUMENT-6 ,(make-bad-range-type 6)) + (BAD-RANGE-ARGUMENT-7 ,(make-bad-range-type 7)) + (BAD-RANGE-ARGUMENT-8 ,(make-bad-range-type 8)) + (BAD-RANGE-ARGUMENT-9 ,(make-bad-range-type 9)) + (BROKEN-CVARIABLE ,(make-internal-type "Broken compiled variable")) + (BROKEN-VARIABLE-CACHE + ,(make-internal-type "Broken variable value cell")) + (COMPILED-CODE-ERROR ,(make-internal-type "Compiled code error")) + (EXECUTE-MANIFEST-VECTOR + ,(make-internal-type "Attempt to execute manifest vector")) + (EXTERNAL-RETURN + ,(make-internal-type "Error during external application")) + (FAILED-ARG-1-COERCION ,(make-failed-arg-type 0)) + (FAILED-ARG-2-COERCION ,(make-failed-arg-type 1)) + (FASDUMP-ENVIRONMENT + ,(make-condition-type + (list error-type:fasdump) + "Object to dump is or points to environment objects")) + (FASL-FILE-BAD-DATA + ,(make-condition-type (list error-type:fasload) "Bad binary file")) + (FASL-FILE-TOO-BIG + ,(make-condition-type (list error-type:fasload) "Not enough room")) + (FASLOAD-BAND + ,(make-condition-type + (list error-type:fasload) + "Binary file contains a scheme image (band), not an object")) + (FASLOAD-COMPILED-MISMATCH + ,(make-condition-type + (list error-type:fasload) + "Binary file contains compiled code for a different microcode")) + (FLOATING-OVERFLOW ,(make-base-type "Floating point overflow")) + (ILLEGAL-REFERENCE-TRAP ,(make-internal-type "Illegal reference trap")) + (INAPPLICABLE-CONTINUATION + ,(make-internal-type "Inapplicable continuation")) + (IO-ERROR ,(make-base-type "I/O error")) + (OUT-OF-FILE-HANDLES + ,(make-condition-type (list error-type:open-file) + "Too many open files")) + (UNASSIGNED-VARIABLE ,(make-base-type "Unassigned variable")) + (UNBOUND-VARIABLE ,(make-base-type "Unbound variable")) + (UNDEFINED-PRIMITIVE-OPERATION + ,(make-internal-type "Undefined primitive procedure")) + (UNDEFINED-PROCEDURE + ,(make-base-type "Application of inapplicable object")) + (UNDEFINED-USER-TYPE ,(make-internal-type "Undefined type code")) + (UNIMPLEMENTED-PRIMITIVE + ,(make-internal-type "Unimplemented primitive procedure")) + (WRONG-ARITY-PRIMITIVES + ,(make-condition-type + (list error-type:fasload) + "Primitives in binary file have the wrong arity")) + (WRONG-NUMBER-OF-ARGUMENTS + ,(make-base-type "Wrong number of arguments")) + (WRONG-TYPE-ARGUMENT-0 ,(make-wrong-type-type 0)) + (WRONG-TYPE-ARGUMENT-1 ,(make-wrong-type-type 1)) + (WRONG-TYPE-ARGUMENT-2 ,(make-wrong-type-type 2)) + (WRONG-TYPE-ARGUMENT-3 ,(make-wrong-type-type 3)) + (WRONG-TYPE-ARGUMENT-4 ,(make-wrong-type-type 4)) + (WRONG-TYPE-ARGUMENT-5 ,(make-wrong-type-type 5)) + (WRONG-TYPE-ARGUMENT-6 ,(make-wrong-type-type 6)) + (WRONG-TYPE-ARGUMENT-7 ,(make-wrong-type-type 7)) + (WRONG-TYPE-ARGUMENT-8 ,(make-wrong-type-type 8)) + (WRONG-TYPE-ARGUMENT-9 ,(make-wrong-type-type 9)) + )) + types)) + +(define (make-error-alists error-code-limit) + (let ((alists (make-vector error-code-limit '()))) + + (define (define-total-error-handler error-type handler) + (vector-set! alists + (microcode-error error-type) + handler)) + + (define (define-error-handler error-type frame-type frame-filter handler) + (let ((error-code (microcode-error error-type)) + (return-code (microcode-return frame-type))) + (let ((entry (vector-ref alists error-code))) + (cond ((pair? entry) + (let ((entry* (assv return-code (cdr entry)))) + (if entry* + (let ((entry** (assq frame-filter (cdr entry*)))) + (if entry** + (set-cdr! entry** handler) + (set-cdr! entry* + (let ((entry** + (cons frame-filter handler))) + (if (eq? frame-filter true) + (append! (cdr entry*) + (list entry**)) + (cons entry** (cdr entry*))))))) + (set-cdr! entry + (cons (list return-code + (cons frame-filter handler)) + (cdr entry)))))) + ((null? entry) + (vector-set! alists + error-code + (list (list return-code + (cons frame-filter handler))))) + (else + (error "Can't overwrite error handler" entry))))) + *the-non-printing-object*) + + (define (define-standard-frame-handler error-type frame-type frame-filter + irritant) + (define-error-handler error-type frame-type frame-filter + (lambda (condition-type frame) + (make-error-condition + condition-type + (list (irritant (standard-frame/expression frame))) + (standard-frame/environment frame))))) + + (define (define-expression-frame-handler error-type frame-type frame-filter + irritant) + (define-error-handler error-type frame-type frame-filter + (lambda (condition-type frame) + (make-error-condition + condition-type + (list (irritant (expression-only-frame/expression frame))) + repl-environment)))) + + (define (define-internal-apply-handler error-type environment irritant + . operators) + (define-error-handler error-type 'INTERNAL-APPLY + (apply internal-apply-frame/operator-filter operators) + (lambda (condition-type frame) + (make-error-condition + condition-type + (list (internal-apply-frame/select frame irritant)) + (if environment + (internal-apply-frame/select frame environment) + repl-environment))))) + + (define (define-operator-handler error-type) + (define-error-handler error-type 'INTERNAL-APPLY true + (lambda (condition-type frame) + (make-error-condition condition-type + (internal-apply-frame/operator frame) + repl-environment)))) + + (define (define-operand-handler error-type irritant #!optional filter) + (define-error-handler error-type 'INTERNAL-APPLY + (if (default-object? filter) true filter) + (lambda (condition-type frame) + (make-error-condition + condition-type + (list (internal-apply-frame/select frame irritant) + (error-irritant/noise char:newline) + (error-irritant/noise "within procedure") + (internal-apply-frame/operator frame)) + repl-environment)))) + + (define-standard-frame-handler 'UNBOUND-VARIABLE 'EVAL-ERROR + standard-frame/variable? variable-name) + + (define-standard-frame-handler 'UNBOUND-VARIABLE 'ASSIGNMENT-CONTINUE true + assignment-name) + + (define-expression-frame-handler 'UNBOUND-VARIABLE 'ACCESS-CONTINUE true + access-name) + + (define-internal-apply-handler 'UNBOUND-VARIABLE 0 1 + (ucode-primitive lexical-reference) + (ucode-primitive lexical-assignment)) + + (define-internal-apply-handler 'UNBOUND-VARIABLE 0 + internal-apply-frame/add-fluid-binding-name + (ucode-primitive add-fluid-binding! 3)) + + (define-standard-frame-handler 'UNASSIGNED-VARIABLE 'EVAL-ERROR + standard-frame/variable? variable-name) + + (define-expression-frame-handler 'UNASSIGNED-VARIABLE 'ACCESS-CONTINUE true + access-name) + + (define-internal-apply-handler 'UNASSIGNED-VARIABLE 0 1 + (ucode-primitive lexical-reference)) + + (define-expression-frame-handler 'BAD-FRAME 'ACCESS-CONTINUE true + access-environment) + + (define-expression-frame-handler 'BAD-FRAME 'IN-PACKAGE-CONTINUE true + in-package-environment) + + (define-standard-frame-handler 'BROKEN-CVARIABLE 'EVAL-ERROR + standard-frame/variable? variable-name) + + (define-standard-frame-handler 'BROKEN-CVARIABLE 'ASSIGNMENT-CONTINUE true + assignment-name) + + (define-error-handler 'WRONG-NUMBER-OF-ARGUMENTS 'INTERNAL-APPLY true + wrong-number-of-arguments-error) + + (define-operator-handler 'UNDEFINED-PROCEDURE) + (define-operator-handler 'UNDEFINED-PRIMITIVE-OPERATION) + (define-operator-handler 'UNIMPLEMENTED-PRIMITIVE) + (define-operator-handler 'EXTERNAL-RETURN) + + (define-operand-handler 'FAILED-ARG-1-COERCION 0) + (define-operand-handler 'FAILED-ARG-2-COERCION 1) + + (define-operand-handler 'WRONG-TYPE-ARGUMENT-0 0) + (define-operand-handler 'WRONG-TYPE-ARGUMENT-1 1) + (define-operand-handler 'WRONG-TYPE-ARGUMENT-2 2) + (define-operand-handler 'WRONG-TYPE-ARGUMENT-3 3) + (define-operand-handler 'WRONG-TYPE-ARGUMENT-4 4) + (define-operand-handler 'WRONG-TYPE-ARGUMENT-5 5) + (define-operand-handler 'WRONG-TYPE-ARGUMENT-6 6) + (define-operand-handler 'WRONG-TYPE-ARGUMENT-7 7) + (define-operand-handler 'WRONG-TYPE-ARGUMENT-8 8) + (define-operand-handler 'WRONG-TYPE-ARGUMENT-9 9) + + (define-operand-handler 'BAD-RANGE-ARGUMENT-0 0) + (define-operand-handler 'BAD-RANGE-ARGUMENT-1 1) + (define-operand-handler 'BAD-RANGE-ARGUMENT-2 2) + (define-operand-handler 'BAD-RANGE-ARGUMENT-3 3) + (define-operand-handler 'BAD-RANGE-ARGUMENT-4 4) + (define-operand-handler 'BAD-RANGE-ARGUMENT-5 5) + (define-operand-handler 'BAD-RANGE-ARGUMENT-6 6) + (define-operand-handler 'BAD-RANGE-ARGUMENT-7 7) + (define-operand-handler 'BAD-RANGE-ARGUMENT-8 8) + (define-operand-handler 'BAD-RANGE-ARGUMENT-9 9) + + (define-operand-handler 'FASL-FILE-TOO-BIG 0 + internal-apply-frame/fasload?) + (define-operand-handler 'FASL-FILE-BAD-DATA 0 + internal-apply-frame/fasload?) + (define-operand-handler 'WRONG-ARITY-PRIMITIVES 0 + internal-apply-frame/fasload?) + (define-operand-handler 'IO-ERROR 0 + internal-apply-frame/fasload?) + (define-operand-handler 'FASLOAD-COMPILED-MISMATCH 0 + internal-apply-frame/fasload?) + (define-operand-handler 'FASLOAD-BAND 0 + internal-apply-frame/fasload?) + + (define-operand-handler 'IO-ERROR 1 + internal-apply-frame/fasdump?) + (define-operand-handler 'FASDUMP-ENVIRONMENT 0 + internal-apply-frame/fasdump?) + + (define-error-handler 'EXTERNAL-RETURN 'INTERNAL-APPLY + internal-apply-frame/file-open-channel? + open-file-error) + + (define-error-handler 'OUT-OF-FILE-HANDLES 'INTERNAL-APPLY + internal-apply-frame/file-open-channel? + out-of-file-handles-error) + + (define-total-error-handler 'WRITE-INTO-PURE-SPACE + write-into-pure-space-error) + + (define-total-error-handler 'BAD-ERROR-CODE + bad-error-code-handler) + + alists)) \ No newline at end of file diff --git a/v7/src/runtime/urtrap.scm b/v7/src/runtime/urtrap.scm new file mode 100644 index 000000000..be3e3fc1f --- /dev/null +++ b/v7/src/runtime/urtrap.scm @@ -0,0 +1,114 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/urtrap.scm,v 14.1 1988/05/20 01:06:12 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Reference Traps +;;; package: reference-trap-package + +(declare (usual-integrations)) + +(define-structure (reference-trap + (print-procedure + (unparser/standard-method 'REFERENCE-TRAP + (lambda (state trap) + (unparse-object state (reference-trap-kind trap)))))) + (kind false read-only true) + (extra false read-only true)) + +(define-primitives + primitive-object-type? + primitive-object-set-type + primitive-object-ref) + +(define (map-reference-trap getter) + (if (primitive-object-type? (ucode-type reference-trap) (getter)) + (let ((index (object-datum (getter)))) + (if (<= index trap-max-immediate) + (make-reference-trap index false) + (make-reference-trap (primitive-object-ref (getter) 0) + (primitive-object-ref (getter) 1)))) + (getter))) + +(define (unmap-reference-trap trap) + (if (reference-trap? trap) + (primitive-object-set-type + (ucode-type reference-trap) + (if (<= (reference-trap-kind trap) trap-max-immediate) + (reference-trap-kind trap) + (cons (reference-trap-kind trap) + (reference-trap-extra trap)))) + trap)) + +(define (reference-trap-kind-name kind) + (or (and (< kind (vector-length trap-kind-names)) + (vector-ref trap-kind-names kind)) + 'UNKNOWN)) + +(define (make-unassigned-reference-trap) + (make-reference-trap 0 false)) + +(define (unassigned-reference-trap? object) + (and (reference-trap? object) + (memq (reference-trap-kind-name (reference-trap-kind object)) + '(UNASSIGNED UNASSIGNED-DANGEROUS)))) + +(define (make-unbound-reference-trap) + (make-reference-trap 2 false)) + +(define (unbound-reference-trap? object) + (and (reference-trap? object) + (memq (reference-trap-kind-name (reference-trap-kind object)) + '(UNBOUND UNBOUND-DANGEROUS)))) + +;;; The following must agree with the microcode. + +(define-integrable trap-max-immediate 9) + +(define-integrable trap-kind-names + '#(UNASSIGNED ;0 + UNASSIGNED-DANGEROUS ;1 + UNBOUND ;2 + UNBOUND-DANGEROUS ;3 + ILLEGAL ;4 + ILLEGAL-DANGEROUS ;5 + #F ;6 + #F ;7 + #F ;8 + #F ;9 + NOP ;10 + DANGEROUS ;11 + FLUID ;12 + FLUID-DANGEROUS ;13 + COMPILER-CACHED ;14 + COMPILER-CACHED-DANGEROUS ;15 + )) \ No newline at end of file diff --git a/v8/src/runtime/conpar.scm b/v8/src/runtime/conpar.scm new file mode 100644 index 000000000..f93fca50b --- /dev/null +++ b/v8/src/runtime/conpar.scm @@ -0,0 +1,489 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/conpar.scm,v 14.1 1988/05/20 00:54:26 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Continuation Parser +;;; package: continuation-parser-package + +(declare (usual-integrations)) + +;;;; Stack Frames + +(define-structure (stack-frame + (constructor make-stack-frame + (type elements dynamic-state fluid-bindings + interrupt-mask history + previous-history-offset + previous-history-control-point %next)) + (conc-name stack-frame/)) + (type false read-only true) + (elements false read-only true) + (dynamic-state false read-only true) + (fluid-bindings false read-only true) + (interrupt-mask false read-only true) + (history false read-only true) + (previous-history-offset false read-only true) + (previous-history-control-point false read-only true) + ;; %NEXT is either a parser-state object or the next frame. In the + ;; former case, the parser-state is used to compute the next frame. + %next + (properties (make-1d-table) read-only true)) + +(define (stack-frame/reductions stack-frame) + (let ((history (stack-frame/history stack-frame))) + (if (eq? history undefined-history) + '() + (history-reductions history)))) + +(define undefined-history + "no history") + +(define (stack-frame/next stack-frame) + (let ((next (stack-frame/%next stack-frame))) + (if (parser-state? next) + (let ((next (parse/start next))) + (set-stack-frame/%next! stack-frame next) + next) + next))) + +(define-integrable (continuation/first-subproblem continuation) + (stack-frame/skip-non-subproblems (continuation->stack-frame continuation))) + +(define (stack-frame/next-subproblem stack-frame) + (if (stack-frame/subproblem? stack-frame) + (let ((stack-frame (stack-frame/next stack-frame))) + (and stack-frame + (stack-frame/skip-non-subproblems stack-frame))) + (stack-frame/skip-non-subproblems stack-frame))) + +(define (stack-frame/skip-non-subproblems stack-frame) + (if (stack-frame/subproblem? stack-frame) + stack-frame + (let ((stack-frame (stack-frame/next stack-frame))) + (and stack-frame + (stack-frame/skip-non-subproblems stack-frame))))) + +(define-integrable (stack-frame/length stack-frame) + (vector-length (stack-frame/elements stack-frame))) + +(define (stack-frame/ref stack-frame index) + (map-reference-trap + (let ((elements (stack-frame/elements stack-frame))) + (lambda () + (vector-ref elements index))))) +(define-integrable (stack-frame/return-code stack-frame) + (stack-frame-type/code (stack-frame/type stack-frame))) + +(define-integrable (stack-frame/subproblem? stack-frame) + (stack-frame-type/subproblem? (stack-frame/type stack-frame))) + +;;;; Parser + +(define-structure (parser-state (constructor make-parser-state) + (conc-name parser-state/)) + (dynamic-state false read-only true) + (fluid-bindings false read-only true) + (interrupt-mask false read-only true) + (history false read-only true) + (previous-history-offset false read-only true) + (previous-history-control-point false read-only true) + (element-stream false read-only true) + (next-control-point false read-only true)) + +(define (continuation->stack-frame continuation) + (parse/control-point (continuation/control-point continuation) + (continuation/dynamic-state continuation) + (continuation/fluid-bindings continuation))) + +(define (parse/control-point control-point dynamic-state fluid-bindings) + (and control-point + (parse/start + (make-parser-state + dynamic-state + fluid-bindings + (control-point/interrupt-mask control-point) + (history-transform (control-point/history control-point)) + (control-point/previous-history-offset control-point) + (control-point/previous-history-control-point control-point) + (control-point/element-stream control-point) + (control-point/next-control-point control-point))))) + +(define (parse/start state) + (let ((stream (parser-state/element-stream state))) + (if (stream-pair? stream) + (let ((type (parse/type stream)) + (stream (stream-cdr stream))) + (let ((length (parse/length stream type))) + (with-values (lambda () (parse/elements stream length)) + (lambda (elements stream) + (parse/dispatch type + elements + (parse/next-state state length stream)))))) + (parse/control-point (parser-state/next-control-point state) + (parser-state/dynamic-state state) + (parser-state/fluid-bindings state))))) + +(define (parse/type stream) + (let ((return-address (element-stream/head stream))) + (if (not (return-address? return-address)) + (error "illegal return address" return-address)) + (let ((code (return-address/code return-address))) + (if (>= code (vector-length stack-frame-types)) + (error "return-code too large" code)) + (let ((type (vector-ref stack-frame-types code))) + (if (not type) + (error "return-code has no type" code)) + type)))) + +(define (parse/length stream type) + (let ((length (stack-frame-type/length type))) + (if (integer? length) + length + (length stream)))) + +(define (parse/elements stream length) + (let ((elements (make-vector length))) + (let loop ((stream stream) (index 0)) + (if (< index length) + (begin (if (not (stream-pair? stream)) + (error "stack too short" index)) + (vector-set! elements index (stream-car stream)) + (loop (stream-cdr stream) (1+ index))) + (values elements stream))))) + +(define (parse/dispatch type elements state) + ((stack-frame-type/parser type) type elements state)) + +(define (parse/next-state state length stream) + (let ((previous-history-control-point + (parser-state/previous-history-control-point state))) + (make-parser-state + (parser-state/dynamic-state state) + (parser-state/fluid-bindings state) + (parser-state/interrupt-mask state) + (parser-state/history state) + (if previous-history-control-point + (parser-state/previous-history-offset state) + (max (- (parser-state/previous-history-offset state) length) 0)) + previous-history-control-point + stream + (parser-state/next-control-point state)))) + +(define (make-frame type elements state element-stream) + (let ((subproblem? (stack-frame-type/subproblem? type)) + (history (parser-state/history state)) + (previous-history-offset (parser-state/previous-history-offset state)) + (previous-history-control-point + (parser-state/previous-history-control-point state))) + (make-stack-frame type + elements + (parser-state/dynamic-state state) + (parser-state/fluid-bindings state) + (parser-state/interrupt-mask state) + (if subproblem? history undefined-history) + previous-history-offset + previous-history-control-point + (make-parser-state + (parser-state/dynamic-state state) + (parser-state/fluid-bindings state) + (parser-state/interrupt-mask state) + (if subproblem? (history-superproblem history) history) + previous-history-offset + previous-history-control-point + element-stream + (parser-state/next-control-point state))))) + +(define (element-stream/head stream) + (if (not (stream-pair? stream)) (error "not a stream-pair" stream)) + (map-reference-trap (lambda () (stream-car stream)))) + +(define (element-stream/ref stream index) + (if (not (stream-pair? stream)) (error "not a stream-pair" stream)) + (if (zero? index) + (map-reference-trap (lambda () (stream-car stream))) + (element-stream/ref (stream-cdr stream) (-1+ index)))) + +;;;; Unparser + +(define (stack-frame->continuation stack-frame) + (make-continuation 'REENTRANT + (stack-frame->control-point stack-frame) + (stack-frame/dynamic-state stack-frame) + (stack-frame/fluid-bindings stack-frame))) + +(define (stack-frame->control-point stack-frame) + (with-values (lambda () (unparse/stack-frame stack-frame)) + (lambda (element-stream next-control-point) + (make-control-point + false + 0 + (stack-frame/interrupt-mask stack-frame) + (history-untransform (stack-frame/history stack-frame)) + (stack-frame/previous-history-offset stack-frame) + (stack-frame/previous-history-control-point stack-frame) + element-stream + next-control-point)))) + +(define (unparse/stack-frame stack-frame) + (let ((next (stack-frame/%next stack-frame))) + (cond ((stack-frame? next) + (with-values (lambda () (unparse/stack-frame next)) + (lambda (element-stream next-control-point) + (values (let ((type (stack-frame/type stack-frame))) + ((stack-frame-type/unparser type) + type + (stack-frame/elements stack-frame) + element-stream)) + next-control-point)))) + ((parser-state? next) + (values (parser-state/element-stream next) + (parser-state/next-control-point next))) + (else (values (stream) false))))) + +;;;; Generic Parsers/Unparsers + +(define (parser/interpreter-next type elements state) + (make-frame type elements state (parser-state/element-stream state))) + +(define (unparser/interpreter-next type elements element-stream) + (cons-stream (make-return-address (stack-frame-type/code type)) + (let ((length (vector-length elements))) + (let loop ((index 0)) + (if (< index length) + (cons-stream (vector-ref elements index) + (loop (1+ index))) + element-stream))))) + +(define (parser/compiler-next type elements state) + (make-frame type elements state + (cons-stream + (ucode-return-address reenter-compiled-code) + (cons-stream + (- (vector-ref elements 0) (vector-length elements)) + (parser-state/element-stream state))))) + +(define (unparser/compiler-next type elements element-stream) + (unparser/interpreter-next type elements (stream-tail element-stream 2))) + +(define (make-restore-frame type + elements + state + dynamic-state + fluid-bindings + interrupt-mask + history + previous-history-offset + previous-history-control-point) + (parser/interpreter-next + type + elements + (make-parser-state dynamic-state + fluid-bindings + interrupt-mask + history + previous-history-offset + previous-history-control-point + (parser-state/element-stream state) + (parser-state/next-control-point state)))) + +;;;; Specific Parsers + +(define (parser/restore-dynamic-state type elements state) + (make-restore-frame type elements state + (vector-ref elements 0) + (parser-state/fluid-bindings state) + (parser-state/interrupt-mask state) + (parser-state/history state) + (parser-state/previous-history-offset state) + (parser-state/previous-history-control-point state))) + +(define (parser/restore-fluid-bindings type elements state) + (make-restore-frame type elements state + (parser-state/dynamic-state state) + (vector-ref elements 0) + (parser-state/interrupt-mask state) + (parser-state/history state) + (parser-state/previous-history-offset state) + (parser-state/previous-history-control-point state))) + +(define (parser/restore-interrupt-mask type elements state) + (make-restore-frame type elements state + (parser-state/dynamic-state state) + (parser-state/fluid-bindings state) + (vector-ref elements 0) + (parser-state/history state) + (parser-state/previous-history-offset state) + (parser-state/previous-history-control-point state))) + +(define (parser/restore-history type elements state) + (make-restore-frame type elements state + (parser-state/dynamic-state state) + (parser-state/fluid-bindings state) + (parser-state/interrupt-mask state) + (history-transform (vector-ref elements 0)) + (vector-ref elements 1) + (vector-ref elements 2))) + +(define (length/combination-save-value stream) + (+ 2 (system-vector-length (element-stream/head stream)))) + +(define ((length/application-frame index missing) stream) + (+ index 1 (- (object-datum (element-stream/ref stream index)) missing))) + +(define (length/repeat-primitive stream) + (-1+ (primitive-procedure-arity (element-stream/head stream)))) + +(define (length/reenter-compiled-code stream) + (1+ (element-stream/head stream))) + +;;;; Stack Frame Types + +(define-structure (stack-frame-type + (constructor make-stack-frame-type + (code subproblem? length parser unparser)) + (conc-name stack-frame-type/)) + (code false read-only true) + (subproblem? false read-only true) + (properties (make-1d-table) read-only true) + (length false read-only true) + (parser false read-only true) + (unparser false read-only true)) + +(define (initialize-package!) + (set! stack-frame-types (make-stack-frame-types))) + +(define stack-frame-types) + +(define (make-stack-frame-types) + (let ((types (make-vector (microcode-return/code-limit) false))) + + (define (stack-frame-type name subproblem? length parser unparser) + (let ((code (microcode-return name))) + (vector-set! types + code + (make-stack-frame-type code subproblem? length parser + unparser)))) + + (define (interpreter-frame name length #!optional parser) + (stack-frame-type name false length + (if (default-object? parser) + parser/interpreter-next + parser) + unparser/interpreter-next)) + + (define (compiler-frame name length #!optional parser) + (stack-frame-type name false length + (if (default-object? parser) + parser/compiler-next + parser) + unparser/compiler-next)) + + (define (interpreter-subproblem name length) + (stack-frame-type name true length parser/interpreter-next + unparser/interpreter-next)) + + (define (compiler-subproblem name length) + (stack-frame-type name true length parser/compiler-next + unparser/compiler-next)) + + (interpreter-frame 'RESTORE-TO-STATE-POINT 1 parser/restore-dynamic-state) + (interpreter-frame 'RESTORE-FLUIDS 1 parser/restore-fluid-bindings) + (interpreter-frame 'RESTORE-INTERRUPT-MASK 1 parser/restore-interrupt-mask) + (interpreter-frame 'RESTORE-HISTORY 3 parser/restore-history) + (interpreter-frame 'RESTORE-DONT-COPY-HISTORY 3 parser/restore-history) + + (interpreter-frame 'NON-EXISTENT-CONTINUATION 1) + (interpreter-frame 'HALT 1) + (interpreter-frame 'JOIN-STACKLETS 1) + (interpreter-frame 'POP-RETURN-ERROR 1) + + (interpreter-subproblem 'IN-PACKAGE-CONTINUE 1) + (interpreter-subproblem 'ACCESS-CONTINUE 1) + (interpreter-subproblem 'PRIMITIVE-COMBINATION-1-APPLY 1) + (interpreter-subproblem 'FORCE-SNAP-THUNK 1) + (interpreter-subproblem 'GC-CHECK 1) + (interpreter-subproblem 'RESTORE-VALUE 1) + (interpreter-subproblem 'ASSIGNMENT-CONTINUE 2) + (interpreter-subproblem 'DEFINITION-CONTINUE 2) + (interpreter-subproblem 'SEQUENCE-2-SECOND 2) + (interpreter-subproblem 'SEQUENCE-3-SECOND 2) + (interpreter-subproblem 'SEQUENCE-3-THIRD 2) + (interpreter-subproblem 'CONDITIONAL-DECIDE 2) + (interpreter-subproblem 'DISJUNCTION-DECIDE 2) + (interpreter-subproblem 'COMBINATION-1-PROCEDURE 2) + (interpreter-subproblem 'COMBINATION-2-FIRST-OPERAND 2) + (interpreter-subproblem 'EVAL-ERROR 2) + (interpreter-subproblem 'PRIMITIVE-COMBINATION-2-FIRST-OPERAND 2) + (interpreter-subproblem 'PRIMITIVE-COMBINATION-2-APPLY 2) + (interpreter-subproblem 'PRIMITIVE-COMBINATION-3-SECOND-OPERAND 2) + (interpreter-subproblem 'COMBINATION-2-PROCEDURE 3) + (interpreter-subproblem 'REPEAT-DISPATCH 3) + (interpreter-subproblem 'PRIMITIVE-COMBINATION-3-FIRST-OPERAND 3) + (interpreter-subproblem 'PRIMITIVE-COMBINATION-3-APPLY 3) + (interpreter-subproblem 'MOVE-TO-ADJACENT-POINT 5) + + (interpreter-subproblem 'COMBINATION-SAVE-VALUE + length/combination-save-value) + + (interpreter-subproblem 'REPEAT-PRIMITIVE length/repeat-primitive) + + (let ((length (length/application-frame 1 0))) + (interpreter-subproblem 'COMBINATION-APPLY length) + (interpreter-subproblem 'INTERNAL-APPLY length)) + + (interpreter-subproblem 'REENTER-COMPILED-CODE + length/reenter-compiled-code) + + (compiler-frame 'COMPILER-INTERRUPT-RESTART 2) + (compiler-frame 'COMPILER-LINK-CACHES-RESTART 7) + + (compiler-subproblem 'COMPILER-REFERENCE-RESTART 3) + (compiler-subproblem 'COMPILER-SAFE-REFERENCE-RESTART 3) + (compiler-subproblem 'COMPILER-ACCESS-RESTART 3) + (compiler-subproblem 'COMPILER-UNASSIGNED?-RESTART 3) + (compiler-subproblem 'COMPILER-UNBOUND?-RESTART 3) + (compiler-subproblem 'COMPILER-REFERENCE-TRAP-RESTART 3) + (compiler-subproblem 'COMPILER-SAFE-REFERENCE-TRAP-RESTART 3) + (compiler-subproblem 'COMPILER-UNASSIGNED?-TRAP-RESTART 3) + (compiler-subproblem 'COMPILER-ASSIGNMENT-RESTART 4) + (compiler-subproblem 'COMPILER-DEFINITION-RESTART 4) + (compiler-subproblem 'COMPILER-ASSIGNMENT-TRAP-RESTART 4) + + (compiler-subproblem 'COMPILER-LOOKUP-APPLY-RESTART + (length/application-frame 3 1)) + + (let ((length (length/application-frame 3 0))) + (compiler-subproblem 'COMPILER-LOOKUP-APPLY-TRAP-RESTART length) + (compiler-subproblem 'COMPILER-OPERATOR-LOOKUP-TRAP-RESTART length)) + + types)) \ No newline at end of file diff --git a/v8/src/runtime/dbgutl.scm b/v8/src/runtime/dbgutl.scm new file mode 100644 index 000000000..8781e9418 --- /dev/null +++ b/v8/src/runtime/dbgutl.scm @@ -0,0 +1,113 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/dbgutl.scm,v 14.1 1988/05/20 00:55:52 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Debugger Utilities +;;; package: debugger-utilities-package + +(declare (usual-integrations)) + +(define (initialize-package!) + (set! rename-list + `((,lambda-tag:unnamed . LAMBDA) + (,lambda-tag:internal-lambda . LAMBDA) + (,lambda-tag:internal-lexpr . LAMBDA) + (,lambda-tag:let . LET) + (,lambda-tag:fluid-let . FLUID-LET) + (,lambda-tag:make-environment . MAKE-ENVIRONMENT)))) + +(define (print-user-friendly-name frame) + (let ((name (environment-name frame))) + (let ((rename (assq name rename-list))) + (if rename + (begin (write-string "a ") + (write (cdr rename)) + (write-string " special form")) + (begin (write-string "the procedure ") + (write name)))))) + +(define (environment-name environment) + (lambda-components* (procedure-lambda (environment-procedure environment)) + (lambda (name required optional rest body) + required optional rest body + name))) + +(define (special-name? symbol) + (assq symbol rename-list)) + +(define rename-list) + +(define (show-frame frame depth) + (if (eq? system-global-environment frame) + (begin + (newline) + (write-string "This frame is the system global environment")) + (begin + (newline) + (write-string "Frame created by ") + (print-user-friendly-name frame) + (if (>= depth 0) + (begin (newline) + (write-string "Depth (relative to starting frame): ") + (write depth))) + (newline) + (let ((bindings (environment-bindings frame))) + (if (null? bindings) + (write-string "Has no bindings") + (begin + (write-string "Has bindings:") + (newline) + (for-each print-binding + (sort bindings + (lambda (x y) + (stringstring (car x)) + (symbol->string (car y)))))))))))) + +(define (print-binding binding) + (let ((x-size (output-port/x-size (current-output-port))) + (write->string + (lambda (object length) + (let ((x (write-to-string object length))) + (if (and (car x) (> length 4)) + (substring-move-right! " ..." 0 4 (cdr x) (- length 4))) + (cdr x))))) + (newline) + (write-string + (let ((s (write->string (car binding) (quotient x-size 2)))) + (if (null? (cdr binding)) + (string-append s " is unassigned") + (let ((s (string-append s " = "))) + (string-append s + (write->string (cadr binding) + (max (- x-size (string-length s)) + 0))))))))) \ No newline at end of file diff --git a/v8/src/runtime/framex.scm b/v8/src/runtime/framex.scm new file mode 100644 index 000000000..7b01140ed --- /dev/null +++ b/v8/src/runtime/framex.scm @@ -0,0 +1,236 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/framex.scm,v 14.1 1988/05/20 00:57:08 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Debugging Info +;;; package: debugging-info-package + +(declare (usual-integrations)) + +(define (stack-frame/debugging-info frame) + (let ((method + (1d-table/get (stack-frame-type/properties (stack-frame/type frame)) + method-tag + false))) + (if (not method) + (error "STACK-FRAME/DEBUGGING-INFO: missing method" frame)) + (method frame))) + +(define-integrable (debugging-info/undefined-expression? expression) + (eq? expression undefined-expression)) + +(define-integrable (debugging-info/undefined-environment? environment) + (eq? environment undefined-environment)) + +(define-integrable (debugging-info/compiled-code? expression) + (eq? expression compiled-code)) + +(define-integrable (make-evaluated-object object) + (cons evaluated-object-tag object)) + +(define (debugging-info/evaluated-object? expression) + (and (pair? expression) + (eq? (car expression) evaluated-object-tag))) + +(define-integrable (debugging-info/evaluated-object-value expression) + (cdr expression)) + +(define method-tag "stack-frame/debugging-info method") +(define undefined-expression "undefined expression") +(define undefined-environment "undefined environment") +(define compiled-code "compiled code") +(define evaluated-object-tag "evaluated") + +(define (method/standard frame) + (values (stack-frame/ref frame 0) (stack-frame/ref frame 1))) + +(define (method/null frame) + frame + (values undefined-expression undefined-environment)) + +(define (method/expression-only frame) + (values (stack-frame/ref frame 0) undefined-environment)) + +(define (method/environment-only frame) + (values undefined-expression (stack-frame/ref frame 1))) + +(define (method/compiled-code frame) + frame + (values compiled-code undefined-environment)) + +(define (method/primitive-combination-3-first-operand frame) + (values (stack-frame/ref frame 0) (stack-frame/ref frame 2))) + +(define (method/force-snap-thunk frame) + (values (make-combination + (ucode-primitive force 1) + (list (make-evaluated-object (stack-frame/ref frame 0)))) + undefined-environment)) + +(define ((method/application-frame index) frame) + (values (make-combination + (make-evaluated-object (stack-frame/ref frame index)) + (stack-frame-list frame (1+ index))) + undefined-environment)) + +(define ((method/compiler-reference scode-maker) frame) + (values (scode-maker (stack-frame/ref frame 2)) + (stack-frame/ref frame 1))) + +(define ((method/compiler-assignment scode-maker) frame) + (values (scode-maker (stack-frame/ref frame 2) + (make-evaluated-object (stack-frame/ref frame 3))) + (stack-frame/ref frame 1))) + +(define ((method/compiler-reference-trap scode-maker) frame) + (values (scode-maker (stack-frame/ref frame 1)) + (stack-frame/ref frame 2))) + +(define ((method/compiler-assignment-trap scode-maker) frame) + (values (scode-maker (stack-frame/ref frame 1) + (make-evaluated-object (stack-frame/ref frame 3))) + (stack-frame/ref frame 2))) + +(define (method/compiler-lookup-apply-restart frame) + (values (make-combination (stack-frame/ref frame 2) + (stack-frame-list frame 4)) + undefined-environment)) + +(define (method/compiler-lookup-apply-trap-restart frame) + (values (make-combination (make-variable (stack-frame/ref frame 1)) + (stack-frame-list frame 5)) + (stack-frame/ref frame 2))) + +(define (stack-frame-list frame start) + (let ((end (stack-frame/length frame))) + (let loop ((index start)) + (if (< index end) + (cons (make-evaluated-object (stack-frame/ref frame index)) + (loop (1+ index))) + '())))) + +(define (initialize-package!) + (for-each (lambda (entry) + (for-each (lambda (name) + (let ((type + (or (vector-ref stack-frame-types + (microcode-return name)) + (error "Missing return type" name)))) + (1d-table/put! (stack-frame-type/properties type) + method-tag + (car entry)))) + (cdr entry))) + `((,method/standard + ASSIGNMENT-CONTINUE + COMBINATION-1-PROCEDURE + COMBINATION-2-FIRST-OPERAND + COMBINATION-2-PROCEDURE + COMBINATION-SAVE-VALUE + CONDITIONAL-DECIDE + DEFINITION-CONTINUE + DISJUNCTION-DECIDE + EVAL-ERROR + PRIMITIVE-COMBINATION-2-FIRST-OPERAND + PRIMITIVE-COMBINATION-3-SECOND-OPERAND + SEQUENCE-2-SECOND + SEQUENCE-3-SECOND + SEQUENCE-3-THIRD) + + (,method/null + COMBINATION-APPLY + GC-CHECK + MOVE-TO-ADJACENT-POINT) + + (,method/expression-only + ACCESS-CONTINUE + IN-PACKAGE-CONTINUE + PRIMITIVE-COMBINATION-1-APPLY + PRIMITIVE-COMBINATION-2-APPLY + PRIMITIVE-COMBINATION-3-APPLY) + + (,method/environment-only + REPEAT-DISPATCH) + + (,method/compiled-code + REENTER-COMPILED-CODE) + + (,method/primitive-combination-3-first-operand + PRIMITIVE-COMBINATION-3-FIRST-OPERAND) + + (,method/force-snap-thunk + FORCE-SNAP-THUNK) + + (,(method/application-frame 2) + INTERNAL-APPLY) + + (,(method/application-frame 0) + REPEAT-PRIMITIVE) + + (,(method/compiler-reference identity-procedure) + COMPILER-REFERENCE-RESTART + COMPILER-SAFE-REFERENCE-RESTART) + + (,(method/compiler-reference make-variable) + COMPILER-ACCESS-RESTART) + + (,(method/compiler-reference make-unassigned?) + COMPILER-UNASSIGNED?-RESTART) + + (,(method/compiler-reference + (lambda (name) + (make-combination (ucode-primitive lexical-unbound?) + (list (make-the-environment) name)))) + COMPILER-UNBOUND?-RESTART) + + (,(method/compiler-assignment make-assignment-from-variable) + COMPILER-ASSIGNMENT-RESTART) + + (,(method/compiler-assignment make-definition) + COMPILER-DEFINITION-RESTART) + + (,(method/compiler-reference-trap make-variable) + COMPILER-REFERENCE-TRAP-RESTART + COMPILER-SAFE-REFERENCE-TRAP-RESTART) + + (,(method/compiler-reference-trap make-unassigned?) + COMPILER-UNASSIGNED?-TRAP-RESTART) + + (,(method/compiler-assignment-trap make-assignment) + COMPILER-ASSIGNMENT-TRAP-RESTART) + + (,method/compiler-lookup-apply-restart + COMPILER-LOOKUP-APPLY-RESTART) + + (,method/compiler-lookup-apply-trap-restart + COMPILER-LOOKUP-APPLY-TRAP-RESTART + COMPILER-OPERATOR-LOOKUP-TRAP-RESTART)))) \ No newline at end of file diff --git a/v8/src/runtime/global.scm b/v8/src/runtime/global.scm new file mode 100644 index 000000000..4ac53b04c --- /dev/null +++ b/v8/src/runtime/global.scm @@ -0,0 +1,280 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/global.scm,v 14.1 1988/05/20 00:58:36 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Miscellaneous Global Definitions + +(declare (usual-integrations)) + +;;;; Primitive Operators + +(define-primitives + scode-eval force error-procedure + set-interrupt-enables! enable-interrupts! with-interrupt-mask + get-fixed-objects-vector with-history-disabled + primitive-procedure-arity + + ;; Environment + lexical-reference lexical-assignment local-assignment + lexical-unassigned? lexical-unbound? lexical-unreferenceable? + environment-link-name + + ;; Pointers + (object-type 1) + (object-gc-type 1) + (object-datum 1) + (object-type? 2) + (object-new-type object-set-type 2) + eq? + + ;; Cells + make-cell cell? cell-contents set-cell-contents! + + ;; System Compound Datatypes + system-pair-cons system-pair? + system-pair-car system-pair-set-car! + system-pair-cdr system-pair-set-cdr! + + hunk3-cons + system-hunk3-cxr0 system-hunk3-set-cxr0! + system-hunk3-cxr1 system-hunk3-set-cxr1! + system-hunk3-cxr2 system-hunk3-set-cxr2! + + (system-list->vector system-list-to-vector) + (system-subvector->list system-subvector-to-list) + system-vector? + (system-vector-length system-vector-size) + system-vector-ref + system-vector-set!) + +;;;; Potpourri + +(define (identity-procedure x) x) +(define (null-procedure . args) args '()) +(define (false-procedure . args) args false) +(define (true-procedure . args) args true) + +(define (apply f . args) + ((ucode-primitive apply) + f + (if (null? args) + '() + (let loop ((first-element (car args)) (rest-elements (cdr args))) + (if (null? rest-elements) + first-element + (cons first-element + (loop (car rest-elements) (cdr rest-elements)))))))) + +(define (eval expression environment) + (scode-eval (syntax expression system-global-syntax-table) environment)) +(define-integrable (system-hunk3-cons type cxr0 cxr1 cxr2) + (object-new-type type (hunk3-cons cxr0 cxr1 cxr2))) + +(define-integrable (symbol-hash symbol) + (string-hash (symbol->string symbol))) + +(define (symbol-append . symbols) + (string->symbol (apply string-append (map symbol->string symbols)))) + +(define (bind-cell-contents! cell new-value thunk) + (let ((old-value)) + (dynamic-wind (lambda () + (set! old-value (cell-contents cell)) + (set-cell-contents! cell new-value) + (set! new-value)) + thunk + (lambda () + (set! new-value (cell-contents cell)) + (set-cell-contents! cell old-value) + (set! old-value))))) + +(define (values . objects) + (lambda (receiver) + (apply receiver objects))) + +(define-integrable (with-values thunk receiver) + ((thunk) receiver)) + +(define (write-to-string object #!optional max) + (if (default-object? max) (set! max false)) + (if (not max) + (with-output-to-string + (lambda () + (write object))) + (with-output-to-truncated-string max + (lambda () + (write object))))) + +(define (pa procedure) + (if (not (compound-procedure? procedure)) + (error "Must be a compound procedure" procedure)) (pp (unsyntax-lambda-list (procedure-lambda procedure)))) + +(define (pwd) + (working-directory-pathname)) + +(define (cd pathname) + (set-working-directory-pathname! pathname)) + +;; Compatibility. +(define %pwd pwd) +(define %cd cd) + +(define (show-time thunk) + (let ((process-start (process-time-clock)) + (real-start (real-time-clock))) + (let ((value (thunk))) + (let ((process-end (process-time-clock)) + (real-end (real-time-clock))) + (newline) + (write-string "process time: ") + (write (- process-end process-start)) + (write-string "; real time: ") + (write (- real-end real-start))) + value))) + +(define (wait-interval ticks) + (let ((end (+ (real-time-clock) ticks))) + (let wait-loop () + (if (< (real-time-clock) end) + (wait-loop))))) + +(define-integrable (future? object) + ((ucode-primitive primitive-type? 2) (ucode-type future) object)) + +(define (exit) + (if (prompt-for-confirmation "Kill Scheme? ") (%exit))) + +(define (%exit) + (close-all-open-files) + ((ucode-primitive exit))) + +(define (quit) + (with-absolutely-no-interrupts (ucode-primitive halt)) + *the-non-printing-object*) + +(define (define-structure/keyword-parser argument-list default-alist) + (if (null? argument-list) + (map cdr default-alist) + (let ((alist + (map (lambda (entry) (cons (car entry) (cdr entry))) + default-alist))) + (let loop ((arguments argument-list)) + (if (not (null? arguments)) + (begin + (if (null? (cdr arguments)) + (error "Keyword list does not have even length" + argument-list)) + (set-cdr! (or (assq (car arguments) alist) + (error "Unknown keyword" (car arguments))) + (cadr arguments)) + (loop (cddr arguments))))) + (map cdr alist)))) + +(define (syntaxer/cond-=>-helper form1-result thunk2 thunk3) + (if form1-result + ((thunk2) form1-result) + (thunk3))) + +(define syntaxer/default-environment + (let () (the-environment))) + +(define user-initial-environment + (let () (the-environment))) + +(define user-initial-prompt + "]=>") +(define (copy-program exp) + (if (not (object-type? (ucode-type compiled-entry) exp)) + (error "COPY-PROGRAM: Can only copy compiled programs" exp)) + (let* ((original (compiled-code-address->block exp)) + (block + (object-new-type + (ucode-type compiled-code-block) + (vector-copy (object-new-type (ucode-type vector) original)))) + (end (system-vector-length block))) + + (define (map-entry entry) + (with-absolutely-no-interrupts + (lambda () + ((ucode-primitive primitive-object-set-type) + (object-type entry) + (+ (compiled-code-address->offset entry) + (object-datum block)))))) + + (let loop ((n (1+ (object-datum (system-vector-ref block 0))))) + (if (< n end) + (begin + (if (lambda? (system-vector-ref block n)) + (lambda-components (system-vector-ref block n) + (lambda (name required optional rest auxiliary declarations + body) + (if (and (object-type? (ucode-type compiled-entry) body) + (eq? original + (compiled-code-address->block body))) + (system-vector-set! + block + n + (make-lambda name required optional rest auxiliary + declarations (map-entry body))))))) + (loop (1+ n))))) + (map-entry exp))) + +(define-integrable (object-non-pointer? object) + (zero? (object-gc-type object))) + +(define-integrable (object-pointer? object) + (not (object-non-pointer? object))) + +(define (impurify object) + (if (and (object-pointer? object) (pure? object)) + ((ucode-primitive primitive-impurify) object)) + object) + +(define (fasdump object filename) + (let ((filename (canonicalize-output-filename filename)) + (port (cmdl/output-port (nearest-cmdl)))) + (newline port) + (write-string "FASDumping " port) (write filename port) + (if (not ((ucode-primitive primitive-fasdump) object filename false)) + (error "FASDUMP: Object is too large to be dumped" object)) + (write-string " -- done" port)) + object) + +(define (undefined-value? object) + ;; Note: the unparser takes advantage of the fact that objects + ;; satisfying this predicate also satisfy: + ;; (object-type? (microcode-type 'TRUE) object) + (or (eq? object undefined-conditional-branch) + ;; same as `undefined-conditional-branch'. + ;; (eq? object *the-non-printing-object*) + (eq? object (microcode-object/unassigned)))) \ No newline at end of file diff --git a/v8/src/runtime/load.scm b/v8/src/runtime/load.scm new file mode 100644 index 000000000..deba015b1 --- /dev/null +++ b/v8/src/runtime/load.scm @@ -0,0 +1,160 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.1 1988/05/20 00:59:11 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Code Loader +;;; package: load-package + +(declare (usual-integrations)) + +(define (initialize-package!) + (set! load-noisily? false) + (set! load/default-types '("com" "bin" "scm")) + (set! fasload/default-types '("com" "bin")) + (add-event-receiver! event:after-restart load-init-file)) + +(define load-noisily?) +(define load/default-types) +(define fasload/default-types) + +(define (read-file filename) + (stream->list + (call-with-input-file + (pathname-default-version (->pathname filename) 'NEWEST) + read-stream))) + +(define (fasload filename) + (fasload/internal + (find-true-filename (->pathname filename) fasload/default-types))) + +(define (fasload/internal true-filename) + (let ((port (cmdl/output-port (nearest-cmdl)))) + (newline port) + (write-string "FASLoading " port) + (write true-filename port) + (let ((value ((ucode-primitive binary-fasload) true-filename))) + (write-string " -- done" port) + value))) + +(define (load-noisily filename #!optional environment) + (fluid-let ((load-noisily? true)) + (load filename + (if (default-object? environment) default-object environment)))) + +(define (load-init-file) + (let ((truename (init-file-truename))) + (if truename + (load truename user-initial-environment))) + *the-non-printing-object*) + +;;; This is careful to do the minimum number of file existence probes +;;; before opening the input file. + +(define (load filename/s #!optional environment) + (let ((environment + ;; Kludge until optional defaulting fixed. + (if (default-object? environment) default-object environment))) + (let ((kernel + (lambda (filename last-file?) + (let ((value + (let ((pathname (->pathname filename))) + (load/internal pathname + (find-true-filename pathname + load/default-types) + environment + load-noisily?)))) + (cond (last-file? value) + (load-noisily? (write-line value))))))) + (if (pair? filename/s) + (let loop ((filenames filename/s)) + (if (null? (cdr filenames)) + (kernel (car filenames) true) + (begin (kernel (car filenames) false) + (loop (cdr filenames))))) + (kernel filename/s true))))) + +(define default-object + "default-object") + +(define (load/internal pathname true-filename environment load-noisily?) + (let ((port (open-input-file/internal pathname true-filename))) + (if (= 250 (char->ascii (peek-char port))) + (begin (close-input-port port) + (scode-eval (fasload/internal true-filename) + (if (eq? environment default-object) + (standard-repl-environment) + environment))) + (write-stream (eval-stream (read-stream port) environment) + (if load-noisily? + (lambda (value) + (hook/repl-write (nearest-repl) value)) + (lambda (value) value false)))))) +(define (find-true-filename pathname default-types) + (pathname->string + (or (let ((try + (lambda (pathname) + (pathname->input-truename + (pathname-default-version pathname 'NEWEST))))) + (if (pathname-type pathname) + (try pathname) + (or (pathname->input-truename pathname) + (let loop ((types default-types)) + (and (not (null? types)) + (or (try (pathname-new-type pathname (car types))) + (loop (cdr types)))))))) + (error "No such file" pathname)))) + +(define (read-stream port) + (parse-objects port + (current-parser-table) + (lambda (object) + (and (eof-object? object) + (begin (close-input-port port) + true))))) + +(define (eval-stream stream environment) + (stream-map stream + (lambda (s-expression) + (hook/repl-eval (nearest-repl) + s-expression + (if (eq? environment default-object) + (standard-repl-environment) + environment))))) + +(define (write-stream stream write) + (if (stream-pair? stream) + (let loop ((value (stream-car stream)) (stream (stream-cdr stream))) + (if (stream-pair? stream) + (begin (write value) + (loop (stream-car stream) (stream-cdr stream))) value)) + *the-non-printing-object*)) \ No newline at end of file diff --git a/v8/src/runtime/make.scm b/v8/src/runtime/make.scm new file mode 100644 index 000000000..52827a04b --- /dev/null +++ b/v8/src/runtime/make.scm @@ -0,0 +1,324 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.1 1988/05/20 00:59:28 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Make Runtime System + +(declare (usual-integrations)) + +((ucode-primitive set-interrupt-enables!) 0) +(define system-global-environment (the-environment)) +(define system-packages (let () (the-environment))) + +(let () + +(define-primitives + (+ &+) + binary-fasload + exit + (file-exists? 1) + garbage-collect + get-fixed-objects-vector + get-primitive-address + get-primitive-name + lexical-reference + microcode-identify + primitive-purify + scode-eval + set-fixed-objects-vector! + set-interrupt-enables! + string->symbol + string-allocate + string-length + substring=? + substring-move-right! + substring-upcase! + tty-flush-output + tty-write-char + tty-write-string + vector-ref + vector-set! + with-interrupt-mask) + +(define microcode-identification + (microcode-identify)) + +(define newline-char + (vector-ref microcode-identification 5)) + +(define os-name-string + (vector-ref microcode-identification 8)) + +(define (fatal-error message) + (tty-write-char newline-char) + (tty-write-string message) + (tty-write-char newline-char) + (tty-flush-output) + (exit)) + +;;;; GC, Interrupts, Errors + +(define safety-margin 4500) + +(let ((condition-handler/gc + (lambda (interrupt-code interrupt-enables) + interrupt-code interrupt-enables + (with-interrupt-mask 0 + (lambda (interrupt-mask) + interrupt-mask + (garbage-collect safety-margin))))) + (condition-handler/stack-overflow + (lambda (interrupt-code interrupt-enables) + interrupt-code interrupt-enables + (fatal-error "Stack overflow!"))) + (condition-handler/hardware-trap + (lambda (escape-code) + escape-code + (fatal-error "Hardware trap!"))) + (fixed-objects (get-fixed-objects-vector))) + (let ((interrupt-vector (vector-ref fixed-objects 1))) + (vector-set! interrupt-vector 0 condition-handler/stack-overflow) + (vector-set! interrupt-vector 2 condition-handler/gc)) + (vector-set! fixed-objects #x0C condition-handler/hardware-trap) + (set-fixed-objects-vector! fixed-objects)) + +(set-interrupt-enables! #x0005) + +;;;; Utilities + +(define (fasload filename) + (tty-write-char newline-char) + (tty-write-string filename) + (tty-flush-output) + (let ((value (binary-fasload filename))) + (tty-write-string " loaded") + (tty-flush-output) + value)) + +(define (eval object environment) + (let ((value (scode-eval object environment))) + (tty-write-string " evaluated") + (tty-flush-output) + value)) + +(define (cold-load/purify object) + (if (not (car (primitive-purify object #t safety-margin))) + (fatal-error "Error! insufficient pure space")) + (tty-write-string " purified") + (tty-flush-output) + object) + +(define (implemented-primitive-procedure? primitive) + (get-primitive-address (get-primitive-name (object-datum primitive)) false)) + +(define map-filename + (if (implemented-primitive-procedure? file-exists?) + (lambda (filename) + (let ((com-file (string-append filename ".com"))) + (if (file-exists? com-file) + com-file + (string-append filename ".bin")))) + (lambda (filename) + (string-append filename ".bin")))) + +(define (string-append x y) + (let ((x-length (string-length x)) + (y-length (string-length y))) + (let ((result (string-allocate (+ x-length y-length)))) + (substring-move-right! x 0 x-length result 0) + (substring-move-right! y 0 y-length result x-length) + result))) + +(define (string-upcase string) + (let ((size (string-length string))) + (let ((result (string-allocate size))) + (substring-move-right! string 0 size result 0) + (substring-upcase! result 0 size) + result))) + +(define (string=? string1 string2) + (substring=? string1 0 (string-length string1) + string2 0 (string-length string2))) + +(define (package-initialize package-name procedure-name) + (tty-write-char newline-char) + (tty-write-string "initialize:") + (let loop ((name package-name)) + (if (not (null? name)) + (begin (tty-write-string " ") + (tty-write-string (system-pair-car (car name))) + (loop (cdr name))))) + (tty-flush-output) + ((lexical-reference (package-reference package-name) procedure-name))) + +(define (package-reference name) + (if (null? name) + system-global-environment + (let loop ((name name) (environment system-packages)) + (if (null? name) + environment + (loop (cdr name) (lexical-reference environment (car name))))))) + +(define (package-initialization-sequence packages) + (let loop ((packages packages)) + (if (not (null? packages)) + (begin (package-initialize (car packages) 'INITIALIZE-PACKAGE!) + (loop (cdr packages)))))) + +;; Construct the package structure. +(eval (fasload "runtim.bcon") system-global-environment) + +;; Global databases. Load, then initialize. + +(let loop + ((files + '(("gcdemn" . (GC-DAEMONS)) + ("poplat" . (POPULATION)) + ("prop1d" . (1D-PROPERTY)) + ("events" . (EVENT-DISTRIBUTOR)) + ("gdatab" . (GLOBAL-DATABASE)) + ("boot" . ()) + ("queue" . ()) + ("gc" . (GARBAGE-COLLECTOR))))) + (if (not (null? files)) + (begin + (eval (cold-load/purify (fasload (map-filename (car (car files))))) + (package-reference (cdr (car files)))) + (loop (cdr files))))) +(package-initialize '(GC-DAEMONS) 'INITIALIZE-PACKAGE!) +(package-initialize '(POPULATION) 'INITIALIZE-PACKAGE!) +(package-initialize '(1D-PROPERTY) 'INITIALIZE-PACKAGE!) +(package-initialize '(EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE!) +(package-initialize '(GLOBAL-DATABASE) 'INITIALIZE-PACKAGE!) +(package-initialize '(POPULATION) 'INITIALIZE-UNPARSER!) +(package-initialize '(1D-PROPERTY) 'INITIALIZE-UNPARSER!) +(package-initialize '(EVENT-DISTRIBUTOR) 'INITIALIZE-UNPARSER!) +(package-initialize '(GARBAGE-COLLECTOR) 'INITIALIZE-PACKAGE!) + +;; Load everything else. +((eval (fasload "runtim.bldr") system-global-environment) + (lambda (filename environment) + (if (not (or (string=? filename "gcdemn") + (string=? filename "poplat") + (string=? filename "prop1d") + (string=? filename "events") + (string=? filename "gdatab") + (string=? filename "boot") + (string=? filename "queue") + (string=? filename "gc"))) + (eval (purify (fasload (map-filename filename))) environment))) + `((SORT-TYPE . MERGE-SORT) + (OS-TYPE . ,(string->symbol (string-upcase os-name-string))))) + +;; Funny stuff is done. Rest of sequence is standardized. +(package-initialization-sequence + '( + ;; Microcode interface + (MICROCODE-TABLES) + (PRIMITIVE-IO) + (SAVE/RESTORE) + (STATE-SPACE) + (SYSTEM-CLOCK) + + ;; Basic data structures + (NUMBER) + (LIST) + (CHARACTER) + (CHARACTER-SET) + (GENSYM) + (STREAM) + (2D-PROPERTY) + (HASH) + (RANDOM-NUMBER) + + ;; Microcode data structures + (HISTORY) + (LAMBDA-ABSTRACTION) + (SCODE) + (SCODE-COMBINATOR) + (SCODE-SCAN) + (SCODE-WALKER) + (CONTINUATION-PARSER) + + ;; I/O ports + (CONSOLE-INPUT) + (CONSOLE-OUTPUT) + (FILE-INPUT) + (FILE-OUTPUT) + (STRING-INPUT) + (STRING-OUTPUT) + (TRUNCATED-STRING-OUTPUT) + (INPUT-PORT) + (OUTPUT-PORT) + (WORKING-DIRECTORY) + (LOAD) + + ;; Syntax + (PARSER) + (NUMBER-UNPARSER) + (UNPARSER) + (SYNTAXER) + (MACROS) + (SYSTEM-MACROS) + (DEFSTRUCT) + (UNSYNTAXER) + (PRETTY-PRINTER) + + ;; REP Loops + (ERROR-HANDLER) + (MICROCODE-ERRORS) + (INTERRUPT-HANDLER) + (GC-STATISTICS) + (REP) + + ;; Debugging + (ADVICE) + (DEBUGGER-COMMAND-LOOP) + (DEBUGGER-UTILITIES) + (ENVIRONMENT-INSPECTOR) + (DEBUGGING-INFO) + (DEBUGGER) + + ;; Emacs -- last because it grabs the kitchen sink. + (EMACS-INTERFACE) + )) + +) + +(add-system! (make-system "Microcode" + microcode-id/version + microcode-id/modification + '())) +(add-system! (make-system "Runtime" 14 0 '())) +(remove-environment-parent! system-packages) +(initial-top-level-repl) \ No newline at end of file diff --git a/v8/src/runtime/uenvir.scm b/v8/src/runtime/uenvir.scm new file mode 100644 index 000000000..c208b416b --- /dev/null +++ b/v8/src/runtime/uenvir.scm @@ -0,0 +1,141 @@ +;;; -*-Scheme-*- +;;; +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/uenvir.scm,v 14.1 1988/05/20 01:04:16 cph Exp $ +;;; +;;; Copyright (c) 1988 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of this +;;; software shall duly acknowledge such use, in accordance with +;;; the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; + +;;;; Microcode Environments + +(declare (usual-integrations)) + +;;;; Environment + +(define-integrable (environment? object) + (object-type? (ucode-type environment) object)) + +(define (environment-procedure environment) + (select-procedure (environment->external environment))) + +(define (environment-has-parent? environment) + (not (eq? (select-parent (environment->external environment)) + null-environment))) + +(define (environment-parent environment) + (select-parent (environment->external environment))) + +(define (environment-bindings environment) + (environment-split environment + (lambda (external internal) + (map (lambda (name) + (cons name + (if (lexical-unassigned? internal name) + '() + `(,(lexical-reference internal name))))) + (list-transform-negative + (map* (lambda-bound (select-lambda external)) + car + (let ((extension (environment-extension internal))) + (if (environment-extension? extension) + (environment-extension-aux-list extension) + '()))) + (lambda (name) + (lexical-unbound? internal name))))))) + +(define (environment-arguments environment) + (environment-split environment + (lambda (external internal) + (let ((lookup + (lambda (name) + (if (lexical-unassigned? internal name) + (make-unassigned-reference-trap) + (lexical-reference internal name))))) + (lambda-components* (select-lambda external) + (lambda (name required optional rest body) + name body + (map* (let loop ((names optional)) + (cond ((null? names) (if rest (lookup rest) '())) + ((lexical-unassigned? internal (car names)) '()) + (else + (cons (lookup (car names)) (loop (cdr names)))))) + lookup + required))))))) + +(define (set-environment-parent! environment parent) + (system-pair-set-cdr! + (let ((extension (environment-extension environment))) + (if (environment-extension? extension) + (begin (set-environment-extension-parent! extension parent) + (environment-extension-procedure extension)) + extension)) + parent)) + +(define (remove-environment-parent! environment) + (set-environment-parent! environment null-environment)) + +(define null-environment + (object-new-type (ucode-type null) 1)) + +(define (environment-split environment receiver) + (let ((procedure (select-procedure environment))) + (let ((lambda (compound-procedure-lambda procedure))) + (receiver (if (internal-lambda? lambda) + (compound-procedure-environment procedure) + environment) + environment)))) + +(define (environment->external environment) + (let ((procedure (select-procedure environment))) + (if (internal-lambda? (compound-procedure-lambda procedure)) + (compound-procedure-environment procedure) + environment))) + +(define-integrable (select-extension environment) + (system-vector-ref environment 0)) + +(define (select-procedure environment) + (let ((object (select-extension environment))) + (if (environment-extension? object) + (environment-extension-procedure object) + object))) + +(define (select-parent environment) + (compound-procedure-environment (select-procedure environment))) + +(define (select-lambda environment) + (compound-procedure-lambda (select-procedure environment))) + +(define (environment-extension environment) + (select-extension (environment->external environment))) \ No newline at end of file -- 2.25.1