From c799c06856108344575cde4af78d6f2f202a32e9 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 16 Dec 1986 02:55:59 +0000 Subject: [PATCH] *** empty log message *** --- v7/src/runtime/advice.scm | 458 ++++++++++++++++++++++++++++++++ v7/src/runtime/bitstr.scm | 83 ++++++ v7/src/runtime/boot.scm | 133 ++++++++++ v7/src/runtime/char.scm | 375 ++++++++++++++++++++++++++ v7/src/runtime/datime.scm | 117 +++++++++ v7/src/runtime/debug.scm | 536 ++++++++++++++++++++++++++++++++++++++ v7/src/runtime/emacs.scm | 164 ++++++++++++ v7/src/runtime/equals.scm | 85 ++++++ v7/src/runtime/error.scm | 471 +++++++++++++++++++++++++++++++++ v7/src/runtime/events.scm | 98 +++++++ v7/src/runtime/format.scm | 355 +++++++++++++++++++++++++ v7/src/runtime/gc.scm | 200 ++++++++++++++ v7/src/runtime/gcstat.scm | 270 +++++++++++++++++++ v7/src/runtime/gensym.scm | 68 +++++ v7/src/runtime/hash.scm | 269 +++++++++++++++++++ v7/src/runtime/histry.scm | 255 ++++++++++++++++++ 16 files changed, 3937 insertions(+) create mode 100644 v7/src/runtime/advice.scm create mode 100644 v7/src/runtime/bitstr.scm create mode 100644 v7/src/runtime/boot.scm create mode 100644 v7/src/runtime/char.scm create mode 100644 v7/src/runtime/datime.scm create mode 100644 v7/src/runtime/debug.scm create mode 100644 v7/src/runtime/emacs.scm create mode 100644 v7/src/runtime/equals.scm create mode 100644 v7/src/runtime/error.scm create mode 100644 v7/src/runtime/events.scm create mode 100644 v7/src/runtime/format.scm create mode 100644 v7/src/runtime/gc.scm create mode 100644 v7/src/runtime/gcstat.scm create mode 100644 v7/src/runtime/gensym.scm create mode 100644 v7/src/runtime/hash.scm create mode 100644 v7/src/runtime/histry.scm diff --git a/v7/src/runtime/advice.scm b/v7/src/runtime/advice.scm new file mode 100644 index 000000000..127025dcb --- /dev/null +++ b/v7/src/runtime/advice.scm @@ -0,0 +1,458 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1985 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. +;;; + +;;;; Advice package + +(declare (usual-integrations)) + +(define advice-package + (make-package advice-package + ((the-args) + (the-procedure) + (the-result) + + (entry-advice-population (make-population)) + (exit-advice-population (make-population)) + ) +(define (*args*) the-args) +(define (*proc*) the-procedure) +(define (*result*) the-result) + +;;;; Advice Wrappers + +(define (add-lambda-advice! lambda advice-transformation) + ((access lambda-wrap-body! lambda-package) lambda + (lambda (body state cont) + (if (null? state) + (cont (make-advice-hook) + (advice-transformation '() '() cons)) + (cont body + (advice-transformation (car state) (cdr state) cons)))))) + +(define (remove-lambda-advice! lambda advice-transformation) + (lambda-advice lambda + (lambda (entry-advice exit-advice) + (advice-transformation entry-advice exit-advice + (lambda (new-entry-advice new-exit-advice) + (if (and (null? new-entry-advice) + (null? new-exit-advice)) + ((access lambda-unwrap-body! lambda-package) lambda) + ((access lambda-wrap-body! lambda-package) lambda + (lambda (body state cont) + (cont body (cons new-entry-advice new-exit-advice)))))))))) + +(define (lambda-advice lambda cont) + ((access lambda-wrapper-components lambda-package) lambda + (lambda (original-body state) + (if (null? state) + (error "Procedure has no advice -- LAMBDA-ADVICE" lambda) + (cont (car state) + (cdr state)))))) + +(define (make-advice-hook) + (make-combination syntaxed-advice-procedure + (list (make-the-environment)))) + +(define syntaxed-advice-procedure + (scode-quote + (ACCESS ADVISED-PROCEDURE-WRAPPER ADVICE-PACKAGE '()))) + +;;;; The Advice Hook + +;;; This procedure is called with the newly-created environment as its +;;; argument. + +;;; Doing (PROCEED) from within entry or exit advice will cause that +;;; particular piece of advice to be terminated, but any remaining +;;; advice to be executed. Doing (PROCEED value), however, +;;; immediately terminates all advice and returns VALUE as if the +;;; procedure called had generated the value. Returning from a piece +;;; of exit advice is equivalent to doing (PROCEED value) from it. + +(define (advised-procedure-wrapper environment) + (let ((procedure (environment-procedure environment)) + (arguments (environment-arguments environment))) + ((access lambda-wrapper-components lambda-package) + (procedure-lambda procedure) + (lambda (original-body state) + (call-with-current-continuation + (lambda (continuation) + + (define ((catching-proceeds receiver) advice) + (with-proceed-point + (lambda (value) + (if (null? value) + '() + (continuation (car value)))) + (lambda () + (receiver advice)))) + + (for-each (catching-proceeds + (lambda (advice) + (advice procedure arguments environment))) + (car state)) + (let ((value (scode-eval original-body environment))) + (for-each (catching-proceeds + (lambda (advice) + (set! value + (advice procedure + arguments + value + environment)))) + (cdr state)) + value))))))) + +;;;; Primitive Advisors + +(define (primitive-advice lambda) + (lambda-advice lambda list)) + +(define (primitive-entry-advice lambda) + (lambda-advice lambda + (lambda (entry-advice exit-advice) + entry-advice))) + +(define (primitive-exit-advice lambda) + (lambda-advice lambda + (lambda (entry-advice exit-advice) + exit-advice))) + +(define (primitive-advise-entry lambda advice) + (add-lambda-advice! lambda + (lambda (entry-advice exit-advice cont) + (cont (if (memq advice entry-advice) + entry-advice + (cons advice entry-advice)) + exit-advice))) + (add-to-population! entry-advice-population lambda)) + +(define (primitive-advise-exit lambda advice) + (add-lambda-advice! lambda + (lambda (entry-advice exit-advice cont) + (cont entry-advice + (if (memq advice exit-advice) + exit-advice + (append! exit-advice (list advice)))))) + (add-to-population! exit-advice-population lambda)) + +(define ((primitive-advise-both new-entry-advice new-exit-advice) lambda) + (add-lambda-advice! lambda + (lambda (entry-advice exit-advice cont) + (cont (if (memq new-entry-advice entry-advice) + entry-advice + (cons new-entry-advice entry-advice)) + (if (memq new-exit-advice exit-advice) + exit-advice + (append! exit-advice (list new-exit-advice)))))) + (add-to-population! entry-advice-population lambda) + (add-to-population! exit-advice-population lambda)) + +(define (eq?-adjoin object list) + (if (memq object list) + list + (cons object list))) + +(define (primitive-unadvise-entire-entry lambda) + (remove-lambda-advice! lambda + (lambda (entry-advice exit-advice cont) + (cont '() exit-advice))) + (remove-from-population! entry-advice-population lambda)) + +(define (primitive-unadvise-entire-exit lambda) + (remove-lambda-advice! lambda + (lambda (entry-advice exit-advice cont) + (cont entry-advice '()))) + (remove-from-population! exit-advice-population lambda)) + +(define (primitive-unadvise-entire-lambda lambda) + ((access lambda-unwrap-body! lambda-package) lambda) + (remove-from-population! entry-advice-population lambda) + (remove-from-population! exit-advice-population lambda)) + +(define ((primitive-unadvise-entry advice) lambda) + (remove-lambda-advice! lambda + (lambda (entry-advice exit-advice cont) + (let ((new-entry-advice (delq! advice entry-advice))) + (if (null? new-entry-advice) + (remove-from-population! entry-advice-population lambda)) + (cont new-entry-advice exit-advice))))) + +(define ((primitive-unadvise-exit advice) lambda) + (remove-lambda-advice! lambda + (lambda (entry-advice exit-advice cont) + (let ((new-exit-advice (delq! advice exit-advice))) + (if (null? new-exit-advice) + (remove-from-population! exit-advice-population lambda)) + (cont entry-advice new-exit-advice))))) + +(define ((primitive-unadvise-both old-entry-advice old-exit-advice) lambda) + (remove-lambda-advice! lambda + (lambda (entry-advice exit-advice cont) + (let ((new-entry-advice (delq! old-entry-advice entry-advice)) + (new-exit-advice (delq! old-exit-advice exit-advice))) + (if (null? new-entry-advice) + (remove-from-population! entry-advice-population lambda)) + (if (null? new-exit-advice) + (remove-from-population! exit-advice-population lambda)) + (cont new-entry-advice new-exit-advice))))) + +(define (((particular-advisor advisor) advice) lambda) + (advisor lambda advice)) + +(define particular-entry-advisor (particular-advisor primitive-advise-entry)) +(define particular-exit-advisor (particular-advisor primitive-advise-exit)) +(define particular-both-advisor primitive-advise-both) +(define particular-entry-unadvisor primitive-unadvise-entry) +(define particular-exit-unadvisor primitive-unadvise-exit) +(define particular-both-unadvisor primitive-unadvise-both) + +;;;; Trace + +(define (trace-entry-advice proc args env) + (trace-display proc args)) + +(define (trace-exit-advice proc args result env) + (trace-display proc args result) + result) + +(define (trace-display proc args #!optional result) + (newline) + (let ((width (- (access printer-width implementation-dependencies) 3))) + (let ((output + (with-output-to-truncated-string + width + (lambda () + (if (unassigned? result) + (write-string "[Entering ") + (begin (write-string "[") + (write result) + (write-string " <== "))) + (write-string "<") + (write proc) + (for-each (lambda (arg) (write-char #\Space) (write arg)) + args))))) + (if (car output) ; Too long? + (begin + (write-string (substring (cdr output) 0 (- width 5))) + (write-string " ... ")) + (write-string (cdr output))))) + (write-string ">]")) + +(define primitive-trace-entry + (particular-entry-advisor trace-entry-advice)) + +(define primitive-trace-exit + (particular-exit-advisor trace-exit-advice)) + +(define primitive-trace-both + (particular-both-advisor trace-entry-advice trace-exit-advice)) + +(define primitive-untrace + (particular-both-unadvisor trace-entry-advice trace-exit-advice)) + +(define primitive-untrace-entry + (particular-entry-unadvisor trace-entry-advice)) + +(define primitive-untrace-exit + (particular-exit-unadvisor trace-exit-advice)) + +;;;; Break + +(define (break-rep env message . info) + (push-rep env + (lambda () + (apply trace-display info) + ((standard-rep-message message))) + (standard-rep-prompt breakpoint-prompt))) + +(define (break-entry-advice proc args env) + (fluid-let ((the-procedure proc) + (the-args args)) + (break-rep env "Breakpoint on entry" proc args))) + +(define (break-exit-advice proc args result env) + (fluid-let ((the-procedure proc) + (the-args args) + (the-result result)) + (break-rep env "Breakpoint on exit" proc args result)) + result) + +(define primitive-break-entry + (particular-entry-advisor break-entry-advice)) + +(define primitive-break-exit + (particular-exit-advisor break-exit-advice)) + +(define primitive-break-both + (particular-both-advisor break-entry-advice break-exit-advice)) + +(define primitive-unbreak + (particular-both-unadvisor break-entry-advice break-exit-advice)) + +(define primitive-unbreak-entry + (particular-entry-unadvisor break-entry-advice)) + +(define primitive-unbreak-exit + (particular-exit-unadvisor break-exit-advice)) + +;;;; Top Level Wrappers + +(define (find-internal-lambda procedure path) + (define (find-lambda lambda path) + (define (loop elements) + (cond ((null? elements) + (error "Couldn't find internal definition" path)) + ((definition? (car elements)) + (definition-components (car elements) + (lambda (name value) + (if (eq? name (car path)) + (if (lambda? value) + (find-lambda value (cdr path)) + (error "Internal definition not a procedure" path)) + (loop (cdr elements)))))) + (else + (loop (cdr elements))))) + + (if (null? path) + lambda + (lambda-components* lambda + (lambda (name required optional rest body) + (loop (sequence-actions body)))))) + + (if (null? path) + (procedure-lambda procedure) + (find-lambda (procedure-lambda procedure) (car path)))) + +;; The LIST-COPY will prevent any mutation problems. +(define ((wrap-advice-extractor extractor) procedure . path) + (list-copy (extractor (find-internal-lambda procedure path)))) + +(define advice (wrap-advice-extractor primitive-advice)) +(define entry-advice (wrap-advice-extractor primitive-entry-advice)) +(define exit-advice (wrap-advice-extractor primitive-exit-advice)) + +(define ((wrap-general-advisor advisor) procedure advice . path) + (advisor (find-internal-lambda procedure path) advice) + *the-non-printing-object*) + +(define advise-entry (wrap-general-advisor primitive-advise-entry)) +(define advise-exit (wrap-general-advisor primitive-advise-exit)) + +(define (((wrap-unadvisor map-over-population) unadvisor) . procedure&path) + (if (null? procedure&path) + (map-over-population unadvisor) + (unadvisor (find-internal-lambda (car procedure&path) + (cdr procedure&path)))) + *the-non-printing-object*) + +(define wrap-entry-unadvisor + (wrap-unadvisor + (lambda (operation) + (map-over-population entry-advice-population operation)))) + +(define wrap-exit-unadvisor + (wrap-unadvisor + (lambda (operation) + (map-over-population exit-advice-population operation)))) + +(define wrap-both-unadvisor + (wrap-unadvisor + (lambda (operation) + (map-over-population entry-advice-population operation) + (map-over-population exit-advice-population operation)))) + +(define unadvise (wrap-both-unadvisor primitive-unadvise-entire-lambda)) +(define unadvise-entry (wrap-entry-unadvisor primitive-unadvise-entire-entry)) +(define unadvise-exit (wrap-exit-unadvisor primitive-unadvise-entire-exit)) + +(define untrace (wrap-both-unadvisor primitive-untrace)) +(define untrace-entry (wrap-entry-unadvisor primitive-untrace-entry)) +(define untrace-exit (wrap-exit-unadvisor primitive-untrace-exit)) + +(define unbreak (wrap-both-unadvisor primitive-unbreak)) +(define unbreak-entry (wrap-entry-unadvisor primitive-unbreak-entry)) +(define unbreak-exit (wrap-exit-unadvisor primitive-unbreak-exit)) + +(define ((wrap-advisor advisor) procedure . path) + (advisor (find-internal-lambda procedure path)) + *the-non-printing-object*) + +(define trace-entry (wrap-advisor primitive-trace-entry)) +(define trace-exit (wrap-advisor primitive-trace-exit)) +(define trace-both (wrap-advisor primitive-trace-both)) + +(define break-entry (wrap-advisor primitive-break-entry)) +(define break-exit (wrap-advisor primitive-break-exit)) +(define break-both (wrap-advisor primitive-break-both)) + +;;; end of ADVICE-PACKAGE. +)) + +;;;; Exports + +(define advice (access advice advice-package)) +(define entry-advice (access entry-advice advice-package)) +(define exit-advice (access exit-advice advice-package)) + +(define advise-entry (access advise-entry advice-package)) +(define advise-exit (access advise-exit advice-package)) + +(define unadvise (access unadvise advice-package)) +(define unadvise-entry (access unadvise-entry advice-package)) +(define unadvise-exit (access unadvise-exit advice-package)) + +(define trace (access trace-both advice-package)) +(define trace-entry (access trace-entry advice-package)) +(define trace-exit (access trace-exit advice-package)) +(define trace-both (access trace-both advice-package)) + +(define untrace (access untrace advice-package)) +(define untrace-entry (access untrace-entry advice-package)) +(define untrace-exit (access untrace-exit advice-package)) + +(define break (access break-both advice-package)) +(define break-entry (access break-entry advice-package)) +(define break-exit (access break-exit advice-package)) +(define break-both (access break-both advice-package)) + +(define unbreak (access unbreak advice-package)) +(define unbreak-entry (access unbreak-entry advice-package)) +(define unbreak-exit (access unbreak-exit advice-package)) + +(define *args* (access *args* advice-package)) +(define *proc* (access *proc* advice-package)) +(define *result* (access *result* advice-package)) \ No newline at end of file diff --git a/v7/src/runtime/bitstr.scm b/v7/src/runtime/bitstr.scm new file mode 100644 index 000000000..fb3127737 --- /dev/null +++ b/v7/src/runtime/bitstr.scm @@ -0,0 +1,83 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Bit String Primitives + +(declare (usual-integrations)) + +(in-package system-global-environment +(let-syntax () + (define-macro (define-primitives . names) + `(BEGIN ,@(map (lambda (name) + `(DEFINE ,name + ,(make-primitive-procedure name))) + names))) + (define-primitives + bit-string-allocate make-bit-string bit-string? + bit-string-length bit-string-ref bit-string-clear! bit-string-set! + bit-string-zero? bit-string=? + bit-string-fill! bit-string-move! bit-string-movec! + bit-string-or! bit-string-and! bit-string-andc! + bit-substring-move-right! + bit-string->unsigned-integer unsigned-integer->bit-string + read-bits! write-bits!))) + +(define (bit-string-append x y) + (let ((x-length (bit-string-length x)) + (y-length (bit-string-length y))) + (let ((result (bit-string-allocate (+ x-length y-length)))) + (bit-substring-move-right! x 0 x-length result 0) + (bit-substring-move-right! y 0 y-length result x-length) + result))) + +(define (bit-substring bit-string start end) + (let ((result (bit-string-allocate (- end start)))) + (bit-substring-move-right! bit-string start end result 0) + result)) + +(define (signed-integer->bit-string nbits number) + (unsigned-integer->bit-string nbits + (if (negative? number) + (+ number (expt 2 nbits)) + number))) + +(define (bit-string->signed-integer bit-string) + (let ((unsigned-result (bit-string->unsigned-integer bit-string)) + (nbits (bit-string-length bit-string))) + (if (bit-string-ref bit-string (-1+ nbits)) ;Sign bit. + (- unsigned-result (expt 2 nbits)) + unsigned-result))) \ No newline at end of file diff --git a/v7/src/runtime/boot.scm b/v7/src/runtime/boot.scm new file mode 100644 index 000000000..ba1bd1798 --- /dev/null +++ b/v7/src/runtime/boot.scm @@ -0,0 +1,133 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Boot Utilities + +(declare (usual-integrations)) + +;;; The utilities in this file are the first thing loaded into the +;;; world after the type tables. They can't depend on anything else +;;; except those tables. + +;;;; Primitive Operators + +(let-syntax ((define-global-primitives + (macro names + `(BEGIN + ,@(mapcar (lambda (name) + `(DEFINE ,name ,(make-primitive-procedure name))) + names))))) + (define-global-primitives + SCODE-EVAL FORCE WITH-THREADED-CONTINUATION + SET-INTERRUPT-ENABLES! WITH-INTERRUPTS-REDUCED + WITH-INTERRUPT-MASK + GET-FIXED-OBJECTS-VECTOR WITH-HISTORY-DISABLED + PRIMITIVE-PROCEDURE-ARITY NOT FALSE? + UNSNAP-LINKS! + + ;; Environment + LEXICAL-REFERENCE LEXICAL-ASSIGNMENT LOCAL-ASSIGNMENT + LEXICAL-UNASSIGNED? LEXICAL-UNBOUND? LEXICAL-UNREFERENCEABLE? + + ;; Pointers + EQ? + PRIMITIVE-SET-TYPE MAKE-NON-POINTER-OBJECT + PRIMITIVE-TYPE? PRIMITIVE-TYPE PRIMITIVE-DATUM + OBJECT-DANGEROUS? MAKE-OBJECT-SAFE MAKE-OBJECT-DANGEROUS + + ;; System Compound Datatypes + MAKE-CELL CELL? CELL-CONTENTS SET-CELL-CONTENTS! + + SYSTEM-PAIR-CONS SYSTEM-PAIR? + SYSTEM-PAIR-CAR SYSTEM-PAIR-SET-CAR! + SYSTEM-PAIR-CDR SYSTEM-PAIR-SET-CDR! + + SYSTEM-HUNK3-CXR0 SYSTEM-HUNK3-SET-CXR0! + SYSTEM-HUNK3-CXR1 SYSTEM-HUNK3-SET-CXR1! + SYSTEM-HUNK3-CXR2 SYSTEM-HUNK3-SET-CXR2! + + SYSTEM-LIST-TO-VECTOR SYSTEM-SUBVECTOR-TO-LIST SYSTEM-VECTOR? + SYSTEM-VECTOR-SIZE SYSTEM-VECTOR-REF SYSTEM-VECTOR-SET! + ) +;;; end of DEFINE-GLOBAL-PRIMITIVES scope. +) + +;;;; Potpourri + +(define *the-non-printing-object* '(*THE-NON-PRINTING-OBJECT*)) +(define (identity-procedure x) x) +(define false #F) +(define true #T) + +(define (null-procedure . args) '()) +(define (false-procedure . args) #F) +(define (true-procedure . args) #T) + +(define (without-interrupts thunk) + (with-interrupts-reduced interrupt-mask-gc-ok + (lambda (old-mask) + (thunk)))) + +(define apply + (let ((primitive (make-primitive-procedure 'APPLY))) + (named-lambda (apply f . args) + (primitive 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 system-hunk3-cons + (let ((hunk3-cons (make-primitive-procedure 'HUNK3-CONS))) + (named-lambda (system-hunk3-cons type cxr0 cxr1 cxr2) + (primitive-set-type type (hunk3-cons cxr0 cxr1 cxr2))))) + +(define (symbol-hash symbol) + (string-hash (symbol->string symbol))) + +(define (symbol-append . symbols) + (string->symbol (apply string-append (map symbol->string symbols)))) + +(define (boolean? object) + (or (eq? object #F) + (eq? object #T))) \ No newline at end of file diff --git a/v7/src/runtime/char.scm b/v7/src/runtime/char.scm new file mode 100644 index 000000000..cf345fb7c --- /dev/null +++ b/v7/src/runtime/char.scm @@ -0,0 +1,375 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; New Character Abstraction + +(declare (usual-integrations)) + +(in-package system-global-environment +(let-syntax () + (define-macro (define-primitives . names) + `(BEGIN ,@(map (lambda (name) + `(DEFINE ,name ,(make-primitive-procedure name))) + names))) + (define-primitives + make-char char-code char-bits + char->integer integer->char char->ascii + char-ascii? ascii->char + char-upcase char-downcase))) + +(define char-code-limit #x80) +(define char-bits-limit #x20) +(define char-integer-limit (* char-code-limit char-bits-limit)) + +(define (chars->ascii chars) + (map char->ascii chars)) + +(define (code->char code) + (make-char code 0)) + +(define (char=? x y) + (= (char->integer x) (char->integer y))) + +(define (charinteger x) (char->integer y))) + +(define (char<=? x y) + (<= (char->integer x) (char->integer y))) + +(define (char>? x y) + (> (char->integer x) (char->integer y))) + +(define (char>=? x y) + (>= (char->integer x) (char->integer y))) + +(define (char-ci->integer char) + (char->integer (char-upcase char))) + +(define (char-ci=? x y) + (= (char-ci->integer x) (char-ci->integer y))) + +(define (char-ciinteger x) (char-ci->integer y))) + +(define (char-ci<=? x y) + (<= (char-ci->integer x) (char-ci->integer y))) + +(define (char-ci>? x y) + (> (char-ci->integer x) (char-ci->integer y))) + +(define (char-ci>=? x y) + (>= (char-ci->integer x) (char-ci->integer y))) + +(define char?) +(define digit->char) +(define char->digit) +(define name->char) +(define char->name) +(let () + +(define char-type + (microcode-type 'CHARACTER)) + +(define 0-code (char-code (ascii->char #x30))) +(define upper-a-code (char-code (ascii->char #x41))) +(define lower-a-code (char-code (ascii->char #x61))) +(define space-char (ascii->char #x20)) +(define hyphen-char (ascii->char #x2D)) +(define backslash-char (ascii->char #x5C)) + +(define named-codes + `(("Backspace" . #x08) + ("Tab" . #x09) + ("Linefeed" . #x0A) + ("VT" . #x0B) + ("Page" . #x0C) + ("Return" . #x0D) + ("Call" . #x1A) + ("Altmode" . #x1B) + ("Backnext" . #x1F) + ("Space" . #x20) + ("Rubout" . #x7F) + )) + +(define named-bits + `(("C" . #o01) + ("Control" . #o01) + ("M" . #o02) + ("Meta" . #o02) + ("S" . #o04) + ("Super" . #o04) + ("H" . #o10) + ("Hyper" . #o10) + ("T" . #o20) + ("Top" . #o20) + )) + +(define (-map-> alist string start end) + (define (loop entries) + (and (not (null? entries)) + (let ((key (caar entries))) + (if (substring-ci=? string start end + key 0 (string-length key)) + (cdar entries) + (loop (cdr entries)))))) + (loop alist)) + +(define (<-map- alist n) + (define (loop entries) + (and (not (null? entries)) + (if (= n (cdar entries)) + (caar entries) + (loop (cdr entries))))) + (loop alist)) + +(set! char? +(named-lambda (char? object) + (primitive-type? char-type object))) + +(set! digit->char +(named-lambda (digit->char digit #!optional radix) + (cond ((unassigned? radix) (set! radix 10)) + ((not (and (<= 2 radix) (<= radix 36))) + (error "DIGIT->CHAR: Bad radix" radix))) + (and (<= 0 digit) (< digit radix) + (code->char (if (< digit 10) + (+ digit 0-code) + (+ (- digit 10) upper-a-code)))))) + +(set! char->digit +(named-lambda (char->digit char #!optional radix) + (cond ((unassigned? radix) (set! radix 10)) + ((not (and (<= 2 radix) (<= radix 36))) + (error "CHAR->DIGIT: Bad radix" radix))) + (and (zero? (char-bits char)) + (let ((code (char-code char))) + (define (try base-digit base-code) + (let ((n (+ base-digit (- code base-code)))) + (and (<= base-digit n) + (< n radix) + n))) + (or (try 0 0-code) + (try 10 upper-a-code) + (try 10 lower-a-code)))))) + +(set! name->char +(named-lambda (name->char string) + (let ((end (string-length string)) + (bits '())) + (define (loop start) + (let ((left (- end start))) + (cond ((zero? left) + (error "Missing character name")) + ((= left 1) + (let ((char (string-ref string start))) + (if (char-graphic? char) + (char-code char) + (error "Non-graphic character" char)))) + (else + (let ((hyphen (substring-find-next-char string start end + hyphen-char))) + (if (not hyphen) + (name->code string start end) + (let ((bit (-map-> named-bits string start hyphen))) + (if (not bit) + (name->code string start end) + (begin (if (not (memv bit bits)) + (set! bits (cons bit bits))) + (loop (1+ hyphen))))))))))) + (let ((code (loop 0))) + (make-char code (apply + bits)))))) + +(define (name->code string start end) + (if (substring-ci=? string start end "Newline" 0 7) + (char-code char:newline) + (or (-map-> named-codes string start end) + (error "Unknown character name" (substring string start end))))) + +(set! char->name +(named-lambda (char->name char #!optional slashify?) + (if (unassigned? slashify?) (set! slashify? false)) + (define (loop weight bits) + (if (zero? bits) + (let ((code (char-code char))) + (let ((base-char (code->char code))) + (cond ((<-map- named-codes code)) + ((and slashify? + (not (zero? (char-bits char))) + (or (char=? base-char backslash-char) + (char-set-member? (access atom-delimiters + parser-package) + base-char))) + (string-append "\\" (char->string base-char))) + ((char-graphic? base-char) + (char->string base-char)) + (else + (string-append ""))))) + (let ((qr (integer-divide bits 2))) + (let ((rest (loop (* weight 2) (integer-divide-quotient qr)))) + (if (zero? (integer-divide-remainder qr)) + rest + (string-append (or (<-map- named-bits weight) + (string-append "")) + "-" + rest)))))) + (loop 1 (char-bits char)))) + +) + +;;;; Character Sets + +(define (char-set? object) + (and (string? object) (= (string-length object) 256))) + +(define (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 (predicate->char-set predicate) + (let ((char-set (string-allocate 256))) + (define (loop code) + (if (< code 256) + (begin (vector-8b-set! char-set code + (if (predicate (ascii->char code)) 1 0)) + (loop (1+ code))))) + (loop 0) + 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 + (predicate->char-set + (let ((lower (ascii->char #x41)) + (upper (ascii->char #x5A))) + (lambda (char) + (and (char<=? lower char) + (char<=? char upper)))))) + +(define char-set:lower-case + (predicate->char-set + (let ((lower (ascii->char #x61)) + (upper (ascii->char #x7A))) + (lambda (char) + (and (char<=? lower char) + (char<=? char upper)))))) + +(define char-set:numeric + (predicate->char-set + (let ((lower (ascii->char #x30)) + (upper (ascii->char #x39))) + (lambda (char) + (and (char<=? lower char) + (char<=? char upper)))))) + +(define char-set:alphabetic + (char-set-union char-set:upper-case char-set:lower-case)) + +(define char-set:alphanumeric + (char-set-union char-set:alphabetic char-set:numeric)) + +(define char-set:graphic + (predicate->char-set + (let ((lower (ascii->char #x20)) + (upper (ascii->char #x7E))) + (lambda (char) + (and (char<=? lower char) + (char<=? char upper)))))) + +(define char-set:standard + (char-set-union char-set:graphic (char-set (ascii->char #x0D)))) + +(define char-set:whitespace + (char-set (ascii->char #x09) ;Tab + (ascii->char #x0A) ;Linefeed + (ascii->char #x0C) ;Page + (ascii->char #x0D) ;Return + (ascii->char #x20) ;Space + )) + +(define char-set:not-whitespace + (char-set-invert char-set:whitespace)) + +(define ((char-set-predicate char-set) char) + (char-set-member? char-set char)) + +(define char-upper-case? (char-set-predicate char-set:upper-case)) +(define char-lower-case? (char-set-predicate char-set:lower-case)) +(define char-numeric? (char-set-predicate char-set:numeric)) +(define char-alphabetic? (char-set-predicate char-set:alphabetic)) +(define char-alphanumeric? (char-set-predicate char-set:alphanumeric)) +(define char-graphic? (char-set-predicate char-set:graphic)) +(define char-standard? (char-set-predicate char-set:standard)) diff --git a/v7/src/runtime/datime.scm b/v7/src/runtime/datime.scm new file mode 100644 index 000000000..87d4d09a4 --- /dev/null +++ b/v7/src/runtime/datime.scm @@ -0,0 +1,117 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1985 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. +;;; + +;;;; Date and Time Routines + +(declare (usual-integrations)) + +;;;; Date and Time + +(define date + (let ((year (make-primitive-procedure 'CURRENT-YEAR)) + (month (make-primitive-procedure 'CURRENT-MONTH)) + (day (make-primitive-procedure 'CURRENT-DAY))) + (named-lambda (date #!optional receiver) + ((if (unassigned? receiver) list receiver) + (year) (month) (day))))) + +(define time + (let ((hour (make-primitive-procedure 'CURRENT-HOUR)) + (minute (make-primitive-procedure 'CURRENT-MINUTE)) + (second (make-primitive-procedure 'CURRENT-SECOND))) + (named-lambda (time #!optional receiver) + ((if (unassigned? receiver) list receiver) + (hour) (minute) (second))))) + +(define date->string) +(define time->string) +(let () + +(set! date->string +(named-lambda (date->string year month day) + (if year + (string-append + (vector-ref days-of-the-week + (let ((qr (integer-divide year 4))) + (remainder (+ (* year 365) + (if (and (zero? (integer-divide-remainder qr)) + (<= month 2)) + (integer-divide-quotient qr) + (1+ (integer-divide-quotient qr))) + (vector-ref days-through-month (-1+ month)) + day + 6) + 7))) + " " + (vector-ref months-of-the-year (-1+ month)) + " " + (write-to-string day) + ", 19" + (write-to-string year)) + "Date primitives not installed"))) + +(define months-of-the-year + #("January" "February" "March" "April" "May" "June" "July" + "August" "September" "October" "November" "December")) + +(define days-of-the-week + #("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday")) + +(define days-through-month + (let () + (define (month-loop months value) + (if (null? months) + '() + (cons value + (month-loop (cdr months) (+ value (car months)))))) + (list->vector (month-loop '(31 28 31 30 31 30 31 31 30 31 30 31) 0)))) + +(set! time->string +(named-lambda (time->string hour minute second) + (if hour + (string-append (write-to-string + (cond ((zero? hour) 12) + ((< hour 13) hour) + (else (- hour 12)))) + (if (< minute 10) ":0" ":") + (write-to-string minute) + (if (< second 10) ":0" ":") + (write-to-string second) + " " + (if (< hour 12) "AM" "PM")) + "Time primitives not installed"))) + diff --git a/v7/src/runtime/debug.scm b/v7/src/runtime/debug.scm new file mode 100644 index 000000000..16b17340b --- /dev/null +++ b/v7/src/runtime/debug.scm @@ -0,0 +1,536 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1985 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 + +(in-package debugger-package +(declare (usual-integrations)) + +(define debug-package + (make-package debug-package + ((current-continuation) + (previous-continuations) + (command-set (make-command-set 'DEBUG-COMMANDS)) + (current-reduction-number) + (current-number-of-reductions) + (current-reduction) + (current-environment) + (reduction-wrap-around-tag 'WRAP-AROUND) + (print-user-friendly-name + (access print-user-friendly-name env-package)) + (print-expression pp) + (student-walk? #!FALSE) + (print-return-values? #!FALSE)) + +(define (define-debug-command letter function help-text) + (define-letter-command command-set letter function help-text)) + +;;; Basic Commands + +(define-debug-command #\? (standard-help-command command-set) + "Help, list command letters") + +(define-debug-command #\Q standard-exit-command "Quit (exit DEBUG)") + +(define (debug #!optional the-continuation) + (fluid-let ((current-continuation) + (previous-continuations '()) + (current-reduction-number) + (current-number-of-reductions) + (current-reduction #!FALSE) + (current-environment '())) + + (debug-abstract-continuation + (cond ((unassigned? the-continuation) (rep-continuation)) + ((raw-continuation? the-continuation); Must precede next test! + (raw-continuation->continuation the-continuation)) + ((continuation? the-continuation) the-continuation) + (else (Error "DEBUG: Not a continuation" the-continuation)))))) + +(define (debug-abstract-continuation continuation) + (set-current-continuation! continuation initial-reduction-number) + (letter-commands command-set + (lambda () + (print-current-expression) + ((standard-rep-message "Debugger"))) + (standard-rep-prompt "Debug-->"))) + +(define (undefined-environment? environment) + (or (continuation-undefined-environment? environment) + (eq? environment system-global-environment) + (and (environment? environment) + ((access system-external-environment? environment-package) + environment)))) + +(define (print-undefined-environment) + (format "~%Undefined environment at this subproblem/reduction level")) + +(define (with-rep-alternative env receiver) + (if (undefined-environment? env) + (begin + (print-undefined-environment) + (format "~%Using the read-eval-print environment instead!") + (receiver (rep-environment))) + (receiver env))) + +(define (if-valid-environment env receiver) + (if (undefined-environment? env) + (print-undefined-environment) + (receiver env))) + +(define (current-expression) + (if current-reduction + (reduction-expression current-reduction) + (let ((exp (continuation-expression current-continuation))) + (if (or (not (continuation-undefined-expression? exp)) + (null? (continuation-annotation current-continuation))) + exp + (cons 'UNDEFINED-EXPRESSION + (continuation-annotation current-continuation)))))) + +;;;; Random display commands + +(define (pretty-print-current-expression) + (print-expression (current-expression))) + +(define-debug-command #\L pretty-print-current-expression + "(list expression) Pretty-print the current expression") + +(define (pretty-print-reduction-function) + (if-valid-environment (if current-reduction + (reduction-environment current-reduction) + current-environment) + (lambda (env) (pp (environment-procedure env))))) + +(define-debug-command #\P pretty-print-reduction-function + "Pretty print current procedure") + +(define (print-current-expression) + (define (print-current-reduction) + (format "~2xReduction Number:~x~o~%Expression:" current-reduction-number) + (print-expression (reduction-expression current-reduction))) + + (define (print-application-information env) + (define (do-it return?) + (if return? (format "~%within ") (format "within ")) + (print-user-friendly-name env) + (if return? + (format "~%applied to ~@68o" (environment-arguments env)) + (format " applied to ~@68o" (environment-arguments env)))) + + (let ((output (with-output-to-string (lambda () (do-it #!FALSE))))) + (if (< (string-length output) + (access printer-width implementation-dependencies)) + (format "~%~s" output) + (do-it #!TRUE)))) + + (if (null-continuation? current-continuation) + (format "~%Null continuation") + (begin + (format "~%Subproblem Level: ~o" (length previous-continuations)) + (if current-reduction + (print-current-reduction) + (begin + (format "~%Possibly Incomplete Expression:") + (print-expression (continuation-expression current-continuation)))) + (if-valid-environment current-environment + print-application-information)))) + +(define-debug-command #\S print-current-expression + "Print the current subproblem/reduction") + +(define (reductions-command) + (if (null-continuation? current-continuation) + (format "~%Null continuation") + (let loop ((r (continuation-reductions current-continuation))) + (cond ((pair? r) + (print-expression (reduction-expression (car r))) + (loop (cdr r))) + ((wrap-around-in-reductions? r) + (format "~%Wrap Around in the reductions at this level.")) + (else 'done))))) + +(define-debug-command #\R reductions-command + "Print the reductions of the current subproblem level") + +;;;; Short history display + +(define (summarize-history-command) + (define (print-continuations cont level) + (define (print-reductions reductions show-all?) + (define (print-reduction red number) + (terse-print-expression level + (reduction-expression red) + (reduction-environment red))) + + (let loop ((reductions reductions) (number 0)) + (if (pair? reductions) + (begin + (print-reduction (car reductions) number) + (if show-all? (loop (cdr reductions) (1+ number))))))) + + (if (null-continuation? cont) + *the-non-printing-object* + (begin + (let ((reductions (continuation-reductions cont))) + (if (not (pair? reductions)) + (terse-print-expression level + (continuation-expression cont) + (continuation-environment cont)) + (print-reductions reductions (= level 0)))) + (print-continuations (continuation-next-continuation cont) + (1+ level))))) + + (let ((top-continuation (if (null? previous-continuations) + current-continuation + (car (last-pair previous-continuations))))) + + (if (null-continuation? top-continuation) + (format "~%No history available") + (begin + (format "~%Sub Prb. Procedure Name Expression~%") + (print-continuations top-continuation 0))))) + +(define terse-print-expression + (let ((the-non-printing-symbol (make-symbol ""))) + (named-lambda (terse-print-expression level expression environment) + (format "~%~@3o~:20o~4x~@:52c" + level + ;; procedure name + (if (or (undefined-environment? environment) + (special-name? (environment-name environment))) + the-non-printing-symbol + (environment-name environment)) + expression)))) + +(define-debug-command #\H summarize-history-command + "Prints a summary of the entire history") + +;;;; Motion to earlier expressions + +(define (earlier-reduction) + (define (up! message) + (format "~%~s~%Going to the previous (earlier) continuation!" message) + (earlier-continuation-command)) + + (cond ((and student-walk? + (> (length previous-continuations) 0) + (= current-reduction-number 0)) + (earlier-continuation-command)) + ((< current-reduction-number (-1+ current-number-of-reductions)) + (set-current-reduction! (1+ current-reduction-number)) + (print-current-expression)) + ((wrap-around-in-reductions? + (continuation-reductions current-continuation)) + (up! "Wrap around in reductions at this level!")) + (else (up! "No more reductions at this level!")))) + +(define-debug-command #\B earlier-reduction "Earlier reduction (Back in time)") + +(define (earlier-subproblem) + (let ((new (continuation-next-continuation current-continuation))) + (set! previous-continuations + (cons current-continuation previous-continuations)) + (set-current-continuation! new normal-reduction-number))) + +(define (earlier-continuation-command) + (if (not (null-continuation? (continuation-next-continuation + current-continuation))) + (earlier-subproblem) + (format "~%There are only ~o subproblem levels" + (length previous-continuations))) + (print-current-expression)) + +(define-debug-command #\U earlier-continuation-command + "Move (Up) to the previous (earlier) continuation") + +;;;; Motion to later expressions + +(define (later-reduction) + (cond ((> current-reduction-number 0) + (set-current-reduction! (-1+ current-reduction-number)) + (print-current-expression)) + ((or (not student-walk?) + (= (length previous-continuations) 1)) + (later-continuation-TO-LAST-REDUCTION)) + (else (later-continuation)))) + +(define-debug-command #\F later-reduction "Later reduction (Forward in time)") + +(define (later-continuation) + (if (null? previous-continuations) + (format "~%Already at lowest subproblem level") + (begin (later-subproblem) (print-current-expression)))) + +(define (later-continuation-TO-LAST-REDUCTION) + (define (later-subproblem-TO-LAST-REDUCTION) + (set-current-continuation! + (car (set! previous-continuations (cdr previous-continuations))) + last-reduction-number)) + + (if (null? previous-continuations) + (format "~%Already at lowest subproblem level") + (begin (later-subproblem-TO-LAST-REDUCTION) + (print-current-expression)))) + +(define (later-subproblem) + (set-current-continuation! + (car (set! previous-continuations (cdr previous-continuations))) + normal-reduction-number)) + +(define (later-continuation-command) + (if (null? previous-continuations) + (format "~%Already at oldest continuation") + (begin (later-subproblem) (print-current-expression)))) + +(define-debug-command #\D later-continuation-command + "Move (Down) to the next (later) continuation") + +;;;; General motion command + +(define (goto-command) + (define (get-reduction-number) + (format "~%Reduction Number (0 through ~o inclusive): " + (-1+ current-number-of-reductions)) + (let ((red (read))) + (cond ((not (number? red)) + (beep) + (format "~%Reduction number must be numeric!") + (get-reduction-number)) + ((not (and (>= red 0) + (< red current-number-of-reductions))) + (format "~%Reduction number out of range.!") + (get-reduction-number)) + (else (set-current-reduction! red))))) + + (define (choose-reduction) + (cond ((> current-number-of-reductions 1) (get-reduction-number)) + ((= current-number-of-reductions 1) + (format "~%There is only one reduction for this subproblem") + (set-current-reduction! 1)) + (else (format "~%There are no reductions for this subproblem.")))) + + (define (get-subproblem-number) + (format "~%Subproblem number: ") + (let ((len (length previous-continuations)) (sub (read))) + (cond ((not (number? sub)) + (beep) + (format "~%Subproblem level must be numeric!") + (get-subproblem-number)) + ((< sub len) (repeat later-subproblem (- len sub)) + (choose-reduction)) + (else + (let loop ((len len)) + (cond ((= sub len) (choose-reduction)) + ((null-continuation? + (continuation-next-continuation current-continuation)) + (format "~%There is no such subproblem.") + (format "~%Now at subproblem number: ~o" + (length previous-continuations)) + (choose-reduction)) + (else (earlier-subproblem) (loop (1+ len))))))))) + + (get-subproblem-number) + (print-current-expression)) + +(define-debug-command #\G goto-command + "Go to a particular Subproblem/Reduction level") + +;;;; Evaluation and frame display commands + +(define (enter-read-eval-print-loop) + (with-rep-alternative + current-environment + (lambda (env) + (read-eval-print env + "You are now in the desired environment" + "Eval-in-env-->")))) + +(define-debug-command #\E enter-read-eval-print-loop + "Enter a read-eval-print loop in the current environment") + +(define (eval-in-current-environment) + (with-rep-alternative current-environment + (lambda (env) + (environment-warning-hook env) + (format "~%Eval--> ") + (eval (read) env)))) + +(define-debug-command #\V eval-in-current-environment + "Evaluate expression in current environment") + +(define show-current-frame + (let ((show-frame (access show-frame env-package))) + (named-lambda (show-current-frame) + (if-valid-environment current-environment + (lambda (env) (show-frame env -1)))))) + +(define-debug-command #\C show-current-frame + "Show Bindings of identifiers in the current environment") + +(define (enter-where-command) + (with-rep-alternative current-environment where)) + +(define-debug-command #\W enter-where-command + "Enter WHERE on the current environment") + +(define (error-info-command) + (format "~% Message: ~s~%Irritant: ~o" (error-message) (error-irritant))) + +(define-debug-command #\I error-info-command "Redisplay the error message") + +;;;; Advanced hacking commands + +(define (return-command) ;command Z + (define (confirm) + (format "~%Confirm: [Y or N] ") + (let ((ans (read))) + (cond ((eq? ans 'Y) #!TRUE) + ((eq? ans 'N) #!FALSE) + (else (confirm))))) + + (define (return-read) + (let ((exp (read))) + (if (eq? exp '$) + (unsyntax (current-expression)) + exp))) + + (define (do-it environment next) + (environment-warning-hook environment) + (format "~%Expression to EVALUATE and CONTINUE with ($ to retry): ") + (if print-return-values? + (let ((eval-exp (eval (return-read) environment))) + (format "~%That evaluates to:~%~o" eval-exp) + (if (confirm) (next eval-exp))) + (next (eval (return-read) environment)))) + + (let ((next (continuation-next-continuation current-continuation))) + (if (null-continuation? next) + (begin (beep) (format "~%Can't continue!!!")) + (with-rep-alternative current-environment + (lambda (env) (do-it env next)))))) + +(define-debug-command #\Z return-command + "Return (continue with) an expression after evaluating it") + +(define user-debug-environment (make-environment)) + +(define (internal-command) + (read-eval-print user-debug-environment + "You are now in the debugger environment" + "Debugger-->")) + +(define-debug-command #\X internal-command + "Create a read eval print loop in the debugger environment") + +;;;; Reduction and continuation motion low-level + +(define reduction-expression car) +(define reduction-environment cadr) + +(define (last-reduction-number) + (-1+ current-number-of-reductions)) + +(define (normal-reduction-number) + (min (-1+ current-number-of-reductions) 0)) + +(define (initial-reduction-number) + (let ((environment (continuation-environment current-continuation))) + (if (and (environment? environment) + (let ((procedure (environment-procedure environment))) + (or (eq? procedure error-procedure) + (eq? procedure breakpoint-procedure)))) + 1 + 0))) + +(define (set-current-continuation! continuation hook) + (set! current-continuation continuation) + (set! current-number-of-reductions + (if (null-continuation? continuation) + 0 + (dotted-list-length + (continuation-reductions current-continuation)))) + (set-current-reduction! (hook))) + +(define (set-current-reduction! number) + (set! current-reduction-number number) + (if (and (not (= current-number-of-reductions 0)) (>= number 0)) + (set! current-reduction + (list-ref (continuation-reductions current-continuation) number)) + (set! current-reduction #!FALSE)) + (set! current-environment + (if current-reduction + (reduction-environment current-reduction) + (continuation-environment current-continuation)))) + +(define (repeat f n) + (if (> n 0) + (begin (f) + (repeat f (-1+ n))))) + +(define (dotted-list-length l) + (let count ((n 0) (L L)) + (if (pair? l) + (count (1+ n) (CDR L)) + n))) + +(define (wrap-around-in-reductions? reductions) + (eq? (list-tail reductions (dotted-list-length reductions)) + reduction-wrap-around-tag)) + +;;; end DEBUG-PACKAGE. +)) +;;; end IN-PACKAGE DEBUGGER-PACKAGE. +) + +(define debug + (access debug debug-package debugger-package)) + +(define special-name? + (let ((the-special-names + (list lambda-tag:unnamed + (access internal-lambda-tag lambda-package) + (access internal-lexpr-tag lambda-package) + lambda-tag:let + lambda-tag:shallow-fluid-let + lambda-tag:deep-fluid-let + lambda-tag:common-lisp-fluid-let + lambda-tag:make-environment + lambda-tag:make-package))) + (named-lambda (special-name? symbol) + (memq symbol the-special-names)))) + (memq symbol the-special-names)))) \ No newline at end of file diff --git a/v7/src/runtime/emacs.scm b/v7/src/runtime/emacs.scm new file mode 100644 index 000000000..ec6fb8932 --- /dev/null +++ b/v7/src/runtime/emacs.scm @@ -0,0 +1,164 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; GNU Emacs/Scheme Modeline Interface + +(declare (usual-integrations)) + +(define emacs-interface-package + (make-environment + +(define (transmit-signal type) + (write-char #\Altmode console-output-port) + (write-char type console-output-port)) + +(define (transmit-signal-without-gc type) + (with-interrupts-reduced interrupt-mask-none + (lambda (old-mask) + (transmit-signal type)))) + +(define (emacs-read-start) + (transmit-signal-without-gc #\s)) + +(define (emacs-read-finish) + (transmit-signal-without-gc #\f)) + +(define (emacs-start-gc) + (transmit-signal #\b)) + +(define (emacs-finish-gc state) + (transmit-signal #\e)) + +(define (transmit-signal-with-argument type string) + (with-interrupts-reduced interrupt-mask-none + (lambda (old-mask) + (transmit-signal type) + (write-string string console-output-port) + (write-char #\Altmode console-output-port)))) + +(define (emacs-rep-message string) + (transmit-signal-with-argument #\m string)) + +(define (emacs-rep-prompt level string) + (transmit-signal-with-argument #\p + (string-append (object->string level) + " " + string))) + +(define (emacs-rep-value object) + (transmit-signal-with-argument #\v (object->string object))) + +(define (object->string object) + (with-output-to-string + (lambda () + (write object)))) + +(define (emacs-read-char-immediate) + (define (loop) + (let ((char (primitive-read-char-immediate))) + (if (char=? char char:newline) + (loop) + (begin (emacs-read-finish) + char)))) + (emacs-read-start) + (transmit-signal-without-gc #\c) + (loop)) + +(define primitive-read-char-immediate + (make-primitive-procedure 'TTY-READ-CHAR-IMMEDIATE)) + +(define paranoid-error-hook? + false) + +(define (emacs-error-hook) + (transmit-signal-without-gc #\z) + (beep) + (if paranoid-error-hook? + (begin + (transmit-signal-with-argument #\P +"Error! Type ctl-E to enter error loop, anything else to return to top level.") + (if (not (char-ci=? (emacs-read-char-immediate) #\C-E)) + (abort-to-previous-driver "Quit!"))))) + +(define normal-start-gc (access gc-start-hook gc-statistics-package)) +(define normal-finish-gc (access gc-finish-hook gc-statistics-package)) +(define normal-rep-message rep-message-hook) +(define normal-rep-prompt rep-prompt-hook) +(define normal-rep-value rep-value-hook) +(define normal-read-start (access read-start-hook console-input-port)) +(define normal-read-finish (access read-finish-hook console-input-port)) +(define normal-read-char-immediate + (access tty-read-char-immediate console-input-port)) +(define normal-error-hook (access *error-decision-hook* error-system)) + +(define (install-emacs-hooks!) + (set! (access gc-start-hook gc-statistics-package) emacs-start-gc) + (set! (access gc-finish-hook gc-statistics-package) emacs-finish-gc) + (set! rep-message-hook emacs-rep-message) + (set! rep-prompt-hook emacs-rep-prompt) + (set! rep-value-hook emacs-rep-value) + (set! (access read-start-hook console-input-port) emacs-read-start) + (set! (access read-finish-hook console-input-port) emacs-read-finish) + (set! (access tty-read-char-immediate console-input-port) + emacs-read-char-immediate) + (set! (access *error-decision-hook* error-system) emacs-error-hook)) + +(define (install-normal-hooks!) + (set! (access gc-start-hook gc-statistics-package) normal-start-gc) + (set! (access gc-finish-hook gc-statistics-package) normal-finish-gc) + (set! rep-message-hook normal-rep-message) + (set! rep-prompt-hook normal-rep-prompt) + (set! rep-value-hook normal-rep-value) + (set! (access read-start-hook console-input-port) normal-read-start) + (set! (access read-finish-hook console-input-port) normal-read-finish) + (set! (access tty-read-char-immediate console-input-port) + normal-read-char-immediate) + (set! (access *error-decision-hook* error-system) normal-error-hook)) + +(define under-emacs? + (make-primitive-procedure 'UNDER-EMACS?)) + +(define (install!) + ((if (under-emacs?) + install-emacs-hooks! + install-normal-hooks!))) + +(add-event-receiver! event:after-restore install!) +(install!) + +;;; end EMACS-INTERFACE-PACKAGE +)) \ No newline at end of file diff --git a/v7/src/runtime/equals.scm b/v7/src/runtime/equals.scm new file mode 100644 index 000000000..d0fe71468 --- /dev/null +++ b/v7/src/runtime/equals.scm @@ -0,0 +1,85 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Equality + +(declare (usual-integrations)) + +(let-syntax ((type? + ;; Use PRIMITIVE-TYPE? for everything because the + ;; compiler can optimize it well. + (macro (name object) + `(PRIMITIVE-TYPE? ,(microcode-type name) ,object)))) + +(define (eqv? x y) + ;; EQV? is officially supposed to work on booleans, characters, and + ;; numbers specially, but it turns out that EQ? does the right thing + ;; for everything but numbers, so we take advantage of that. + (if (eq? x y) + #T + (and (primitive-type? (primitive-type x) y) + (or (type? big-fixnum y) + (type? big-flonum y)) + (= x y)))) + +(define (equal? x y) + (if (eq? x y) + #T + (and (primitive-type? (primitive-type x) y) + (cond ((or (type? big-fixnum y) + (type? big-flonum y)) + (= x y)) + ((type? list y) + (and (equal? (car x) (car y)) + (equal? (cdr x) (cdr y)))) + ((type? vector y) + (let ((size (vector-length x))) + (define (loop index) + (or (= index size) + (and (equal? (vector-ref x index) + (vector-ref y index)) + (loop (1+ index))))) + (and (= size (vector-length y)) + (loop 0)))) + ((type? cell y) + (equal? (cell-contents x) (cell-contents y))) + ((type? character-string y) + (string=? x y)) + ((type? vector-1b y) + (bit-string=? x y)) + (else false))))) + diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm new file mode 100644 index 000000000..84e965a4f --- /dev/null +++ b/v7/src/runtime/error.scm @@ -0,0 +1,471 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1985 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. +;;; + +;;;; Error System + +(declare (usual-integrations) + (compilable-primitive-functions set-fixed-objects-vector!)) + +(define error-procedure + (make-primitive-procedure 'ERROR-PROCEDURE)) + +(define (error-from-compiled-code message . irritant-info) + (error-procedure message + (cond ((null? irritant-info) *the-non-printing-object*) + ((null? (cdr irritant-info)) (car irritant-info)) + (else irritant-info)) + (rep-environment))) + +(define (error-message) + (access error-message error-system)) + +(define (error-irritant) + (access error-irritant error-system)) + +(define error-prompt + "Error->") + +(define error-system + (make-environment + +(define *error-code*) +(define *error-hook*) +(define *error-decision-hook* #F) + +(define error-message + "") + +(define error-irritant + *the-non-printing-object*) + +;;;; REP Interface + +(define (error-procedure-handler message irritant environment) + (with-proceed-point + proceed-value-filter + (lambda () + (fluid-let ((error-message message) + (error-irritant irritant)) + (*error-hook* environment message irritant #!FALSE))))) + +(define ((error-handler-wrapper handler) error-code interrupt-enables) + (with-interrupts-reduced INTERRUPT-MASK-GC-OK + (lambda (old-mask) + (fluid-let ((*error-code* error-code)) + (with-proceed-point + proceed-value-filter + (lambda () + (set-interrupt-enables! interrupt-enables) + (handler (continuation-expression (rep-continuation))))))))) + +(define (wrapped-error-handler wrapper) + (access handler (procedure-environment wrapper))) + +(define (start-error-rep message irritant) + (fluid-let ((error-message message) + (error-irritant irritant)) + (let ((environment (continuation-environment (rep-continuation)))) + (if (continuation-undefined-environment? environment) + (*error-hook* (rep-environment) message irritant #!TRUE) + (*error-hook* environment message irritant #!FALSE))))) + +(define (standard-error-hook environment message irritant + substitute-environment?) + (push-rep environment + (let ((message (make-error-message message irritant))) + (if substitute-environment? + (lambda () + (message) + (write-string " +There is no environment available; +using the current read-eval-print environment.")) + message)) + (standard-rep-prompt error-prompt))) + +(define ((make-error-message message irritant)) + (newline) + (write-string message) + (if (not (eq? irritant *the-non-printing-object*)) + (let ((out (write-to-string irritant 40))) + (write-char #\Space) + (write-string (cdr out)) + (if (car out) (write-string "...")))) + (if *error-decision-hook* (*error-decision-hook*))) + +;;; (PROCEED) means retry error expression, (PROCEED value) means +;;; return VALUE as the value of the error subproblem. + +(define (proceed-value-filter value) + (let ((continuation (rep-continuation))) + (if (or (null? value) (null-continuation? continuation)) + (continuation '()) + ((continuation-next-continuation continuation) (car value))))) + +;;;; Error Handlers + +;;; All error handlers have the following form: + +(define ((make-error-handler direction-alist operator-alist + default-handler default-combination-handler) + expression) + ((let direction-loop ((alist direction-alist)) + (cond ((null? alist) + (cond ((combination? expression) + (let ((operator (combination-operator* expression))) + (let operator-loop ((alist operator-alist)) + (cond ((null? alist) default-combination-handler) + ((memq operator (caar alist)) (cdar alist)) + (else (operator-loop (cdr alist))))))) + (else default-handler))) + (((caar alist) expression) (cdar alist)) + (else (direction-loop (cdr alist))))) + expression)) + +;;; Then there are several methods for modifying the behavior of a +;;; given error handler. + +(define expression-specific-adder) +(define operation-specific-adder) + +(let () + (define (((alist-adder name) error-handler) filter receiver) + (let ((environment + (procedure-environment (wrapped-error-handler error-handler)))) + (lexical-assignment environment + name + (cons (cons filter receiver) + (lexical-reference environment name))))) + + (set! expression-specific-adder + (alist-adder 'DIRECTION-ALIST)) + (set! operation-specific-adder + (alist-adder 'OPERATOR-ALIST))) + +(define default-expression-setter) +(define default-combination-setter) + +(let () + (define (((set-default name) error-handler) receiver) + (lexical-assignment + (procedure-environment (wrapped-error-handler error-handler)) + name + receiver)) + + (set! default-expression-setter + (set-default 'DEFAULT-HANDLER)) + (set! default-combination-setter + (set-default 'DEFAULT-COMBINATION-HANDLER))) + +;;;; Error Vector + +;;; Initialize the error vector to the default state: + +(define (default-error-handler expression) + (start-error-rep "Anomalous error -- get a wizard" *error-code*)) + +(define system-error-vector + (make-initialized-vector number-of-microcode-errors + (lambda (error-code) + (error-handler-wrapper + (make-error-handler '() + '() + default-error-handler + default-error-handler))))) + +;;; Use this procedure to displace the default handler completely. + +(define (define-total-error-handler error-name handler) + (vector-set! system-error-vector + (microcode-error error-name) + (error-handler-wrapper handler))) + +;;; It will be installed later. + +(define (install) + (set! *error-hook* standard-error-hook) + (vector-set! (get-fixed-objects-vector) + (fixed-objects-vector-slot 'SYSTEM-ERROR-VECTOR) + system-error-vector) + (vector-set! (get-fixed-objects-vector) + (fixed-objects-vector-slot 'ERROR-PROCEDURE) + error-procedure-handler) + (vector-set! (get-fixed-objects-vector) + (fixed-objects-vector-slot 'COMPILER-ERROR-PROCEDURE) + error-from-compiled-code) + (set-fixed-objects-vector! (get-fixed-objects-vector))) + +;;;; Error Definers + +(define ((define-definer type definer) error-name . args) + (apply definer + (type (vector-ref system-error-vector (microcode-error error-name))) + args)) + +(define ((define-specific-error error-name message) filter selector) + ((cond ((pair? filter) define-operation-specific-error) + (else define-expression-specific-error)) + error-name filter message selector)) + +(define define-expression-specific-error + (define-definer expression-specific-adder + (lambda (adder filter message selector) + (adder filter (expression-error-rep message selector))))) + +(define define-operation-specific-error + (define-definer operation-specific-adder + (lambda (adder filter message selector) + (adder filter (combination-error-rep message selector))))) + +(define define-operand-error + (define-definer default-combination-setter + (lambda (setter message selector) + (setter (combination-error-rep message selector))))) + +(define define-operator-error + (define-definer default-combination-setter + (lambda (setter message) + (setter (expression-error-rep message combination-operator*))))) + +(define define-combination-error + (define-definer default-combination-setter + (lambda (setter message selector) + (setter (expression-error-rep message selector))))) + +(define define-default-error + (define-definer default-expression-setter + (lambda (setter message selector) + (setter (expression-error-rep message selector))))) + +(define ((expression-error-rep message selector) expression) + (start-error-rep message (selector expression))) + +(define ((combination-error-rep message selector) combination) + (start-error-rep + (string-append message + " " + (let ((out (write-to-string (selector combination) 40))) + (if (car out) + (string-append (cdr out) "...") + (cdr out))) + "\nwithin procedure") + (combination-operator* combination))) + +;;;; Combination Operations + +;;; Combinations coming out of the continuation parser are either all +;;; unevaluated, or all evaluated, or all operands evaluated and the +;;; operator undefined. Thus we must be careful about unwrapping +;;; the components when necessary. In practice, it turns out that +;;; all but one of the interesting errors happen at the application +;;; point, at which all of the combination's components are evaluated. + +(define (combination-operator* combination) + (unwrap-evaluated-object (combination-operator combination))) + +(define ((combination-operand selector) combination) + (unwrap-evaluated-object (selector (combination-operands combination)))) + +(define combination-first-operand (combination-operand first)) +(define combination-second-operand (combination-operand second)) +(define combination-third-operand (combination-operand third)) + +(define (combination-operands* combination) + (map unwrap-evaluated-object (combination-operands combination))) + +(define (unwrap-evaluated-object object) + (if (continuation-evaluated-object? object) + (continuation-evaluated-object-value object) + (error "Not evaluated -- get a wizard" unwrap-evaluated-object object))) + +;;;; Environment Operation Errors + +(define define-unbound-variable-error + (define-specific-error 'UNBOUND-VARIABLE + "Unbound Variable")) + +(define-unbound-variable-error variable? variable-name) +(define-unbound-variable-error access? access-name) +(define-unbound-variable-error assignment? assignment-name) +(define-unbound-variable-error + (list (make-primitive-procedure 'LEXICAL-REFERENCE) + (make-primitive-procedure 'LEXICAL-ASSIGNMENT)) + combination-second-operand) + +(define-unbound-variable-error + (list (make-primitive-procedure 'ADD-FLUID-BINDING! #!true)) + (lambda (obj) + (let ((object (combination-second-operand obj))) + (cond ((variable? object) (variable-name object)) + ((symbol? object) object) + (else (error "Handler has bad object -- GET-A-WIZARD" object)))))) + +(define define-unassigned-variable-error + (define-specific-error 'UNASSIGNED-VARIABLE + "Unassigned Variable")) + +(define-unassigned-variable-error variable? variable-name) +(define-unassigned-variable-error access? access-name) +(define-unassigned-variable-error + (list (make-primitive-procedure 'LEXICAL-REFERENCE)) + combination-second-operand) + +(define define-bad-frame-error + (define-specific-error 'BAD-FRAME + "Illegal Environment Frame")) + +(define-bad-frame-error access? access-environment) +(define-bad-frame-error in-package? in-package-environment) + +(define define-assignment-to-procedure-error + (define-specific-error 'ASSIGN-LAMBDA-NAME + "Attempt to assign procedure's name")) + +(define-assignment-to-procedure-error assignment? assignment-name) +(define-assignment-to-procedure-error definition? definition-name) +(define-assignment-to-procedure-error + (list (make-primitive-procedure 'LEXICAL-ASSIGNMENT) + (make-primitive-procedure 'LOCAL-ASSIGNMENT) + (make-primitive-procedure 'ADD-FLUID-BINDING! #!true) + (make-primitive-procedure 'MAKE-FLUID-BINDING! #!true)) + combination-second-operand) + +;;;; Application Errors + +(define-operator-error 'UNDEFINED-PROCEDURE + "Application of Non-Procedure Object") + +(define-operator-error 'UNDEFINED-PRIMITIVE-OPERATION + "Undefined Primitive Procedure") + +(define-operand-error 'WRONG-NUMBER-OF-ARGUMENTS + "Wrong Number of Arguments" + (lambda (combination) + (length (combination-operands* combination)))) + +(let ((make + (lambda (wta-error-code bra-error-code position-string + position-selector) + (let ((ap-string (string-append position-string " argument position")) + (selector (combination-operand position-selector))) + (define-operand-error wta-error-code + (string-append "Illegal datum in " ap-string) + selector) + (define-operand-error bra-error-code + (string-append "Datum out of range in " ap-string) + selector))))) + (make 'WRONG-TYPE-ARGUMENT-0 'BAD-RANGE-ARGUMENT-0 "first" first) + (make 'WRONG-TYPE-ARGUMENT-1 'BAD-RANGE-ARGUMENT-1 "second" second) + (make 'WRONG-TYPE-ARGUMENT-2 'BAD-RANGE-ARGUMENT-2 "third" third) + (make 'WRONG-TYPE-ARGUMENT-3 'BAD-RANGE-ARGUMENT-3 "fourth" fourth) + (make 'WRONG-TYPE-ARGUMENT-4 'BAD-RANGE-ARGUMENT-4 "fifth" fifth) + (make 'WRONG-TYPE-ARGUMENT-5 'BAD-RANGE-ARGUMENT-5 "sixth" sixth) + (make 'WRONG-TYPE-ARGUMENT-6 'BAD-RANGE-ARGUMENT-6 "seventh" seventh) + (make 'WRONG-TYPE-ARGUMENT-7 'BAD-RANGE-ARGUMENT-7 "eighth" eighth) + (make 'WRONG-TYPE-ARGUMENT-8 'BAD-RANGE-ARGUMENT-8 + "ninth" (lambda (list) (general-car-cdr list #x1400))) + (make 'WRONG-TYPE-ARGUMENT-9 'BAD-RANGE-ARGUMENT-9 + "tenth" (lambda (list) (general-car-cdr list #x3000)))) + +;;;; Primitive Operator Errors + +(define-operation-specific-error 'FASL-FILE-TOO-BIG + (list (make-primitive-procedure 'PRIMITIVE-FASLOAD) + (make-primitive-procedure 'BINARY-FASLOAD)) + "Not enough room to Fasload" + combination-first-operand) + +(define-operation-specific-error 'FASL-FILE-BAD-DATA + (list (make-primitive-procedure 'PRIMITIVE-FASLOAD) + (make-primitive-procedure 'BINARY-FASLOAD)) + "Fasload file would not relocate correctly" + combination-first-operand) + +(define-operation-specific-error 'RAN-OUT-OF-HASH-NUMBERS + (list (make-primitive-procedure 'OBJECT-HASH)) + "Hashed too many objects -- get a wizard" + combination-first-operand) + +;;; This will trap any external-primitive errors that +;;; aren't caught by special handlers. + +(define-operator-error 'EXTERNAL-RETURN + "Error during External Application") + +(define-operation-specific-error 'EXTERNAL-RETURN + (list (make-primitive-procedure 'FILE-OPEN-CHANNEL)) + "Unable to open file" + combination-first-operand) + +;;;; SCODE Syntax Errors + +;;; This error gets an unevaluated combination, but it doesn't ever +;;; look at the components, so it doesn't matter. + +(define define-broken-variable-error + (define-specific-error 'BROKEN-CVARIABLE + "Broken Compiled Variable -- get a wizard")) + +(define-broken-variable-error variable? variable-name) +(define-broken-variable-error assignment? assignment-name) + +;;;; System Errors + +(define-total-error-handler 'BAD-ERROR-CODE + (lambda (error-code) + (start-error-rep "Bad Error Code -- get a wizard" error-code))) + +(define-default-error 'BAD-INTERRUPT-CODE + "Illegal Interrupt Code -- get a wizard" + identity-procedure) + +(define-default-error 'EXECUTE-MANIFEST-VECTOR + "Attempt to execute Manifest Vector -- get a wizard" + identity-procedure) + +(define-total-error-handler 'WRITE-INTO-PURE-SPACE + (lambda (error-code) + (newline) + (write-string "Automagically IMPURIFYing an object....") + (impurify (combination-first-operand + (continuation-expression (rep-continuation)))))) + +(define-default-error 'UNDEFINED-USER-TYPE + "Undefined Type Code -- get a wizard" + identity-procedure) + +;;; end ERROR-SYSTEM package. +)) \ No newline at end of file diff --git a/v7/src/runtime/events.scm b/v7/src/runtime/events.scm new file mode 100644 index 000000000..9623a098c --- /dev/null +++ b/v7/src/runtime/events.scm @@ -0,0 +1,98 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1985 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. +;;; + +;;;; Event Distribution + +(declare (usual-integrations)) + +(define make-event-distributor) +(define event-distributor?) +(define add-event-receiver!) +(define remove-event-receiver!) + +(let ((:type (make-named-tag "EVENT-DISTRIBUTOR"))) + (set! make-event-distributor + (named-lambda (make-event-distributor) + (define receivers '()) + (define queue-head '()) + (define queue-tail '()) + (define event-in-progress? #!FALSE) + + (lambda arguments + (if (null? queue-head) + (begin (set! queue-head (list arguments)) + (set! queue-tail queue-head)) + (begin (set-cdr! queue-tail (list arguments)) + (set! queue-tail (cdr queue-tail)))) + (if (not (set! event-in-progress? #!TRUE)) + (begin (let ((arguments (car queue-head))) + (set! queue-head (cdr queue-head)) + (let loop ((receivers receivers)) + (if (not (null? receivers)) + (begin (apply (car receivers) arguments) + (loop (cdr receivers)))))) + (set! event-in-progress? #!FALSE)))))) + + (set! event-distributor? + (named-lambda (event-distributor? object) + (and (compound-procedure? object) + (let ((e (procedure-environment object))) + (and (not (lexical-unreferenceable? e ':TYPE)) + (eq? (access :type e) :type) + e))))) + + (define ((make-receiver-modifier name operation) + event-distributor event-receiver) + (let ((e (event-distributor? event-distributor))) + (if (not e) + (error "Not an event distributor" name event-distributor)) + (without-interrupts + (lambda () + (set! (access receivers e) + (operation event-receiver + (access receivers e))))))) + + (set! add-event-receiver! + (make-receiver-modifier 'ADD-EVENT-RECEIVER! + (lambda (receiver receivers) + (append! receivers (list receiver))))) + + (set! remove-event-receiver! + (make-receiver-modifier 'REMOVE-EVENT-RECEIVER! + delq!)) + +) \ No newline at end of file diff --git a/v7/src/runtime/format.scm b/v7/src/runtime/format.scm new file mode 100644 index 000000000..1efb21d49 --- /dev/null +++ b/v7/src/runtime/format.scm @@ -0,0 +1,355 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Output Formatter + +(declare (usual-integrations)) + +;;; Please don't believe this implementation! I don't like either the +;;; calling interface or the control string syntax, but I need the +;;; functionality pretty badly and I don't have the time to think +;;; about all of that right now -- CPH. + +(define format) +(let () + +;;;; Top Level + +(set! format +(named-lambda (format port-or-string . arguments) + (cond ((null? port-or-string) + (if (and (not (null? arguments)) + (string? (car arguments))) + (with-output-to-string + (lambda () + (format-start (car arguments) (cdr arguments)))) + (error "Missing format string" 'FORMAT))) + ((string? port-or-string) + (format-start port-or-string arguments) + *the-non-printing-object*) + ((output-port? port-or-string) + (if (and (not (null? arguments)) + (string? (car arguments))) + (begin (with-output-to-port port-or-string + (lambda () + (format-start (car arguments) (cdr arguments)))) + *the-non-printing-object*) + (error "Missing format string" 'FORMAT))) + (else + (error "Unrecognizable first argument" 'FORMAT + port-or-string))))) + +(define (format-start string arguments) + (format-loop string arguments) + ((access :flush-output *current-output-port*))) + +(declare (integrate *unparse-char *unparse-string *unparse-object)) + +(define (*unparse-char char) + (declare (integrate char)) + ((access :write-char *current-output-port*) char)) + +(define (*unparse-string string) + (declare (integrate string)) + ((access :write-string *current-output-port*) string)) + +(define (*unparse-object object) + (declare (integrate object)) + ((access unparse-object unparser-package) object *current-output-port*)) + +(define (format-loop string arguments) + (let ((index (string-find-next-char string #\~))) + (cond (index + (if (not (zero? index)) + (*unparse-string (substring string 0 index))) + (parse-dispatch (string-tail string (1+ index)) + arguments + '() + '() + (lambda (remaining-string remaining-arguments) + (format-loop remaining-string + remaining-arguments)))) + ((null? arguments) + (*unparse-string string)) + (else + (error "Too many arguments" 'FORMAT arguments))))) + +(define (parse-dispatch string supplied-arguments parsed-arguments modifiers + receiver) + ((vector-ref format-dispatch-table (vector-8b-ref string 0)) + string + supplied-arguments + parsed-arguments + modifiers + receiver)) + +;;;; Argument Parsing + +(define ((format-wrapper operator) + string supplied-arguments parsed-arguments modifiers receiver) + ((apply operator modifiers (reverse! parsed-arguments)) + (string-tail string 1) + supplied-arguments + receiver)) + +(define ((parse-modifier keyword) + string supplied-arguments parsed-arguments modifiers receiver) + (parse-dispatch (string-tail string 1) + supplied-arguments + parsed-arguments + (cons keyword modifiers) + receiver)) + +(define (parse-digit string supplied-arguments parsed-arguments modifiers + receiver) + (let accumulate ((acc (char->digit (string-ref string 0) 10)) + (i 1)) + (if (char-numeric? (string-ref string i)) + (accumulate (+ (* acc 10) + (char->digit (string-ref string i) 10)) + (1+ i)) + (parse-dispatch (string-tail string i) + supplied-arguments + (cons acc parsed-arguments) + modifiers + receiver)))) + +(define (parse-ignore string supplied-arguments parsed-arguments modifiers + receiver) + (parse-dispatch (string-tail string 1) + supplied-arguments + parsed-arguments + modifiers + receiver)) + +(define (parse-arity string supplied-arguments parsed-arguments modifiers + receiver) + (parse-dispatch (string-tail string 1) + supplied-arguments + (cons (length supplied-arguments) parsed-arguments) + modifiers + receiver)) + +(define (parse-argument string supplied-arguments parsed-arguments modifiers + receiver) + (parse-dispatch (string-tail string 1) + (cdr supplied-arguments) + (cons (car supplied-arguments) parsed-arguments) + modifiers + receiver)) + +(define (string-tail string index) + (substring string index (string-length string))) + +;;;; Formatters + +(define (((format-insert-character character) modifiers #!optional n) + string arguments receiver) + (if (unassigned? n) + (*unparse-char character) + (let loop ((i 0)) + (if (not (= i n)) + (begin (*unparse-char character) + (loop (1+ i)))))) + (receiver string arguments)) + +(define format-insert-return (format-insert-character char:newline)) +(define format-insert-tilde (format-insert-character #\~)) +(define format-insert-space (format-insert-character #\Space)) + +(define ((format-ignore-comment modifiers) string arguments receiver) + (receiver (substring string + (1+ (string-find-next-char string char:newline)) + (string-length string)) + arguments)) + +(define format-ignore-whitespace) +(let () + +(define newline-string + (char->string char:newline)) + +(define (eliminate-whitespace string) + (let ((limit (string-length string))) + (let loop ((n 0)) + (cond ((= n limit) "") + ((let ((char (string-ref string n))) + (and (char-whitespace? char) + (not (char=? char char:newline)))) + (loop (1+ n))) + (else + (substring string n limit)))))) + +(set! format-ignore-whitespace +(named-lambda ((format-ignore-whitespace modifiers) string arguments receiver) + (receiver (cond ((null? modifiers) (eliminate-whitespace string)) + ((memq 'AT modifiers) + (string-append newline-string + (eliminate-whitespace string))) + (else string)) + arguments))) +) + +(define ((format-string modifiers #!optional n-columns) + string arguments receiver) + (if (null? arguments) + (error "Too few arguments" 'FORMAT string)) + (if (unassigned? n-columns) + (*unparse-string (car arguments)) + (unparse-string-into-fixed-size (car arguments) #!FALSE + n-columns modifiers)) + (receiver string (cdr arguments))) + +(define ((format-object modifiers #!optional n-columns) + string arguments receiver) + (if (null? arguments) + (error "Too few arguments" 'FORMAT string)) + (if (unassigned? n-columns) + (*unparse-object (car arguments)) + (unparse-object-into-fixed-size (car arguments) n-columns modifiers)) + (receiver string (cdr arguments))) + +(define ((format-code modifiers #!optional n-columns) + string arguments receiver) + (if (null? arguments) + (error "Too few arguments" 'FORMAT string)) + (if (unassigned? n-columns) + (*unparse-object (unsyntax (car arguments))) + (unparse-object-into-fixed-size (unsyntax (car arguments)) + n-columns + modifiers)) + (receiver string (cdr arguments))) + +(define (unparse-object-into-fixed-size object n-columns modifiers) + (let ((output (write-to-string object n-columns))) + (unparse-string-into-fixed-size (cdr output) + (car output) + n-columns + modifiers))) + +(define (unparse-string-into-fixed-size string already-truncated? + n-columns modifiers) + (let ((padding (- n-columns (string-length string)))) + (cond ((and (zero? padding) (not already-truncated?)) + (*unparse-string string)) + ((positive? padding) + (let ((pad-string (make-string padding #\Space))) + (if (memq 'AT modifiers) + (begin (*unparse-string string) + (*unparse-string pad-string)) + (begin (*unparse-string pad-string) + (*unparse-string string))))) + ;; This is pretty random -- figure out something better. + ((memq 'COLON modifiers) + (*unparse-string (substring string 0 (- n-columns 4))) + (*unparse-string " ...")) + (else + (*unparse-string (substring string 0 n-columns)))))) + +;;;; Dispatcher Setup + +(define format-dispatch-table + (make-initialized-vector + 128 + (lambda (character) + (lambda (string supplied-arguments parsed-arguments modifiers receiver) + (error "Unknown formatting character" 'FORMAT character))))) + +(define (add-dispatcher! char dispatcher) + (if (char-alphabetic? char) + (begin (vector-set! format-dispatch-table + (char->ascii (char-downcase char)) + dispatcher) + (vector-set! format-dispatch-table + (char->ascii (char-upcase char)) + dispatcher)) + (vector-set! format-dispatch-table + (char->ascii char) + dispatcher))) + +(add-dispatcher! #\0 parse-digit) +(add-dispatcher! #\1 parse-digit) +(add-dispatcher! #\2 parse-digit) +(add-dispatcher! #\3 parse-digit) +(add-dispatcher! #\4 parse-digit) +(add-dispatcher! #\5 parse-digit) +(add-dispatcher! #\6 parse-digit) +(add-dispatcher! #\7 parse-digit) +(add-dispatcher! #\8 parse-digit) +(add-dispatcher! #\9 parse-digit) +(add-dispatcher! #\, parse-ignore) +(add-dispatcher! #\# parse-arity) +(add-dispatcher! #\V parse-argument) +(add-dispatcher! #\@ (parse-modifier 'AT)) +(add-dispatcher! #\: (parse-modifier 'COLON)) + +;;; +;;; (format format-string arg arg ...) +;;; (format port format-string arg arg ...) +;;; +;;; Format strings are normally interpreted literally, except that +;;; certain escape sequences allow insertion of computed values. The +;;; following escape sequences are recognized: +;;; +;;; ~n% inserts n newlines +;;; ~n~ inserts n tildes +;;; ~nX inserts n spaces +;;; +;;; ~ inserts the next argument. +;;; ~n right justifies the argument in a field of size n. +;;; ~n@ left justifies the argument in a field of size n. +;;; +;;; where may be: +;;; S meaning the argument is a string and should be used literally. +;;; O meaning the argument is an object and should be printed first. +;;; C meaning the object is SCode and should be unsyntaxed and printed. +;;; +;;; If the resulting string is too long, it is truncated. +;;; ~n: or ~n:@ means print trailing dots when truncating. +;;; + +(add-dispatcher! #\% (format-wrapper format-insert-return)) +(add-dispatcher! #\~ (format-wrapper format-insert-tilde)) +(add-dispatcher! #\X (format-wrapper format-insert-space)) +(add-dispatcher! #\; (format-wrapper format-ignore-comment)) +(add-dispatcher! char:newline (format-wrapper format-ignore-whitespace)) +(add-dispatcher! #\S (format-wrapper format-string)) +(add-dispatcher! #\O (format-wrapper format-object)) +(add-dispatcher! #\C (format-wrapper format-code)) + +;;; end LET. +) \ No newline at end of file diff --git a/v7/src/runtime/gc.scm b/v7/src/runtime/gc.scm new file mode 100644 index 000000000..b9f168f13 --- /dev/null +++ b/v7/src/runtime/gc.scm @@ -0,0 +1,200 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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 + +(declare (usual-integrations) + (compilable-primitive-functions + garbage-collect primitive-purify primitive-impurify primitive-fasdump + set-interrupt-enables! enable-interrupts! primitive-gc-type pure? + get-next-constant call-with-current-continuation hunk3-cons + set-fixed-objects-vector! tty-write-char tty-write-string exit)) + +(define add-gc-daemon!) +(define gc-flip) +(define purify) +(define impurify) +(define fasdump) +(define suspend-world) +(define set-default-gc-safety-margin!) + +(define garbage-collector-package + (make-environment + +(define default-safety-margin 4500) + +;; SET-DEFAULT-GC-SAFETY-MARGIN! changes the amount of memory +;; saved from the heap to allow the GC handler to run. + +(set! set-default-gc-safety-margin! +(named-lambda (set-default-gc-safety-margin! #!optional margin) + (if (or (unassigned? margin) (null? margin)) + default-safety-margin + (begin (set! default-safety-margin margin) + (gc-flip margin))))) + +;;;; Cold Load GC + +(define (reset) + (enable-interrupts! interrupt-mask-none)) + +;;; User call -- optionally overrides the default GC safety +;;; margin for this flip only. + +(set! gc-flip +(named-lambda (gc-flip #!optional new-safety-margin) + (with-interrupts-reduced interrupt-mask-none + (lambda (old-interrupt-mask) + (garbage-collect + (if (unassigned? new-safety-margin) + default-safety-margin + new-safety-margin)))))) + +(vector-set! (vector-ref (get-fixed-objects-vector) 1) + 2 ;Local Garbage Collection Interrupt + (named-lambda (gc-interrupt interrupt-code interrupt-enables) + (gc-flip Default-Safety-Margin))) + +(vector-set! (vector-ref (get-fixed-objects-vector) 1) + 1 ;Local Stack Overflow Interrupt + (named-lambda (stack-overflow-interrupt interrupt-code + interrupt-enables) + (stack-overflow) + (set-interrupt-enables! interrupt-enables))) + +;;; This variable is clobbered by GCSTAT. +(define (stack-overflow) + (tty-write-char char:newline) + (tty-write-string "Stack overflow!") + (tty-write-char char:newline) + (exit)) + +(vector-set! (get-fixed-objects-vector) + #x0C + (named-lambda (hardware-trap-handler escape-code) + (hardware-trap))) + +;;; This is clobbered also by GCSTAT. +(define (hardware-trap) + (tty-write-char char:newline) + (tty-write-string "Hardware trap") + (tty-write-char char:newline) + (exit)) + +;;; The GC daemon is invoked by the microcode whenever there is a need. +;;; All we provide here is a trivial extension mechanism. + +(vector-set! (get-fixed-objects-vector) + #x0B + (named-lambda (gc-daemon) + (trigger-daemons gc-daemons))) + +(set-fixed-objects-vector! (get-fixed-objects-vector)) + +(define (trigger-daemons daemons . extra-args) + (let loop ((daemons daemons)) + (if (not (null? daemons)) + (begin (apply (car daemons) extra-args) + (loop (cdr daemons)))))) + +(define gc-daemons '()) + +(set! add-gc-daemon! +(named-lambda (add-gc-daemon! daemon) + (if (not (memq daemon gc-daemons)) + (set! gc-daemons (cons daemon gc-daemons))))) + +(reset) + +;;;; "GC-like" Primitives + +;; Purify an item -- move it into pure space and clean everything +;; by doing a gc-flip + +(set! purify +(named-lambda (purify item #!optional really-pure?) + (if (primitive-purify item + (if (unassigned? really-pure?) + false + really-pure?)) + item + (error "Not enough room in constant space" purify item)))) + +(set! impurify +(named-lambda (impurify object) + (if (or (zero? (primitive-gc-type object)) + (not (pure? object))) + object + (primitive-impurify object)))) + +(set! fasdump +(named-lambda (fasdump object filename) + (let ((filename (canonicalize-output-filename filename)) + (port (rep-output-port))) + (newline port) + (write-string "FASDumping " port) + (write filename port) + (if (not (primitive-fasdump object filename false)) + (error "Object is too large to be dumped" fasdump object)) + (write-string " -- done" port)) + object)) + +(set! suspend-world +(named-lambda (suspend-world suspender after-suspend after-restore) + (with-interrupts-reduced interrupt-mask-gc-ok + (lambda (ie) + ((call-with-current-continuation + (lambda (cont) + (let ((fixed-objects-vector (get-fixed-objects-vector)) + (dynamic-state (current-dynamic-state))) + (fluid-let () + (call-with-current-continuation + (lambda (restart) + (gc-flip) + (suspender restart) + (cont after-suspend))) + (set-fixed-objects-vector! fixed-objects-vector) + (set-current-dynamic-state! dynamic-state) + (reset) + ((access snarf-version microcode-system)) + (reset-keyboard-interrupt-dispatch-table!) + (set! *rep-keyboard-map* (keyboard-interrupt-dispatch-table)) + ((access reset! working-directory-package)) + after-restore)))) + ie))))) + +;;; end GARBAGE-COLLECTOR-PACKAGE. diff --git a/v7/src/runtime/gcstat.scm b/v7/src/runtime/gcstat.scm new file mode 100644 index 000000000..19339d4f2 --- /dev/null +++ b/v7/src/runtime/gcstat.scm @@ -0,0 +1,270 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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 Statistics + +(declare (usual-integrations)) + +(define gctime) +(define gc-statistics) +(define gc-history-mode) + +(define gc-statistics-package + (make-package gc-statistics-package () + +;;;; Statistics Hooks + +(define (gc-start-hook) 'DONE) +(define (gc-finish-hook state) 'DONE) + +(define ((make-flip-hook old-flip) . More) + (with-interrupts-reduced INTERRUPT-MASK-NONE + (lambda (Old-Interrupt-Mask) + (measure-interval + #!FALSE ;i.e. do not count the interval in RUNTIME. + (lambda (start-time) + (let ((old-state (gc-start-hook))) + (let ((new-space-remaining (primitive-datum (apply old-flip more)))) + (gc-finish-hook old-state) + (if (< new-space-remaining 4096) + (abort->nearest + (standard-rep-message "Aborting: Out of memory!"))) + (lambda (end-time) + (statistics-flip start-time + end-time + new-space-remaining) + new-space-remaining)))))))) + +;;;; Statistics Collector + +(define meter) +(define total-gc-time) +(define last-gc-start) +(define last-gc-end) + +(define (statistics-reset!) + (set! meter 1) + (set! total-gc-time 0) + (set! last-gc-start #!FALSE) + (set! last-gc-end (system-clock)) + (reset-recorder! '())) + +(define (statistics-flip start-time end-time heap-left) + (let ((statistic + (vector meter + start-time end-time + last-gc-start last-gc-end + heap-left))) + (set! meter (1+ meter)) + (set! total-gc-time (+ (- end-time start-time) total-gc-time)) + (set! last-gc-start start-time) + (set! last-gc-end end-time) + (record-statistic! statistic))) + +(set! gctime (named-lambda (gctime) total-gc-time)) + +;;;; Statistics Recorder + +(define last-statistic) +(define history) + +(define (reset-recorder! old) + (set! last-statistic #!FALSE) + (reset-history! old)) + +(define (record-statistic! statistic) + (set! last-statistic statistic) + (record-in-history! statistic)) + +(set! gc-statistics + (named-lambda (gc-statistics) + (let ((history (get-history))) + (if (null? history) + (if last-statistic + (list last-statistic) + '()) + history)))) + +;;;; History Modes + +(define reset-history!) +(define record-in-history!) +(define get-history) +(define history-mode) + +(set! gc-history-mode + (named-lambda (gc-history-mode #!optional new-mode) + (let ((old-mode history-mode)) + (if (not (unassigned? new-mode)) + (let ((old-history (get-history))) + (set-history-mode! new-mode) + (reset-history! old-history))) + old-mode))) + +(define (set-history-mode! mode) + (let ((entry (assq mode history-modes))) + (if (not entry) + (error "Bad mode name" 'SET-HISTORY-MODE! mode)) + ((cdr entry)) + (set! history-mode (car entry)))) + +(define history-modes + `((NONE . ,(named-lambda (none:install-history!) + (set! reset-history! none:reset-history!) + (set! record-in-history! none:record-in-history!) + (set! get-history none:get-history))) + (BOUNDED . ,(named-lambda (bounded:install-history!) + (set! reset-history! bounded:reset-history!) + (set! record-in-history! bounded:record-in-history!) + (set! get-history bounded:get-history))) + (UNBOUNDED . ,(named-lambda (unbounded:install-history!) + (set! reset-history! unbounded:reset-history!) + (set! record-in-history! unbounded:record-in-history!) + (set! get-history unbounded:get-history))))) + +;;; NONE + +(define (none:reset-history! old) + (set! history '())) + +(define (none:record-in-history! item) + 'DONE) + +(define (none:get-history) + '()) + +;;; BOUNDED + +(define history-size 8) + +(define (copy-to-size l size) + (let ((max (length l))) + (if (>= max size) + (initial-segment l size) + (append (initial-segment l max) + (make-list (- size max) '()))))) + +(define (bounded:reset-history! old) + (set! history (apply circular-list (copy-to-size old history-size)))) + +(define (bounded:record-in-history! item) + (set-car! history item) + (set! history (cdr history))) + +(define (bounded:get-history) + (let loop ((scan (cdr history))) + (cond ((eq? scan history) '()) + ((null? (car scan)) (loop (cdr scan))) + (else (cons (car scan) (loop (cdr scan))))))) + +;;; UNBOUNDED + +(define (unbounded:reset-history! old) + (set! history old)) + +(define (unbounded:record-in-history! item) + (set! history (cons item history))) + +(define (unbounded:get-history) + (reverse history)) + +;;;; Initialization + +(define (install!) + (set-history-mode! 'BOUNDED) + (statistics-reset!) + (set! gc-flip (make-flip-hook gc-flip)) + (set! (access stack-overflow garbage-collector-package) + (named-lambda (stack-overflow) + (abort->nearest + (standard-rep-message + "Aborting: Maximum recursion depth exceeded!")))) + (set! (access hardware-trap garbage-collector-package) + (named-lambda (hardware-trap) + (abort->nearest + (standard-rep-message + "Aborting: The hardware trapped!")))) + (add-event-receiver! event:after-restore statistics-reset!)) + +;;; end GC-STATISTICS-PACKAGE. +)) + +;;;; GC Notification + +(define toggle-gc-notification!) +(define print-gc-statistics) +(let () + +(define normal-recorder '()) + +(define (gc-notification statistic) + (normal-recorder statistic) + (with-output-to-port (rep-output-port) + (lambda () + (print-statistic statistic)))) + +(set! toggle-gc-notification! +(named-lambda (toggle-gc-notification!) + (if (null? normal-recorder) + (begin (set! normal-recorder + (access record-statistic! gc-statistics-package)) + (set! (access record-statistic! gc-statistics-package) + gc-notification)) + (begin (set! (access record-statistic! gc-statistics-package) + normal-recorder) + (set! normal-recorder '()))) + *the-non-printing-object*)) + +(set! print-gc-statistics +(named-lambda (print-gc-statistics) + (for-each print-statistic (gc-statistics)))) + +(define (print-statistic statistic) + (apply (lambda (meter + this-gc-start this-gc-end + last-gc-start last-gc-end + heap-left) + (let ((delta-time (- this-gc-end this-gc-start))) + (newline) (write-string "GC #") (write meter) + (write-string " took: ") (write delta-time) + (write-string " (") + (write (round (* (/ delta-time (- this-gc-end last-gc-end)) + 100))) + (write-string "%) free: ") (write heap-left))) + (vector->list statistic))) + +) \ No newline at end of file diff --git a/v7/src/runtime/gensym.scm b/v7/src/runtime/gensym.scm new file mode 100644 index 000000000..dde16adb5 --- /dev/null +++ b/v7/src/runtime/gensym.scm @@ -0,0 +1,68 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1984 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. +;;; + +;;;; GENSYM + +(declare (usual-integrations)) + +(define (make-name-generator prefix) + (let ((counter 0)) + (named-lambda (name-generator) + (string->uninterned-symbol + (string-append prefix + (write-to-string + (let ((n counter)) + (set! counter (1+ counter)) + n))))))) + +(define generate-uninterned-symbol + (let ((name-counter 0) + (name-prefix "G")) + (define (get-number) + (let ((result name-counter)) + (set! name-counter (1+ name-counter)) + result)) + (named-lambda (generate-uninterned-symbol #!optional argument) + (if (not (unassigned? argument)) + (cond ((symbol? argument) + (set! name-prefix (symbol->string argument))) + ((integer? argument) + (set! name-counter argument)) + (else + (error "Bad argument: GENERATE-UNINTERNED-SYMBOL" + argument)))) + (string->uninterned-symbol diff --git a/v7/src/runtime/hash.scm b/v7/src/runtime/hash.scm new file mode 100644 index 000000000..af77b13be --- /dev/null +++ b/v7/src/runtime/hash.scm @@ -0,0 +1,269 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1985 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. +;;; + +;;;; Object Hashing + +(declare (usual-integrations)) + +((make-primitive-procedure 'INITIALIZE-OBJECT-HASH) 313) +(add-gc-daemon! (make-primitive-procedure 'REHASH-GC-DAEMON)) +(add-event-receiver! event:after-restore gc-flip) + +(define object-hash (make-primitive-procedure 'OBJECT-HASH)) +(define object-unhash (make-primitive-procedure 'OBJECT-UNHASH)) + +(define hash-of-false (object-hash #!FALSE)) +(define hash-of-false-number (primitive-datum hash-of-false)) + +(define (hash object) + (primitive-datum (object-hash object))) + +(define (unhash n) + (if (= n hash-of-false-number) + #!FALSE + (or (object-unhash (make-non-pointer-object n)) + (error "Not a valid hash number" 'UNHASH n)))) + +(define (valid-hash-number? n) + (if (eq? n hash-of-false) + #!TRUE + (object-unhash n))) + +;;;; Populations +;;; +;;; 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 make-population) +(define population?) + +(let ((population-tag '(POPULATION))) + +(define population-of-populations + (cons population-tag '())) + +(set! make-population +(named-lambda (make-population) + (let ((population (cons population-tag '()))) + (add-to-population! population-of-populations population) + population))) + +(set! population? +(named-lambda (population? object) + (and (pair? object) + (eq? (car object) population-tag)))) + +(define (gc-population! population) + (set-cdr! population (delete-invalid-hash-numbers! (cdr population)))) + +(define delete-invalid-hash-numbers! + (list-deletor! + (lambda (hash-number) + (not (valid-hash-number? hash-number))))) + +(define (gc-all-populations!) + (gc-population! population-of-populations) + (map-over-population population-of-populations gc-population!)) + +(add-secondary-gc-daemon! gc-all-populations!) + +) + +(define (add-to-population! population object) + (let ((n (object-hash object))) + (if (not (memq n (cdr population))) + (set-cdr! population (cons n (cdr population)))))) + +(define (remove-from-population! population object) + (set-cdr! population + (delq! (object-hash object) + (cdr population)))) + +;;; Population Mappings +;;; These have the effect of doing a GC-POPULATION! every time it is +;;; called, since the cost of doing so is very small. + +(define (map-over-population population procedure) + (let loop ((previous population) + (rest (cdr population))) + (if (null? rest) + '() + (let ((unhash (object-unhash (car rest)))) + (if (or (eq? hash-of-false (car rest)) + unhash) + (cons (procedure unhash) + (loop rest (cdr rest))) + (begin (set-cdr! previous (cdr rest)) + (loop previous (cdr rest)))))))) + +(define (map-over-population! population procedure) + (let loop ((previous population) + (rest (cdr population))) + (if (not (null? rest)) + (let ((unhash (object-unhash (car rest)))) + (if (or (eq? hash-of-false (car rest)) + unhash) + (begin (procedure unhash) + (loop rest (cdr rest))) + (begin (set-cdr! previous (cdr rest)) + (loop previous (cdr rest)))))))) + +(define (for-all-inhabitants? population predicate) + (let loop ((previous population) + (rest (cdr population))) + (or (null? rest) + (let ((unhash (object-unhash (car rest)))) + (if (or (eq? hash-of-false (car rest)) + unhash) + (and (predicate unhash) + (loop rest (cdr rest))) + (begin (set-cdr! previous (cdr rest)) + (loop previous (cdr rest)))))))) + +(define (exists-an-inhabitant? population predicate) + (let loop ((previous population) + (rest (cdr population))) + (and (not (null? rest)) + (let ((unhash (object-unhash (car rest)))) + (if (or (eq? hash-of-false (car rest)) + unhash) + (or (predicate unhash) + (loop rest (cdr rest))) + (begin (set-cdr! previous (cdr rest)) + (loop previous (cdr rest)))))))) + +;;;; Properties + +(define 2D-put!) +(define 2D-get) +(define 2D-remove!) +(define 2D-get-alist-x) +(define 2D-get-alist-y) + +(let ((system-properties '())) + +(set! 2D-put! + (named-lambda (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))))))) + +(set! 2D-get + (named-lambda (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. + +(set! 2D-remove! + (named-lambda (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 delete-invalid-hash-numbers! + (list-deletor! + (lambda (bucket) + (or (not (valid-hash-number? (car bucket))) + (begin (set-cdr! bucket (delete-invalid-y! (cdr bucket))) + (null? (cdr bucket))))))) + +(define delete-invalid-y! + (list-deletor! + (lambda (entry) + (not (valid-hash-number? (car entry)))))) + +(add-secondary-gc-daemon! gc-system-properties!) + +(set! 2D-get-alist-x + (named-lambda (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))))) + '())))) + +(set! 2D-get-alist-y + (named-lambda (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)))))))) + diff --git a/v7/src/runtime/histry.scm b/v7/src/runtime/histry.scm new file mode 100644 index 000000000..77a96e6dc --- /dev/null +++ b/v7/src/runtime/histry.scm @@ -0,0 +1,255 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1985 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. +;;; + +;;;; History Manipulation + +(declare (usual-integrations)) + +(define max-subproblems 10) +(define max-reductions 5) +(define with-new-history) + +(define history-package + (make-package history-package + ((set-current-history! + (make-primitive-procedure 'SET-CURRENT-HISTORY!)) + (return-address-pop-from-compiled-code + (make-return-address + (microcode-return 'POP-FROM-COMPILED-CODE))) + + ;; VERTEBRA abstraction. + (make-vertebra (make-primitive-procedure 'HUNK3-CONS)) + (vertebra-rib system-hunk3-cxr0) + (deeper-vertebra system-hunk3-cxr1) + (shallower-vertebra system-hunk3-cxr2) + (set-vertebra-rib! system-hunk3-set-cxr0!) + (set-deeper-vertebra! system-hunk3-set-cxr1!) + (set-shallower-vertebra! system-hunk3-set-cxr2!) + + ;; REDUCTION abstraction. + (make-reduction (make-primitive-procedure 'HUNK3-CONS)) + (reduction-expression system-hunk3-cxr0) + (reduction-environment system-hunk3-cxr1) + (next-reduction system-hunk3-cxr2) + (set-reduction-expression! system-hunk3-set-cxr0!) + (set-reduction-environment! system-hunk3-set-cxr1!) + (set-next-reduction! system-hunk3-set-cxr2!) + ) + +(declare (compilable-primitive-functions + (make-vertebra hunk3-cons) + (vertebra-rib system-hunk3-cxr0) + (deeper-vertebra system-hunk3-cxr1) + (shallower-vertebra system-hunk3-cxr2) + (set-vertebra-rib! system-hunk3-set-cxr0!) + (set-deeper-vertebra! system-hunk3-set-cxr1!) + (set-shallower-vertebra! system-hunk3-set-cxr2!) + (make-reduction hunk3-cons) + (reduction-expression system-hunk3-cxr0) + (reduction-environment system-hunk3-cxr1) + (next-reduction system-hunk3-cxr2) + (set-reduction-expression! system-hunk3-set-cxr0!) + (set-reduction-environment! system-hunk3-set-cxr1!) + (set-next-reduction! system-hunk3-set-cxr2!))) + +(define (marked-vertebra? vertebra) + (object-dangerous? (deeper-vertebra vertebra))) + +(define (mark-vertebra! vertebra) + (set-deeper-vertebra! vertebra + (make-object-dangerous (deeper-vertebra vertebra)))) + +(define (unmark-vertebra! vertebra) + (set-deeper-vertebra! vertebra + (make-object-safe (deeper-vertebra vertebra)))) + +(define (marked-reduction? reduction) + (object-dangerous? (next-reduction reduction))) + +(define (mark-reduction! reduction) + (set-next-reduction! reduction + (make-object-dangerous (next-reduction reduction)))) + +(define (unmark-reduction! reduction) + (set-next-reduction! reduction + (make-object-safe (next-reduction reduction)))) + +(define (link-vertebrae previous next) + (set-deeper-vertebra! previous next) + (set-shallower-vertebra! next previous)) + +;;;; History Initialization + +(define (create-history depth width) + (define (new-vertebra) + (let ((head (make-reduction #!FALSE #!FALSE '()))) + (set-next-reduction! + head + (let reduction-loop ((n (-1+ width))) + (if (zero? n) + head + (make-reduction #!FALSE + #!FALSE + (reduction-loop (-1+ n)))))) + (make-vertebra head '() '()))) + + (cond ((or (not (integer? depth)) + (negative? depth)) + (error "Invalid Depth" 'CREATE-HISTORY depth)) + ((or (not (integer? width)) + (negative? width)) + (error "Invalid Width" 'CREATE-HISTORY width)) + (else + (if (or (zero? depth) (zero? width)) + (begin (set! depth 1) (set! width 1))) + (let ((head (new-vertebra))) + (let subproblem-loop ((n (-1+ depth)) + (previous head)) + (if (zero? n) + (link-vertebrae previous head) + (let ((next (new-vertebra))) + (link-vertebrae previous next) + (subproblem-loop (-1+ n) next)))) + head)))) + +;;; The PUSH-HISTORY! accounts for the pop which happens after +;;; SET-CURRENT-HISTORY! is run. + +(set! with-new-history + (named-lambda (with-new-history thunk) + (set-current-history! + (let ((history (push-history! (create-history max-subproblems + max-reductions)))) + (if (zero? max-subproblems) + + ;; In this case, we want the history to appear empty, + ;; so when it pops up, there is nothing in it. + history + + ;; Otherwise, record a dummy reduction, which will appear + ;; in the history. + (begin + (record-evaluation-in-history! history + (scode-quote #!FALSE) + system-global-environment) + (push-history! history))))) + (thunk))) + +;;;; Primitive History Operations +;;; These operations mimic the actions of the microcode. +;;; The history motion operations all return the new history. + +(define (record-evaluation-in-history! history expression environment) + (let ((current-reduction (vertebra-rib history))) + (set-reduction-expression! current-reduction expression) + (set-reduction-environment! current-reduction environment))) + +(define (set-history-to-next-reduction! history) + (let ((next-reduction (next-reduction (vertebra-rib history)))) + (set-vertebra-rib! history next-reduction) + (unmark-reduction! next-reduction) + history)) + +(define (push-history! history) + (let ((deeper-vertebra (deeper-vertebra history))) + (mark-vertebra! deeper-vertebra) + (mark-reduction! (vertebra-rib deeper-vertebra)) + deeper-vertebra)) + +(define (pop-history! history) + (unmark-vertebra! history) + (shallower-vertebra history)) + +;;;; Side-Effectless Examiners + +(define (history-transform history) + (let loop ((current history)) + (cons current + (if (marked-vertebra? current) + (cons (delay + (unfold-and-reverse-rib (vertebra-rib current))) + (delay + (let ((next (shallower-vertebra current))) + (if (eq? next history) + '() + (loop next))))) + '())))) + +(define (dummy-compiler-reduction? reduction) + (and (marked-reduction? reduction) + (null? (reduction-expression reduction)) + (eq? return-address-pop-from-compiled-code + (reduction-environment reduction)))) + +(define (unfold-and-reverse-rib rib) + (let loop ((current (next-reduction rib)) + (output 'WRAP-AROUND)) + (let ((step + (if (dummy-compiler-reduction? current) + '() + (cons (list (reduction-expression current) + (reduction-environment current)) + (if (marked-reduction? current) + '() + output))))) + (if (eq? current rib) + step + (loop (next-reduction current) + step))))) + +(define the-empty-history + (cons (vector-ref (get-fixed-objects-vector) + (fixed-objects-vector-slot 'DUMMY-HISTORY)) + '())) + +(define (history-superproblem history) + (if (null? (cdr history)) + history + (force (cddr history)))) + +(define (history-reductions history) + (if (null? (cdr history)) + '() + (force (cadr history)))) + +(define (history-untransform history) + (car history)) + + +;;; end HISTORY-PACKAGE. +)) +(the-environment))) \ No newline at end of file -- 2.25.1