From 039bbb4d55cac6752af77c60e46c3c8123f923fb Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 13 Jun 1988 12:00:56 +0000 Subject: [PATCH] First checkin for version 14. --- v7/src/runtime/advice.scm | 490 +++++++------- v7/src/runtime/bitstr.scm | 150 +++-- v7/src/runtime/boole.scm | 3 +- v7/src/runtime/boot.scm | 264 +++----- v7/src/runtime/char.scm | 349 +++------- v7/src/runtime/chrset.scm | 3 +- v7/src/runtime/codwlk.scm | 4 +- v7/src/runtime/conpar.scm | 13 +- v7/src/runtime/contin.scm | 4 +- v7/src/runtime/cpoint.scm | 4 +- v7/src/runtime/datime.scm | 214 +++--- v7/src/runtime/dbgcmd.scm | 94 ++- v7/src/runtime/dbgutl.scm | 11 +- v7/src/runtime/debug.scm | 911 +++++++++++++------------ v7/src/runtime/defstr.scm | 404 ++++++------ v7/src/runtime/emacs.scm | 399 +++++------ v7/src/runtime/equals.scm | 107 ++- v7/src/runtime/error.scm | 896 ++++++++++--------------- v7/src/runtime/events.scm | 180 ++--- v7/src/runtime/framex.scm | 8 +- v7/src/runtime/gc.scm | 376 +++++------ v7/src/runtime/gcdemn.scm | 73 +- v7/src/runtime/gcnote.scm | 4 +- v7/src/runtime/gcstat.scm | 288 ++++---- v7/src/runtime/gdatab.scm | 4 +- v7/src/runtime/gensym.scm | 121 ++-- v7/src/runtime/global.scm | 6 +- v7/src/runtime/hash.scm | 209 +++--- v7/src/runtime/histry.scm | 306 ++++----- v7/src/runtime/input.scm | 785 +++++++--------------- v7/src/runtime/intrpt.scm | 424 ++++++------ v7/src/runtime/io.scm | 283 ++++---- v7/src/runtime/lambda.scm | 650 +++++++++--------- v7/src/runtime/lambdx.scm | 3 +- v7/src/runtime/list.scm | 908 +++++++++++++------------ v7/src/runtime/load.scm | 70 +- v7/src/runtime/make.scm | 233 ++++--- v7/src/runtime/msort.scm | 72 +- v7/src/runtime/numpar.scm | 120 ++-- v7/src/runtime/output.scm | 517 ++++++--------- v7/src/runtime/packag.scm | 3 +- v7/src/runtime/parse.scm | 790 +++++++++++----------- v7/src/runtime/partab.scm | 4 +- v7/src/runtime/pathnm.scm | 329 ++++----- v7/src/runtime/poplat.scm | 4 +- v7/src/runtime/pp.scm | 484 +++++++------- v7/src/runtime/prop1d.scm | 10 +- v7/src/runtime/prop2d.scm | 4 +- v7/src/runtime/qsort.scm | 173 +++-- v7/src/runtime/queue.scm | 3 +- v7/src/runtime/random.scm | 4 +- v7/src/runtime/rep.scm | 819 ++++++++++++++--------- v7/src/runtime/savres.scm | 4 +- v7/src/runtime/scan.scm | 161 +++-- v7/src/runtime/scode.scm | 506 +++++++------- v7/src/runtime/scomb.scm | 509 ++++++-------- v7/src/runtime/sdata.scm | 328 +++------ v7/src/runtime/sfile.scm | 109 +-- v7/src/runtime/stream.scm | 301 ++++----- v7/src/runtime/string.scm | 178 ++--- v7/src/runtime/strnin.scm | 4 +- v7/src/runtime/strott.scm | 4 +- v7/src/runtime/strout.scm | 4 +- v7/src/runtime/syntab.scm | 36 +- v7/src/runtime/syntax.scm | 1282 +++++++++++++----------------------- v7/src/runtime/sysclk.scm | 154 ++--- v7/src/runtime/sysmac.scm | 57 +- v7/src/runtime/system.scm | 312 +++------ v7/src/runtime/udata.scm | 40 +- v7/src/runtime/uenvir.scm | 72 +- v7/src/runtime/uerror.scm | 19 +- v7/src/runtime/unpars.scm | 679 ++++++++++--------- v7/src/runtime/unsyn.scm | 503 ++++++-------- v7/src/runtime/unxdir.scm | 4 +- v7/src/runtime/unxpth.scm | 387 ++--------- v7/src/runtime/urtrap.scm | 4 +- v7/src/runtime/utabs.scm | 442 ++++--------- v7/src/runtime/vector.scm | 129 ++-- v7/src/runtime/version.scm | 5 +- v7/src/runtime/where.scm | 244 ++----- v7/src/runtime/wind.scm | 152 ++--- v7/src/runtime/wrkdir.scm | 4 +- v8/src/runtime/conpar.scm | 13 +- v8/src/runtime/dbgutl.scm | 11 +- v8/src/runtime/framex.scm | 8 +- v8/src/runtime/global.scm | 6 +- v8/src/runtime/load.scm | 70 +- v8/src/runtime/make.scm | 233 ++++--- v8/src/runtime/uenvir.scm | 72 +- 89 files changed, 8820 insertions(+), 10813 deletions(-) diff --git a/v7/src/runtime/advice.scm b/v7/src/runtime/advice.scm index 8a37839dd..1e93e0aa0 100644 --- a/v7/src/runtime/advice.scm +++ b/v7/src/runtime/advice.scm @@ -1,55 +1,116 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/advice.scm,v 13.44 1987/06/30 20:58:10 cph Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/advice.scm,v 14.1 1988/06/13 11:38:43 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; Advice package +;;; package: (runtime advice) (declare (usual-integrations)) -(define advice-package - (make-environment +(define (initialize-package!) + (set! entry-advice-population (make-population)) + (set! exit-advice-population (make-population)) + (set! particular-entry-advisor (particular-advisor primitive-advise-entry)) + (set! particular-exit-advisor (particular-advisor primitive-advise-exit)) + (set! particular-both-advisor primitive-advise-both) + (set! particular-entry-unadvisor primitive-unadvise-entry) + (set! particular-exit-unadvisor primitive-unadvise-exit) + (set! particular-both-unadvisor primitive-unadvise-both) + (set! primitive-trace-entry (particular-entry-advisor trace-entry-advice)) + (set! primitive-trace-exit (particular-exit-advisor trace-exit-advice)) + (set! primitive-trace-both + (particular-both-advisor trace-entry-advice trace-exit-advice)) + (set! primitive-untrace + (particular-both-unadvisor trace-entry-advice trace-exit-advice)) + (set! primitive-untrace-entry + (particular-entry-unadvisor trace-entry-advice)) + (set! primitive-untrace-exit (particular-exit-unadvisor trace-exit-advice)) + (set! primitive-break-entry (particular-entry-advisor break-entry-advice)) + (set! primitive-break-exit (particular-exit-advisor break-exit-advice)) + (set! primitive-break-both + (particular-both-advisor break-entry-advice break-exit-advice)) + (set! primitive-unbreak + (particular-both-unadvisor break-entry-advice break-exit-advice)) + (set! primitive-unbreak-entry + (particular-entry-unadvisor break-entry-advice)) + (set! primitive-unbreak-exit (particular-exit-unadvisor break-exit-advice)) + (set! advice (wrap-advice-extractor primitive-advice)) + (set! entry-advice (wrap-advice-extractor primitive-entry-advice)) + (set! exit-advice (wrap-advice-extractor primitive-exit-advice)) + (set! advise-entry (wrap-general-advisor primitive-advise-entry)) + (set! advise-exit (wrap-general-advisor primitive-advise-exit)) + (set! wrap-entry-unadvisor + (wrap-unadvisor + (lambda (operation) + (map-over-population entry-advice-population operation)))) + (set! wrap-exit-unadvisor + (wrap-unadvisor + (lambda (operation) + (map-over-population exit-advice-population operation)))) + (set! wrap-both-unadvisor + (wrap-unadvisor + (lambda (operation) + (map-over-population entry-advice-population operation) + (map-over-population exit-advice-population operation)))) + (set! unadvise (wrap-both-unadvisor primitive-unadvise-entire-lambda)) + (set! unadvise-entry (wrap-entry-unadvisor primitive-unadvise-entire-entry)) + (set! unadvise-exit (wrap-exit-unadvisor primitive-unadvise-entire-exit)) + (set! untrace (wrap-both-unadvisor primitive-untrace)) + (set! untrace-entry (wrap-entry-unadvisor primitive-untrace-entry)) + (set! untrace-exit (wrap-exit-unadvisor primitive-untrace-exit)) + (set! unbreak (wrap-both-unadvisor primitive-unbreak)) + (set! unbreak-entry (wrap-entry-unadvisor primitive-unbreak-entry)) + (set! unbreak-exit (wrap-exit-unadvisor primitive-unbreak-exit)) + (set! trace-entry (wrap-advisor primitive-trace-entry)) + (set! trace-exit (wrap-advisor primitive-trace-exit)) + (set! trace-both (wrap-advisor primitive-trace-both)) + (set! trace trace-both) + (set! break-entry (wrap-advisor primitive-break-entry)) + (set! break-exit (wrap-advisor primitive-break-exit)) + (set! break-both (wrap-advisor primitive-break-both)) + (set! break break-both)) + +;;;; Advice Wrappers + +(define entry-advice-population) +(define exit-advice-population) -(define the-args) +(define the-arguments) (define the-procedure) (define the-result) (define (*args*) - the-args) + the-arguments) (define (*proc*) the-procedure) @@ -57,42 +118,35 @@ (define (*result*) the-result) -(define entry-advice-population - (make-population)) - -(define exit-advice-population - (make-population)) - -;;;; Advice Wrappers - (define (add-lambda-advice! lambda advice-transformation) - ((access lambda-wrap-body! lambda-package) lambda - (lambda (body state cont) + (lambda-wrap-body! lambda + (lambda (body state receiver) (if (null? state) - (cont (make-advice-hook) - (advice-transformation '() '() cons)) - (cont body - (advice-transformation (car state) (cdr state) cons)))))) + (receiver (make-advice-hook) + (advice-transformation '() '() cons)) + (receiver 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 + (if (and (null? new-entry-advice) (null? new-exit-advice)) + (lambda-unwrap-body! lambda) + (lambda-wrap-body! lambda + (lambda (body state receiver) + state + (receiver body + (cons new-entry-advice new-exit-advice)))))))))) + +(define (lambda-advice lambda receiver) + (lambda-wrapper-components lambda (lambda (original-body state) + original-body (if (null? state) - (error "Procedure has no advice -- LAMBDA-ADVICE" lambda) - (cont (car state) - (cdr state)))))) + (error "Procedure has no advice -- LAMBDA-ADVICE" lambda)) + (receiver (car state) (cdr state))))) (define (make-advice-hook) (make-combination syntaxed-advice-procedure @@ -100,7 +154,9 @@ (define syntaxed-advice-procedure (scode-quote - (ACCESS ADVISED-PROCEDURE-WRAPPER ADVICE-PACKAGE '()))) + ((ACCESS PACKAGE/REFERENCE #F) + ((ACCESS FIND-PACKAGE #F) '(RUNTIME ADVICE)) + 'ADVISED-PROCEDURE-WRAPPER))) ;;;; The Advice Hook @@ -117,18 +173,17 @@ (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-wrapper-components (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 (proceed-continuation values) + (if (null? values) + (proceed-continuation '()) + (continuation (car values)))) (lambda () (receiver advice)))) @@ -155,42 +210,44 @@ (define (primitive-entry-advice lambda) (lambda-advice lambda (lambda (entry-advice exit-advice) + exit-advice entry-advice))) (define (primitive-exit-advice lambda) (lambda-advice lambda (lambda (entry-advice exit-advice) + entry-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 - (begin (add-to-population! entry-advice-population lambda) - (cons advice entry-advice))) - exit-advice)))) + (lambda (entry-advice exit-advice receiver) + (receiver (if (memq advice entry-advice) + entry-advice + (begin (add-to-population! entry-advice-population lambda) + (cons advice entry-advice))) + exit-advice)))) (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 - (begin (add-to-population! exit-advice-population lambda) - (append! exit-advice (list advice)))))))) + (lambda (entry-advice exit-advice receiver) + (receiver entry-advice + (if (memq advice exit-advice) + exit-advice + (begin (add-to-population! exit-advice-population lambda) + (append! exit-advice (list advice)))))))) (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 - (begin (add-to-population! entry-advice-population lambda) - (cons new-entry-advice entry-advice))) - (if (memq new-exit-advice exit-advice) - exit-advice - (begin (add-to-population! exit-advice-population lambda) - (append! exit-advice (list new-exit-advice)))))))) + (lambda (entry-advice exit-advice receiver) + (receiver (if (memq new-entry-advice entry-advice) + entry-advice + (begin (add-to-population! entry-advice-population lambda) + (cons new-entry-advice entry-advice))) + (if (memq new-exit-advice exit-advice) + exit-advice + (begin (add-to-population! exit-advice-population lambda) + (append! exit-advice (list new-exit-advice)))))))) (define (eq?-adjoin object list) (if (memq object list) @@ -199,146 +256,126 @@ (define (primitive-unadvise-entire-entry lambda) (remove-lambda-advice! lambda - (lambda (entry-advice exit-advice cont) - (cont '() exit-advice))) + (lambda (entry-advice exit-advice receiver) + entry-advice + (receiver '() 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 '()))) + (lambda (entry-advice exit-advice receiver) + exit-advice + (receiver entry-advice '()))) (remove-from-population! exit-advice-population lambda)) (define (primitive-unadvise-entire-lambda lambda) - ((access lambda-unwrap-body! lambda-package) lambda) + (lambda-unwrap-body! 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) + (lambda (entry-advice exit-advice receiver) (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))))) + (receiver new-entry-advice exit-advice))))) (define ((primitive-unadvise-exit advice) lambda) (remove-lambda-advice! lambda - (lambda (entry-advice exit-advice cont) + (lambda (entry-advice exit-advice receiver) (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))))) + (receiver 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) + (lambda (entry-advice exit-advice receiver) (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))))) + (receiver 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) +(define particular-entry-advisor) +(define particular-exit-advisor) +(define particular-both-advisor) +(define particular-entry-unadvisor) +(define particular-exit-unadvisor) +(define particular-both-unadvisor) ;;;; Trace -(define (trace-entry-advice proc args env) - (trace-display proc args)) +(define (trace-entry-advice procedure arguments environment) + environment + (trace-display procedure arguments)) -(define (trace-exit-advice proc args result env) - (trace-display proc args result) +(define (trace-exit-advice procedure arguments result environment) + environment + (trace-display procedure arguments result) result) -(define (trace-display proc args #!optional result) +(define (trace-display procedure arguments #!optional result) (newline) - (let ((width (- (access printer-width implementation-dependencies) 3))) + (let ((width (- (output-port/x-size (current-output-port)) 3))) (let ((output (with-output-to-truncated-string width (lambda () - (if (unassigned? result) + (if (default-object? result) (write-string "[Entering ") (begin (write-string "[") (write result) (write-string " <== "))) (write-string "<") - (write proc) + (write procedure) (for-each (lambda (arg) (write-char #\Space) (write arg)) - args))))) + arguments))))) (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)) +(define primitive-trace-entry) +(define primitive-trace-exit) +(define primitive-trace-both) +(define primitive-untrace) +(define primitive-untrace-entry) +(define primitive-untrace-exit) ;;;; 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 (break-rep environment message . info) + (breakpoint (cmdl-message/append + (cmdl-message/active (lambda () (apply trace-display info))) + (cmdl-message/standard message)) + environment)) -(define primitive-break-both - (particular-both-advisor break-entry-advice break-exit-advice)) +(define (break-entry-advice procedure arguments environment) + (fluid-let ((the-procedure procedure) + (the-arguments arguments)) + (break-rep environment "Breakpoint on entry" procedure arguments))) -(define primitive-unbreak - (particular-both-unadvisor break-entry-advice break-exit-advice)) - -(define primitive-unbreak-entry - (particular-entry-unadvisor break-entry-advice)) +(define (break-exit-advice procedure arguments result environment) + (fluid-let ((the-procedure procedure) + (the-arguments arguments) + (the-result result)) + (break-rep environment "Breakpoint on exit" procedure arguments result)) + result) -(define primitive-unbreak-exit - (particular-exit-unadvisor break-exit-advice)) +(define primitive-break-entry) +(define primitive-break-exit) +(define primitive-break-both) +(define primitive-unbreak) +(define primitive-unbreak-entry) +(define primitive-unbreak-exit) ;;;; Top Level Wrappers @@ -362,6 +399,7 @@ lambda (lambda-components lambda (lambda (name required optional rest auxiliary declarations body) + name required optional rest declarations (if (memq (car path) auxiliary) (loop (sequence-actions body)) (error "No internal definition by this name" (car path))))))) @@ -374,16 +412,16 @@ (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 advice) +(define entry-advice) +(define 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 advise-entry) +(define advise-exit) (define (((wrap-unadvisor map-over-population) unadvisor) . procedure&path) (if (null? procedure&path) @@ -392,80 +430,28 @@ (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-entry-unadvisor) +(define wrap-exit-unadvisor) +(define wrap-both-unadvisor) +(define unadvise) +(define unadvise-entry) +(define unadvise-exit) +(define untrace) +(define untrace-entry) +(define untrace-exit) +(define unbreak) +(define unbreak-entry) +(define 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 +(define trace-entry) +(define trace-exit) +(define trace-both) +(define trace) +(define break-entry) +(define break-exit) +(define break-both) +(define break) \ No newline at end of file diff --git a/v7/src/runtime/bitstr.scm b/v7/src/runtime/bitstr.scm index 7cdac5efe..62737eedb 100644 --- a/v7/src/runtime/bitstr.scm +++ b/v7/src/runtime/bitstr.scm @@ -1,64 +1,97 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/bitstr.scm,v 13.46 1987/08/10 20:26:15 jinx Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/bitstr.scm,v 14.1 1988/06/13 11:40:45 cph Rel $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; Bit String Primitives +;;; package: () (declare (usual-integrations)) -(let-syntax ((define-primitives - (macro names - `(BEGIN ,@(map (lambda (name) - `(LOCAL-ASSIGNMENT - SYSTEM-GLOBAL-ENVIRONMENT - ',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-string-xor! bit-substring-move-right! - bit-string->unsigned-integer unsigned-integer->bit-string - read-bits! write-bits! - bit-substring-find-next-set-bit)) +(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-string-xor! bit-substring-move-right! + bit-string->unsigned-integer unsigned-integer->bit-string + read-bits! write-bits! + bit-substring-find-next-set-bit) + +(define (bit-string-copy bit-string) + (let ((result (bit-string-allocate (bit-string-length bit-string)))) + (bit-string-move! result bit-string) + result)) + +(define (bit-string-not bit-string) + (let ((result (bit-string-allocate (bit-string-length bit-string)))) + (bit-string-movec! result bit-string) + result)) + +(define (bit-string-or x y) + (let ((result (bit-string-allocate (bit-string-length x)))) + (bit-string-move! result x) + (bit-string-or! result y) + result)) + +(define (bit-string-and x y) + (let ((result (bit-string-allocate (bit-string-length x)))) + (bit-string-move! result x) + (bit-string-and! result y) + result)) + +(define (bit-string-andc x y) + (let ((result (bit-string-allocate (bit-string-length x)))) + (bit-string-move! result x) + (bit-string-andc! result y) + result)) + +(define (bit-string-xor x y) + (let ((result (bit-string-allocate (bit-string-length x)))) + (bit-string-move! result x) + (bit-string-xor! result y) + 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 (bit-substring-extend string start end length) + ;; Assumption: (<= (- end start) length) + (let ((result (make-bit-string length false))) + (bit-substring-move-right! string start end result 0) + result)) (define (bit-string-append x y) (declare (integrate x y)) @@ -73,11 +106,6 @@ (declare (integrate bit-string-append)) (bit-string-append y x)) -(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 diff --git a/v7/src/runtime/boole.scm b/v7/src/runtime/boole.scm index 225d811e6..1437a3cf5 100644 --- a/v7/src/runtime/boole.scm +++ b/v7/src/runtime/boole.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/boole.scm,v 14.1 1988/05/20 00:51:46 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/boole.scm,v 14.2 1988/06/13 11:40:52 cph Rel $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Boolean Operations +;;; package: () (declare (usual-integrations)) diff --git a/v7/src/runtime/boot.scm b/v7/src/runtime/boot.scm index ac52dcadb..12d69469f 100644 --- a/v7/src/runtime/boot.scm +++ b/v7/src/runtime/boot.scm @@ -1,185 +1,91 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/boot.scm,v 13.46 1988/05/03 19:04:10 jinx Exp $ -;;; -;;; Copyright (c) 1988 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions and -;;; understandings. -;;; -;;; 1. Any copy made of this software must include this copyright -;;; notice in full. -;;; -;;; 2. Users of this software agree to make their best efforts (a) -;;; to return to the MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. All materials developed as a consequence of the use of this -;;; software shall duly acknowledge such use, in accordance with -;;; the usual standards of acknowledging credit in academic -;;; research. -;;; -;;; 4. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Boot Utilities - -(declare (usual-integrations) - (integrate-primitive-procedures - compiled-code-address->block - compiled-code-address->offset - primitive-object-set-type)) - -;;; The utilities in this file are the first thing loaded into the -;;; world after the type tables. They shouldn't depend on anything else -;;; except those tables. - -;;;; Primitive Operators - -(let-syntax ((define-global-primitives - (macro names - `(BEGIN - ,@(map (lambda (name) - `(DEFINE ,name ,(make-primitive-procedure name))) - names))))) - (define-global-primitives - SCODE-EVAL FORCE - SET-INTERRUPT-ENABLES! WITH-INTERRUPTS-REDUCED - WITH-INTERRUPT-MASK - GET-FIXED-OBJECTS-VECTOR WITH-HISTORY-DISABLED - PRIMITIVE-PROCEDURE-ARITY NOT FALSE? - ;; 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 - - ;; List Operations - ;; (these appear here for the time being because the compiler - ;; couldn't handle the `in-package' required to put them in - ;; `list.scm'. They should be moved back when that is fixed. - CONS PAIR? NULL? LENGTH CAR CDR SET-CAR! SET-CDR! - GENERAL-CAR-CDR MEMQ ASSQ - - ;; 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 +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/boot.scm,v 14.1 1988/06/13 11:40:56 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. -(define *the-non-printing-object* '(*THE-NON-PRINTING-OBJECT*)) -(define (identity-procedure x) x) -(define false #F) -(define true #T) +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. -(define (null-procedure . args) args '()) ; args ignored -(define (false-procedure . args) args #F) ; args ignored -(define (true-procedure . args) args #T) ; args ignored +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 Time Definitions +;;; package: () + +(declare (usual-integrations)) + +(define (unparser/standard-method name #!optional unparser) + (lambda (state object) + (if (not (unparser-state? state)) (error "Bad unparser state" state)) + (let ((port (unparser-state/port state))) + (write-string "#[" port) + (if (string? name) + (write-string name port) + (unparse-object state name)) + (write-char #\Space port) + (write-string (number->string (hash object)) port) + (if (and (not (default-object? unparser)) unparser) + (begin (write-char #\Space port) + (unparser state object))) + (write-char #\] port)))) +(define *the-non-printing-object* + (object-new-type (ucode-type true) 1)) + +(define-integrable interrupt-bit/stack #x0001) +(define-integrable interrupt-bit/global-gc #x0002) +(define-integrable interrupt-bit/gc #x0004) +(define-integrable interrupt-bit/global-1 #x0008) +(define-integrable interrupt-bit/kbd #x0010) +(define-integrable interrupt-bit/global-2 #x0020) +(define-integrable interrupt-bit/timer #x0040) +(define-integrable interrupt-bit/global-3 #x0080) +(define-integrable interrupt-bit/suspend #x0100) + +;; GC & stack overflow only +(define-integrable interrupt-mask/gc-ok #x0007) + +;; Absolutely everything off +(define-integrable interrupt-mask/none #x0000) + +;; Normal: all enabled +(define-integrable interrupt-mask/all #xFFFF) + +(define (with-absolutely-no-interrupts thunk) + (with-interrupt-mask interrupt-mask/none + (lambda (interrupt-mask) + interrupt-mask + (thunk)))) (define (without-interrupts thunk) - (with-interrupts-reduced interrupt-mask-gc-ok - (lambda (old-mask) - old-mask ;; ignored + (with-interrupt-mask interrupt-mask/gc-ok + (lambda (interrupt-mask) + interrupt-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))) - -;;; This won't work until vector is loaded, but it has no better place to go. - -(let-syntax ((ucode-type (macro (name) (microcode-type name)))) - -(define (copy-program exp) - (if (not (primitive-type? (ucode-type COMPILED-ENTRY) exp)) - (error "copy-program: Can only copy compiled programs" exp)) - (let* ((original (compiled-code-address->block exp)) - (block (primitive-set-type - (ucode-type COMPILED-CODE-BLOCK) - (vector-copy - (primitive-set-type (ucode-type VECTOR) - original)))) - (end (system-vector-size block))) - - (define (map-entry entry) - (with-interrupt-mask - interrupt-mask-none - (lambda (old) - old ;; ignored - (primitive-object-set-type - (primitive-type entry) - (+ (compiled-code-address->offset entry) - (primitive-datum block)))))) - - (let loop ((n (1+ (primitive-datum (system-vector-ref block 0))))) - (cond ((>= n end) - (map-entry exp)) - ((not (lambda? (system-vector-ref block n))) - (loop (1+ n))) - (else - (lambda-components (system-vector-ref block n) - (lambda (name req opt rest aux decl body) - (if (and (primitive-type? (ucode-type COMPILED-ENTRY) body) - (eq? original (compiled-code-address->block body))) - (system-vector-set! block n - (make-lambda name req opt rest aux decl - (map-entry body)))) - (loop (1+ n))))))))) - -) ;; End of let-syntax \ No newline at end of file +(define-primitives + (object-pure? pure?) + (object-constant? constant?) + get-next-constant) \ No newline at end of file diff --git a/v7/src/runtime/char.scm b/v7/src/runtime/char.scm index d8cad83d1..e792675c2 100644 --- a/v7/src/runtime/char.scm +++ b/v7/src/runtime/char.scm @@ -1,123 +1,111 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/char.scm,v 13.43 1988/04/27 18:24:54 mhwu Exp $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/char.scm,v 14.1 1988/06/13 11:41:03 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; Character Abstraction +;;; package: (runtime character) (declare (usual-integrations)) -(let-syntax ((define-primitives - (macro names - `(BEGIN ,@(map (lambda (name) - `(LOCAL-ASSIGNMENT - SYSTEM-GLOBAL-ENVIRONMENT - ',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 #o20) -(define char-integer-limit (* char-code-limit char-bits-limit)) - -(define (chars->ascii chars) +(define-primitives + make-char char-code char-bits char->integer integer->char char->ascii + char-ascii? ascii->char char-upcase char-downcase) + +(define-integrable (char? object) + (object-type? (ucode-type character) object)) + +(define-integrable char-code-limit #x80) +(define-integrable char-bits-limit #x20) +(define-integrable char-integer-limit #x1000) + +(define-integrable (chars->ascii chars) (map char->ascii chars)) -(define (code->char code) +(define-integrable (code->char code) (make-char code 0)) -(define (char=? x y) +(define-integrable (char=? x y) (= (char->integer x) (char->integer y))) -(define (charinteger x) (char->integer y))) -(define (char<=? x y) +(define-integrable (char<=? x y) (<= (char->integer x) (char->integer y))) -(define (char>? x y) +(define-integrable (char>? x y) (> (char->integer x) (char->integer y))) -(define (char>=? x y) +(define-integrable (char>=? x y) (>= (char->integer x) (char->integer y))) -(define (char-ci->integer char) +(define-integrable (char-ci->integer char) (char->integer (char-upcase char))) -(define (char-ci=? x y) +(define-integrable (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) +(define-integrable (char-ci<=? x y) (<= (char-ci->integer x) (char-ci->integer y))) -(define (char-ci>? x y) +(define-integrable (char-ci>? x y) (> (char-ci->integer x) (char-ci->integer y))) -(define (char-ci>=? x y) +(define-integrable (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 0-code) +(define upper-a-code) +(define lower-a-code) +(define space-char) +(define hyphen-char) +(define backslash-char) + +(define (initialize-package!) + (set! 0-code (char-code (ascii->char #x30))) + (set! upper-a-code (char-code (ascii->char #x41))) + (set! lower-a-code (char-code (ascii->char #x61))) + (set! space-char (ascii->char #x20)) + (set! hyphen-char (ascii->char #x2D)) + (set! backslash-char (ascii->char #x5C))) (define named-codes - `(("Backspace" . #x08) + '(("Backspace" . #x08) ("Tab" . #x09) ("Linefeed" . #x0A) - ("VT" . #x0B) ("Page" . #x0C) ("Return" . #x0D) ("Call" . #x1A) @@ -125,7 +113,9 @@ ("Backnext" . #x1F) ("Space" . #x20) ("Rubout" . #x7F) - ;; ASCII codes + + ;; ASCII codes. Some of these are aliases for previous + ;; definitions, and will not appear as output. ("NUL" . #x00) ("SOH" . #x01) ("STX" . #x02) @@ -134,7 +124,12 @@ ("ENQ" . #x05) ("ACK" . #x06) ("BEL" . #x07) - ;; Skip + ("BS" . #x08) + ("HT" . #x09) + ("LF" . #x0A) + ("VT" . #x0B) + ("FF" . #x0C) + ("CR" . #x0D) ("SO" . #x0E) ("SI" . #x0F) ("DLE" . #x10) @@ -147,24 +142,26 @@ ("ETB" . #x17) ("CAN" . #x18) ("EM" . #x19) - ;; Skip + ("SUB" . #x1A) + ("ESC" . #x1B) ("FS" . #x1C) ("GS" . #x1D) ("RS" . #x1E) ("US" . #x1F) + ("DEL" . #x7F) )) (define named-bits - `(("M" . #o01) - ("Meta" . #o01) - ("C" . #o02) - ("Control" . #o02) - ("S" . #o04) - ("Super" . #o04) - ("H" . #o10) - ("Hyper" . #o10) - ("T" . #o20) - ("Top" . #o20) + '(("M" . #x01) + ("Meta" . #x01) + ("C" . #x02) + ("Control" . #x02) + ("S" . #x04) + ("Super" . #x04) + ("H" . #x08) + ("Hyper" . #x08) + ("T" . #x10) + ("Top" . #x10) )) (define (-map-> alist string start end) @@ -185,23 +182,17 @@ (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)) +(define (digit->char digit #!optional radix) + (cond ((default-object? 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)))))) + (+ (- digit 10) upper-a-code))))) -(set! char->digit -(named-lambda (char->digit char #!optional radix) - (cond ((unassigned? radix) (set! radix 10)) +(define (char->digit char #!optional radix) + (cond ((default-object? radix) (set! radix 10)) ((not (and (<= 2 radix) (<= radix 36))) (error "CHAR->DIGIT: Bad radix" radix))) (and (zero? (char-bits char)) @@ -213,10 +204,9 @@ n))) (or (try 0 0-code) (try 10 upper-a-code) - (try 10 lower-a-code)))))) + (try 10 lower-a-code))))) -(set! name->char -(named-lambda (name->char string) +(define (name->char string) (let ((end (string-length string)) (bits '())) (define (loop start) @@ -240,7 +230,7 @@ (set! bits (cons bit bits))) (loop (1+ hyphen))))))))))) (let ((code (loop 0))) - (make-char code (apply + bits)))))) + (make-char code (apply + bits))))) (define (name->code string start end) (if (substring-ci=? string start end "Newline" 0 7) @@ -248,9 +238,8 @@ (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 (char->name char #!optional slashify?) + (if (default-object? slashify?) (set! slashify? false)) (define (loop weight bits) (if (zero? bits) (let ((code (char-code char))) @@ -259,8 +248,7 @@ ((and slashify? (not (zero? (char-bits char))) (or (char=? base-char backslash-char) - (char-set-member? (access atom-delimiters - parser-package) + (char-set-member? char-set/atom-delimiters base-char))) (string-append "\\" (char->string base-char))) ((char-graphic? base-char) @@ -279,127 +267,4 @@ ">")) "-" 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)) -(define char-whitespace? (char-set-predicate char-set:whitespace)) + (loop 1 (char-bits char))) \ No newline at end of file diff --git a/v7/src/runtime/chrset.scm b/v7/src/runtime/chrset.scm index 2abe91ac2..d41b99a04 100644 --- a/v7/src/runtime/chrset.scm +++ b/v7/src/runtime/chrset.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/chrset.scm,v 14.1 1988/05/20 00:53:47 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/chrset.scm,v 14.2 1988/06/13 11:41:14 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Character Sets +;;; package: (runtime character-set) (declare (usual-integrations)) diff --git a/v7/src/runtime/codwlk.scm b/v7/src/runtime/codwlk.scm index f30f5c65e..bc6e679b8 100644 --- a/v7/src/runtime/codwlk.scm +++ b/v7/src/runtime/codwlk.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/codwlk.scm,v 14.1 1988/05/20 00:54:04 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/codwlk.scm,v 14.2 1988/06/13 11:41:19 cph Rel $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,7 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; SCode Walker -;;; scode-walker-package +;;; package: (runtime scode-walker) (declare (usual-integrations)) diff --git a/v7/src/runtime/conpar.scm b/v7/src/runtime/conpar.scm index 60ed0f09b..b4572ced2 100644 --- a/v7/src/runtime/conpar.scm +++ b/v7/src/runtime/conpar.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/conpar.scm,v 14.1 1988/05/20 00:54:26 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/conpar.scm,v 14.2 1988/06/13 11:41:24 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,7 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Continuation Parser -;;; package: continuation-parser-package +;;; package: (runtime continuation-parser) (declare (usual-integrations)) @@ -158,9 +158,7 @@ MIT in each case. |# (if (not (return-address? return-address)) (error "illegal return address" return-address)) (let ((code (return-address/code return-address))) - (if (>= code (vector-length stack-frame-types)) - (error "return-code too large" code)) - (let ((type (vector-ref stack-frame-types code))) + (let ((type (microcode-return/code->type code))) (if (not type) (error "return-code has no type" code)) type)))) @@ -379,6 +377,11 @@ MIT in each case. |# (parser false read-only true) (unparser false read-only true)) +(define (microcode-return/code->type code) + (if (not (< code (vector-length stack-frame-types))) + (error "return-code too large" code)) + (vector-ref stack-frame-types code)) + (define (initialize-package!) (set! stack-frame-types (make-stack-frame-types))) diff --git a/v7/src/runtime/contin.scm b/v7/src/runtime/contin.scm index 1079e6fa9..6e4e0fcb2 100644 --- a/v7/src/runtime/contin.scm +++ b/v7/src/runtime/contin.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/contin.scm,v 14.1 1988/05/20 00:54:50 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/contin.scm,v 14.2 1988/06/13 11:42:51 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,7 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Continuations -;;; package: continuation-package +;;; package: (runtime continuation) (declare (usual-integrations)) diff --git a/v7/src/runtime/cpoint.scm b/v7/src/runtime/cpoint.scm index 753787eda..e450b1223 100644 --- a/v7/src/runtime/cpoint.scm +++ b/v7/src/runtime/cpoint.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/cpoint.scm,v 14.1 1988/05/20 00:55:10 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/cpoint.scm,v 14.2 1988/06/13 11:42:56 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,7 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Control Points -;;; package: control-point-package +;;; package: (runtime control-point) (declare (usual-integrations)) diff --git a/v7/src/runtime/datime.scm b/v7/src/runtime/datime.scm index 5773e6587..370d0b152 100644 --- a/v7/src/runtime/datime.scm +++ b/v7/src/runtime/datime.scm @@ -1,120 +1,114 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/datime.scm,v 13.41 1987/01/23 00:11:08 jinx Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- -;;;; Date and Time Routines +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/datime.scm,v 14.1 1988/06/13 11:43:00 cph Exp $ -(declare (usual-integrations)) - -;;;; Date and Time +Copyright (c) 1988 Massachusetts Institute of Technology -(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))))) +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. -(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 () +1. Any copy made of this software must include this copyright notice +in full. -(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"))) +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. -(define months-of-the-year - #("January" "February" "March" "April" "May" "June" "July" - "August" "September" "October" "November" "December")) +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. -(define days-of-the-week - #("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday")) +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. -(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)))) +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. |# -(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"))) +;;;; Date and Time Routines +;;; package: (runtime date/time) + +(declare (usual-integrations)) + +;;;; Decoded Time + +;;; Based on Common Lisp definition. Needs time zone stuff, and +;;; handling of abbreviated year specifications. + +(define-structure (decoded-time (conc-name decoded-time/)) + (second false read-only true) + (minute false read-only true) + (hour false read-only true) + (day false read-only true) + (month false read-only true) + (year false read-only true) + (day-of-week false read-only true)) + +(define (get-decoded-time) + ;; Can return false, indicating that we don't know the time. + (let ((day ((ucode-primitive current-day))) + (month ((ucode-primitive current-month))) + (year ((ucode-primitive current-year)))) + (and year + (let ((year (+ year 1900))) + (make-decoded-time + ((ucode-primitive current-second)) + ((ucode-primitive current-minute)) + ((ucode-primitive current-hour)) + day + month + year + (zellers-congruence day month year)))))) + +(define (zellers-congruence day month year) + (let ((qr (integer-divide year 100))) + (let ((month (modulo (- month 2) 12)) + (year (integer-divide-remainder qr)) + (century (integer-divide-quotient qr))) + (modulo (-1+ (- (+ day + (quotient (-1+ (* 13 month)) 5) + year + (quotient year 4) + (quotient century 4)) + (+ (* 2 century) + (if (zero? (remainder year 4)) + (* 2 (quotient month 11)) + (quotient month 11))))) + 7)))) + +(define (decoded-time/date-string time) + (string-append + (vector-ref '#("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" + "Saturday" "Sunday") + (decoded-time/day-of-week time)) + " " + (vector-ref '#("January" "February" "March" "April" "May" "June" + "July" "August" "September" "October" + "November" "December") + (-1+ (decoded-time/month time))) + " " + (write-to-string (decoded-time/day time)) + ", " + (write-to-string (decoded-time/year time)))) -) +(define (decoded-time/time-string time) + (let ((second (decoded-time/second time)) + (minute (decoded-time/minute time)) + (hour (decoded-time/hour time))) + (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")))) \ No newline at end of file diff --git a/v7/src/runtime/dbgcmd.scm b/v7/src/runtime/dbgcmd.scm index 8c880bb66..7f36da71e 100644 --- a/v7/src/runtime/dbgcmd.scm +++ b/v7/src/runtime/dbgcmd.scm @@ -1,44 +1,39 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgcmd.scm,v 14.1 1988/05/20 00:55:29 cph Exp $ -;;; -;;; Copyright (c) 1988 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions and -;;; understandings. -;;; -;;; 1. Any copy made of this software must include this copyright -;;; notice in full. -;;; -;;; 2. Users of this software agree to make their best efforts (a) -;;; to return to the MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. All materials developed as a consequence of the use of this -;;; software shall duly acknowledge such use, in accordance with -;;; the usual standards of acknowledging credit in academic -;;; research. -;;; -;;; 4. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgcmd.scm,v 14.2 1988/06/13 11:43:06 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; Debugger Command Loop Support -;;; package: debugger-command-loop-package +;;; package: (runtime debugger-command-loop) (declare (usual-integrations)) @@ -78,16 +73,17 @@ (prompt (cdr (cmdl/state cmdl)))) (let loop () (let ((char (char-upcase (prompt-for-command-char prompt cmdl)))) - (let ((entry (assv char (cdr command-set)))) - (if entry - ((cadr entry)) - (begin - (let ((port (cmdl/output-port cmdl))) - (beep port) - (newline port) - (write-string "Unknown command char: " port) - (write char port)) - (loop))))))) + (with-output-to-port (cmdl/output-port cmdl) + (lambda () + (let ((entry (assv char (cdr command-set)))) + (if entry + ((cadr entry)) + (begin + (beep) + (newline) + (write-string "Unknown command char: ") + (write char) + (loop))))))))) (cmdl-message/null)) (define ((standard-help-command command-set)) diff --git a/v7/src/runtime/dbgutl.scm b/v7/src/runtime/dbgutl.scm index d24048388..7fb8c4fb8 100644 --- a/v7/src/runtime/dbgutl.scm +++ b/v7/src/runtime/dbgutl.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgutl.scm,v 14.1 1988/05/20 00:55:52 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgutl.scm,v 14.2 1988/06/13 11:43:10 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,7 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Debugger Utilities -;;; package: debugger-utilities-package +;;; package: (runtime debugger-utilities) (declare (usual-integrations)) @@ -110,4 +110,9 @@ MIT in each case. |# (string-append s (write->string (cadr binding) (max (- x-size (string-length s)) - 0))))))))) \ No newline at end of file + 0))))))))) + +(define (debug/read-eval-print-1 environment) + (let ((value (debug/eval (prompt-for-expression "Eval--> ") environment))) + (newline) + (write value))) \ No newline at end of file diff --git a/v7/src/runtime/debug.scm b/v7/src/runtime/debug.scm index 20903176c..279e73d3d 100644 --- a/v7/src/runtime/debug.scm +++ b/v7/src/runtime/debug.scm @@ -1,493 +1,485 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/debug.scm,v 13.46 1987/12/09 22:11:26 jinx Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- -;;;; Debugger - -(in-package debugger-package -(declare (usual-integrations)) - -(define debug-package - (make-environment - -(define current-continuation) -(define previous-continuations) -(define current-reduction-number) -(define current-number-of-reductions) -(define current-reduction) -(define current-environment) +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/debug.scm,v 14.1 1988/06/13 11:43:15 cph Exp $ -(define command-set - (make-command-set 'DEBUG-COMMANDS)) +Copyright (c) 1988 Massachusetts Institute of Technology -(define reduction-wrap-around-tag - 'WRAP-AROUND) +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. -(define print-user-friendly-name - (access print-user-friendly-name env-package)) +1. Any copy made of this software must include this copyright notice +in full. -(define print-expression - pp) +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. -(define student-walk? - false) +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. -(define print-return-values? - false) +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. -(define environment-arguments-truncation - 68) +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. |# -(define (define-debug-command letter function help-text) - (define-letter-command command-set letter function help-text)) +;;;; Debugger +;;; package: (runtime debugger) +(declare (usual-integrations)) + +(define (initialize-package!) + (set! command-set + (make-command-set + 'DEBUG-COMMANDS + `((#\? ,standard-help-command + "Help, list command letters") + (#\A ,debug-compiled + "Invoke compiled code debugger on the current subproblem") + (#\B ,earlier-reduction-command + "Earlier reduction (Back in time)") + (#\C ,show-current-frame + "Show Bindings of identifiers in the current environment") + (#\D ,later-subproblem-command + "Move (Down) to the next (later) subproblem") + (#\E ,enter-read-eval-print-loop + "Enter a read-eval-print loop in the current environment") + (#\F ,later-reduction-command + "Later reduction (Forward in time)") + (#\G ,goto-command + "Go to a particular Subproblem/Reduction level") + (#\H ,summarize-history-command + "Prints a summary of the entire history") + (#\I ,error-info-command + "Redisplay the error message") + (#\L ,pretty-print-current-expression + "(list expression) Pretty-print the current expression") + (#\P ,pretty-print-reduction-function + "Pretty print current procedure") + (#\Q ,standard-exit-command + "Quit (exit DEBUG)") + (#\R ,reductions-command + "Print the reductions of the current subproblem level") + (#\S ,print-current-expression + "Print the current subproblem/reduction") + (#\U ,earlier-subproblem-command + "Move (Up) to the previous (earlier) subproblem") + (#\V ,eval-in-current-environment + "Evaluate expression in current environment") + (#\W ,enter-where-command + "Enter WHERE on the current environment") + (#\X ,internal-command + "Create a read eval print loop in the debugger environment") + (#\Z ,return-command + "Return (continue with) an expression after evaluating it") + )))) + +(define command-set) + ;;; Basic Commands -(define-debug-command #\? (standard-help-command command-set) - "Help, list command letters") +(define current-subproblem) +(define previous-subproblems) +(define current-subproblem-number) +(define current-reduction-number) +(define current-reductions) +(define current-number-of-reductions) +(define current-reduction) +(define current-environment) +(define current-expression) -(define-debug-command #\Q standard-exit-command "Quit (exit DEBUG)") +(define reduction-wrap-around-tag 'WRAP-AROUND) +(define student-walk? false) +(define print-return-values? false) +(define environment-arguments-truncation 68) -(define (debug #!optional the-continuation) - (fluid-let ((current-continuation) - (previous-continuations '()) +(define (debug #!optional object) + (fluid-let ((current-subproblem) + (previous-subproblems) + (current-subproblem-number) (current-reduction-number) + (current-reductions) (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"))) - "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)))))) + (current-reduction) + (current-environment) + (current-expression)) + (set-current-subproblem! + (let ((object + (if (default-object? object) + (or (error-continuation) + (current-proceed-continuation)) + object))) + (or (coerce-to-stack-frame object) + (error "DEBUG: null continuation" object))) + '() + (lambda () 0)) + (letter-commands command-set + (cmdl-message/append + (cmdl-message/active print-current-expression) + (cmdl-message/standard "Debugger")) + "Debug-->"))) + +(define (coerce-to-stack-frame object) + (cond ((stack-frame? object) + (stack-frame/skip-non-subproblems object)) + ((continuation? object) + (coerce-to-stack-frame (continuation->stack-frame object))) + (else + (error "DEBUG: illegal argument" object)))) ;;;; 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") + (print-expression 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") + (if-valid-environment current-environment + (lambda (environment) + (pp (environment-procedure environment))))) (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) - (let ((do-it - (lambda (return?) - (if return? (newline)) - (write-string "within ") - (print-user-friendly-name env) - (if return? (newline)) - (write-string " applied to ") - (write-string - (cdr (write-to-string (environment-arguments env) - environment-arguments-truncation)))))) - (let ((output (with-output-to-string (lambda () (do-it false))))) - (if (< (string-length output) - (access printer-width implementation-dependencies)) - (begin (newline) (write-string output)) - (do-it true))))) - (newline) - (if (null-continuation? current-continuation) - (write-string "Null continuation") + (write-string "Subproblem Level: ") + (write current-subproblem-number) + (if current-reduction (begin - (write-string "Subproblem Level: ") - (write (length previous-continuations)) - (if current-reduction - (print-current-reduction) - (begin - (newline) - (write-string "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") - + (write-string " Reduction Number: ") + (write current-reduction-number) + (newline) + (write-string "Expression:")) + (begin + (newline) + (write-string "Possibly Incomplete Expression:"))) + (print-expression current-expression) + (if-valid-environment current-environment + (lambda (environment) + (let ((do-it + (lambda (return?) + (if return? (newline)) + (write-string "within ") + (print-user-friendly-name environment) + (if return? (newline)) + (write-string " applied to ") + (write-string + (cdr + (write-to-string (environment-arguments environment) + environment-arguments-truncation)))))) + (let ((output (with-output-to-string (lambda () (do-it false))))) + (if (< (string-length output) + (output-port/x-size (current-output-port))) + (begin (newline) (write-string output)) + (do-it true))))))) + (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") + (let loop ((reductions current-reductions)) + (cond ((pair? reductions) + (print-expression (reduction-expression (car reductions))) + (loop (cdr reductions))) + ((wrap-around-in-reductions? reductions) + (newline) + (write-string "Wrap Around in the reductions at this 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))))) + (let ((top-subproblem + (if (null? previous-subproblems) + current-subproblem + (car (last-pair previous-subproblems))))) + (newline) + (write-string "Sub Prb. Procedure Name Expression") + (newline) + (let loop ((frame top-subproblem) (level 0)) + (if frame + (begin + (let ((reductions (stack-frame/reductions frame))) + (if (pair? reductions) + (let ((print-reduction + (lambda (reduction) + (terse-print-expression + level + (reduction-expression reduction) + (reduction-environment reduction))))) + (print-reduction (car reductions)) + (if (= level 0) + (for-each print-reduction (cdr reductions)))) + (with-values + (lambda () (stack-frame/debugging-info frame)) + (lambda (expression environment) + (terse-print-expression level + expression + environment))))) + (loop (stack-frame/next-subproblem frame) (1+ level))))))) (define (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-object* - (environment-name environment)) - expression)) - -(define-debug-command #\H summarize-history-command - "Prints a summary of the entire history") + (newline) + (write-string (string-pad-left (number->string level) 3)) + (write-string " ") + ;;; procedure name + (write-string + (string-pad-right + (if (or (not (environment? environment)) + (special-name? (environment-name environment))) + "" + (write-to-truncated-string (environment-name environment) 20)) + 20)) + (write-string " ") + (write-string (write-to-truncated-string (unsyntax expression) 50))) + +(define (write-to-truncated-string object n-columns) + (let ((result (write-to-string object n-columns))) + (if (car result) + (string-append (substring (cdr result) 0 (- n-columns 4)) " ...") + (cdr result)))) ;;;; Motion to earlier expressions -(define (earlier-reduction) - (define (up! message) - (format "~%~s~%Going to the previous (earlier) continuation!" message) - (earlier-continuation-command)) - +(define (earlier-subproblem-command) + (if (stack-frame/next-subproblem current-subproblem) + (begin + (earlier-subproblem) + (print-current-expression)) + (begin + (beep) + (newline) + (write-string "There are only ") + (write current-subproblem-number) + (write-string " subproblem levels; already at earliest level")))) + +(define (earlier-reduction-command) (cond ((and student-walk? - (> (length previous-continuations) 0) + (> current-subproblem-number 0) (= current-reduction-number 0)) - (earlier-continuation-command)) + (earlier-subproblem-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)") + (else + (newline) + (write-string + (if (wrap-around-in-reductions? current-reductions) + "Wrap around in reductions at this level!" + "No more reductions at this level!")) + (newline) + (write-string "Going to the previous (earlier) subproblem") + (earlier-subproblem-command)))) (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") + ;; Assumption: (not (not (stack-frame/next-subproblem current-subproblem))) + (set-current-subproblem! (stack-frame/next-subproblem current-subproblem) + (cons current-subproblem previous-subproblems) + normal-reduction-number)) ;;;; 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") +(define (later-subproblem-command) + (later-subproblem normal-reduction-number)) + +(define (later-reduction-command) + (if (positive? current-reduction-number) + (begin + (set-current-reduction! (-1+ current-reduction-number)) + (print-current-expression)) + (later-subproblem + (if (or (not student-walk?) + (= current-subproblem-number 1)) + last-reduction-number + normal-reduction-number)))) + +(define (later-subproblem select-reduction-number) + (if (null? previous-subproblems) + (begin + (beep) + (newline) + (write-string "Already at latest subproblem level")) + (begin + (set-current-subproblem! (car previous-subproblems) + (cdr previous-subproblems) + select-reduction-number) + (print-current-expression)))) ;;;; General motion command (define (goto-command) - (define (get-reduction-number) - (let ((red - (prompt-for-expression - (format false - "Reduction Number (0 through ~o inclusive): " - (-1+ current-number-of-reductions))))) - (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! 0)) - (else (format "~%There are no reductions for this subproblem.")))) - - (define (get-subproblem-number) - (let ((len (length previous-continuations)) - (sub (prompt-for-expression "Subproblem number: "))) - (cond ((not (number? sub)) + (let loop () + (let ((subproblem-number (prompt-for-expression "Subproblem number: "))) + (cond ((not (and (integer? subproblem-number) + (not (negative? subproblem-number)))) (beep) - (format "~%Subproblem level must be numeric!") - (get-subproblem-number)) - ((< sub len) (repeat later-subproblem (- len sub)) - (choose-reduction)) + (newline) + (write-string "Subproblem level must be nonnegative integer!") + (loop)) + ((< subproblem-number current-subproblem-number) + (repeat (lambda () + (set-current-subproblem! (car previous-subproblems) + (cdr previous-subproblems) + normal-reduction-number)) + (- current-subproblem-number subproblem-number))) (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) + (let loop () + (if (< current-subproblem-number subproblem-number) + (if (stack-frame/next-subproblem current-subproblem) + (begin + (earlier-subproblem) + (loop)) + (begin + (beep) + (newline) + (write-string "There is no such subproblem.") + (newline) + (write-string "Now at subproblem number: ~o") + (write current-subproblem-number))))))))) + (set-current-reduction! + (cond ((> current-number-of-reductions 1) + (let get-reduction-number () + (let ((reduction-number + (prompt-for-expression + (string-append + "Reduction Number (0 through " + (number->string (-1+ current-number-of-reductions)) + " inclusive): ")))) + (cond ((not (and (integer? reduction-number) + (not (negative? reduction-number)))) + (beep) + (newline) + (write-string + "Reduction number must be nonnegative integer!") + (get-reduction-number)) + ((not (< reduction-number current-number-of-reductions)) + (beep) + (newline) + (write-string "Reduction number too large!") + (get-reduction-number)) + (else + reduction-number))))) + ((= current-number-of-reductions 1) + (newline) + (write-string "There is only one reduction for this subproblem") + 0) + (else + (newline) + (write-string "There are no reductions for this subproblem.") + -1))) (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) - (debug/read-eval-print env + (lambda (environment) + (debug/read-eval-print environment "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) - (debug/eval (prompt-for-expression "Eval--> ") 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)))))) + (with-rep-alternative current-environment debug/read-eval-print-1)) -(define-debug-command #\C show-current-frame - "Show Bindings of identifiers in the current environment") +(define (show-current-frame) + (if-valid-environment current-environment + (lambda (environment) + (show-frame environment -1)))) (define (enter-where-command) (with-rep-alternative current-environment debug/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") + (let ((message (error-message)) + (irritants (error-irritants))) + (newline) + (write-string " Message: ") + (write-string message) + (newline) + (if (null? irritants) + (write-string " No irritants") + (begin + (write-string " Irritants: ") + (for-each + (let ((n (- (output-port/x-size (current-output-port)) 4))) + (lambda (irritant) + (newline) + (write-string " ") + (if (error-irritant/noise? irritant) + (begin + (write-string "noise: ") + (write (error-irritant/noise-value irritant))) + (write-string + (let ((result (write-to-string irritant n))) + (if (car result) + (substring-move-right! "..." 0 3 + (cdr result) (- n 3))) + (cdr result)))))) + irritants))) + (newline) + (write-string " Formatted output:") + (newline) + (format-error-message message irritants))) ;;;; Advanced hacking commands -(define (return-command) ;command Z - (define (do-it environment next) - (environment-warning-hook environment) - (let ((value - (debug/eval - (let ((expression - (prompt-for-expression - "Expression to EVALUATE and CONTINUE with ($ to retry): " - ))) - (if (eq? expression '$) - (unsyntax (current-expression)) - expression)) - environment))) - (if print-return-values? - (begin - (format "~%That evaluates to:~%~o" value) - (if (prompt-for-confirmation "Confirm: ") (next value))) - (next value)))) - - (let ((next (continuation-next-continuation current-continuation))) - (if (null-continuation? next) - (begin (beep) (format "~%Can't continue!!!")) +(define (return-command) + (let ((next (stack-frame/next-subproblem current-subproblem))) + (if next (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)) + (lambda (environment) + (let ((value + (debug/eval + (let ((expression + (prompt-for-expression + "Expression to EVALUATE and CONTINUE with ($ to retry): "))) + (if (eq? expression '$) + (unsyntax current-expression) + expression)) + environment))) + (if print-return-values? + (begin + (newline) + (write-string "That evaluates to:") + (newline) + (write value) + (if (prompt-for-confirmation "Confirm: ") (next value))) + (next value))))) + (begin + (beep) + (newline) + (write-string "Can't continue!!!"))))) (define (internal-command) (debug/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") - -(define debug-compiled-continuation false) +(define user-debug-environment + (let () (the-environment))) (define (debug-compiled) - (if debug-compiled-continuation - (debug-compiled-continuation current-continuation) - (begin (beep) - (format "~%The compiled code debugger is not present in this system.")))) + (if debug-compiled-subproblem + (debug-compiled-subproblem current-subproblem) + (begin + (beep) + (newline) + (write-string "The compiled code debugger is not installed")))) -(define-debug-command #\A debug-compiled - "Invoke the compiled code debugger on the current continuation") +(define debug-compiled-subproblem false) -;;;; Reduction and continuation motion low-level - -(define reduction-expression car) -(define reduction-environment cadr) +;;;; Reduction and subproblem motion low-level + +(define (set-current-subproblem! stack-frame previous-frames + select-reduction-number) + (set! current-subproblem stack-frame) + (set! previous-subproblems previous-frames) + (set! current-subproblem-number (length previous-subproblems)) + (set! current-reductions + (if stack-frame (stack-frame/reductions current-subproblem) '())) + (set! current-number-of-reductions (dotted-list-length current-reductions)) + (set-current-reduction! (select-reduction-number))) (define (last-reduction-number) (-1+ current-number-of-reductions)) @@ -495,34 +487,22 @@ (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)))) + (set! current-reduction + (and (not (null? current-reductions)) + (>= number 0) + (list-ref current-reductions number))) + (if current-reduction + (begin + (set! current-expression (reduction-expression current-reduction)) + (set! current-environment (reduction-environment current-reduction))) + (with-values (lambda () (stack-frame/debugging-info current-subproblem)) + (lambda (expression environment) + (set! current-expression expression) + (set! current-environment environment))))) + +;;;; Utilities (define (repeat f n) (if (> n 0) @@ -535,28 +515,45 @@ (count (1+ n) (CDR L)) n))) +(define-integrable (reduction-expression reduction) + (car reduction)) + +(define-integrable (reduction-environment reduction) + (cadr reduction)) + (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))) - (named-lambda (special-name? symbol) - (memq symbol the-special-names)))) \ No newline at end of file + +(define (with-rep-alternative environment receiver) + (if (debugging-info/undefined-environment? environment) + (begin + (print-undefined-environment) + (newline) + (write-string "Using the read-eval-print environment instead!") + (receiver (standard-repl-environment))) + (receiver environment))) + +(define (if-valid-environment environment receiver) + (cond ((debugging-info/undefined-environment? environment) + (print-undefined-environment)) + ((eq? environment system-global-environment) + (newline) + (write-string + "System global environment at this subproblem/reduction level")) + (else + (receiver environment)))) + +(define (print-undefined-environment) + (newline) + (write-string "Undefined environment at this subproblem/reduction level")) + +(define (print-expression expression) + (cond ((debugging-info/undefined-expression? expression) + (newline) + (write-string "")) + ((debugging-info/compiled-code? expression) + (newline) + (write-string "")) + (else + (pp expression)))) \ No newline at end of file diff --git a/v7/src/runtime/defstr.scm b/v7/src/runtime/defstr.scm index 82fb0f10d..fe40253c7 100644 --- a/v7/src/runtime/defstr.scm +++ b/v7/src/runtime/defstr.scm @@ -1,43 +1,39 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/defstr.scm,v 1.7 1987/12/11 16:13:21 cph Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/defstr.scm,v 14.1 1988/06/13 11:43:43 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; Structure Definition Macro +;;; package: (runtime defstruct) (declare (usual-integrations)) @@ -50,6 +46,10 @@ differences: same order as specified in the definition of the structure. A keyword constructor may be specified by giving the option KEYWORD-CONSTRUCTOR. +* BOA constructors are described using Scheme lambda lists. Since +there is nothing corresponding to &aux in Scheme lambda lists, this +functionality is not implemented. + * By default, no COPIER procedure is generated. * The side effect procedure corresponding to the accessor "foo" is @@ -60,38 +60,34 @@ given the name "set-foo!". * The option values FALSE, NIL, TRUE, and T are treated as if the appropriate boolean constant had been specified instead. -* After evaluating the structure definition, the name of the structure -is bound to a Scheme type object. This works somewhat differently -from a Common Lisp type. - * The PRINT-FUNCTION option is named PRINT-PROCEDURE. Its argument is -a procedure of one argument (the structure instance) rather than three -as in Common Lisp. +a procedure of two arguments (the unparser state and the structure +instance) rather than three as in Common Lisp. -* By default, named structures are tagged with the Scheme type object. -In Common Lisp, the structures are tagged with symbols, but that -depends on the Common Lisp package system to help generate unique +* By default, named structures are tagged with a unique object of some +kind. In Common Lisp, the structures are tagged with symbols, but +that depends on the Common Lisp package system to help generate unique tags; Scheme has no such way of generating unique symbols. * The NAMED option may optionally take an argument, which should be the name of a variable. If used, structure instances will be tagged -with that variable's value rather than the Scheme type object. The -variable must be defined when the defstruct is evaluated. +with that variable's value. If the structure has a PRINT-PROCEDURE +(the default) the variable must be defined when the defstruct is +evaluated. * The TYPE option is restricted to the values VECTOR and LIST. * The INCLUDE option is not implemented. -* BOA constructors are described using Scheme lambda lists. Since -there is nothing corresponding to &aux in Scheme lambda lists, this -functionality is not implemented. - |# -(define defstruct-package - (make-environment +(define (initialize-package!) + (set! structure (make-named-tag "DEFSTRUCT-DESCRIPTION")) + (set! slot-assoc (association-procedure eq? slot/name)) + (syntax-table-define system-global-syntax-table 'DEFINE-STRUCTURE + transform/define-structure)) -(syntax-table-define system-global-syntax-table 'DEFINE-STRUCTURE +(define transform/define-structure (macro (name-and-options . slot-descriptions) (let ((structure (parse/name-and-options name-and-options))) (structure/set-slots! structure @@ -120,11 +116,10 @@ functionality is not implemented. (boa-constructors '()) (copier-name false) (predicate-name (symbol-append name '?)) - (print-procedure false) + (print-procedure print-procedure/default) (type-seen? false) (type 'STRUCTURE) (named-seen? false) - (type-tagged? true) (tag-name name) (offset 0) (include false)) @@ -191,9 +186,11 @@ functionality is not implemented. ((INITIAL-OFFSET) (check-arguments 1 1) (set! offset (car arguments))) + #| ((INCLUDE) (check-arguments 1 1) (set! include arguments)) + |# (else (error "Unrecognized structure option" keyword))))) @@ -202,7 +199,8 @@ functionality is not implemented. (parse/option (car option) (cdr option)) (parse/option option '()))) options) - (vector name + (vector structure + name conc-name keyword-constructor? (and (or constructor-seen? @@ -211,11 +209,9 @@ functionality is not implemented. boa-constructors copier-name predicate-name - (or print-procedure - (and (eq? tag-name name) - `(ACCESS DEFAULT-UNPARSER - DEFSTRUCT-PACKAGE - ,system-global-environment))) + (if (eq? print-procedure print-procedure/default) + `(,(absolute 'UNPARSER/STANDARD-METHOD) ',name) + print-procedure) type (cond ((eq? type 'STRUCTURE) 'VECTOR) ((eq? type 'VECTOR) 'VECTOR) @@ -226,6 +222,9 @@ functionality is not implemented. offset include '()))) + +(define print-procedure/default + "default") ;;;; Parse Slot-Descriptions @@ -241,6 +240,7 @@ functionality is not implemented. (structure/offset structure)))) (define (parse/slot-description structure slot-description index) + structure (let ((kernel (lambda (name default options) (let ((type #T) @@ -296,7 +296,7 @@ functionality is not implemented. (loop (cdr slots) (1+ n))))) `(BEGIN ,@(loop slots reserved))))) - (define-structure-refs structure 0 + (define-structure-refs structure 1 name conc-name keyword-constructor? @@ -320,11 +320,56 @@ functionality is not implemented. type read-only?)) -(define slot-assoc - (association-procedure eq? slot/name)) +(define structure) +(define slot-assoc) + +(define (structure? object) + (and (vector? object) + (not (zero? (vector-length object))) + (eq? structure (vector-ref object 0)))) + +(define (tag->structure tag) + (if (structure? tag) + tag + (let ((tag (2d-get tag structure))) + (and (structure? tag) + tag)))) + +(define (named-structure? object) + (cond ((vector? object) + (and (not (zero? (vector-length object))) + (tag->structure (vector-ref object 0)))) + ((pair? object) + (tag->structure (car object))) + (else false))) + +(define (named-structure/description instance) + (let ((structure + (tag->structure + (cond ((vector? instance) (vector-ref instance 0)) + ((pair? instance) (car instance)) + (else (error "Illegal structure instance" instance)))))) + (if (not structure) + (error "Illegal structure instance" instance)) + (let ((scheme-type (structure/scheme-type structure))) + (if (not (case scheme-type + ((VECTOR) (vector? instance)) + ((LIST) (list? instance)) + (else (error "Illegal structure type" scheme-type)))) + (error "Malformed structure instance" instance)) + (let ((accessor + (case scheme-type + ((VECTOR) vector-ref) + ((LIST) list-ref)))) + (map (lambda (slot) + `(,(slot/name slot) ,(accessor instance (slot/index slot)))) + (structure/slots structure)))))) ;;;; Code Generation +(define (absolute name) + `(ACCESS ,name #F)) + (define (accessor-definitions structure) (mapcan (lambda (slot) (let ((accessor-name @@ -337,13 +382,9 @@ functionality is not implemented. (DECLARE (INTEGRATE STRUCTURE)) ,(case (structure/scheme-type structure) ((VECTOR) - `((ACCESS VECTOR-REF ,system-global-environment) - STRUCTURE - ,(slot/index slot))) + `(,(absolute 'VECTOR-REF) STRUCTURE ,(slot/index slot))) ((LIST) - `((ACCESS LIST-REF ,system-global-environment) - STRUCTURE - ,(slot/index slot))) + `(,(absolute 'LIST-REF) STRUCTURE ,(slot/index slot))) (else (error "Unknown scheme type" structure))))))) (structure/slots structure))) @@ -366,15 +407,13 @@ functionality is not implemented. (DECLARE (INTEGRATE STRUCTURE VALUE)) ,(case (structure/scheme-type structure) ((VECTOR) - `((ACCESS VECTOR-SET! ,system-global-environment) - STRUCTURE - ,(slot/index slot) - VALUE)) + `(,(absolute 'VECTOR-SET!) STRUCTURE + ,(slot/index slot) + VALUE)) ((LIST) - `((ACCESS SET-CAR! ,system-global-environment) - ((ACCESS LIST-TAIL ,system-global-environment) - STRUCTURE - ,(slot/index slot)) + `(,(absolute 'SET-CAR!) + (,(absolute 'LIST-TAIL) STRUCTURE + ,(slot/index slot)) VALUE)) (else (error "Unknown scheme type" structure)))))))) @@ -398,7 +437,7 @@ functionality is not implemented. (let ((slot-names (map slot/name (structure/slots structure)))) `(DEFINE (,name ,@slot-names) ;; *** Kludge -- SCHEME-TYPE happens to be same as constructor. - ((ACCESS ,(structure/scheme-type structure) ,system-global-environment) + (,(absolute (structure/scheme-type structure)) ,@(constructor-prefix-slots structure) ,@slot-names)))) @@ -406,21 +445,18 @@ functionality is not implemented. (let ((keyword-list (string->uninterned-symbol "keyword-list"))) `(DEFINE (,name . ,keyword-list) ,(let ((list-cons - `((ACCESS CONS* ,system-global-environment) + `(,(absolute 'CONS*) ,@(constructor-prefix-slots structure) - ((ACCESS KEYWORD-PARSER - DEFSTRUCT-PACKAGE - ,system-global-environment) + (,(absolute 'DEFINE-STRUCTURE/KEYWORD-PARSER) ,keyword-list - ((ACCESS LIST ,system-global-environment) + (,(absolute 'LIST) ,@(map (lambda (slot) - `((ACCESS CONS ,system-global-environment) - ',(slot/name slot) - ,(slot/default slot))) + `(,(absolute 'CONS) ',(slot/name slot) + ,(slot/default slot))) (structure/slots structure))))))) (case (structure/scheme-type structure) ((VECTOR) - `((ACCESS LIST->VECTOR ,system-global-environment) ,list-cons)) + `(,(absolute 'LIST->VECTOR) ,list-cons)) ((LIST) list-cons) (else @@ -429,29 +465,28 @@ functionality is not implemented. (define (constructor-definition/boa structure name lambda-list) `(DEFINE (,name . ,lambda-list) ;; *** Kludge -- SCHEME-TYPE happens to be same as constructor. - ((ACCESS ,(structure/scheme-type structure) ,system-global-environment) + (,(absolute (structure/scheme-type structure)) ,@(constructor-prefix-slots structure) - ,@((access parse-lambda-list syntaxer-package) - lambda-list - (lambda (required optional rest) - (let ((name->slot - (lambda (name) - (or (slot-assoc name (structure/slots structure)) - (error "Not a defined structure slot" name))))) - (let ((required (map name->slot required)) - (optional (map name->slot optional)) - (rest (and rest (name->slot rest)))) - (map (lambda (slot) - (cond ((or (memq slot required) - (eq? slot rest)) - (slot/name slot)) - ((memq slot optional) - `(IF (UNASSIGNED? ,(slot/name slot)) - ,(slot/default slot) - ,(slot/name slot))) - (else - (slot/default slot)))) - (structure/slots structure))))))))) + ,@(parse-lambda-list lambda-list + (lambda (required optional rest) + (let ((name->slot + (lambda (name) + (or (slot-assoc name (structure/slots structure)) + (error "Not a defined structure slot" name))))) + (let ((required (map name->slot required)) + (optional (map name->slot optional)) + (rest (and rest (name->slot rest)))) + (map (lambda (slot) + (cond ((or (memq slot required) + (eq? slot rest)) + (slot/name slot)) + ((memq slot optional) + `(IF (DEFAULT-OBJECT? ,(slot/name slot)) + ,(slot/default slot) + ,(slot/name slot))) + (else + (slot/default slot)))) + (structure/slots structure))))))))) (define (constructor-prefix-slots structure) (let ((offsets (make-list (structure/offset structure) false))) @@ -459,114 +494,61 @@ functionality is not implemented. (cons (structure/tag-name structure) offsets) offsets))) -(define (type-definitions structure) - (if (structure/named? structure) - `((DEFINE ,(structure/name structure) - ((ACCESS MAKE-STRUCTURE-TYPE - DEFSTRUCT-PACKAGE - ,system-global-environment) - ',structure - ,(and (not (eq? (structure/tag-name structure) - (structure/name structure))) - (structure/tag-name structure))))) - '())) +(define (type-definitions *structure) + (cond ((not (structure/named? *structure)) + '()) + ((eq? (structure/tag-name *structure) (structure/name *structure)) + `((DEFINE ,(structure/name *structure) + ',*structure))) + (else + `((2D-PUT! ,(structure/tag-name *structure) + ',structure + ',*structure))))) (define (predicate-definitions structure) (if (and (structure/predicate-name structure) (structure/named? structure)) - `((DEFINE ,(structure/predicate-name structure) - ((ACCESS TYPE-OBJECT-PREDICATE ,system-global-environment) - ,(structure/name structure)))) + (case (structure/scheme-type structure) + ((VECTOR) + `((DEFINE (,(structure/predicate-name structure) OBJECT) + (AND (,(absolute 'VECTOR?) OBJECT) + (,(absolute 'NOT) + (,(absolute 'ZERO?) (,(absolute 'VECTOR-LENGTH) OBJECT))) + (,(absolute 'EQ?) (,(absolute 'VECTOR-REF) OBJECT 0) + ,(structure/tag-name structure)))))) + ((LIST) + `((DEFINE (,(structure/predicate-name structure) OBJECT) + (AND (,(absolute 'PAIR?) OBJECT) + (,(absolute 'EQ?) (,(absolute 'CAR) OBJECT) + ,(structure/tag-name structure)))))) + (else + (error "Unknown scheme type" structure))) '())) - + (define (copier-definitions structure) - (if (structure/copier-name structure) - `((DEFINE ,(structure/copier-name structure) + (let ((copier-name (structure/copier-name structure))) + (if copier-name + `((DECLARE (INTEGRATE-OPERATOR ,copier-name)) ,(case (structure/scheme-type structure) - ((vector) `(ACCESS VECTOR-COPY ,system-global-environment)) - ((list) `(ACCESS LIST-COPY ,system-global-environment)) - (else (error "Unknown scheme type" structure))))) - '())) + ((VECTOR) + `(DEFINE (,copier-name OBJECT) + (DECLARE (INTEGRATE OBJECT)) + (,(absolute 'VECTOR-COPY) OBJECT))) + ((LIST) + `(DEFINE (,copier-name OBJECT) + (DECLARE (INTEGRATE OBJECT)) + (,(absolute 'LIST-COPY) OBJECT))) + (else + (error "Unknown scheme type" structure)))) + '()))) (define (print-procedure-definitions structure) (if (and (structure/print-procedure structure) (structure/named? structure)) - `(((ACCESS ,(case (structure/scheme-type structure) - ((VECTOR) 'ADD-UNPARSER-SPECIAL-OBJECT!) - ((LIST) 'ADD-UNPARSER-SPECIAL-PAIR!) - (else (error "Unknown scheme type" structure))) - UNPARSER-PACKAGE - ,system-global-environment) + `((,(absolute (case (structure/scheme-type structure) + ((VECTOR) 'UNPARSER/SET-TAGGED-VECTOR-METHOD!) + ((LIST) 'UNPARSER/SET-TAGGED-PAIR-METHOD!) + (else (error "Unknown scheme type" structure)))) ,(structure/tag-name structure) ,(structure/print-procedure structure))) - '())) - -;;;; Runtime Support - -(define (keyword-parser argument-list default-alist) - (if (null? argument-list) - (map cdr default-alist) - (let ((alist - (map (lambda (entry) (cons (car entry) (cdr entry))) - default-alist))) - (define (loop arguments) - (if (not (null? arguments)) - (begin - (if (null? (cdr arguments)) - (error "Keyword list does not have even length" - argument-list)) - (set-cdr! (or (assq (car arguments) alist) - (error "Unknown keyword" (car arguments))) - (cadr arguments)) - (loop (cddr arguments))))) - (loop argument-list) - (map cdr alist)))) - -(define (default-unparser structure-instance) - ((access unparse-with-brackets unparser-package) - (lambda () - (write - (structure/name - (or (structure-instance->description structure-instance) - (error "Not a named structure")))) - (write-char #\Space) - (write (hash structure-instance))))) - -(define (make-structure-type structure tag) - (let ((type - (case (structure/scheme-type structure) - ((VECTOR) - (make-sub-type - (structure/name structure) - (microcode-type-object 'VECTOR) - (lambda (vector) - (and (not (zero? (vector-length vector))) - (eq? (vector-ref vector 0) tag))))) - ((LIST) - (make-sub-type - (structure/name structure) - (microcode-type-object 'PAIR) - (lambda (pair) - (eq? (car pair) tag)))) - (else - (error "Unknown scheme type" structure))))) - ;; Note side effects needed here, because of predicates - ;; that are closed in this environment. - (if (not tag) (set! tag type)) - (2d-put! tag tag->structure structure) - (set! structure false) - type)) - -(define (structure-instance->description structure) - (2d-get (cond ((and (vector? structure) - (not (zero? (vector-length structure)))) - (vector-ref structure 0)) - ((pair? structure) (car structure)) - (else false)) - tag->structure)) - -(define tag->structure - "tag->structure") - -;;; end DEFSTRUCT-PACKAGE -)) \ No newline at end of file + '())) \ No newline at end of file diff --git a/v7/src/runtime/emacs.scm b/v7/src/runtime/emacs.scm index 30f07cdfa..823cb5ac0 100644 --- a/v7/src/runtime/emacs.scm +++ b/v7/src/runtime/emacs.scm @@ -1,235 +1,264 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/emacs.scm,v 13.50 1987/12/05 16:38:53 cph Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/emacs.scm,v 14.1 1988/06/13 11:43:56 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; GNU Emacs/Scheme Modeline Interface +;;; package: (runtime emacs-interface) (declare (usual-integrations)) -(define emacs-interface-package - (make-environment +(define-primitives + tty-read-char-ready? + tty-read-char-immediate + (under-emacs? 0)) (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)) + (with-absolutely-no-interrupts + (lambda () + (transmit-signal type)))) (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-value object) - (transmit-signal-with-argument #\v (object->string object))) + (with-absolutely-no-interrupts + (lambda () + (transmit-signal type) + (write-string string console-output-port) + (write-char #\Altmode console-output-port)))) (define (object->string object) (with-output-to-string (lambda () (write object)))) + +(define (emacs/read-start) + (transmit-signal-without-gc #\s)) + +(define (emacs/read-finish) + (transmit-signal-without-gc #\f)) + +(define (emacs/gc-start) + (transmit-signal #\b) + (normal/gc-start)) + +(define (emacs/gc-finish start-value space-remaining) + (transmit-signal #\e) + (normal/gc-finish start-value space-remaining)) -(define paranoid-error-hook? - false) +(define (emacs/repl-read repl) + (if (cmdl/io-to-console? repl) + (begin + (transmit-signal-without-gc #\R) + (let ((s-expression (read console-input-port))) + (repl-history/record! (repl/reader-history repl) s-expression) + s-expression)) + (normal/repl-read repl))) -(define (emacs-error-hook) - (transmit-signal-without-gc #\z) - (beep) - (if paranoid-error-hook? +(define (emacs/repl-write repl object) + (if (cmdl/io-to-console? repl) (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!"))))) + (repl-history/record! (repl/printer-history repl) object) + (transmit-signal-with-argument #\v + (if (undefined-value? object) + "" + (object->string object)))) + (normal/repl-write repl object))) + +(define (emacs/cmdl-message cmdl string) + (if (cmdl/io-to-console? cmdl) + (transmit-signal-with-argument #\m string) + (normal/cmdl-message cmdl string))) -(define (emacs-rep-prompt level string) +(define (emacs/cmdl-prompt cmdl prompt) (transmit-signal-with-argument #\p - (string-append (object->string level) + (string-append (object->string (cmdl/level cmdl)) " " - (let ((entry (assoc string emacs-rep-prompt-alist))) + (let ((entry (assoc prompt cmdl-prompt-alist))) (if entry (cdr entry) - string))))) + prompt))))) -(define emacs-rep-prompt-alist +(define cmdl-prompt-alist '(("]=>" . "[Normal REPL]") ("==>" . "[Normal REPL]") ("Eval-in-env-->" . "[Normal REPL]") ("Bkpt->" . "[Breakpoint REPL]") ("Error->" . "[Error REPL]") - ("Debug-->" . "[Debugger]") ("Debugger-->" . "[Debugger REPL]") ("Visiting->" . "[Visiting environment]") + ("Debug-->" . "[Debugger]") ("Where-->" . "[Environment Inspector]") ("Which-->" . "[Task Inspector]"))) - -(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) - (if (not (primitive-read-char-ready? 0)) - (transmit-signal-without-gc #\c)) - (loop)) - -(define primitive-read-char-ready? - (make-primitive-procedure 'TTY-READ-CHAR-READY?)) - -(define primitive-read-char-immediate - (make-primitive-procedure 'TTY-READ-CHAR-IMMEDIATE)) -(define (emacs/prompt-for-command-char prompt) - (emacs-rep-prompt (rep-level) prompt) - (transmit-signal-with-argument - #\D - (cond ((string=? "Debug-->" prompt) "Scheme-debug") - ((string=? "Where-->" prompt) "Scheme-where") - (else "Scheme"))) - (transmit-signal-without-gc #\o) - (emacs/read-char-internal)) - -(define (emacs/prompt-for-confirmation prompt) - (transmit-signal-with-argument #\n prompt) - (emacs/read-char-internal)) - -(define (emacs/read-char-internal) - (emacs-read-start) - (let ((char (primitive-read-char-immediate))) - (emacs-read-finish) +(define (emacs/error-decision) + (transmit-signal-without-gc #\z) + (beep console-output-port) + (if paranoid-error-decision? + (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 paranoid-error-decision? + false) + +(define (emacs/^G-interrupt interrupt-enables) + (transmit-signal #\g) + (normal/^G-interrupt interrupt-enables)) + +(define (emacs/read-char-immediate) + (emacs/read-start) + (let ((char (tty-read-char-immediate))) + (emacs/read-finish) char)) -(define (emacs/prompt-for-expression prompt) - (transmit-signal-with-argument #\i prompt) - (read)) +(define (emacs/read-command-char cmdl prompt) + (if (cmdl/io-to-console? cmdl) + (begin + (transmit-signal-with-argument + #\D + (cond ((string=? "Debug-->" prompt) "Scheme-debug") + ((string=? "Where-->" prompt) "Scheme-where") + ((string=? "Which-->" prompt) "Scheme-which") + (else "Scheme"))) + (transmit-signal-without-gc #\o) + (read-char-internal)) + (normal/read-command-char cmdl prompt))) -(define (emacs/rep-read-hook) - (transmit-signal-without-gc #\R) - (read)) - -(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 normal/rep-read-hook rep-read-hook) -(define normal/prompt-for-command-char - (access prompt-for-command-char debugger-package)) -(define normal/prompt-for-confirmation - (access prompt-for-confirmation debugger-package)) -(define normal/prompt-for-expression - (access prompt-for-expression debugger-package)) +(define (emacs/prompt-for-confirmation cmdl prompt) + (if (cmdl/io-to-console? cmdl) + (begin + (transmit-signal-with-argument #\n prompt) + (char=? #\y (read-char-internal))) + (normal/prompt-for-confirmation cmdl prompt))) -(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) - (set! rep-read-hook emacs/rep-read-hook) - (set! (access prompt-for-command-char debugger-package) - emacs/prompt-for-command-char) - (set! (access prompt-for-confirmation debugger-package) - emacs/prompt-for-confirmation) - (set! (access prompt-for-expression debugger-package) - emacs/prompt-for-expression)) +(define (emacs/prompt-for-expression cmdl prompt) + (if (cmdl/io-to-console? cmdl) + (begin + (transmit-signal-with-argument #\i prompt) + (read console-input-port)) + (normal/prompt-for-expression cmdl prompt))) -(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) - (set! rep-read-hook normal/rep-read-hook) - (set! (access prompt-for-command-char debugger-package) - normal/prompt-for-command-char) - (set! (access prompt-for-confirmation debugger-package) - normal/prompt-for-confirmation) - (set! (access prompt-for-expression debugger-package) - normal/prompt-for-expression)) - -(define under-emacs? - (make-primitive-procedure 'UNDER-EMACS? 0)) +(define (read-char-internal) + (let ((char (emacs/read-char-immediate))) + (if (char=? char char:newline) + (read-char-internal) + char))) +(define (cmdl/io-to-console? cmdl) + (and (eq? console-input-port (cmdl/input-port cmdl)) + (eq? console-output-port (cmdl/output-port cmdl)))) + +(define (emacs/set-working-directory-pathname! pathname) + (transmit-signal-with-argument #\w (pathname->string pathname))) + +(define normal/gc-start) +(define normal/gc-finish) +(define normal/cmdl-message) +(define normal/cmdl-prompt) +(define normal/repl-write) +(define normal/repl-read) +(define normal/read-char-immediate) +(define normal/read-start) +(define normal/read-finish) +(define normal/error-decision) +(define normal/read-command-char) +(define normal/prompt-for-confirmation) +(define normal/prompt-for-expression) +(define normal/^G-interrupt) +(define normal/set-working-directory-pathname!) + +(define (initialize-package!) + (set! normal/gc-start hook/gc-start) + (set! normal/gc-finish hook/gc-finish) + (set! normal/cmdl-message hook/cmdl-message) + (set! normal/cmdl-prompt hook/cmdl-prompt) + (set! normal/repl-write hook/repl-write) + (set! normal/repl-read hook/repl-read) + (set! normal/read-char-immediate hook/read-char-immediate) + (set! normal/read-start hook/read-start) + (set! normal/read-finish hook/read-finish) + (set! normal/error-decision hook/error-decision) + (set! normal/read-command-char hook/read-command-char) + (set! normal/prompt-for-confirmation hook/prompt-for-confirmation) + (set! normal/prompt-for-expression hook/prompt-for-expression) + (set! normal/^G-interrupt hook/^G-interrupt) + (set! normal/set-working-directory-pathname! + hook/set-working-directory-pathname!) + (add-event-receiver! event:after-restore install!) + (install!)) + (define (install!) ((if (under-emacs?) install-emacs-hooks! install-normal-hooks!))) -(add-event-receiver! event:after-restore install!) -(install!) +(define (install-emacs-hooks!) + (set! hook/gc-start emacs/gc-start) + (set! hook/gc-finish emacs/gc-finish) + (set! hook/cmdl-message emacs/cmdl-message) + (set! hook/cmdl-prompt emacs/cmdl-prompt) + (set! hook/repl-write emacs/repl-write) + (set! hook/repl-read emacs/repl-read) + (set! hook/read-char-immediate emacs/read-char-immediate) + (set! hook/read-start emacs/read-start) + (set! hook/read-finish emacs/read-finish) + (set! hook/error-decision emacs/error-decision) + (set! hook/read-command-char emacs/read-command-char) + (set! hook/prompt-for-confirmation emacs/prompt-for-confirmation) + (set! hook/prompt-for-expression emacs/prompt-for-expression) + (set! hook/^G-interrupt emacs/^G-interrupt) + (set! hook/set-working-directory-pathname! + emacs/set-working-directory-pathname!)) -;;; end EMACS-INTERFACE-PACKAGE -)) \ No newline at end of file +(define (install-normal-hooks!) + (set! hook/gc-start normal/gc-start) + (set! hook/gc-finish normal/gc-finish) + (set! hook/cmdl-message normal/cmdl-message) + (set! hook/cmdl-prompt normal/cmdl-prompt) + (set! hook/repl-write normal/repl-write) + (set! hook/repl-read normal/repl-read) + (set! hook/read-char-immediate normal/read-char-immediate) + (set! hook/read-start normal/read-start) + (set! hook/read-finish normal/read-finish) + (set! hook/error-decision normal/error-decision) + (set! hook/read-command-char normal/read-command-char) + (set! hook/prompt-for-confirmation normal/prompt-for-confirmation) + (set! hook/prompt-for-expression normal/prompt-for-expression) + (set! hook/^G-interrupt normal/^G-interrupt) + (set! hook/set-working-directory-pathname! + normal/set-working-directory-pathname!)) \ No newline at end of file diff --git a/v7/src/runtime/equals.scm b/v7/src/runtime/equals.scm index 8ed005d02..cb392b1b1 100644 --- a/v7/src/runtime/equals.scm +++ b/v7/src/runtime/equals.scm @@ -1,77 +1,67 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/equals.scm,v 13.42 1987/03/17 18:49:17 cph Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/equals.scm,v 14.1 1988/06/13 11:44:04 cph Rel $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; Equality +;;; package: () (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) true - (and (primitive-type? (primitive-type x) y) - (or (and (or (type? big-fixnum y) - (type? big-flonum y)) + (and (object-type? (object-type x) y) + (or (and (or (object-type? (ucode-type big-fixnum) y) + (object-type? (ucode-type big-flonum) y)) (= x y)) - (and (type? vector y) + (and (object-type? (ucode-type vector) y) (zero? (vector-length x)) (zero? (vector-length y))))))) (define (equal? x y) (if (eq? x y) true - (and (primitive-type? (primitive-type x) y) - (cond ((or (type? big-fixnum y) - (type? big-flonum y)) + (and (object-type? (object-type x) y) + (cond ((or (object-type? (ucode-type big-fixnum) y) + (object-type? (ucode-type big-flonum) y)) (= x y)) - ((type? list y) + ((object-type? (ucode-type list) y) (and (equal? (car x) (car y)) (equal? (cdr x) (cdr y)))) - ((type? vector y) + ((object-type? (ucode-type vector) y) (let ((size (vector-length x))) (define (loop index) (if (= index size) @@ -80,13 +70,10 @@ (vector-ref y index)) (loop (1+ index))))) (and (= size (vector-length y)) - (loop 0)))) - ((type? cell y) + (loop 0)))) ((object-type? (ucode-type cell) y) (equal? (cell-contents x) (cell-contents y))) - ((type? character-string y) + ((object-type? (ucode-type character-string) y) (string=? x y)) - ((type? vector-1b y) + ((object-type? (ucode-type vector-1b) y) (bit-string=? x y)) - (else false))))) - -) + (else false))))) \ No newline at end of file diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm index e56142a40..8b4e27506 100644 --- a/v7/src/runtime/error.scm +++ b/v7/src/runtime/error.scm @@ -1,556 +1,384 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 13.51 1988/05/03 19:04:42 jinx Exp $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- -;;;; Error System +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 14.1 1988/06/13 11:44:09 cph Exp $ -(declare (usual-integrations) - (integrate-primitive-procedures set-fixed-objects-vector!)) - -(define error-procedure - (make-primitive-procedure 'ERROR-PROCEDURE 3)) +Copyright (c) 1988 Massachusetts Institute of Technology -(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))) +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. -(define (error-message) - (access error-message error-system)) +1. Any copy made of this software must include this copyright notice +in full. -(define (error-irritant) - (access error-irritant error-system)) +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. -(define error-prompt - "Error->") +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. -(define error-system - (make-environment +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. -(define *error-code*) -(define *error-hook*) -(define *error-decision-hook* false) +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. |# -(define error-message - "") +;;;; Error System +;;; package: (runtime error-handler) -(define error-irritant - *the-non-printing-object*) +(declare (usual-integrations)) -;;;; 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 error-code - (continuation-expression (rep-continuation))))))))) - -(define (wrapped-error-handler wrapper) - (access handler (procedure-environment wrapper))) +(define (initialize-package!) + (set! next-condition-type-index 0) + (set! handler-frames false) + (set! condition-type:error + (let ((dependencies (list false))) + (let ((result (%make-condition-type dependencies true false))) + (set-car! dependencies result) + result))) + (set! error-type:vanilla + (make-condition-type (list condition-type:error) "Anonymous error")) + (set! hook/error-handler default/error-handler) + (set! hook/error-decision default/error-decision) + (let ((fixed-objects (get-fixed-objects-vector))) + (vector-set! fixed-objects + (fixed-objects-vector-slot 'ERROR-PROCEDURE) + error-procedure-handler) + (vector-set! fixed-objects + (fixed-objects-vector-slot 'COMPILER-ERROR-PROCEDURE) + error-from-compiled-code) + ((ucode-primitive set-fixed-objects-vector!) fixed-objects))) + +(define (error-procedure-handler message irritants environment) + (with-proceed-point proceed-value-filter + (lambda () + (simple-error + environment + message + ;; Kludge to support minimal upwards compatibility with `error' + ;; forms syntaxed by older syntaxer. Should be flushed after + ;; new runtime system has been in use for a while. + (cond ((eq? irritants *the-non-printing-object*) '()) + ((or (null? irritants) (pair? irritants)) irritants) + (else (list irritants))))))) + +(define (error-from-compiled-code message . irritants) + (with-proceed-point proceed-value-filter + (lambda () + (simple-error repl-environment message irritants)))) ;;; (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))))) - -(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*))) - -;;;; Error Handlers - -;;; All error handlers have the following form: - -(define ((make-error-handler direction-alist operator-alist - default-handler default-combination-handler) - error-code 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 (error-code-or-name code) - (let ((v (vector-ref (get-fixed-objects-vector) - (fixed-objects-vector-slot 'MICROCODE-ERRORS-VECTOR)))) - (if (or (>= code (vector-length v)) - (null? (vector-ref v code))) - code - (vector-ref v code)))) - -(define (default-error-handler expression) - (start-error-rep "Anomalous error -- get a wizard" - (error-code-or-name *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))) +(define (proceed-value-filter continuation values) + (let ((next-subproblem + (and (not (null? values)) + (continuation/first-subproblem continuation)))) + (if next-subproblem + ((stack-frame->continuation next-subproblem) (car values)) + (continuation *the-non-printing-object*)))) -;;;; 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))) - -(define (combination-operator? expression) - (and (combination? expression) - (variable? (combination-operator expression)))) - -(define (combination-operator-name combination) - (variable-name (combination-operator combination))) +(define (simple-error environment message irritants) + (signal-error + (if (condition-type? message) + (make-error-condition message irritants environment) + ;; This handles old and "vanilla" errors. + (let ((condition + (make-error-condition error-type:vanilla + irritants + environment))) + (1d-table/put! (condition/properties condition) message-tag message) + condition)))) + +(define (make-error-condition condition-type irritants environment) + ;; Microcode errors also use this. + (let ((condition + (make-condition condition-type + irritants + (current-proceed-continuation)))) + (1d-table/put! (condition/properties condition) + environment-tag + (if (eq? environment repl-environment) + (cons (standard-repl-environment) true) + (cons environment false))) + condition)) + +(define message-tag + "message-tag") + +(define environment-tag + "environment-tag") + +(define repl-environment + "repl-environment") + +(define error-type:vanilla) + +(define (condition/message condition) + (let ((condition-type (condition/type condition))) + (or (and (eq? condition-type error-type:vanilla) + (1d-table/get (condition/properties condition) message-tag false)) + (condition-type/message condition-type)))) + +(define-integrable (condition/environment condition) + (car (1d-table/get (condition/properties condition) environment-tag false))) + +(define-integrable (condition/substitute-environment? condition) + (cdr (1d-table/get (condition/properties condition) environment-tag false))) -;;;; 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 combination-operator? combination-operator-name) -(define-unbound-variable-error - (list (make-primitive-procedure 'LEXICAL-REFERENCE 2) - (make-primitive-procedure 'LEXICAL-ASSIGNMENT 3)) - combination-second-operand) - -(define-unbound-variable-error - (list (make-primitive-procedure 'ENVIRONMENT-LINK-NAME 3)) - combination-third-operand) - -(define-unbound-variable-error - (list (make-primitive-procedure 'ADD-FLUID-BINDING! 3)) - (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 combination-operator? - combination-operator-name) -(define-unassigned-variable-error - (list (make-primitive-procedure 'LEXICAL-REFERENCE 2)) - 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) +;;;; Standard Error Handler + +(define (standard-error-handler condition) + (fluid-let ((*error-condition* condition)) + (hook/error-handler condition))) + +(define hook/error-handler) +(define (default/error-handler condition) + (push-repl (condition/environment condition) + (let ((message + (cmdl-message/append + (apply cmdl-message/error + (condition/message condition) + (condition/irritants condition)) + (cmdl-message/active hook/error-decision)))) + (if (condition/substitute-environment? condition) + (cmdl-message/append + message + (cmdl-message/strings + "" + "There is no environment available;" + "using the current REPL environment")) + message)) + "Error->")) + +(define hook/error-decision) +(define (default/error-decision) + false) + +(define *error-condition* false) + +(define-integrable (error-condition) + *error-condition*) + +(define (error-continuation) + (let ((condition (error-condition))) + (and condition + (condition/continuation condition)))) + +(define-integrable (error-message) + (condition/message (error-condition))) + +(define-integrable (error-irritants) + (condition/irritants (error-condition))) -;;;; Application Errors - -(define-operator-error 'UNDEFINED-PROCEDURE - "Application of Non-Procedure Object") - -(define-operator-error 'UNDEFINED-PRIMITIVE-OPERATION - "Undefined Primitive Procedure") - -(define-operator-error 'UNIMPLEMENTED-PRIMITIVE - "Unimplemented 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)))) - -(define-operand-error 'FAILED-ARG-1-COERCION - "Argument 1 cannot be coerced to floating point" - combination-first-operand) - -(define-operand-error 'FAILED-ARG-2-COERCION - "Argument 2 cannot be coerced to floating point" - combination-second-operand) +;;;; Error Messages + +(define (warn string . irritants) + (with-output-to-port (cmdl/output-port (nearest-cmdl)) + (lambda () + (newline) + (write-string "Warning: ") + (format-error-message string irritants)))) + +(define-integrable (error-irritants/sans-noise) + (list-transform-negative (error-irritants) + error-irritant/noise?)) + +(define (error-irritant) + (let ((irritants (error-irritants/sans-noise))) + (cond ((null? irritants) *the-non-printing-object*) + ((null? (cdr irritants)) (car irritants)) + (else irritants)))) + +(define (cmdl-message/error string . irritants) + (cmdl-message/strings + (if (null? irritants) + string + (with-output-to-string + (lambda () + (format-error-message string irritants)))))) + +(define (format-error-message message irritants) + (fluid-let ((*unparser-list-depth-limit* 2) + (*unparser-list-breadth-limit* 5)) + (for-each (lambda (irritant) + (if (error-irritant/noise? irritant) + (display (error-irritant/noise-value irritant)) + (begin + (write-char #\Space) + (write irritant)))) + (cons (if (string? message) + (error-irritant/noise message) + message) + irritants)))) + +(define-integrable (error-irritant/noise noise) + (cons error-irritant/noise-tag noise)) + +(define (error-irritant/noise? irritant) + (and (pair? irritant) + (eq? (car irritant) error-irritant/noise-tag))) + +(define-integrable (error-irritant/noise-value irritant) + (cdr irritant)) + +(define error-irritant/noise-tag + "error-irritant/noise") -;;;; Primitive Operator Errors - -(let ((fasload (make-primitive-procedure 'BINARY-FASLOAD 1)) - (fasdump (make-primitive-procedure 'PRIMITIVE-FASDUMP 3)) - (load-band (make-primitive-procedure 'LOAD-BAND 1))) - - (define-operation-specific-error 'FASL-FILE-TOO-BIG - (list fasload load-band) - "FASLOAD: Not enough room" - combination-first-operand) - - (define-operation-specific-error 'FASL-FILE-BAD-DATA - (list fasload load-band) - "FASLOAD: Bad binary file" - combination-first-operand) - - ;; This one will never be reported by load-band. - ;; It is too late to run the old image. - (define-operation-specific-error 'WRONG-ARITY-PRIMITIVES - (list fasload load-band) - "FASLOAD: Primitives in binary file have the wrong arity" - combination-first-operand) - - (define-operation-specific-error 'IO-ERROR - (list fasload load-band) - "FASLOAD: I/O error" - combination-first-operand) - - (define-operation-specific-error 'FASLOAD-COMPILED-MISMATCH - (list fasload load-band) - "FASLOAD: Binary file contains compiled code for a different microcode" - combination-first-operand) - - (define-operation-specific-error 'FASLOAD-BAND - (list fasload) - "FASLOAD: Binary file contains a scheme image (band), not an object" - combination-first-operand) - - (define-operation-specific-error 'IO-ERROR - (list fasdump) - "FASDUMP: I/O error" - combination-second-operand) - - (define-operation-specific-error 'FASDUMP-ENVIRONMENT - (list fasdump) - "FASDUMP: Object to dump is or points to environment objects" - combination-first-operand) - ) +;;;; Condition Types + +(define-structure (condition-type + (constructor %make-condition-type + (dependencies error? message)) + (conc-name condition-type/)) + ;; `dependencies' is sorted in decreasing `index' order. + (dependencies false read-only true) + (error? false read-only true) + (message false read-only true) + (index (allocate-condition-type-index!) read-only true) + (properties (make-1d-table) read-only true)) + +(define (make-condition-type dependencies message) + (for-each guarantee-condition-type dependencies) + (let ((dependencies + (cons false + (reduce dependencies/union + '() + (map condition-type/dependencies dependencies))))) + (let ((result + (%make-condition-type dependencies + (if (memq condition-type:error dependencies) + true + false) + message))) + (set-car! dependencies result) + result))) + +(define (allocate-condition-type-index!) + (let ((index next-condition-type-index)) + (set! next-condition-type-index (1+ index)) + index)) + +(define next-condition-type-index) + +(define (guarantee-condition-type object) + (if (not (condition-type? object)) (error "Illegal condition-type" object)) + object) + +(define-integrable (condition-typetype + (microcode-return name)) (error "Missing return type" name)))) (1d-table/put! (stack-frame-type/properties type) method-tag diff --git a/v7/src/runtime/gc.scm b/v7/src/runtime/gc.scm index df02d51f2..41cb5b98f 100644 --- a/v7/src/runtime/gc.scm +++ b/v7/src/runtime/gc.scm @@ -1,205 +1,185 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gc.scm,v 13.44 1988/05/05 08:39:12 cph Exp $ -;;; -;;; Copyright (c) 1988 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions and -;;; understandings. -;;; -;;; 1. Any copy made of this software must include this copyright -;;; notice in full. -;;; -;;; 2. Users of this software agree to make their best efforts (a) -;;; to return to the MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. All materials developed as a consequence of the use of this -;;; software shall duly acknowledge such use, in accordance with -;;; the usual standards of acknowledging credit in academic -;;; research. -;;; -;;; 4. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gc.scm,v 14.1 1988/06/13 11:45:00 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; Garbage Collector +;;; package: (runtime garbage-collector) -(declare (usual-integrations) - (integrate-primitive-procedures - 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)) +(declare (usual-integrations)) -(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) - 0 ;Local Stack Overflow Interrupt - (named-lambda (stack-overflow-interrupt interrupt-code - interrupt-enables) - (stack-overflow) - (set-interrupt-enables! interrupt-enables))) +(define (initialize-package!) + (set! hook/gc-flip default/gc-flip) + (set! hook/purify default/purify) + (set! hook/stack-overflow default/stack-overflow) + (set! hook/hardware-trap default/hardware-trap) + (set! default-safety-margin 4500) + (set! pure-space-queue '()) + (set! constant-space-queue '()) + (set! hook/gc-start default/gc-start) + (set! hook/gc-finish default/gc-finish) + (let ((fixed-objects (get-fixed-objects-vector))) + (let ((interrupt-vector (vector-ref fixed-objects 1))) + (vector-set! interrupt-vector 0 condition-handler/stack-overflow) + (vector-set! interrupt-vector 2 condition-handler/gc)) + (vector-set! fixed-objects #x0C condition-handler/hardware-trap) + ((ucode-primitive set-fixed-objects-vector!) fixed-objects))) + +(define (condition-handler/gc interrupt-code interrupt-enables) + interrupt-code interrupt-enables + (hook/gc-flip default-safety-margin)) + +(define (condition-handler/stack-overflow interrupt-code interrupt-enables) + interrupt-code + (hook/stack-overflow) + (set-interrupt-enables! interrupt-enables)) + +(define (condition-handler/hardware-trap escape-code) + escape-code + (hook/hardware-trap)) + +(define hook/gc-flip) +(define hook/purify) +(define hook/stack-overflow) +(define hook/hardware-trap) +(define default-safety-margin) -;;; 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) +(define (default/gc-flip safety-margin) + (cond ((not (null? pure-space-queue)) + (let ((result (purify-internal pure-space-queue true safety-margin))) + (if (car result) + (set! pure-space-queue '()) + (begin + (set! pure-space-queue (cdr pure-space-queue)) + (queued-purification-failure))) + (cdr result))) + ((not (null? constant-space-queue)) + (let ((result + (purify-internal constant-space-queue false safety-margin))) + (if (car result) + (set! constant-space-queue '()) + (begin + (set! constant-space-queue (cdr constant-space-queue)) + (queued-purification-failure))) + (cdr result))) + (else + (gc-flip-internal safety-margin)))) + +(define (queued-purification-failure) + (warn "Unable to purify all queued items; dequeuing one")) + +(define (default/purify item pure-space? queue?) + (if (not (if pure-space? (object-pure? item) (object-constant? item))) + (cond ((not queue?) + (if (not (car (purify-internal item + pure-space? + default-safety-margin))) + (error "PURIFY: not enough room in constant space" item))) + (pure-space? + (with-absolutely-no-interrupts + (lambda () + (set! pure-space-queue (cons item pure-space-queue))))) + (else + (with-absolutely-no-interrupts + (lambda () + (set! constant-space-queue + (cons item constant-space-queue)))))))) + +(define (default/stack-overflow) + (abort "maximum recursion depth exceeded")) + +(define (default/hardware-trap) + (abort "the hardware trapped")) -;;;; "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 (not (car (primitive-purify item - (if (unassigned? really-pure?) - false - really-pure?) - default-safety-margin))) - (error "Not enough room in constant space" purify item)) - 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)) +(define pure-space-queue) +(define constant-space-queue) +(define hook/gc-start) +(define hook/gc-finish) + +(define (gc-flip-internal safety-margin) + (let ((start-value (hook/gc-start))) + (let ((space-remaining ((ucode-primitive garbage-collect) safety-margin))) + (gc-abort-test space-remaining) + (hook/gc-finish start-value space-remaining) + space-remaining))) + +(define (purify-internal item pure-space? safety-margin) + (let ((start-value (hook/gc-start))) + (let ((result + ((ucode-primitive primitive-purify) item + pure-space? + safety-margin))) + (gc-abort-test (cdr result)) + (hook/gc-finish start-value (cdr result)) + result))) + +(define (default/gc-start) + false) + +(define (default/gc-finish start-value space-remaining) + start-value space-remaining + false) + +(define-integrable (gc-abort-test space-remaining) + (if (< space-remaining 4096) + (abort "out of memory"))) + +(define (abort message) + (abort-to-nearest-driver (string-append "Aborting!: " message))) -(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! primitive-io)) - ((access reset! working-directory-package)) - after-restore)))) - ie))))) - -;;; end GARBAGE-COLLECTOR-PACKAGE. -)) \ No newline at end of file +;;;; User Primitives + +(define (set-gc-safety-margin! #!optional safety-margin) + (if (not (or (default-object? safety-margin) (not safety-margin))) + (begin (set! default-safety-margin safety-margin) + (gc-flip safety-margin))) default-safety-margin) + +(define (gc-flip #!optional safety-margin) + ;; Optionally overrides the GC safety margin for this flip only. + (with-absolutely-no-interrupts + (lambda () + (hook/gc-flip (if (default-object? safety-margin) + default-safety-margin + safety-margin))))) +(define (purify item #!optional pure-space? queue?) + ;; Purify an item -- move it into pure space and clean everything by + ;; doing a gc-flip. + (hook/purify item + (if (default-object? pure-space?) true pure-space?) + (if (default-object? queue?) true queue?)) + item) + +(define (constant-space/in-use) + (- (get-next-constant) constant-space/base)) + +;; This is set to the correct value during the cold load. +(define constant-space/base) \ No newline at end of file diff --git a/v7/src/runtime/gcdemn.scm b/v7/src/runtime/gcdemn.scm index a7b952f88..50036fbf2 100644 --- a/v7/src/runtime/gcdemn.scm +++ b/v7/src/runtime/gcdemn.scm @@ -1,44 +1,39 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gcdemn.scm,v 14.1 1988/05/20 00:57:31 cph Exp $ -;;; -;;; Copyright (c) 1988 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions and -;;; understandings. -;;; -;;; 1. Any copy made of this software must include this copyright -;;; notice in full. -;;; -;;; 2. Users of this software agree to make their best efforts (a) -;;; to return to the MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. All materials developed as a consequence of the use of this -;;; software shall duly acknowledge such use, in accordance with -;;; the usual standards of acknowledging credit in academic -;;; research. -;;; -;;; 4. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gcdemn.scm,v 14.2 1988/06/13 11:45:08 cph Rel $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; Garbage Collector Daemons -;;; package: gc-daemons +;;; package: (runtime gc-daemons) (declare (usual-integrations)) diff --git a/v7/src/runtime/gcnote.scm b/v7/src/runtime/gcnote.scm index dfb59bb8c..dc3f2dd1f 100644 --- a/v7/src/runtime/gcnote.scm +++ b/v7/src/runtime/gcnote.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gcnote.scm,v 14.1 1988/05/20 00:57:56 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gcnote.scm,v 14.2 1988/06/13 11:45:12 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,7 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; GC Notification -;;; package: gc-notification-package +;;; package: (runtime gc-notification) (declare (usual-integrations)) diff --git a/v7/src/runtime/gcstat.scm b/v7/src/runtime/gcstat.scm index af96bd654..2b35280dc 100644 --- a/v7/src/runtime/gcstat.scm +++ b/v7/src/runtime/gcstat.scm @@ -1,78 +1,62 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gcstat.scm,v 13.44 1987/06/26 01:01:16 cph Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gcstat.scm,v 14.1 1988/06/13 11:45:17 cph Rel $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; GC Statistics +;;; package: (runtime gc-statistics) (declare (usual-integrations)) + +(define (initialize-package!) + (set! hook/record-statistic! default/record-statistic!) + (set! history-modes + `((NONE . ,none:install-history!) + (BOUNDED . ,bounded:install-history!) + (UNBOUNDED . ,unbounded:install-history!))) + (set-history-mode! 'BOUNDED) + (statistics-reset!) + (add-event-receiver! event:after-restore statistics-reset!) + (set! hook/gc-start recorder/gc-start) + (set! hook/gc-finish recorder/gc-finish)) -(define gctime) -(define gc-statistics) -(define gc-history-mode) +(define (recorder/gc-start) + (process-time-clock)) -(define gc-statistics-package - (make-environment +(define (recorder/gc-finish start-time space-remaining) + (let ((end-time (process-time-clock))) + (increment-non-runtime! (- end-time start-time)) + (statistics-flip start-time end-time space-remaining))) -;;;; 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) @@ -82,22 +66,37 @@ (set! meter 1) (set! total-gc-time 0) (set! last-gc-start false) - (set! last-gc-end (system-clock)) + (set! last-gc-end (process-time-clock)) (reset-recorder! '())) +(define-structure (gc-statistic (conc-name gc-statistic/)) + (meter false read-only true) + (heap-left false read-only true) + (this-gc-start false read-only true) + (this-gc-end false read-only true) + (last-gc-start false read-only true) + (last-gc-end false read-only true)) + (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))) + (make-gc-statistic meter heap-left + start-time end-time + last-gc-start last-gc-end))) (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))) + (record-statistic! statistic) + (hook/record-statistic! statistic))) -(set! gctime (named-lambda (gctime) total-gc-time)) +(define hook/record-statistic!) + +(define (default/record-statistic! statistic) + statistic + false) + +(define (gctime) + (internal-time/ticks->seconds total-gc-time)) ;;;; Statistics Recorder @@ -112,14 +111,13 @@ (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)))) +(define (gc-statistics) + (let ((history (get-history))) + (if (null? history) + (if last-statistic + (list last-statistic) + '()) + history))) ;;;; History Modes @@ -128,14 +126,13 @@ (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 (gc-history-mode #!optional new-mode) + (let ((old-mode history-mode)) + (if (not (default-object? 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))) @@ -144,31 +141,26 @@ ((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))))) +(define history-modes) ;;; NONE +(define (none:install-history!) + (set! reset-history! none:reset-history!) + (set! record-in-history! none:record-in-history!) + (set! get-history none:get-history)) + (define (none:reset-history! old) + old (set! history '())) (define (none:record-in-history! item) + item 'DONE) (define (none:get-history) '()) - + ;;; BOUNDED (define history-size 8) @@ -176,10 +168,15 @@ (define (copy-to-size l size) (let ((max (length l))) (if (>= max size) - (initial-segment l size) - (append (initial-segment l max) + (list-head l size) + (append (list-head l max) (make-list (- size max) '()))))) +(define (bounded:install-history!) + (set! reset-history! bounded:reset-history!) + (set! record-in-history! bounded:record-in-history!) + (set! get-history bounded:get-history)) + (define (bounded:reset-history! old) (set! history (apply circular-list (copy-to-size old history-size)))) @@ -192,9 +189,14 @@ (cond ((eq? scan history) '()) ((null? (car scan)) (loop (cdr scan))) (else (cons (car scan) (loop (cdr scan))))))) - + ;;; UNBOUNDED +(define (unbounded:install-history!) + (set! reset-history! unbounded:reset-history!) + (set! record-in-history! unbounded:record-in-history!) + (set! get-history unbounded:get-history)) + (define (unbounded:reset-history! old) (set! history old)) @@ -202,72 +204,4 @@ (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) - (fluid-let ((*unparser-radix* 10)) - (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 + (reverse history)) \ No newline at end of file diff --git a/v7/src/runtime/gdatab.scm b/v7/src/runtime/gdatab.scm index 3180977cc..932ddef07 100644 --- a/v7/src/runtime/gdatab.scm +++ b/v7/src/runtime/gdatab.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gdatab.scm,v 14.1 1988/05/20 00:58:20 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gdatab.scm,v 14.2 1988/06/13 11:45:24 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,7 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Global Databases -;;; package: global-database-package +;;; package: (runtime global-database) (declare (usual-integrations)) diff --git a/v7/src/runtime/gensym.scm b/v7/src/runtime/gensym.scm index 7bcfeae35..d0d2bfd7c 100644 --- a/v7/src/runtime/gensym.scm +++ b/v7/src/runtime/gensym.scm @@ -1,71 +1,60 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gensym.scm,v 13.42 1987/11/21 18:06:02 jinx Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- -;;;; GENSYM +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gensym.scm,v 14.1 1988/06/13 11:45:28 cph Rel $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Symbol Generation +;;; package: (runtime gensym) (declare (usual-integrations)) -(define (make-name-generator prefix) - (let ((counter 0)) - (named-lambda (name-generator) - (string->uninterned-symbol - (string-append prefix - (number->string - (let ((n counter)) - (set! counter (1+ counter)) - n))))))) +(define (generate-uninterned-symbol #!optional argument) + (if (not (default-object? argument)) + (cond ((symbol? argument) + (set! name-prefix (symbol->string argument))) + ((and (integer? argument) + (not (negative? argument))) (set! name-counter argument)) + (else + (error "GENERATE-UNINTERNED-SYMBOL: Bad argument" argument)))) + (string->uninterned-symbol + (string-append name-prefix + (number->string + (let ((result name-counter)) + (set! name-counter (1+ name-counter)) + result))))) + +(define name-counter) +(define name-prefix) -(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 - (string-append name-prefix (number->string (get-number))))))) +(define (initialize-package!) + (set! name-counter 0) + (set! name-prefix "G")) \ No newline at end of file diff --git a/v7/src/runtime/global.scm b/v7/src/runtime/global.scm index 5ae0473a1..9319a6d4a 100644 --- a/v7/src/runtime/global.scm +++ b/v7/src/runtime/global.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/global.scm,v 14.1 1988/05/20 00:58:36 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/global.scm,v 14.2 1988/06/13 11:45:33 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Miscellaneous Global Definitions +;;; package: () (declare (usual-integrations)) @@ -55,6 +56,7 @@ MIT in each case. |# (object-datum 1) (object-type? 2) (object-new-type object-set-type 2) + make-non-pointer-object eq? ;; Cells @@ -256,7 +258,7 @@ MIT in each case. |# (not (object-non-pointer? object))) (define (impurify object) - (if (and (object-pointer? object) (pure? object)) + (if (and (object-pointer? object) (object-pure? object)) ((ucode-primitive primitive-impurify) object)) object) diff --git a/v7/src/runtime/hash.scm b/v7/src/runtime/hash.scm index 9a17203d1..47640243d 100644 --- a/v7/src/runtime/hash.scm +++ b/v7/src/runtime/hash.scm @@ -1,43 +1,43 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/hash.scm,v 13.46 1987/05/26 13:29:58 jinx Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/hash.scm,v 14.1 1988/06/13 11:45:38 cph Rel $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; Object Hashing, populations, and 2D tables +;;; package: (runtime hash) + +(declare (usual-integrations)) + +;;;; Object hashing ;;; The hashing code, and the population code below, depend on weak ;;; conses supported by the microcode. In particular, both pieces of @@ -48,12 +48,6 @@ ;;; since two processors may be updating the data structures ;;; simultaneously. -(declare (usual-integrations)) - -(add-event-receiver! event:after-restore gc-flip) - -;;;; Object hashing - ;;; How this works: ;;; There are two tables, the hash table and the unhash table: @@ -92,6 +86,36 @@ ;;; object-unhash's back. Then object-unhash does not need to be ;;; locked against garbage collection. +(define (initialize-package!) + (set! smallest-positive-bignum + (let loop ((x 1) (y 2)) + (if (object-type? (object-type x) y) + (loop y (* y 2)) + (* y 2)))) + (set! next-hash-number 1) + (set! hash-table-size default/hash-table-size) + (set! unhash-table (make-vector hash-table-size '())) + (set! hash-table (make-vector (1+ hash-table-size) '())) + ;; Could use `primitive-object-set!' to clobber the manifest type + ;; code instead of allocating another word here. + (vector-set! hash-table 0 + ((ucode-primitive primitive-object-set-type) + (ucode-type manifest-special-nm-vector) + (make-non-pointer-object hash-table-size))) + (let loop ((n 0)) + (if (< n hash-table-size) + (begin (vector-set! unhash-table n (cons true '())) + (loop (1+ n))))) + (add-event-receiver! event:after-restore (lambda () (gc-flip))) + (add-gc-daemon! rehash-gc-daemon)) + +(define default/hash-table-size 313) +(define next-hash-number) +(define hash-table-size) +(define unhash-table) +(define hash-table) +(define smallest-positive-bignum) + (define (hash x) (if (eq? x false) 0 @@ -106,55 +130,15 @@ (define (valid-hash-number? n) (or (zero? n) (object-unhash n))) - -(define object-hash) -(define object-unhash) - -(let ((pair-type (microcode-type 'PAIR)) - (weak-cons-type (microcode-type 'WEAK-CONS)) - (snmv-type (microcode-type 'MANIFEST-SPECIAL-NM-VECTOR)) - (&make-object (make-primitive-procedure '&MAKE-OBJECT))) - (declare (integrate-primitive-procedures &make-object)) - -(define next-hash-number) -(define hash-table-size) -(define unhash-table) -(define hash-table) - -(define (initialize-object-hash! size) - (set! next-hash-number 1) - (set! hash-table-size size) - (set! unhash-table (vector-cons size '())) - (set! hash-table (vector-cons (1+ size) '())) - (vector-set! hash-table 0 (&make-object snmv-type size)) - (let initialize ((n 0)) - (if (< n size) - (begin (vector-set! unhash-table n (cons true '())) - (initialize (1+ n)))))) - -;; Primitive-datum may return negative fixnums. Until fixed... - -(define safe-primitive-datum - (let ((smallest-positive-bignum - (let loop ((x 1) (y 2)) - (if (primitive-type? (primitive-type x) y) - (loop y (* y 2)) - (* y 2))))) - (named-lambda (safe-primitive-datum object) - (let ((n (primitive-datum object))) - (if (not (negative? n)) - n - (+ smallest-positive-bignum n)))))) ;;; This is not dangerous because assq is a primitive and does not ;;; cause consing. The rest of the consing (including that by the ;;; interpreter) is a small bounded amount. -(set! object-hash -(named-lambda (object-hash object) - (with-interrupt-mask interrupt-mask-none - (lambda (ignore) - (let* ((hash-index (1+ (modulo (safe-primitive-datum object) hash-table-size))) +(define (object-hash object) + (with-absolutely-no-interrupts + (lambda () + (let* ((hash-index (1+ (modulo (object-datum object) hash-table-size))) (bucket (vector-ref hash-table hash-index)) (association (assq object bucket))) (if association @@ -167,31 +151,30 @@ (set! next-hash-number (1+ next-hash-number)) (vector-set! hash-table hash-index (cons pair bucket)) (set-cdr! unhash-bucket - (cons (primitive-set-type weak-cons-type pair) + (cons (object-new-type (ucode-type weak-cons) pair) (cdr unhash-bucket))) - result))))))) + result)))))) ;;; This is safe because it locks the garbage collector out only for a ;;; little time, enough to tag the bucket being searched, so that the ;;; daemon will not splice that bucket. -(set! object-unhash -(named-lambda (object-unhash number) +(define (object-unhash number) (let ((index (modulo number hash-table-size))) - (with-interrupt-mask interrupt-mask-none - (lambda (ignore) + (with-absolutely-no-interrupts + (lambda () (let ((bucket (vector-ref unhash-table index))) (set-car! bucket false) (let ((result - (with-interrupt-mask interrupt-mask-gc-ok - (lambda (ignore) + (without-interrupts + (lambda () (let loop ((l (cdr bucket))) (cond ((null? l) false) ((= number (system-pair-cdr (car l))) (system-pair-car (car l))) (else (loop (cdr l))))))))) (set-car! bucket true) - result))))))) + result)))))) ;;;; Rehash daemon @@ -209,22 +192,11 @@ ;;; a primitive. See the installation code below. #| -(define (rehash weak-pair) - (let ((index (1+ (modulo (safe-primitive-datum (system-pair-car weak-pair)) - hash-table-size)))) - (vector-set! hash-table - index - (cons (primitive-set-type pair-type weak-pair) - (vector-ref hash-table index))))) - -(define (cleanup n) - (if (zero? n) - 'DONE - (begin (vector-set! hash-table n '()) - (cleanup (-1+ n))))) - (define (rehash-gc-daemon) - (cleanup hash-table-size) + (let cleanup ((n hash-table-size)) + (if (not (zero? n)) + (begin (vector-set! hash-table n '()) + (cleanup (-1+ n))))) (let outer ((n (-1+ hash-table-size))) (if (negative? n) true @@ -244,10 +216,11 @@ (else (rehash (car l)) (inner2 (cdr l)))))))))) -(add-gc-daemon! rehash-gc-daemon) +(define (rehash weak-pair) + (let ((index (1+ (modulo (object-datum (system-pair-car weak-pair)) + hash-table-size)))) + (vector-set! hash-table + index + (cons (object-new-type (ucode-type pair) weak-pair) + (vector-ref hash-table index))))) |# - -(add-gc-daemon! - (let ((primitive (make-primitive-procedure 'REHASH))) - (lambda () - (primitive unhash-table hash-table)))) diff --git a/v7/src/runtime/histry.scm b/v7/src/runtime/histry.scm index 3af481e82..47182c977 100644 --- a/v7/src/runtime/histry.scm +++ b/v7/src/runtime/histry.scm @@ -1,215 +1,159 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/histry.scm,v 13.49 1987/10/12 20:59:10 cph Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/histry.scm,v 14.1 1988/06/13 11:45:51 cph Rel $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; History Manipulation +;;; package: (runtime history) (declare (usual-integrations)) -(define max-subproblems 10) -(define max-reductions 5) -(define with-new-history) - -(define history-package - (let ((set-current-history! - (make-primitive-procedure 'SET-CURRENT-HISTORY!)) - (return-address-pop-from-compiled-code - (make-return-address - (microcode-return 'POP-FROM-COMPILED-CODE))) - (hunk:make (make-primitive-procedure 'HUNK3-CONS)) - (type-code:unmarked-history (microcode-type 'unmarked-history)) - (type-code:marked-history (microcode-type 'marked-history)) - - ;; VERTEBRA abstraction. - (vertebra-rib system-hunk3-cxr0) - (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. - (reduction-expression system-hunk3-cxr0) - (reduction-environment system-hunk3-cxr1) - (set-reduction-expression! system-hunk3-set-cxr0!) - (set-reduction-environment! system-hunk3-set-cxr1!) - (set-next-reduction! system-hunk3-set-cxr2!)) - -(declare (integrate-primitive-procedures - (hunk:make hunk3-cons) - (vertebra-rib system-hunk3-cxr0) - (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-expression system-hunk3-cxr0) - (reduction-environment system-hunk3-cxr1) - (set-reduction-expression! system-hunk3-set-cxr0!) - (set-reduction-environment! system-hunk3-set-cxr1!) - (set-next-reduction! system-hunk3-set-cxr2!)) - - (integrate-operator history:mark history:unmark history:marked?)) - -(define (history:unmark object) - (declare (integrate object)) - (primitive-set-type type-code:unmarked-history object)) - -(define (history:mark object) - (declare (integrate object)) - (primitive-set-type type-code:marked-history object)) - -(define (history:marked? object) - (declare (integrate object)) - (primitive-type? type-code:marked-history object)) - -;;; Vertebra operations - -(declare (integrate-operator make-vertebra same-vertebra?)) +;;; Vertebrae -(define (make-vertebra rib deeper shallower) - (declare (integrate rib deeper shallower)) - (history:unmark (hunk:make rib deeper shallower))) +(define-integrable (make-vertebra rib deeper shallower) + (history:unmark (hunk3-cons rib deeper shallower))) -(define (deeper-vertebra vertebra) - (system-hunk3-cxr1 vertebra)) +(define-integrable vertebra-rib system-hunk3-cxr0) +(define-integrable deeper-vertebra system-hunk3-cxr1) +(define-integrable shallower-vertebra system-hunk3-cxr2) +(define-integrable set-vertebra-rib! system-hunk3-set-cxr0!) +(define-integrable set-deeper-vertebra! system-hunk3-set-cxr1!) +(define-integrable set-shallower-vertebra! system-hunk3-set-cxr2!) -(define (marked-vertebra? vertebra) +(define-integrable (marked-vertebra? vertebra) (history:marked? (system-hunk3-cxr1 vertebra))) (define (mark-vertebra! vertebra) - (system-hunk3-set-cxr1! - vertebra - (history:mark (system-hunk3-cxr1 vertebra)))) + (system-hunk3-set-cxr1! vertebra + (history:mark (system-hunk3-cxr1 vertebra)))) (define (unmark-vertebra! vertebra) (system-hunk3-set-cxr1! vertebra (history:unmark (system-hunk3-cxr1 vertebra)))) -(define (same-vertebra? x y) - (declare (integrate x y)) - (= (primitive-datum x) (primitive-datum y))) +(define-integrable (same-vertebra? x y) + (= (object-datum x) (object-datum y))) (define (link-vertebrae previous next) (set-deeper-vertebra! previous next) (set-shallower-vertebra! next previous)) -;;; Reduction operations +;;; Reductions -(declare (integrate-operator make-reduction same-reduction?)) +(define-integrable (make-reduction expression environment next) + (history:unmark (hunk3-cons expression environment next))) -(define (make-reduction expression environment next) - (declare (integrate expression environment next)) - (history:unmark (hunk:make expression environment next))) +(define-integrable reduction-expression system-hunk3-cxr0) +(define-integrable reduction-environment system-hunk3-cxr1) +(define-integrable next-reduction system-hunk3-cxr2) +(define-integrable set-reduction-expression! system-hunk3-set-cxr0!) +(define-integrable set-reduction-environment! system-hunk3-set-cxr1!) +(define-integrable set-next-reduction! system-hunk3-set-cxr2!) -(define (next-reduction reduction) - (system-hunk3-cxr2 reduction)) - -(define (marked-reduction? reduction) +(define-integrable (marked-reduction? reduction) (history:marked? (system-hunk3-cxr2 reduction))) (define (mark-reduction! reduction) - (system-hunk3-set-cxr2! - reduction - (history:mark (system-hunk3-cxr2 reduction)))) + (system-hunk3-set-cxr2! reduction + (history:mark (system-hunk3-cxr2 reduction)))) (define (unmark-reduction! reduction) (system-hunk3-set-cxr2! reduction (history:unmark (system-hunk3-cxr2 reduction)))) -(define (same-reduction? x y) - (declare (integrate x y)) - (= (primitive-datum x) (primitive-datum y))) +(define-integrable (same-reduction? x y) + (= (object-datum x) (object-datum y))) + +;;; Marks + +(define-integrable (history:unmark object) + (object-new-type (ucode-type unmarked-history) object)) + +(define-integrable (history:mark object) + (object-new-type (ucode-type marked-history) object)) + +(define-integrable (history:marked? object) + (object-type? (ucode-type marked-history) object)) ;;;; 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)))) - + (let ((new-vertebra + (lambda () + (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 '() '()))))) + (if (not (and (integer? depth) (positive? depth))) + (error "CREATE-HISTORY: invalid depth" depth)) + (if (not (and (integer? width) (positive? width))) (error "CREATE-HISTORY: invalid width" width)) + (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 #F) - system-global-environment) - (push-history! history))))) - (thunk))) +(define (with-new-history thunk) + ((ucode-primitive 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 + false + system-global-environment) + (push-history! history))))) + (thunk)) +(define max-subproblems 10) +(define max-reductions 5) + ;;;; Primitive History Operations ;;; These operations mimic the actions of the microcode. ;;; The history motion operations all return the new history. @@ -248,6 +192,8 @@ (loop next))))) '())))) +(define the-empty-history) + (define (unfold-and-reverse-rib rib) (let loop ((current (next-reduction rib)) (output 'WRAP-AROUND)) (let ((step @@ -266,14 +212,9 @@ (define (dummy-compiler-reduction? reduction) (and (null? (reduction-expression reduction)) - (eq? return-address-pop-from-compiled-code + (eq? (ucode-return-address pop-from-compiled-code) (reduction-environment reduction)))) -(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 @@ -284,8 +225,11 @@ '() (force (cadr history)))) -(define (history-untransform history) +(define-integrable (history-untransform history) (car history)) -;;; end HISTORY-PACKAGE. -(the-environment))) \ No newline at end of file +(define (initialize-package!) + (set! the-empty-history + (cons (vector-ref (get-fixed-objects-vector) + (fixed-objects-vector-slot 'DUMMY-HISTORY)) + '()))) \ No newline at end of file diff --git a/v7/src/runtime/input.scm b/v7/src/runtime/input.scm index 4f7923a22..6791ef00a 100644 --- a/v7/src/runtime/input.scm +++ b/v7/src/runtime/input.scm @@ -1,591 +1,282 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/input.scm,v 13.52 1988/05/06 12:40:26 cph Exp $ -;;; -;;; Copyright (c) 1988 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions and -;;; understandings. -;;; -;;; 1. Any copy made of this software must include this copyright -;;; notice in full. -;;; -;;; 2. Users of this software agree to make their best efforts (a) -;;; to return to the MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. All materials developed as a consequence of the use of this -;;; software shall duly acknowledge such use, in accordance with -;;; the usual standards of acknowledging credit in academic -;;; research. -;;; -;;; 4. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; +#| -*-Scheme-*- -;;;; Input +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/input.scm,v 14.1 1988/06/13 11:46:00 cph Exp $ -(declare (usual-integrations)) - -;;;; Input Ports +Copyright (c) 1988 Massachusetts Institute of Technology -(define input-port-tag - "Input Port") +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. -(define (input-port? object) - (and (environment? object) - (not (lexical-unreferenceable? object ':type)) - (eq? (access :type object) input-port-tag))) +1. Any copy made of this software must include this copyright notice +in full. -(define eof-object - "EOF Object") +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. -(define (eof-object? object) - (eq? object eof-object)) +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. -(define *current-input-port*) +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. -(define (current-input-port) - *current-input-port*) +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. |# -(define (with-input-from-port port thunk) - (if (not (input-port? port)) (error "Bad input port" port)) - (fluid-let ((*current-input-port* port)) - (thunk))) - -(define (with-input-from-file input-specifier thunk) - (define new-port (open-input-file input-specifier)) - (define old-port) - (dynamic-wind (lambda () - (set! old-port - (set! *current-input-port* - (set! new-port)))) - thunk - (lambda () - (let ((port)) - ;; Only SET! is guaranteed to do the right thing with - ;; an unassigned value. Binding may not work right. - (set! port (set! *current-input-port* (set! old-port))) - (if (not (unassigned? port)) - (close-input-port port)))))) - -(define (call-with-input-file input-specifier receiver) - (let ((port (open-input-file input-specifier))) - (let ((value (receiver port))) - (close-input-port port) - value))) +;;;; Input +;;; package: (runtime input-port) -(define (close-input-port port) - ((access :close port))) +(declare (usual-integrations)) -;;;; Console Input Port - -(define console-input-port) -(let () +;;;; Input Ports -(define tty-read-char - (make-primitive-procedure 'TTY-READ-CHAR)) +(define (initialize-package!) + (set! *current-input-port* console-input-port)) + +(define (input-port/unparse state port) + ((unparser/standard-method 'INPUT-PORT + (input-port/custom-operation port 'PRINT-SELF)) + state + port)) + +(define-structure (input-port (conc-name input-port/) + (constructor %make-input-port) + (copier %input-port/copy) + (print-procedure input-port/unparse)) + state + (operation/char-ready? false read-only true) + (operation/peek-char false read-only true) + (operation/read-char false read-only true) + (operation/peek-char-immediate false read-only true) + (operation/read-char-immediate false read-only true) + (operation/discard-char false read-only true) + (operation/read-string false read-only true) + (operation/discard-chars false read-only true) + (operation/read-start! false read-only true) + (operation/read-finish! false read-only true) + (custom-operations false read-only true)) + +(define (guarantee-input-port port) + (if (not (input-port? port)) (error "Bad input port" port)) + port) -(define tty-read-char-immediate - (make-primitive-procedure 'TTY-READ-CHAR-IMMEDIATE)) +(define (input-port/custom-operation port name) + (let ((entry (assq name (input-port/custom-operations port)))) + (and entry + (cdr entry)))) -(define tty-read-char-ready? - (make-primitive-procedure 'TTY-READ-CHAR-READY?)) +(define (input-port/copy port state) + (let ((result (%input-port/copy port))) + (set-input-port/state! result state) + result)) -(define tty-read-finish - (make-primitive-procedure 'TTY-READ-FINISH)) +(define (input-port/char-ready? port interval) + ((input-port/operation/char-ready? port) port interval)) -(define (read-start-hook) - 'DONE) +(define (input-port/peek-char port) + ((input-port/operation/peek-char port) port)) -(define (read-finish-hook) - 'DONE) +(define (input-port/read-char port) + ((input-port/operation/read-char port) port)) -(set! console-input-port - (make-environment +(define (input-port/peek-char-immediate port) + ((input-port/operation/peek-char-immediate port) port)) -(define :type input-port-tag) +(define (input-port/read-char-immediate port) + ((input-port/operation/read-char-immediate port) port)) -(define (:print-self) - (unparse-with-brackets - (lambda () - (write-string "Console input port")))) +(define (input-port/discard-char port) + ((input-port/operation/discard-char port) port)) -(define (:close) - 'DONE) +(define (input-port/read-string port delimiters) + ((input-port/operation/read-string port) port delimiters)) -(define character-buffer - false) +(define (input-port/discard-chars port delimiters) + ((input-port/operation/discard-chars port) port delimiters)) -(define (:peek-char) - (or character-buffer - (begin (set! character-buffer (tty-read-char)) - character-buffer))) +(define (input-port/read-start! port) + ((input-port/operation/read-start! port) port)) -(define (:discard-char) - (set! character-buffer false)) +(define (input-port/read-finish! port) + ((input-port/operation/read-finish! port) port)) -(define (:read-char) - (if character-buffer - (set! character-buffer false) - (tty-read-char))) - -(define (:read-string delimiters) - (define (loop) - (if (char-set-member? delimiters (:peek-char)) - '() - (let ((char (:read-char))) - (cons char (loop))))) - (list->string (loop))) - -(define (:discard-chars delimiters) - (define (loop) - (if (not (char-set-member? delimiters (:peek-char))) - (begin (:discard-char) - (loop)))) - (loop)) - -(define (:peek-char-immediate) - (or character-buffer - (begin (set! character-buffer (tty-read-char-immediate)) - character-buffer))) - -(define (:read-char-immediate) - (if character-buffer - (set! character-buffer false) - (tty-read-char-immediate))) - -(define (:char-ready? delay) - (or character-buffer (tty-read-char-ready? delay))) - -(define (:read-start!) - (read-start-hook)) - -(define :read-finish! - (let () - (define (read-finish-loop) - (if (and (:char-ready? 0) - (char-whitespace? (:peek-char))) - (begin (:discard-char) - (read-finish-loop)))) - (lambda () - (tty-read-finish) - (read-finish-loop) - (read-finish-hook)))) - -;;; end CONSOLE-INPUT-PORT. -)) - -) - -(set! *current-input-port* console-input-port) +(define (make-input-port operations state) + (let ((operations + (map (lambda (entry) + (cons (car entry) (cadr entry))) + operations))) + (let ((operation + (lambda (name default) + (let ((entry (assq name operations))) + (if entry + (begin (set! operations (delq! entry operations)) + (cdr entry)) + (or default + (error "MAKE-INPUT-PORT: missing operation" name))))))) + (let ((char-ready? (operation 'CHAR-READY? false)) + (peek-char (operation 'PEEK-CHAR false)) + (read-char (operation 'READ-CHAR false)) + (read-string + (operation 'READ-STRING default-operation/read-string)) + (discard-chars + (operation 'DISCARD-CHARS default-operation/discard-chars)) + (read-start! + (operation 'READ-START! default-operation/read-start!)) + (read-finish! + (operation 'READ-FINISH! default-operation/read-finish!))) + (let ((peek-char-immediate (operation 'PEEK-CHAR-IMMEDIATE peek-char)) + (read-char-immediate (operation 'READ-CHAR-IMMEDIATE read-char)) + (discard-char (operation 'DISCARD-CHAR read-char))) + (%make-input-port state + char-ready? + peek-char + read-char + peek-char-immediate + read-char-immediate + discard-char + read-string + discard-chars + read-start! + read-finish! + operations)))))) -;;;; File Input Ports - -(define open-input-file) -(let () - -(define file-fill-input-buffer - (make-primitive-procedure 'FILE-FILL-INPUT-BUFFER)) - -(define file-length - (make-primitive-procedure 'FILE-LENGTH)) - -(define file-port-buffer-size - 512) - -(set! open-input-file -(named-lambda (open-input-file filename) - (let ((file-channel ((access open-input-channel primitive-io) - (canonicalize-input-filename filename)))) - -(define :type input-port-tag) - -(define (:print-self) - (unparse-with-brackets - (lambda () - (write-string "Buffered input port for file: ") - (write ((access channel-name primitive-io) file-channel))))) - -(define (:pathname) - (->pathname filename)) - -(define (:truename) - (->pathname ((access channel-name primitive-io) file-channel))) +(define (default-operation/read-string port delimiters) + (list->string + (let ((peek-char (input-port/operation/peek-char port)) + (read-char (input-port/operation/read-char port))) + (let loop () + (if (char-set-member? delimiters (peek-char port)) + '() + (let ((char (read-char port))) + (cons char (loop)))))))) + +(define (default-operation/discard-chars port delimiters) + (let ((peek-char (input-port/operation/peek-char port)) + (discard-char (input-port/operation/discard-char port))) + (let loop () + (if (not (char-set-member? delimiters (peek-char port))) + (begin (discard-char port) + (loop)))))) + +(define (default-operation/read-start! port) + port + false) -(define (:length) - (file-length file-channel)) - -(define buffer false) -(define start-index 0) -(define end-index -1) - -(define (refill-buffer!) - (if (not buffer) (set! buffer (string-allocate file-port-buffer-size))) - (set! start-index 0) - (set! end-index (file-fill-input-buffer file-channel buffer)) - (zero? end-index)) - -(declare (integrate buffer-ready?)) - -(define (buffer-ready?) - (and (not (zero? end-index)) - (not (refill-buffer!)))) - -(define (:char-ready? delay) - (or (< start-index end-index) - (buffer-ready?))) - -(define (:close) - (set! end-index 0) - (set! buffer false) - ((access close-physical-channel primitive-io) file-channel)) - -(define (:peek-char) - (if (< start-index end-index) - (string-ref buffer start-index) - (and (buffer-ready?) - (string-ref buffer 0)))) - -(define (:discard-char) - (set! start-index (1+ start-index))) - -(define (:read-char) - (if (< start-index end-index) - (string-ref buffer (set! start-index (1+ start-index))) - (and (buffer-ready?) - (begin (set! start-index 1) - (string-ref buffer 0))))) - -(define (:read-string delimiters) - (define (loop) - (let ((index - (substring-find-next-char-in-set buffer start-index end-index - delimiters))) - (if index - (substring buffer (set! start-index index) index) - (let ((head (substring buffer start-index end-index))) - (if (refill-buffer!) - head - (let ((tail (loop)) - (head-length (string-length head))) - (let ((result (string-allocate (+ head-length - (string-length tail))))) - (substring-move-right! head 0 head-length - result 0) - (substring-move-right! tail 0 (string-length tail) - result head-length) - result))))))) - (and (or (< start-index end-index) - (buffer-ready?)) - (loop))) - -(define (:discard-chars delimiters) - (define (loop) - (let ((index - (substring-find-next-char-in-set buffer start-index end-index - delimiters))) - (cond (index (set! start-index index)) - ((not (refill-buffer!)) (loop))))) - (if (or (< start-index end-index) - (buffer-ready?)) - (loop))) - -(define (:rest->string) - (define (read-rest) - (set! end-index 0) - (loop)) - - (define (loop) - (let ((buffer (string-allocate file-port-buffer-size))) - (let ((n (file-fill-input-buffer file-channel buffer))) - (cond ((zero? n) '()) - ((< n file-port-buffer-size) - (set-string-length! buffer n) - (list buffer)) - (else (cons buffer (loop))))))) - - (if (zero? end-index) - (error "End of file -- :REST->STRING")) - (cond ((= -1 end-index) - (let ((l (:length))) - (if l - (let ((buffer (string-allocate l))) - (set! end-index 0) - (file-fill-input-buffer file-channel buffer) - buffer) - (apply string-append (read-rest))))) - ((< start-index end-index) - (let ((first (substring buffer start-index end-index))) - (apply string-append - (cons first - (read-rest))))) - (else - (apply string-append (read-rest))))) - -(the-environment)))) - -) +(define (default-operation/read-finish! port) + port + false) -;;;; String Input Ports - -(define (with-input-from-string string thunk) - (fluid-let ((*current-input-port* (string->input-port string))) - (thunk))) - -(define (string->input-port string #!optional start end) - (cond ((unassigned? start) - (set! start 0) - (set! end (string-length string))) - ((unassigned? end) - (set! end (string-length string)))) - -(define :type input-port-tag) - -(define (:print-self) - (unparse-with-brackets - (lambda () - (write-string "Input port for string")))) - -(define (:char-ready? delay) - (< start end)) +(define eof-object + "EOF Object") -(define (:close) 'DONE) +(define (eof-object? object) + (eq? object eof-object)) -(define (:peek-char) - (and (< start end) - (string-ref string start))) +(define (make-eof-object port) + port + eof-object) -(define (:discard-char) - (set! start (1+ start))) +(define *current-input-port*) -(define (:read-char) - (and (< start end) - (string-ref string (set! start (1+ start))))) +(define-integrable (current-input-port) + *current-input-port*) -(define (:read-string delimiters) - (and (< start end) - (let ((index - (or (substring-find-next-char-in-set string start end delimiters) - end))) - (substring string (set! start index) index)))) +(define (with-input-from-port port thunk) + (if (not (input-port? port)) (error "Bad input port" port)) + (fluid-let ((*current-input-port* port)) + (thunk))) -(define (:discard-chars delimiters) - (if (< start end) - (set! start - (or (substring-find-next-char-in-set string start end delimiters) - end)))) +(define (with-input-from-file input-specifier thunk) + (let ((new-port (open-input-file input-specifier)) + (old-port false)) + (dynamic-wind (lambda () + (set! old-port *current-input-port*) + (set! *current-input-port* new-port) + (set! new-port false)) + thunk + (lambda () + (if *current-input-port* + (close-input-port *current-input-port*)) + (set! *current-input-port* old-port) + (set! old-port false))))) -;;; end STRING->INPUT-PORT. -(the-environment)) +(define (call-with-input-file input-specifier receiver) + (let ((port (open-input-file input-specifier))) + (let ((value (receiver port))) + (close-input-port port) + value))) ;;;; Input Procedures +;;; **** The INTERVAL option for this operation works only for the +;;; console port. Only Edwin uses this option. + +(define (char-ready? #!optional port interval) + (let ((port + (if (default-object? port) + (current-input-port) + (guarantee-input-port port)))) + (if (not (and (integer? interval) (>= interval 0))) + (error "Bad interval" interval)) + (input-port/char-ready? port interval))) + (define (peek-char #!optional port) - (cond ((unassigned? port) (set! port *current-input-port*)) - ((not (input-port? port)) (error "Bad input port" port))) - (or ((if (lexical-unreferenceable? port ':peek-char-immediate) - (access :peek-char port) - (access :peek-char-immediate port))) - eof-object)) + (let ((port + (if (default-object? port) + (current-input-port) + (guarantee-input-port port)))) + (or (input-port/peek-char-immediate port) + eof-object))) (define (read-char #!optional port) - (cond ((unassigned? port) (set! port *current-input-port*)) - ((not (input-port? port)) (error "Bad input port" port))) - (or ((if (lexical-unreferenceable? port ':read-char-immediate) - (access :read-char port) - (access :read-char-immediate port))) - eof-object)) + (let ((port + (if (default-object? port) + (current-input-port) + (guarantee-input-port port)))) + (or (input-port/read-char-immediate port) + eof-object))) + +(define (read-char-no-hang #!optional port) + (let ((port + (if (default-object? port) + (current-input-port) + (guarantee-input-port port)))) + (and (input-port/char-ready? port 0) + (or (input-port/read-char-immediate port) + eof-object)))) (define (read-string delimiters #!optional port) - (cond ((unassigned? port) (set! port *current-input-port*)) - ((not (input-port? port)) (error "Bad input port" port))) - (or ((access :read-string port) delimiters) - eof-object)) - -(define (read #!optional port) - (cond ((unassigned? port) (set! port *current-input-port*)) - ((not (input-port? port)) (error "Bad input port" port))) - (if (not (lexical-unreferenceable? port ':read-start!)) - ((access :read-start! port))) - (let ((object ((access *parse-object parser-package) port))) - (if (not (lexical-unreferenceable? port ':read-finish!)) - ((access :read-finish! port))) - object)) - -;;; **** The DELAY option for this operation works only for the -;;; console port. Since it is a kludge, it is probably OK. - -(define (char-ready? #!optional port delay) - (cond ((unassigned? port) (set! port *current-input-port*)) - ((not (input-port? port)) (error "Bad input port" port))) - (cond ((unassigned? delay) (set! delay 0)) - ((not (and (integer? delay) (>= delay 0))) (error "Bad delay" delay))) - ((access :char-ready? port) delay)) + (let ((port + (if (default-object? port) + (current-input-port) + (guarantee-input-port port)))) + (or (input-port/read-string port delimiters) + eof-object))) + +(define (read #!optional port parser-table) + (let ((port + (if (default-object? port) + (current-input-port) + (guarantee-input-port port))) + (parser-table + (if (default-object? parser-table) + (current-parser-table) + (guarantee-parser-table parser-table)))) + (input-port/read-start! port) + (let ((object (parse-object/internal port parser-table))) + (input-port/read-finish! port) + object))) -(define (read-char-no-hang #!optional port) - (cond ((unassigned? port) (set! port *current-input-port*)) - ((not (input-port? port)) (error "Bad input port" port))) - (and ((access :char-ready? port) 0) - (read-char port))) - -(define load/default-types '("bin" "scm")) -(define load-noisily? false) - -(define (load-noisily filename #!optional environment) - (let ((environment - (if (unassigned? environment) (rep-environment) environment))) - (fluid-let ((load-noisily? true)) - (load filename environment)))) - -(define read-file) -(define load) -(let () - -(set! read-file - (named-lambda (read-file filename) - (call-with-input-file - (pathname-default-version (->pathname filename) 'NEWEST) - (access *parse-objects-until-eof parser-package)))) - -;;; This crufty piece of code, once it decides which file to load, -;;; does `file-exists?' on that file at least three times!! - -(set! load - (named-lambda (load filename/s #!optional environment) - (let ((environment - (if (unassigned? environment) (rep-environment) environment))) - (let ((kernel - (lambda (filename last-file?) - (let ((value - (load/internal (find-true-filename (->pathname filename) - load/default-types) - environment - load-noisily?))) - (cond (last-file? value) - (load-noisily? (rep-value value))))))) - (if (pair? filename/s) - (let loop ((filenames filename/s)) - (if (null? (cdr filenames)) - (kernel (car filenames) true) - (begin (kernel (car filenames) false) - (loop (cdr filenames))))) - (kernel filename/s true)))))) - -(define (load/internal true-filename environment load-noisily?) - (let ((port (open-input-file true-filename))) - (if (= 250 (char->ascii (peek-char port))) - (begin (close-input-port port) - (scode-eval (fasload true-filename) environment)) - (let ((syntax-table (rep-syntax-table)) - (no-value "no value")) - (let load-loop ((value no-value)) - (let ((s-expression (read port))) - (if (eof-object? s-expression) - (begin (close-input-port port) - value) - (begin (if (and load-noisily? (not (eq? no-value value))) - (rep-value value)) - (load-loop (rep-eval-hook s-expression - environment - syntax-table)))))))))) - -(define (find-true-filename pathname default-types) - (pathname->string - (or (let ((try - (lambda (pathname) - (pathname->input-truename - (pathname-default-version pathname 'NEWEST))))) - (if (pathname-type pathname) - (try pathname) - (or (pathname->input-truename pathname) - (let loop ((types default-types)) - (and (not (null? types)) - (or (try (pathname-new-type pathname (car types))) - (loop (cdr types)))))))) - (error "No such file" pathname)))) - -(define (pathname-default-version pathname version) - (if (pathname-version pathname) - pathname - (pathname-new-version pathname version))) - -) - -(define (stickify-input-filenames filename/s default-pathname) - (map (if default-pathname - (lambda (filename) - (merge-pathnames (->pathname filename) default-pathname)) - ->pathname) - (if (pair? filename/s) - filename/s - (list filename/s)))) - -#|(define (stickify-input-filenames filename/s default-pathname) - (let loop - ((filenames - (if (pair? filename/s) - filename/s - (list filename/s))) - (default-pathname default-pathname)) - (let ((pathname - (let ((pathname (->pathname (car filenames)))) - (if default-pathname - (merge-pathnames pathname default-pathname) - pathname)))) - (cons pathname - (if (pair? (cdr filenames)) - (loop (cdr filenames) pathname) - '())))))|# - -(define fasload) -(let () - -(define default-pathname - (make-pathname false false false "bin" 'NEWEST)) - -(define binary-fasload - (make-primitive-procedure 'BINARY-FASLOAD)) - -(set! fasload -(named-lambda (fasload filename) - (let ((port (rep-output-port)) - (filename (canonicalize-input-filename - (merge-pathnames (->pathname filename) - default-pathname)))) - (newline port) - (write-string "FASLoading " port) - (write filename port) - (let ((value (binary-fasload filename))) - (write-string " -- done" port) - value)))) - -) - -(define transcript-on - (let ((photo-open (make-primitive-procedure 'PHOTO-OPEN))) - (named-lambda (transcript-on filename) - (if (not (photo-open (canonicalize-output-filename filename))) - (error "Transcript file already open: TRANSCRIPT-ON" filename)) - *the-non-printing-object*))) - -(define transcript-off - (let ((photo-close (make-primitive-procedure 'PHOTO-CLOSE))) - (named-lambda (transcript-off) - (if (not (photo-close)) - (error "Transcript file already closed: TRANSCRIPT-OFF")) - *the-non-printing-object*))) \ No newline at end of file +(define (close-input-port port) + (let ((operation (input-port/custom-operation port 'CLOSE))) + (if operation + (operation port)))) \ No newline at end of file diff --git a/v7/src/runtime/intrpt.scm b/v7/src/runtime/intrpt.scm index 1e0b6ac86..0ee1ed840 100644 --- a/v7/src/runtime/intrpt.scm +++ b/v7/src/runtime/intrpt.scm @@ -1,204 +1,240 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/intrpt.scm,v 13.48 1988/02/21 18:14:55 jinx Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/intrpt.scm,v 14.1 1988/06/13 11:46:23 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; Interrupt System +;;; package: (runtime interrupt-handler) -(declare (usual-integrations) - (integrate-primitive-procedures set-fixed-objects-vector!)) +(declare (usual-integrations)) -(define with-external-interrupts-handler) - -(define timer-interrupt - (let ((setup-timer-interrupt - (make-primitive-procedure 'SETUP-TIMER-INTERRUPT 2))) - (named-lambda (timer-interrupt) - (setup-timer-interrupt '() '()) - (error "Unhandled Timer interrupt received")))) - -(define interrupt-system - (let ((get-next-interrupt-character - (make-primitive-procedure 'GET-NEXT-INTERRUPT-CHARACTER)) - (check-and-clean-up-input-channel - (make-primitive-procedure 'CHECK-AND-CLEAN-UP-INPUT-CHANNEL)) - (index:interrupt-vector - (fixed-objects-vector-slot 'SYSTEM-INTERRUPT-VECTOR)) - (index:termination-vector - (fixed-objects-vector-slot - 'MICROCODE-TERMINATIONS-PROCEDURES)) - (^Q-Hook '())) +(define (initialize-package!) + (set! index:interrupt-vector + (fixed-objects-vector-slot 'SYSTEM-INTERRUPT-VECTOR)) + (set! index:termination-vector + (fixed-objects-vector-slot 'MICROCODE-TERMINATIONS-PROCEDURES)) + (set! timer-interrupt default/timer-interrupt) + (set! external-interrupt default/external-interrupt) + (set! keyboard-interrupts + (let ((table (make-vector 256 losing-keyboard-interrupt))) + (for-each (lambda (entry) + (vector-set! table + (char->ascii (car entry)) + (cadr entry))) + `((#\B ,(keep-typeahead ^B-interrupt-handler)) + (#\G ,(flush-typeahead ^G-interrupt-handler)) + (#\U ,(flush-typeahead ^U-interrupt-handler)) + (#\X ,(flush-typeahead ^X-interrupt-handler)) + ;; (#\S ,(keep-typeahead ^S-interrupt-handler)) + ;; (#\Q ,(keep-typeahead ^Q-interrupt-handler)) + ;; (#\P ,(flush-typeahead ^P-interrupt-handler)) + ;; (#\Z ,(flush-typeahead ^Z-interrupt-handler)) + )) + table)) + (set! hook/^B-interrupt default/^B-interrupt) + (set! hook/^G-interrupt default/^G-interrupt) + (set! hook/^U-interrupt default/^U-interrupt) + (set! hook/^X-interrupt default/^X-interrupt) + (set! hook/^S-interrupt default/^S-interrupt) + (set! hook/^Q-interrupt default/^Q-interrupt) + (set! hook/^P-interrupt default/^P-interrupt) + (set! hook/^Z-interrupt default/^Z-interrupt) + (install)) + +(define-primitives + (setup-timer-interrupt 2) + get-next-interrupt-character + check-and-clean-up-input-channel + set-fixed-objects-vector!) + +(define-integrable stack-overflow-slot 0) +(define-integrable gc-slot 2) +(define-integrable character-slot 4) +(define-integrable timer-slot 6) +(define-integrable suspend-slot 8) +(define-integrable illegal-interrupt-slot 9) + +(define index:interrupt-vector) +(define index:termination-vector) -;;;; Soft interrupts +;;;; Miscellaneous Interrupts (define (timer-interrupt-handler interrupt-code interrupt-enables) + interrupt-code interrupt-enables (timer-interrupt)) +(define timer-interrupt) +(define (default/timer-interrupt) + (setup-timer-interrupt '() '()) + (error "Unhandled Timer interrupt received")) + (define (suspend-interrupt-handler interrupt-code interrupt-enables) - (fluid-let (((access *error-hook* error-system) - (lambda (environment message irritant substitute-environment?) - (%exit)))) - (if (not (disk-save (merge-pathnames (string->pathname "scheme_suspend") - (home-directory-pathname)) - true)) - (%exit)))) + interrupt-code interrupt-enables + (bind-condition-handler '() (lambda (condition) condition (%exit)) + (lambda () + (if (not (disk-save (merge-pathnames (string->pathname "scheme_suspend") + (home-directory-pathname)) + true)) + (%exit))))) -;;; Keyboard Interrupts +(define (gc-out-of-space-handler . args) + args + (abort-to-nearest-driver "Aborting! Out of memory")) + +(define (illegal-interrupt-handler interrupt-code interrupt-enables) + (error "Illegal interrupt" interrupt-code interrupt-enables)) + +(define (default-interrupt-handler interrupt-code interrupt-enables) + (error "Anomalous interrupt" interrupt-code interrupt-enables)) + +;;;; Keyboard Interrupts (define (external-interrupt-handler interrupt-code interrupt-enables) - (let ((interrupt-character (get-next-interrupt-character))) - ((vector-ref keyboard-interrupts interrupt-character) interrupt-character - interrupt-enables))) + interrupt-code + (external-interrupt (get-next-interrupt-character) interrupt-enables)) -(define (losing-keyboard-interrupt interrupt-character interrupt-enables) - (error "Bad interrupt character" interrupt-character)) +(define (with-external-interrupts-handler handler thunk) + (fluid-let ((external-interrupt (flush-typeahead handler))) + (thunk))) -(define keyboard-interrupts - (vector-cons 256 losing-keyboard-interrupt)) +(define external-interrupt) +(define (default/external-interrupt character interrupt-enables) + ((vector-ref keyboard-interrupts character) character interrupt-enables)) -(define (install-keyboard-interrupt! interrupt-char handler) - (vector-set! keyboard-interrupts - (char->ascii interrupt-char) - handler)) +(define (losing-keyboard-interrupt character interrupt-enables) + interrupt-enables + (error "Bad interrupt character" character)) -(define (remove-keyboard-interrupt! interrupt-char) - (vector-set! keyboard-interrupts - (char->ascii interrupt-char) - losing-keyboard-interrupt)) +(define keyboard-interrupts) -(define until-most-recent-interrupt-character 0) ;for Pascal, ugh! +;;; The following definitions must match the microcode. +(define until-most-recent-interrupt-character 0) (define multiple-copies-only 1) -(define ((flush-typeahead kernel) interrupt-character interrupt-enables) +(define ((flush-typeahead kernel) character interrupt-enables) (if (check-and-clean-up-input-channel until-most-recent-interrupt-character - interrupt-character) - (kernel interrupt-character interrupt-enables))) + character) + (kernel character interrupt-enables))) -(define ((keep-typeahead kernel) interrupt-character interrupt-enables) - (if (check-and-clean-up-input-channel multiple-copies-only - interrupt-character) - (kernel interrupt-character interrupt-enables))) +(define ((keep-typeahead kernel) character interrupt-enables) + (if (check-and-clean-up-input-channel multiple-copies-only character) + (kernel character interrupt-enables))) -(define ^B-interrupt-handler - (keep-typeahead - (lambda (interrupt-character interrupt-enables) - (with-standard-proceed-point - (lambda () - (breakpoint "^B interrupt" (rep-environment))))))) - -(define ^G-interrupt-handler - (flush-typeahead - (lambda (interrupt-character interrupt-enables) - (if ((access under-emacs? emacs-interface-package)) - ((access transmit-signal emacs-interface-package) #\g)) - (abort-to-top-level-driver "Quit!")))) - -(define ^U-interrupt-handler - (flush-typeahead - (lambda (interrupt-character interrupt-enables) - (abort-to-previous-driver "Up!")))) - -(define ^X-interrupt-handler - (flush-typeahead - (lambda (interrupt-character interrupt-enables) - (abort-to-nearest-driver "Abort!")))) +(define (^B-interrupt-handler character interrupt-enables) + character + (hook/^B-interrupt interrupt-enables)) -(define (gc-out-of-space-handler . args) - (abort-to-nearest-driver "Aborting! Out of memory")) - -#| -(define ^S-interrupt-handler - (keep-typeahead - (lambda (interrupt-character interrupt-enables) - (if (null? ^Q-Hook) - (begin - (set-interrupt-enables! interrupt-enables) - (beep) - (call-with-current-continuation - (lambda (stop-^S-wait) - (fluid-let ((^Q-Hook Stop-^S-Wait)) - (let busy-wait () (busy-wait)))))))))) - -(define ^Q-interrupt-handler - (keep-typeahead - (lambda (interrupt-character interrupt-enables) - (if (not (null? ^Q-Hook)) - (begin - (set-interrupt-enables! interrupt-enables) - (^Q-Hook 'GO-ON)))))) - -(define ^P-interrupt-handler - (flush-typeahead - (lambda (interrupt-character interrupt-enables) - (set-interrupt-enables! interrupt-enables) - (proceed)))) - -(define ^Z-interrupt-handler - (flush-typeahead - (lambda (interrupt-character interrupt-enables) - (set-interrupt-enables! interrupt-enables) - (edit)))) -|# +(define (^G-interrupt-handler character interrupt-enables) + character + (hook/^G-interrupt interrupt-enables)) + +(define (^U-interrupt-handler character interrupt-enables) + character + (hook/^U-interrupt interrupt-enables)) + +(define (^X-interrupt-handler character interrupt-enables) + character + (hook/^X-interrupt interrupt-enables)) + +(define (^S-interrupt-handler character interrupt-enables) + character + (hook/^S-interrupt interrupt-enables)) + +(define (^Q-interrupt-handler character interrupt-enables) + character + (hook/^Q-interrupt interrupt-enables)) + +(define (^P-interrupt-handler character interrupt-enables) + character + (hook/^P-interrupt interrupt-enables)) + +(define (^Z-interrupt-handler character interrupt-enables) + character + (hook/^Z-interrupt interrupt-enables)) + +(define hook/^B-interrupt) +(define hook/^G-interrupt) +(define hook/^U-interrupt) +(define hook/^X-interrupt) +(define hook/^S-interrupt) +(define hook/^Q-interrupt) +(define hook/^P-interrupt) +(define hook/^Z-interrupt) -(install-keyboard-interrupt! #\G ^G-interrupt-handler) -(install-keyboard-interrupt! #\B ^B-interrupt-handler) -; (install-keyboard-interrupt! #\P ^P-interrupt-handler) -(install-keyboard-interrupt! #\U ^U-interrupt-handler) -(install-keyboard-interrupt! #\X ^X-interrupt-handler) -; (install-keyboard-interrupt! #\Z ^Z-interrupt-handler) -; (install-keyboard-interrupt! #\S ^S-interrupt-handler) -; (install-keyboard-interrupt! #\Q ^Q-interrupt-handler) - -(define stack-overflow-slot 0) -(define gc-slot 2) -(define character-slot 4) -(define timer-slot 6) -(define suspend-slot 8) -(define illegal-interrupt-slot 9) +(define (default/^B-interrupt interrupt-enables) + interrupt-enables + (cmdl-interrupt/breakpoint)) -(define (illegal-interrupt-handler interrupt-code interrupt-enables) - (error "Illegal interrupt" interrupt-code interrupt-enables)) +(define (default/^G-interrupt interrupt-enables) + interrupt-enables + (cmdl-interrupt/abort-top-level)) -(define (default-interrupt-handler interrupt-code interrupt-enables) - (error "Anomalous interrupt" interrupt-code interrupt-enables)) +(define (default/^U-interrupt interrupt-enables) + interrupt-enables + (cmdl-interrupt/abort-previous)) + +(define (default/^X-interrupt interrupt-enables) + interrupt-enables + (cmdl-interrupt/abort-nearest)) + +(define (default/^S-interrupt interrupt-enables) + (if (not busy-wait-continuation) + (begin + (set-interrupt-enables! interrupt-enables) + (beep console-output-port) + (call-with-current-continuation + (lambda (continuation) + (fluid-let ((busy-wait-continuation continuation)) + (let busy-wait () (busy-wait)))))))) + +(define (default/^Q-interrupt interrupt-enables) + (if busy-wait-continuation + (begin (set-interrupt-enables! interrupt-enables) + (busy-wait-continuation false)))) + +(define busy-wait-continuation + false) + +(define (default/^P-interrupt interrupt-enables) + (set-interrupt-enables! interrupt-enables) + (proceed)) + +(define (default/^Z-interrupt interrupt-enables) + (set-interrupt-enables! interrupt-enables) + (edit)) (define (install) - (with-interrupts-reduced interrupt-mask-gc-ok - (lambda (old-mask) + (without-interrupts + (lambda () (let ((old-system-interrupt-vector (vector-ref (get-fixed-objects-vector) index:interrupt-vector)) (old-termination-vector @@ -208,16 +244,15 @@ (previous-stack-interrupt (vector-ref old-system-interrupt-vector stack-overflow-slot)) (system-interrupt-vector - (vector-cons (vector-length old-system-interrupt-vector) + (make-vector (vector-length old-system-interrupt-vector) default-interrupt-handler)) (termination-vector - (if old-termination-vector - (if (> number-of-microcode-terminations - (vector-length old-termination-vector)) - (vector-grow old-termination-vector - number-of-microcode-terminations) - old-termination-vector) - (vector-cons number-of-microcode-terminations false)))) + (let ((length (microcode-termination/code-limit))) + (if old-termination-vector + (if (> length (vector-length old-termination-vector)) + (vector-grow old-termination-vector length) + old-termination-vector) + (make-vector length false))))) (vector-set! system-interrupt-vector gc-slot previous-gc-interrupt) (vector-set! system-interrupt-vector stack-overflow-slot @@ -244,31 +279,4 @@ index:termination-vector termination-vector) - (set-fixed-objects-vector! (get-fixed-objects-vector))))))) - -(set! with-external-interrupts-handler -(named-lambda (with-external-interrupts-handler handler code) - (define (interrupt-routine interrupt-code interrupt-enables) - (let ((character (get-next-interrupt-character))) - (check-and-clean-up-input-channel - until-most-recent-interrupt-character - character) - (handler character interrupt-enables))) - - (define old-handler interrupt-routine) - - (define interrupt-vector - (vector-ref (get-fixed-objects-vector) index:interrupt-vector)) - - (dynamic-wind - (lambda () - (set! old-handler - (vector-set! interrupt-vector character-slot old-handler))) - code - (lambda () - (vector-set! interrupt-vector character-slot - (set! old-handler - (vector-ref interrupt-vector character-slot))))))) - -;;; end INTERRUPT-SYSTEM package. -(the-environment))) \ No newline at end of file + (set-fixed-objects-vector! (get-fixed-objects-vector))))))) \ No newline at end of file diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm index 76fd1e7b3..96d45399d 100644 --- a/v7/src/runtime/io.scm +++ b/v7/src/runtime/io.scm @@ -1,80 +1,80 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 13.45 1987/04/13 18:43:17 cph Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 14.1 1988/06/13 11:46:32 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; Input/output utilities +;;; package: (runtime primitive-io) (declare (usual-integrations)) -(define close-all-open-files) +(define (initialize-package!) + (set! open-input-channel (open-channel-wrapper false)) + (set! open-output-channel (open-channel-wrapper true)) + (set! close-all-open-files (close-files file-close-channel)) + (set! primitive-io/reset! (close-files (lambda (ignore) ignore))) + (set! open-files-list (list 'OPEN-FILES-LIST)) + (set! traversing? false) + (add-gc-daemon! close-lost-open-files-daemon) + (add-event-receiver! event:after-restore primitive-io/reset!)) + +(define-integrable (make-physical-channel descriptor channel direction) + (hunk3-cons descriptor channel direction)) + +(define-integrable (channel-descriptor channel) + (system-hunk3-cxr0 channel)) + +(define-integrable (set-channel-descriptor! channel descriptor) + (system-hunk3-set-cxr0! channel descriptor)) -(define primitive-io - (let ((open-file-list-tag '*ALL-THE-OPEN-FILES*) +(define-integrable (channel-name channel) + (system-hunk3-cxr1 channel)) - (weak-cons-type (microcode-type 'WEAK-CONS)) +(define-integrable (channel-direction channel) + (system-hunk3-cxr2 channel)) - (make-physical-channel (make-primitive-procedure 'HUNK3-CONS)) - (channel-descriptor system-hunk3-cxr0) - (set-channel-descriptor! system-hunk3-set-cxr0!) - (channel-name system-hunk3-cxr1) - (channel-direction system-hunk3-cxr2) - (set-channel-direction! system-hunk3-set-cxr2!) +(define-integrable (set-channel-direction! channel direction) + (system-hunk3-set-cxr2! channel direction)) - (closed-direction 0) - (closed-descriptor false)) +(define-primitives + file-open-channel + file-close-channel + close-lost-open-files) - (make-environment - -(declare (integrate-primitive-procedures - (make-physical-channel hunk3-cons) - (channel-descriptor system-hunk3-cxr0) - (set-channel-descriptor! system-hunk3-set-cxr0!) - (channel-name system-hunk3-cxr1) - (channel-direction system-hunk3-cxr2) - (set-channel-direction! system-hunk3-set-cxr2!))) +(define-integrable closed-direction 0) +(define-integrable closed-descriptor false) (define open-files-list) (define traversing?) - -(define (initialize) - (set! open-files-list (list open-file-list-tag)) - (set! traversing? false) - true) ;;;; Open/Close Files @@ -83,56 +83,51 @@ ;;; - false: input channel ;;; - 0: closed channel -(define open-channel-wrapper - (let ((open-channel (make-primitive-procedure 'FILE-OPEN-CHANNEL))) - (named-lambda ((open-channel-wrapper direction) filename) - (without-interrupts - (lambda () - (let ((channel - (make-physical-channel (open-channel filename direction) - filename - direction))) - (with-interrupt-mask interrupt-mask-none ; Disallow gc - (lambda (ie) - (set-cdr! open-files-list - (cons (system-pair-cons weak-cons-type - channel - (channel-descriptor channel)) - (cdr open-files-list))))) - channel)))))) - -(define open-input-channel (open-channel-wrapper false)) -(define open-output-channel (open-channel-wrapper true)) +(define ((open-channel-wrapper direction) filename) + (without-interrupts + (lambda () + (let ((channel + (make-physical-channel + (file-open-channel filename direction) + filename + direction))) + (with-absolutely-no-interrupts + (lambda () + (set-cdr! open-files-list + (cons (system-pair-cons (ucode-type weak-cons) + channel + (channel-descriptor channel)) + (cdr open-files-list))))) + channel)))) + +(define open-input-channel) +(define open-output-channel) -;; This is locked from interrupts, but GC can occur since the -;; procedure itself hangs on to the channel until the last moment, -;; when it returns the channel's name. The list will not be spliced -;; by the daemon behind its back because of the traversing? flag. - -(define close-physical-channel - (let ((primitive (make-primitive-procedure 'FILE-CLOSE-CHANNEL))) - (named-lambda (close-physical-channel channel) - (fluid-let ((traversing? true)) - (without-interrupts - (lambda () - (if (eq? closed-direction - (set-channel-direction! channel closed-direction)) - true ;Already closed! - (begin - (primitive (set-channel-descriptor! channel - closed-descriptor)) - (let loop - ((l1 open-files-list) - (l2 (cdr open-files-list))) - (cond ((null? l2) - (set! traversing? false) - (error "CLOSE-PHYSICAL-CHANNEL: lost channel" - channel)) - ((eq? channel (system-pair-car (car l2))) - (set-cdr! l1 (cdr l2)) - (channel-name channel)) - (else - (loop l2 (cdr l2))))))))))))) +;;; This is locked from interrupts, but GC can occur since the +;;; procedure itself hangs on to the channel until the last moment, +;;; when it returns the channel's name. The list will not be spliced +;;; by the daemon behind its back because of the traversing? flag. + +(define (close-physical-channel channel) + (fluid-let ((traversing? true)) + (without-interrupts + (lambda () + (if (eq? closed-direction + (set-channel-direction! channel closed-direction)) + true ;Already closed! + (begin + (file-close-channel + (set-channel-descriptor! channel closed-descriptor)) (let loop + ((l1 open-files-list) + (l2 (cdr open-files-list))) + (cond ((null? l2) + (set! traversing? false) + (error "CLOSE-PHYSICAL-CHANNEL: lost channel" channel)) + ((eq? channel (system-pair-car (car l2))) + (set-cdr! l1 (cdr l2)) + (channel-name channel)) + (else + (loop l2 (cdr l2))))))))))) ;;;; Finalization and daemon. @@ -156,50 +151,30 @@ (loop (cdr open-files-list)))))))))) ;;; This is invoked before disk-restoring. It "cleans" the microcode. - -(set! close-all-open-files - (close-files (make-primitive-procedure 'FILE-CLOSE-CHANNEL))) +(define close-all-open-files) ;;; This is invoked after disk-restoring. It "cleans" the new runtime system. - -(define reset! - (close-files (lambda (ignore) true))) +(define primitive-io/reset!) -;; This is the daemon which closes files which no one points to. -;; Runs with GC, and lower priority interrupts, disabled. -;; It is unsafe because of the (unnecessary) consing by the -;; interpreter while it executes the loop. - -;; Replaced by a primitive installed below. +;;; This is the daemon which closes files which no one points to. +;;; Runs with GC, and lower priority interrupts, disabled. +;;; It is unsafe because of the (unnecessary) consing by the +;;; interpreter while it executes the loop. +;;; Replaced by a primitive installed below. #| - -(define close-lost-open-files-daemon - (let ((primitive (make-primitive-procedure 'FILE-CLOSE-CHANNEL))) - (named-lambda (close-lost-open-files-daemon) - (if (not traversing?) - (let loop - ((l1 open-files-list) - (l2 (cdr open-files-list))) - (cond ((null? l2) - true) - ((null? (system-pair-car (car l2))) - (primitive (system-pair-cdr (car l2))) - (set-cdr! l1 (cdr l2)) - (loop l1 (cdr l1))) - (else - (loop l2 (cdr l2))))))))) - +(define (close-lost-open-files-daemon) + (if (not traversing?) + (let loop ((l1 open-files-list) (l2 (cdr open-files-list))) + (cond ((null? l2) + true) + ((null? (system-pair-car (car l2))) + (file-close-channel (system-pair-cdr (car l2))) + (set-cdr! l1 (cdr l2)) + (loop l1 (cdr l1))) + (else + (loop l2 (cdr l2))))))) |# - -(define close-lost-open-files-daemon - (let ((primitive (make-primitive-procedure 'CLOSE-LOST-OPEN-FILES))) - (named-lambda (close-lost-open-files-daemon) - (if (not traversing?) - (primitive open-files-list))))) - -;;; End of PRIMITIVE-IO package. -))) - -((access initialize primitive-io)) -(add-gc-daemon! (access close-lost-open-files-daemon primitive-io)) \ No newline at end of file +(define (close-lost-open-files-daemon) + (if (not traversing?) + (close-lost-open-files open-files-list))) \ No newline at end of file diff --git a/v7/src/runtime/lambda.scm b/v7/src/runtime/lambda.scm index 2751b2970..8a1c40fec 100644 --- a/v7/src/runtime/lambda.scm +++ b/v7/src/runtime/lambda.scm @@ -1,64 +1,112 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/lambda.scm,v 13.42 1987/03/17 18:51:08 cph Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/lambda.scm,v 14.1 1988/06/13 11:46:39 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; Lambda Abstraction +;;; package: (runtime lambda-abstraction) (declare (usual-integrations)) -(define lambda?) -(define make-lambda) -(define lambda-components) -(define lambda-body) -(define set-lambda-body!) -(define lambda-bound) - -(define lambda-package - (let ((slambda-type (microcode-type 'LAMBDA)) - (slexpr-type (microcode-type 'LEXPR)) - (xlambda-type (microcode-type 'EXTENDED-LAMBDA)) - (internal-lambda-tag (make-named-tag "INTERNAL-LAMBDA")) - (internal-lexpr-tag (make-named-tag "INTERNAL-LEXPR")) - (lambda-optional-tag (make-interned-symbol "#!OPTIONAL")) - (lambda-rest-tag (make-interned-symbol "#!REST"))) - -(define internal-lambda-tags - (list internal-lambda-tag internal-lexpr-tag)) +(define (initialize-package!) + (set! lambda-tag:internal-lambda (make-named-tag "INTERNAL-LAMBDA")) + (set! lambda-tag:internal-lexpr (make-named-tag "INTERNAL-LEXPR")) + (set! block-declaration-tag (make-named-tag "Block Declaration")) + (unparser/set-tagged-vector-method! block-declaration-tag + (unparser/standard-method 'BLOCK-DECLARATION)) + (lambda-body-procedures clambda/physical-body clambda/set-physical-body! + (lambda (wrap-body! wrapper-components unwrap-body! + unwrapped-body set-unwrapped-body!) + (set! clambda-wrap-body! wrap-body!) + (set! clambda-wrapper-components wrapper-components) + (set! clambda-unwrap-body! unwrap-body!) + (set! clambda-unwrapped-body unwrapped-body) + (set! set-clambda-unwrapped-body! set-unwrapped-body!))) + (lambda-body-procedures clexpr/physical-body clexpr/set-physical-body! + (lambda (wrap-body! wrapper-components unwrap-body! + unwrapped-body set-unwrapped-body!) + (set! clexpr-wrap-body! wrap-body!) + (set! clexpr-wrapper-components wrapper-components) + (set! clexpr-unwrap-body! unwrap-body!) + (set! clexpr-unwrapped-body unwrapped-body) + (set! set-clexpr-unwrapped-body! set-unwrapped-body!))) + (lambda-body-procedures &triple-first &triple-set-first! + (lambda (wrap-body! wrapper-components unwrap-body! + unwrapped-body set-unwrapped-body!) + (set! xlambda-wrap-body! wrap-body!) + (set! xlambda-wrapper-components wrapper-components) + (set! xlambda-unwrap-body! unwrap-body!) + (set! xlambda-unwrapped-body unwrapped-body) + (set! set-xlambda-unwrapped-body! set-unwrapped-body!))) + (set! &lambda-components + (dispatch-1 'LAMBDA-COMPONENTS + clambda-components + clexpr-components + xlambda-components)) + (set! has-internal-lambda? + (dispatch-0 'HAS-INTERNAL-LAMBDA? + clambda-has-internal-lambda? + clexpr-has-internal-lambda? + xlambda-has-internal-lambda?)) + (set! lambda-wrap-body! + (dispatch-1 'LAMBDA-WRAP-BODY! + clambda-wrap-body! + clexpr-wrap-body! + xlambda-wrap-body!)) + (set! lambda-wrapper-components + (dispatch-1 'LAMBDA-WRAPPER-COMPONENTS + clambda-wrapper-components + clexpr-wrapper-components + xlambda-wrapper-components)) + (set! lambda-unwrap-body! + (dispatch-0 'LAMBDA-UNWRAP-BODY! + clambda-unwrap-body! + clexpr-unwrap-body! + xlambda-unwrap-body!)) + (set! lambda-body + (dispatch-0 'LAMBDA-BODY + clambda-unwrapped-body + clexpr-unwrapped-body + xlambda-unwrapped-body)) + (set! set-lambda-body! + (dispatch-1 'SET-LAMBDA-BODY! + set-clambda-unwrapped-body! + set-clexpr-unwrapped-body! + set-xlambda-unwrapped-body!)) + (set! lambda-bound + (dispatch-0 'LAMBDA-BOUND + clambda-bound + clexpr-bound + xlambda-bound))) ;;;; Hairy Advice Wrappers @@ -67,84 +115,76 @@ ;;; but the original state will always remain. ;;; **** Note: this stuff was implemented for the advice package. -;;; Please don't use it for anything else since it will just -;;; confuse things. - -(define lambda-body-procedures - (let ((wrapper-tag '(LAMBDA-WRAPPER)) - (wrapper-body comment-expression) - (set-wrapper-body! set-comment-expression!)) - - (define (make-wrapper original-body new-body state) - (make-comment (vector wrapper-tag original-body state) - new-body)) - - (define (wrapper? object) - (and (comment? object) - (let ((text (comment-text object))) - (and (vector? text) - (not (zero? (vector-length text))) - (eq? (vector-ref text 0) wrapper-tag))))) - - (define (wrapper-state wrapper) - (vector-ref (comment-text wrapper) 2)) - - (define (set-wrapper-state! wrapper new-state) - (vector-set! (comment-text wrapper) 2 new-state)) - - (define (wrapper-original-body wrapper) - (vector-ref (comment-text wrapper) 1)) - - (define (set-wrapper-original-body! wrapper new-body) - (vector-set! (comment-text wrapper) 1 new-body)) +;;; Please don't use it for anything else. + +(define (lambda-body-procedures physical-body set-physical-body! receiver) + (receiver + (named-lambda (wrap-body! lambda transform) + (let ((physical-body (physical-body lambda))) + (if (wrapper? physical-body) + (transform (wrapper-body physical-body) + (wrapper-state physical-body) + (lambda (new-body new-state) + (set-wrapper-body! physical-body new-body) + (set-wrapper-state! physical-body new-state))) + (transform physical-body + '() + (lambda (new-body new-state) + (set-physical-body! lambda + (make-wrapper physical-body + new-body + new-state))))))) + (named-lambda (wrapper-components lambda receiver) + (let ((physical-body (physical-body lambda))) + (if (wrapper? physical-body) + (receiver (wrapper-original-body physical-body) + (wrapper-state physical-body)) + (receiver physical-body '())))) + (named-lambda (unwrap-body! lambda) + (let ((physical-body (physical-body lambda))) + (if (wrapper? physical-body) + (set-physical-body! lambda + (wrapper-original-body physical-body))))) + (named-lambda (unwrapped-body lambda) + (let ((physical-body (physical-body lambda))) + (if (wrapper? physical-body) + (wrapper-original-body physical-body) + physical-body))) + (named-lambda (set-unwrapped-body! lambda new-body) + (if (wrapper? (physical-body lambda)) + (set-wrapper-original-body! (physical-body lambda) new-body) + (set-physical-body! lambda new-body))))) - (named-lambda (lambda-body-procedures physical-body set-physical-body! - receiver) - (receiver - - (named-lambda (wrap-body! lambda transform) - (let ((physical-body (physical-body lambda))) - (if (wrapper? physical-body) - (transform (wrapper-body physical-body) - (wrapper-state physical-body) - (lambda (new-body new-state) - (set-wrapper-body! physical-body new-body) - (set-wrapper-state! physical-body new-state))) - (transform physical-body - '() - (lambda (new-body new-state) - (set-physical-body! lambda - (make-wrapper physical-body - new-body - new-state))))))) - - (named-lambda (wrapper-components lambda receiver) - (let ((physical-body (physical-body lambda))) - (if (wrapper? physical-body) - (receiver (wrapper-original-body physical-body) - (wrapper-state physical-body)) - (receiver physical-body - '())))) - - (named-lambda (unwrap-body! lambda) - (let ((physical-body (physical-body lambda))) - (if (wrapper? physical-body) - (set-physical-body! lambda - (wrapper-original-body physical-body))))) - - (named-lambda (unwrapped-body lambda) - (let ((physical-body (physical-body lambda))) - (if (wrapper? physical-body) - (wrapper-original-body physical-body) - physical-body))) - - (named-lambda (set-unwrapped-body! lambda new-body) - (if (wrapper? (physical-body lambda)) - (set-wrapper-original-body! (physical-body lambda) new-body) - (set-physical-body! lambda new-body))) - - )) - )) +(define-integrable (make-wrapper original-body new-body state) + (make-comment (vector wrapper-tag original-body state) new-body)) + +(define (wrapper? object) + (and (comment? object) + (let ((text (comment-text object))) + (and (vector? text) + (not (zero? (vector-length text))) + (eq? (vector-ref text 0) wrapper-tag))))) + +(define wrapper-tag + '(LAMBDA-WRAPPER)) + +(define-integrable (wrapper-body wrapper) + (comment-expression wrapper)) + +(define-integrable (set-wrapper-body! wrapper body) + (set-comment-expression! wrapper body)) + +(define-integrable (wrapper-state wrapper) + (vector-ref (comment-text wrapper) 2)) + +(define-integrable (set-wrapper-state! wrapper new-state) + (vector-set! (comment-text wrapper) 2 new-state)) + +(define-integrable (wrapper-original-body wrapper) + (vector-ref (comment-text wrapper) 1)) + +(define-integrable (set-wrapper-original-body! wrapper body) + (vector-set! (comment-text wrapper) 1 body)) ;;;; Compound Lambda @@ -153,35 +193,34 @@ required (if (null? auxiliary) body - (make-combination (make-slambda internal-lambda-tag - auxiliary - body) - (map (lambda (auxiliary) - (make-unassigned-object)) - auxiliary))))) + (make-combination (make-internal-lambda auxiliary body) + (make-unassigned auxiliary))))) (define (clambda-components clambda receiver) (slambda-components clambda (lambda (name required body) - (let ((unwrapped-body (clambda-unwrapped-body clambda))) - (if (combination? body) - (let ((operator (combination-operator body))) - (if (is-internal-lambda? operator) - (slambda-components operator - (lambda (tag auxiliary body) - (receiver name required '() '() auxiliary - unwrapped-body))) - (receiver name required '() '() '() unwrapped-body))) - (receiver name required '() '() '() unwrapped-body)))))) + (receiver name required '() '() + (if (combination? body) + (let ((operator (combination-operator body))) + (if (internal-lambda? operator) + (slambda-components operator + (lambda (tag auxiliary body) + tag body + auxiliary)) + '())) + '()) + (clambda-unwrapped-body clambda))))) (define (clambda-bound clambda) (slambda-components clambda (lambda (name required body) + name (if (combination? body) (let ((operator (combination-operator body))) - (if (is-internal-lambda? operator) + (if (internal-lambda? operator) (slambda-components operator (lambda (tag auxiliary body) + tag body (append required auxiliary))) required)) required)))) @@ -190,57 +229,43 @@ (let ((body (slambda-body clambda))) (and (combination? body) (let ((operator (combination-operator body))) - (and (is-internal-lambda? operator) + (and (internal-lambda? operator) operator))))) - + (define clambda-wrap-body!) (define clambda-wrapper-components) (define clambda-unwrap-body!) (define clambda-unwrapped-body) (define set-clambda-unwrapped-body!) -(lambda-body-procedures (lambda (clambda) - (slambda-body - (or (clambda-has-internal-lambda? clambda) - clambda))) - (lambda (clambda new-body) - (set-slambda-body! - (or (clambda-has-internal-lambda? clambda) - clambda) - new-body)) - (lambda (wrap-body! wrapper-components unwrap-body! - unwrapped-body set-unwrapped-body!) - (set! clambda-wrap-body! wrap-body!) - (set! clambda-wrapper-components wrapper-components) - (set! clambda-unwrap-body! unwrap-body!) - (set! clambda-unwrapped-body unwrapped-body) - (set! set-clambda-unwrapped-body! set-unwrapped-body!))) +(define (clambda/physical-body clambda) + (slambda-body (or (clambda-has-internal-lambda? clambda) clambda))) + +(define (clambda/set-physical-body! clambda body) + (set-slambda-body! (or (clambda-has-internal-lambda? clambda) clambda) body)) ;;;; Compound Lexpr (define (make-clexpr name required rest auxiliary body) (make-slexpr name required - (make-combination (make-slambda internal-lexpr-tag - (cons rest auxiliary) - body) - (cons (let ((e (make-the-environment))) - (make-combination - system-subvector-to-list - (list e - (+ (length required) 3) - (make-combination - system-vector-size - (list e))))) - (map (lambda (auxiliary) - (make-unassigned-object)) - auxiliary))))) + (make-combination + (make-internal-lexpr (cons rest auxiliary) body) + (cons (let ((environment (make-the-environment))) + (make-combination + system-subvector->list + (list environment + (+ (length required) 3) + (make-combination system-vector-length + (list environment))))) + (make-unassigned auxiliary))))) (define (clexpr-components clexpr receiver) (slexpr-components clexpr (lambda (name required body) (slambda-components (combination-operator body) (lambda (tag auxiliary body) + tag body (receiver name required '() @@ -251,52 +276,52 @@ (define (clexpr-bound clexpr) (slexpr-components clexpr (lambda (name required body) + name (slambda-components (combination-operator body) (lambda (tag auxiliary body) + tag body (append required auxiliary)))))) (define (clexpr-has-internal-lambda? clexpr) (combination-operator (slexpr-body clexpr))) - + (define clexpr-wrap-body!) (define clexpr-wrapper-components) (define clexpr-unwrap-body!) (define clexpr-unwrapped-body) (define set-clexpr-unwrapped-body!) -(lambda-body-procedures (lambda (clexpr) - (slambda-body (clexpr-has-internal-lambda? clexpr))) - (lambda (clexpr new-body) - (set-slambda-body! - (clexpr-has-internal-lambda? clexpr) - new-body)) - (lambda (wrap-body! wrapper-components unwrap-body! - unwrapped-body set-unwrapped-body!) - (set! clexpr-wrap-body! wrap-body!) - (set! clexpr-wrapper-components wrapper-components) - (set! clexpr-unwrap-body! unwrap-body!) - (set! clexpr-unwrapped-body unwrapped-body) - (set! set-clexpr-unwrapped-body! set-unwrapped-body!))) +(define (clexpr/physical-body clexpr) + (slambda-body (clexpr-has-internal-lambda? clexpr))) + +(define (clexpr/set-physical-body! clexpr body) + (set-slambda-body! (clexpr-has-internal-lambda? clexpr) body)) ;;;; Extended Lambda +(define-integrable xlambda-type + (ucode-type extended-lambda)) + (define (make-xlambda name required optional rest auxiliary body) (&typed-triple-cons xlambda-type body (list->vector - `(,name ,@required - ,@optional - ,@(if (null? rest) - auxiliary - (cons rest auxiliary)))) + (cons name + (append required + optional + (if (null? rest) + auxiliary + (cons rest auxiliary))))) (make-non-pointer-object (+ (length optional) (* 256 - (+ (length required) - (if (null? rest) 0 256))))))) + (+ (length required) (if (null? rest) 0 256))))))) + +(define-integrable (xlambda? object) + (object-type? xlambda-type object)) (define (xlambda-components xlambda receiver) - (let ((qr1 (integer-divide (primitive-datum (&triple-third xlambda)) 256))) + (let ((qr1 (integer-divide (object-datum (&triple-third xlambda)) 256))) (let ((qr2 (integer-divide (car qr1) 256))) (let ((ostart (1+ (cdr qr2)))) (let ((rstart (+ ostart (cdr qr1)))) @@ -318,38 +343,23 @@ (subvector->list names 1 (vector-length names)))) (define (xlambda-has-internal-lambda? xlambda) + xlambda false) - + (define xlambda-wrap-body!) (define xlambda-wrapper-components) (define xlambda-unwrap-body!) (define xlambda-unwrapped-body) (define set-xlambda-unwrapped-body!) - -(lambda-body-procedures &triple-first &triple-set-first! - (lambda (wrap-body! wrapper-components unwrap-body! - unwrapped-body set-unwrapped-body!) - (set! xlambda-wrap-body! wrap-body!) - (set! xlambda-wrapper-components wrapper-components) - (set! xlambda-unwrap-body! unwrap-body!) - (set! xlambda-unwrapped-body unwrapped-body) - (set! set-xlambda-unwrapped-body! set-unwrapped-body!))) ;;;; Generic Lambda -(set! lambda? -(named-lambda (lambda? object) - (or (primitive-type? slambda-type object) - (primitive-type? slexpr-type object) - (primitive-type? xlambda-type object)))) - -(define (is-internal-lambda? lambda) - (and (primitive-type? slambda-type lambda) - (memq (slambda-name lambda) internal-lambda-tags))) +(define (lambda? object) + (or (slambda? object) + (slexpr? object) + (xlambda? object))) -(set! make-lambda -(named-lambda (make-lambda name required optional rest auxiliary - declarations body) +(define (make-lambda name required optional rest auxiliary declarations body) (let ((body* (if (null? declarations) body (make-sequence (list (make-block-declaration declarations) @@ -365,10 +375,9 @@ ((null? rest) (make-clambda name required auxiliary body*)) (else - (make-clexpr name required rest auxiliary body*)))))) + (make-clexpr name required rest auxiliary body*))))) -(set! lambda-components -(named-lambda (lambda-components lambda receiver) +(define (lambda-components lambda receiver) (&lambda-components lambda (lambda (name required optional rest auxiliary body) (let ((actions (and (sequence? body) @@ -378,145 +387,106 @@ (receiver name required optional rest auxiliary (block-declaration-text (car actions)) (make-sequence (cdr actions))) - (receiver name required optional rest auxiliary '() body))))))) - + (receiver name required optional rest auxiliary '() body)))))) + (define ((dispatch-0 op-name clambda-op clexpr-op xlambda-op) lambda) - ((cond ((primitive-type? slambda-type lambda) clambda-op) - ((primitive-type? slexpr-type lambda) clexpr-op) - ((primitive-type? xlambda-type lambda) xlambda-op) + ((cond ((slambda? lambda) clambda-op) + ((slexpr? lambda) clexpr-op) + ((xlambda? lambda) xlambda-op) (else (error "Not a lambda" op-name lambda))) lambda)) - + (define ((dispatch-1 op-name clambda-op clexpr-op xlambda-op) lambda arg) - ((cond ((primitive-type? slambda-type lambda) clambda-op) - ((primitive-type? slexpr-type lambda) clexpr-op) - ((primitive-type? xlambda-type lambda) xlambda-op) + ((cond ((slambda? lambda) clambda-op) + ((slexpr? lambda) clexpr-op) + ((xlambda? lambda) xlambda-op) (else (error "Not a lambda" op-name lambda))) lambda arg)) -(define &lambda-components - (dispatch-1 'LAMBDA-COMPONENTS - clambda-components - clexpr-components - xlambda-components)) - -(define has-internal-lambda? - (dispatch-0 'HAS-INTERNAL-LAMBDA? - clambda-has-internal-lambda? - clexpr-has-internal-lambda? - xlambda-has-internal-lambda?)) - -(define lambda-wrap-body! - (dispatch-1 'LAMBDA-WRAP-BODY! - clambda-wrap-body! - clexpr-wrap-body! - xlambda-wrap-body!)) - -(define lambda-wrapper-components - (dispatch-1 'LAMBDA-WRAPPER-COMPONENTS - clambda-wrapper-components - clexpr-wrapper-components - xlambda-wrapper-components)) - -(define lambda-unwrap-body! - (dispatch-0 'LAMBDA-UNWRAP-BODY! - clambda-unwrap-body! - clexpr-unwrap-body! - xlambda-unwrap-body!)) - -(set! lambda-body - (dispatch-0 'LAMBDA-BODY - clambda-unwrapped-body - clexpr-unwrapped-body - xlambda-unwrapped-body)) - -(set! set-lambda-body! - (dispatch-1 'SET-LAMBDA-BODY! - set-clambda-unwrapped-body! - set-clexpr-unwrapped-body! - set-xlambda-unwrapped-body!)) - -(set! lambda-bound - (dispatch-0 'LAMBDA-BOUND - clambda-bound - clexpr-bound - xlambda-bound)) +(define &lambda-components) +(define has-internal-lambda?) +(define lambda-wrap-body!) +(define lambda-wrapper-components) +(define lambda-unwrap-body!) +(define lambda-body) +(define set-lambda-body!) +(define lambda-bound) + +(define-integrable (make-block-declaration text) + (vector block-declaration-tag text)) + +(define (block-declaration? object) + (and (vector? object) + (not (zero? (vector-length object))) + (eq? (vector-ref object 0) block-declaration-tag))) + +(define-integrable (block-declaration-text block-declaration) + (vector-ref block-declaration 1)) + +(define block-declaration-tag) ;;;; Simple Lambda/Lexpr -(define (make-slambda name required body) +(define-integrable slambda-type + (ucode-type lambda)) + +(define-integrable (make-slambda name required body) (&typed-pair-cons slambda-type body (list->vector (cons name required)))) +(define-integrable (slambda? object) + (object-type? slambda-type object)) + (define (slambda-components slambda receiver) (let ((bound (&pair-cdr slambda))) (receiver (vector-ref bound 0) (subvector->list bound 1 (vector-length bound)) (&pair-car slambda)))) -(define (slambda-name slambda) +(define-integrable (slambda-name slambda) (vector-ref (&pair-cdr slambda) 0)) -(define slambda-body &pair-car) -(define set-slambda-body! &pair-set-car!) +(define-integrable (slambda-body slambda) + (&pair-car slambda)) -(define (make-slexpr name required body) - (&typed-pair-cons slexpr-type body (list->vector (cons name required)))) +(define-integrable (set-slambda-body! slambda body) + (&pair-set-car! slambda body)) -(define slexpr-components slambda-components) -(define slexpr-body slambda-body) +(define-integrable slexpr-type + (ucode-type lexpr)) -;;; end LAMBDA-PACKAGE. -(the-environment))) - -;;;; Alternative Component Views - -(define (make-lambda* name required optional rest body) - (scan-defines body - (lambda (auxiliary declarations body*) - (make-lambda name required optional rest auxiliary declarations body*)))) +(define-integrable (make-slexpr name required body) + (&typed-pair-cons slexpr-type body (list->vector (cons name required)))) -(define (lambda-components* lambda receiver) - (lambda-components lambda - (lambda (name required optional rest auxiliary declarations body) - (receiver name required optional rest - (make-open-block auxiliary declarations body))))) +(define-integrable (slexpr? object) + (object-type? slexpr-type object)) -(define (lambda-components** lambda receiver) - (lambda-components* lambda - (lambda (name required optional rest body) - (receiver (vector name required optional rest) - (append required optional (if (null? rest) '() (list rest))) - body)))) +(define (slexpr-components slexpr receiver) + (let ((bound (&pair-cdr slexpr))) + (receiver (vector-ref bound 0) + (subvector->list bound 1 (vector-length bound)) + (&pair-car slexpr)))) -(define (lambda-pattern/name pattern) - (vector-ref pattern 0)) +(define-integrable (slexpr-body slexpr) + (&pair-car slexpr)) + +;;;; Internal Lambda -(define (lambda-pattern/required pattern) - (vector-ref pattern 1)) +(define lambda-tag:internal-lambda) +(define lambda-tag:internal-lexpr) -(define (lambda-pattern/optional pattern) - (vector-ref pattern 2)) +(define-integrable (make-internal-lambda names body) + (make-slambda lambda-tag:internal-lambda names body)) -(define (lambda-pattern/rest pattern) - (vector-ref pattern 3)) +(define-integrable (make-internal-lexpr names body) + (make-slambda lambda-tag:internal-lexpr names body)) -(define (make-lambda** pattern bound body) +(define (internal-lambda? lambda) + (and (slambda? lambda) + (or (eq? (slambda-name lambda) lambda-tag:internal-lambda) + (eq? (slambda-name lambda) lambda-tag:internal-lexpr)))) - (define (split pattern bound receiver) - (cond ((null? pattern) - (receiver '() bound)) - (else - (split (cdr pattern) (cdr bound) - (lambda (copy tail) - (receiver (cons (car bound) copy) - tail)))))) - - (split (lambda-pattern/required pattern) bound - (lambda (required tail) - (split (lambda-pattern/optional pattern) tail - (lambda (optional rest) - (make-lambda* (lambda-pattern/name pattern) - required - optional - (if (null? rest) rest (car rest)) - body)))))) \ No newline at end of file +(define (make-unassigned auxiliary) + (map (lambda (auxiliary) + auxiliary + (make-unassigned-reference-trap)) + auxiliary)) \ No newline at end of file diff --git a/v7/src/runtime/lambdx.scm b/v7/src/runtime/lambdx.scm index 49ba21ce7..18ab74411 100644 --- a/v7/src/runtime/lambdx.scm +++ b/v7/src/runtime/lambdx.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/lambdx.scm,v 14.1 1988/05/20 00:58:54 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/lambdx.scm,v 14.2 1988/06/13 11:47:06 cph Rel $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Alternative Components for Lambda +;;; package: () (declare (usual-integrations)) diff --git a/v7/src/runtime/list.scm b/v7/src/runtime/list.scm index ad7b32775..cfcb8e8f6 100644 --- a/v7/src/runtime/list.scm +++ b/v7/src/runtime/list.scm @@ -1,436 +1,468 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/list.scm,v 13.43 1988/05/03 18:55:13 jinx Exp $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/list.scm,v 14.1 1988/06/13 11:47:11 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; List Operations +;;; package: (runtime list) (declare (usual-integrations)) -;;; This IN-PACKAGE is just a kludge to prevent the definitions of the -;;; primitives from shadowing the USUAL-INTEGRATIONS declaration. -#| Temporarily relocated to `boot.scm' to help compiler. -(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 - cons pair? null? length car cdr set-car! set-cdr! - general-car-cdr memq assq)))|# - -(define (list . elements) - elements) - -(define (list? frob) - (cond ((pair? frob) (list? (cdr frob))) - ((null? frob) true) - (else false))) +(define-primitives + cons pair? null? length car cdr set-car! set-cdr! general-car-cdr) + +(define (list . items) + items) (define (cons* first-element . rest-elements) - (define (loop this-element rest-elements) + (let loop ((this-element first-element) (rest-elements rest-elements)) (if (null? rest-elements) this-element (cons this-element (loop (car rest-elements) - (cdr rest-elements))))) - (loop first-element rest-elements)) + (cdr rest-elements)))))) + +(define (make-list length #!optional value) + (if (not (and (integer? length) (not (negative? length)))) + (error "MAKE-LIST: length must be nonnegative integer" length)) + (let ((value (if (default-object? value) '() value))) + (let loop ((n length) (result '())) + (if (zero? n) + result + (loop (-1+ n) (cons value result)))))) + +(define (circular-list . items) + (if (not (null? items)) + (let loop ((l items)) + (if (null? (cdr l)) + (set-cdr! l items) + (loop (cdr l))))) + items) + +(define (make-circular-list length #!optional value) + (if (not (and (integer? length) (not (negative? length)))) + (error "MAKE-CIRCULAR-LIST: length must be nonnegative integer" length)) + (if (positive? length) + (let ((value (if (default-object? value) '() value))) + (let ((last (cons value '()))) + (let loop ((n (-1+ length)) (result last)) + (if (zero? n) + (begin + (set-cdr! last result) + result) + (loop (-1+ n) (cons value result)))))) + '())) + +(define (list-ref list index) + (let ((tail (list-tail list index))) + (if (not (pair? tail)) + (error "LIST-REF: index too large" index)) + (car tail))) + +(define (list-tail list index) + (if (not (and (integer? index) (not (negative? index)))) + (error "LIST-TAIL: index must be nonnegative integer" index)) + (let loop ((list list) (index index)) + (if (zero? index) + list + (begin (if (not (pair? list)) + (error "LIST-TAIL: index too large" index)) + (loop (cdr list) (-1+ index)))))) + +(define (list-head list index) + (if (not (and (integer? index) (not (negative? index)))) + (error "LIST-HEAD: index must be nonnegative integer" index)) + (let loop ((list list) (index index)) + (if (zero? index) + '() + (begin + (if (not (pair? list)) + (error "LIST-HEAD: list has too few elements" list index)) + (cons (car list) (loop (cdr list) (-1+ index))))))) + +(define (sublist list start end) + (list-head (list-tail list start) (- end start))) + +(define (list? object) + (let loop ((object object)) + (if (null? object) + true + (and (pair? object) + (loop (cdr object)))))) + +(define (alist? object) + (if (null? object) + true + (and (pair? object) + (pair? (car object)) + (alist? (cdr object))))) + +(define (list-copy items) + (let loop ((items items)) + (if (pair? items) + (cons (car items) (loop (cdr items))) + (begin (if (not (null? items)) + (error "LIST-COPY: argument not proper list" items)) + '())))) + +(define (alist-copy alist) + (if (pair? alist) + (begin (if (not (pair? (car alist))) + (error "ALIST-COPY: illegal alist element" (car alist))) + (cons (cons (caar alist) (cdar alist)) (alist-copy (cdr alist)))) + (begin (if (not (null? alist)) + (error "ALIST-COPY: illegal alist" alist)) + '()))) + +(define (tree-copy tree) + (let loop ((tree tree)) + (if (pair? tree) + (cons (loop (car tree)) (loop (cdr tree))) + tree))) + +;;;; Weak Pairs + +(define-integrable (weak-cons car cdr) + (system-pair-cons (ucode-type weak-cons) (or car weak-pair/false) cdr)) -(define (make-list size #!optional value) - (subvector->list (vector-cons size (if (unassigned? value) '() value)) - 0 - size)) +(define-integrable (weak-pair? object) + (object-type? (ucode-type weak-cons) object)) -(define (list-copy elements) - (apply list elements)) +(define-integrable (weak-pair/car? weak-pair) + (system-pair-car weak-pair)) -(define (list-ref l n) - (cond ((not (pair? l)) (error "LIST-REF: Bad argument" l n)) - ((zero? n) (car l)) - (else (list-ref (cdr l) (-1+ n))))) +(define (weak-car weak-pair) + (let ((car (system-pair-car weak-pair))) + (and (not (eq? car weak-pair/false)) + car))) -(define (list-tail l n) - (cond ((zero? n) l) - ((pair? l) (list-tail (cdr l) (-1+ n))) - (else (error "LIST-TAIL: Bad argument" l)))) +(define-integrable (weak-set-car! weak-pair object) + (system-pair-set-car! weak-pair (or object weak-pair/false))) -(define the-empty-stream '()) -(define empty-stream? null?) -(define head car) +(define-integrable (weak-cdr weak-pair) + (system-pair-cdr weak-pair)) -(define (tail stream) - (force (cdr stream))) +(define-integrable (weak-set-cdr! weak-pair object) + (system-pair-set-cdr! weak-pair object)) + +(define weak-pair/false + "weak-pair/false") ;;;; Standard Selectors -(define (cddr x) (general-car-cdr x #o4)) -(define (cdar x) (general-car-cdr x #o5)) -(define (cadr x) (general-car-cdr x #o6)) -(define (caar x) (general-car-cdr x #o7)) - -(define (cdddr x) (general-car-cdr x #o10)) -(define (cddar x) (general-car-cdr x #o11)) -(define (cdadr x) (general-car-cdr x #o12)) -(define (cdaar x) (general-car-cdr x #o13)) -(define (caddr x) (general-car-cdr x #o14)) -(define (cadar x) (general-car-cdr x #o15)) -(define (caadr x) (general-car-cdr x #o16)) -(define (caaar x) (general-car-cdr x #o17)) - -(define (cddddr x) (general-car-cdr x #o20)) -(define (cdddar x) (general-car-cdr x #o21)) -(define (cddadr x) (general-car-cdr x #o22)) -(define (cddaar x) (general-car-cdr x #o23)) -(define (cdaddr x) (general-car-cdr x #o24)) -(define (cdadar x) (general-car-cdr x #o25)) -(define (cdaadr x) (general-car-cdr x #o26)) -(define (cdaaar x) (general-car-cdr x #o27)) -(define (cadddr x) (general-car-cdr x #o30)) -(define (caddar x) (general-car-cdr x #o31)) -(define (cadadr x) (general-car-cdr x #o32)) -(define (cadaar x) (general-car-cdr x #o33)) -(define (caaddr x) (general-car-cdr x #o34)) -(define (caadar x) (general-car-cdr x #o35)) -(define (caaadr x) (general-car-cdr x #o36)) -(define (caaaar x) (general-car-cdr x #o37)) - -(define first car) -(define (second x) (general-car-cdr x #o6)) -(define (third x) (general-car-cdr x #o14)) -(define (fourth x) (general-car-cdr x #o30)) -(define (fifth x) (general-car-cdr x #o60)) -(define (sixth x) (general-car-cdr x #o140)) -(define (seventh x) (general-car-cdr x #o300)) -(define (eighth x) (general-car-cdr x #o600)) +(define-integrable (caar x) (car (car x))) +(define-integrable (cadr x) (car (cdr x))) +(define-integrable (cdar x) (cdr (car x))) +(define-integrable (cddr x) (cdr (cdr x))) + +(define-integrable (caaar x) (car (car (car x)))) +(define-integrable (caadr x) (car (car (cdr x)))) +(define-integrable (cadar x) (car (cdr (car x)))) +(define-integrable (caddr x) (car (cdr (cdr x)))) + +(define-integrable (cdaar x) (cdr (car (car x)))) +(define-integrable (cdadr x) (cdr (car (cdr x)))) +(define-integrable (cddar x) (cdr (cdr (car x)))) +(define-integrable (cdddr x) (cdr (cdr (cdr x)))) + +(define-integrable (caaaar x) (car (car (car (car x))))) +(define-integrable (caaadr x) (car (car (car (cdr x))))) +(define-integrable (caadar x) (car (car (cdr (car x))))) +(define-integrable (caaddr x) (car (car (cdr (cdr x))))) + +(define-integrable (cadaar x) (car (cdr (car (car x))))) +(define-integrable (cadadr x) (car (cdr (car (cdr x))))) +(define-integrable (caddar x) (car (cdr (cdr (car x))))) +(define-integrable (cadddr x) (car (cdr (cdr (cdr x))))) + +(define-integrable (cdaaar x) (cdr (car (car (car x))))) +(define-integrable (cdaadr x) (cdr (car (car (cdr x))))) +(define-integrable (cdadar x) (cdr (car (cdr (car x))))) +(define-integrable (cdaddr x) (cdr (car (cdr (cdr x))))) + +(define-integrable (cddaar x) (cdr (cdr (car (car x))))) +(define-integrable (cddadr x) (cdr (cdr (car (cdr x))))) +(define-integrable (cdddar x) (cdr (cdr (cdr (car x))))) +(define-integrable (cddddr x) (cdr (cdr (cdr (cdr x))))) + +(define-integrable (first x) (car x)) +(define-integrable (second x) (car (cdr x))) +(define-integrable (third x) (car (cdr (cdr x)))) +(define-integrable (fourth x) (car (cdr (cdr (cdr x))))) +(define-integrable (fifth x) (car (cdr (cdr (cdr (cdr x)))))) +(define-integrable (sixth x) (car (cdr (cdr (cdr (cdr (cdr x))))))) +(define-integrable (seventh x) (car (cdr (cdr (cdr (cdr (cdr (cdr x)))))))) + +(define-integrable (eighth x) + (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr x))))))))) + +(define-integrable (ninth x) + (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr x)))))))))) + +(define-integrable (tenth x) + (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr x))))))))))) ;;;; Sequence Operations (define (append . lists) - (define (outer current remaining) - (define (inner list) - (cond ((pair? list) (cons (car list) (inner (cdr list)))) - ((null? list) (outer (car remaining) (cdr remaining))) - (else (error "APPEND: Argument not a list" current)))) - (if (null? remaining) - current - (inner current))) (if (null? lists) '() - (outer (car lists) (cdr lists)))) + (let outer ((current (car lists)) (remaining (cdr lists))) + (if (null? remaining) + current + (let inner ((list current)) + (if (pair? list) + (cons (car list) (inner (cdr list))) + (begin (if (not (null? list)) + (error "APPEND: Argument not a list" current)) + (outer (car remaining) (cdr remaining))))))))) (define (append! . lists) - (define (loop head tail) - (cond ((null? tail) head) - ((pair? head) - (set-cdr! (last-pair head) (loop (car tail) (cdr tail))) - head) - ((null? head) (loop (car tail) (cdr tail))) - (else (error "APPEND!: Argument not a list" head)))) (if (null? lists) '() - (loop (car lists) (cdr lists)))) + (let loop ((head (car lists)) (tail (cdr lists))) + (cond ((null? tail) + head) + ((pair? head) + (set-cdr! (last-pair head) (loop (car tail) (cdr tail))) + head) + (else + (if (not (null? head)) + (error "APPEND!: Argument not a list" head)) + (loop (car tail) (cdr tail))))))) (define (reverse l) - (define (loop rest so-far) - (cond ((pair? rest) (loop (cdr rest) (cons (car rest) so-far))) - ((null? rest) so-far) - (else (error "REVERSE: Argument not a list" l)))) - (loop l '())) + (let loop ((rest l) (so-far '())) + (if (pair? rest) + (loop (cdr rest) (cons (car rest) so-far)) + (begin (if (not (null? rest)) + (error "REVERSE: Argument not a list" l)) + so-far)))) (define (reverse! l) - (define (loop current new-cdr) - (cond ((pair? current) (loop (set-cdr! current new-cdr) current)) - ((null? current) new-cdr) - (else (error "REVERSE!: Argument not a list" l)))) - (loop l '())) + (let loop ((current l) (new-cdr '())) + (if (pair? current) + (loop (set-cdr! current new-cdr) current) + (begin (if (not (null? current)) + (error "REVERSE!: Argument not a list" l)) + new-cdr)))) ;;;; Mapping Procedures (define (map f . lists) - (cond ((null? lists) - (error "MAP: Too few arguments" f)) - ((null? (cdr lists)) - (let 1-loop ((list (car lists))) - (cond ((pair? list) - (cons (f (car list)) - (1-loop (cdr list)))) - ((null? list) - '()) - (else - (error "MAP: Argument not a list" (car lists)))))) - (else - (let n-loop ((lists lists)) - (let parse-cars - ((lists lists) - (receiver - (lambda (cars cdrs) - (cons (apply f cars) - (n-loop cdrs))))) - (cond ((null? lists) - (receiver '() '())) - ((null? (car lists)) - '()) - ((pair? (car lists)) - (parse-cars (cdr lists) - (lambda (cars cdrs) - (receiver (cons (car (car lists)) cars) - (cons (cdr (car lists)) cdrs))))) - (else - (error "MAP: Argument not a list" (car lists))))))))) - + ;; Compiler doesn't, but ought to, make this very fast. + (apply map* '() f lists)) + (define (map* initial-value f . lists) - (cond ((null? lists) - (error "MAP*: Too few arguments" f)) - ((null? (cdr lists)) - (let 1-loop ((list (car lists))) - (cond ((pair? list) - (cons (f (car list)) - (1-loop (cdr list)))) - ((null? list) - initial-value) - (else - (error "MAP*: Argument not a list" (car lists)))))) - (else - (let n-loop ((lists lists)) - (let parse-cars - ((lists lists) - (receiver - (lambda (cars cdrs) - (cons (apply f cars) - (n-loop cdrs))))) - (cond ((null? lists) - (receiver '() '())) - ((null? (car lists)) - initial-value) - ((pair? (car lists)) - (parse-cars (cdr lists) - (lambda (cars cdrs) - (receiver (cons (car (car lists)) cars) - (cons (cdr (car lists)) cdrs))))) - (else - (error "MAP*: Argument not a list" (car lists))))))))) - -(define (for-each f . lists) - (cond ((null? lists) - (error "FOR-EACH: Too few arguments" f)) - ((null? (cdr lists)) - (let 1-loop ((list (car lists))) - (cond ((pair? list) - (f (car list)) + (if (null? lists) + (error "MAP*: Too few arguments" f)) + (if (null? (cdr lists)) + (let 1-loop ((list (car lists))) + (if (pair? list) + (cons (f (car list)) (1-loop (cdr list))) - ((null? list) - *the-non-printing-object*) - (else - (error "FOR-EACH: Argument not a list" (car lists)))))) - (else - (let n-loop ((lists lists)) - (let parse-cars - ((lists lists) - (receiver - (lambda (cars cdrs) - (apply f cars) - (n-loop cdrs)))) - (cond ((null? lists) - (receiver '() '())) - ((null? (car lists)) - *the-non-printing-object*) - ((pair? (car lists)) - (parse-cars (cdr lists) - (lambda (cars cdrs) - (receiver (cons (car (car lists)) cars) - (cons (cdr (car lists)) cdrs))))) - (else - (error "FOR-EACH: Argument not a list" (car lists))))))))) - -(define mapcar map) -(define mapcar* map*) -(define mapc for-each) - + (begin + (if (not (null? list)) + (error "MAP*: Argument not a list" list)) + initial-value))) + (let n-loop ((lists lists)) + (let parse-cars + ((lists lists) + (receiver + (lambda (cars cdrs) + (cons (apply f cars) + (n-loop cdrs))))) + (cond ((null? lists) + (receiver '() '())) + ((pair? (car lists)) + (parse-cars (cdr lists) + (lambda (cars cdrs) + (receiver (cons (car (car lists)) cars) + (cons (cdr (car lists)) cdrs))))) + (else + (if (not (null? (car lists))) + (error "MAP*: Argument not a list" (car lists))) + initial-value)))))) + (define (reduce f initial list) - (define (loop value l) - (cond ((pair? l) - (loop (f value (car l)) - (cdr l))) - ((null? l) - value) - (else - (error "REDUCE: Argument not a list" list)))) - (loop initial list)) - -(define (there-exists? predicate) - (define (loop objects) - (and (pair? objects) - (or (predicate (car objects)) - (loop (cdr objects))))) - loop) - -(define (for-all? predicate) - (define (loop objects) - (if (pair? objects) - (and (predicate (car objects)) - (loop (cdr objects))) - true)) - loop) + (let loop ((value initial) (l list)) + (cond ((pair? l) (loop (f value (car l)) (cdr l))) + ((null? l) value) + (else (error "REDUCE: Argument not a list" list))))) -;;;; Generalized List Operations - -(define (positive-list-searcher predicate if-win if-lose) - (define (list-searcher-loop list) - (if (pair? list) - (if (predicate list) - (if-win list) - (list-searcher-loop (cdr list))) - (and if-lose (if-lose)))) - list-searcher-loop) - -(define (negative-list-searcher predicate if-win if-lose) - (define (list-searcher-loop list) - (if (pair? list) - (if (predicate list) - (list-searcher-loop (cdr list)) - (if-win list)) - (and if-lose (if-lose)))) - list-searcher-loop) - -(define (positive-list-transformer predicate tail) - (define (list-transform-loop list) - (if (pair? list) - (if (predicate (car list)) - (cons (car list) - (list-transform-loop (cdr list))) - (list-transform-loop (cdr list))) - tail)) - list-transform-loop) - -(define (negative-list-transformer predicate tail) - (define (list-transform-loop list) - (if (pair? list) - (if (predicate (car list)) - (list-transform-loop (cdr list)) - (cons (car list) - (list-transform-loop (cdr list)))) - tail)) - list-transform-loop) +(define (for-each f . lists) + (if (null? lists) + (error "FOR-EACH: Too few arguments" f)) + (if (null? (cdr lists)) + (let 1-loop ((list (car lists))) + (cond ((pair? list) + (f (car list)) + (1-loop (cdr list))) + ((not (null? list)) + (error "FOR-EACH: Argument not a list" list)))) + (let n-loop ((lists lists)) + (let parse-cars + ((lists lists) + (receiver + (lambda (cars cdrs) + (apply f cars) + (n-loop cdrs)))) + (cond ((null? lists) + (receiver '() '())) + ((pair? (car lists)) + (parse-cars (cdr lists) + (lambda (cars cdrs) + (receiver (cons (car (car lists)) cars) + (cons (cdr (car lists)) cdrs))))) + ((not (null? (car lists))) + (error "FOR-EACH: Argument not a list" (car lists))))))) + *the-non-printing-object*) + +(define (mapcan f . lists) + ;; Compiler doesn't, but ought to, make this very fast. + (apply mapcan* '() f lists)) + +(define (mapcan* initial-value f . lists) + (if (null? lists) + (error "MAPCAN*: Too few arguments" f)) + (let loop ((lists lists)) + (let scan + ((lists lists) + (c (lambda (cars cdrs) + (append! (apply f cars) (loop cdrs))))) + (cond ((null? lists) (c '() '())) + ((null? (car lists)) initial-value) + (else + (scan (cdr lists) + (lambda (cars cdrs) + (c (cons (car (car lists)) cars) + (cons (cdr (car lists)) cdrs))))))))) -(define (list-deletor predicate) - (define (list-deletor-loop list) - (if (pair? list) - (if (predicate (car list)) - (list-deletor-loop (cdr list)) - (cons (car list) (list-deletor-loop (cdr list)))) - '())) - list-deletor-loop) +;;;; Generalized List Operations -(define (list-deletor! predicate) - (define (trim-initial-segment list) - (if (pair? list) - (if (predicate (car list)) - (trim-initial-segment (cdr list)) - (begin (locate-initial-segment list (cdr list)) - list)) - list)) - (define (locate-initial-segment last this) - (if (pair? this) - (if (predicate (car this)) - (set-cdr! last (trim-initial-segment (cdr this))) - (locate-initial-segment this (cdr this))) - this)) - trim-initial-segment) - -(define (list-transform-positive list predicate) - (let loop ((list list)) - (if (pair? list) - (if (predicate (car list)) - (cons (car list) (loop (cdr list))) - (loop (cdr list))) +(define (list-transform-positive items predicate) + (let loop ((items items)) + (if (pair? items) + (if (predicate (car items)) + (cons (car items) (loop (cdr items))) + (loop (cdr items))) '()))) -(define (list-transform-negative list predicate) - (let loop ((list list)) - (if (pair? list) - (if (predicate (car list)) - (loop (cdr list)) - (cons (car list) (loop (cdr list)))) +(define (list-transform-negative items predicate) + (let loop ((items items)) + (if (pair? items) + (if (predicate (car items)) + (loop (cdr items)) + (cons (car items) (loop (cdr items)))) '()))) -(define (list-search-positive list predicate) - (let loop ((list list)) - (and (pair? list) - (if (predicate (car list)) - (car list) - (loop (cdr list)))))) - -(define (list-search-negative list predicate) - (let loop ((list list)) - (and (pair? list) - (if (predicate (car list)) - (loop (cdr list)) - (car list))))) - -;;;; Membership Lists - -(define (member-procedure predicate) - (lambda (element list) - (let loop ((list list)) - (and (pair? list) - (if (predicate (car list) element) - list - (loop (cdr list))))))) +(define (list-search-positive items predicate) + (let loop ((items items)) + (and (pair? items) + (if (predicate (car items)) + (car items) + (loop (cdr items)))))) -;(define memq (member-procedure eq?)) -(define memv (member-procedure eqv?)) -(define member (member-procedure equal?)) +(define (list-search-negative items predicate) + (let loop ((items items)) + (and (pair? items) + (if (predicate (car items)) + (loop (cdr items)) + (car items))))) -(define (delete-member-procedure deletor predicate) - (lambda (element list) - ((deletor (lambda (match) - (predicate match element))) - list))) +(define ((list-deletor predicate) items) + (list-transform-negative items predicate)) -(define delq (delete-member-procedure list-deletor eq?)) -(define delv (delete-member-procedure list-deletor eqv?)) -(define delete (delete-member-procedure list-deletor equal?)) +(define (list-deletor! predicate) + (letrec ((trim-initial-segment + (lambda (items) + (if (pair? items) + (if (predicate (car items)) + (trim-initial-segment (cdr items)) + (begin (locate-initial-segment items (cdr items)) + items)) + items))) + (locate-initial-segment + (lambda (last this) + (if (pair? this) + (if (predicate (car this)) + (set-cdr! last (trim-initial-segment (cdr this))) + (locate-initial-segment this (cdr this))) + this)))) + trim-initial-segment)) + +;;;; Membership/Association Lists + +(define (initialize-package!) + (set! memv (member-procedure eqv?)) + (set! member (member-procedure equal?)) + (set! delv (delete-member-procedure list-deletor eqv?)) + (set! delete (delete-member-procedure list-deletor equal?)) + (set! delv! (delete-member-procedure list-deletor! eqv?)) + (set! delete! (delete-member-procedure list-deletor! equal?)) + (set! assv (association-procedure eqv? car)) + (set! assoc (association-procedure equal? car)) + (set! del-assq (delete-association-procedure list-deletor eq? car)) + (set! del-assv (delete-association-procedure list-deletor eqv? car)) + (set! del-assoc (delete-association-procedure list-deletor equal? car)) + (set! del-assq! (delete-association-procedure list-deletor! eq? car)) + (set! del-assv! (delete-association-procedure list-deletor! eqv? car)) + (set! del-assoc! (delete-association-procedure list-deletor! equal? car))) + +(define memv) +(define member) +(define delv) +(define delete) +(define delv!) +(define delete!) +(define assv) +(define assoc) +(define del-assq) +(define del-assv) +(define del-assoc) +(define del-assq!) +(define del-assv!) +(define del-assoc!) -(define delq! (delete-member-procedure list-deletor! eq?)) -(define delv! (delete-member-procedure list-deletor! eqv?)) -(define delete! (delete-member-procedure list-deletor! equal?)) +(define (member-procedure predicate) + (lambda (item items) + (let loop ((items items)) + (and (pair? items) + (if (predicate (car items) item) + items + (loop (cdr items))))))) -;;;; Association Lists +(define ((delete-member-procedure deletor predicate) item items) + ((deletor (lambda (match) (predicate match item))) items)) (define (association-procedure predicate selector) (lambda (key alist) @@ -440,49 +472,79 @@ (car alist) (loop (cdr alist))))))) -;(define assq (association-procedure eq? car)) -(define assv (association-procedure eqv? car)) -(define assoc (association-procedure equal? car)) - (define ((delete-association-procedure deletor predicate selector) key alist) - ((deletor (lambda (association) - (predicate (selector association) key))) - alist)) - -(define del-assq (delete-association-procedure list-deletor eq? car)) -(define del-assv (delete-association-procedure list-deletor eqv? car)) -(define del-assoc (delete-association-procedure list-deletor equal? car)) + ((deletor (lambda (entry) (predicate (selector entry) key))) alist)) + +;;; The following could be defined using the generic procedures above, +;;; but the compiler produces better code for them this way. The only +;;; reason to use these procedures is speed, so we crank them up. + +(define (memq item items) + (let loop ((items items)) + (and (pair? items) + (if (eq? (car items) item) + items + (loop (cdr items)))))) + +(define (assq key alist) + (let loop ((alist alist)) + (and (pair? alist) + (if (eq? (caar alist) key) + (car alist) + (loop (cdr alist)))))) + +(define (delq item items) + (let loop ((items items)) + (if (pair? items) + (if (eq? item (car items)) + (loop (cdr items)) + (cons (car items) (loop (cdr items)))) + '()))) -(define del-assq! (delete-association-procedure list-deletor! eq? car)) -(define del-assv! (delete-association-procedure list-deletor! eqv? car)) -(define del-assoc! (delete-association-procedure list-deletor! equal? car)) +(define (delq! item items) + (letrec ((trim-initial-segment + (lambda (items) + (if (pair? items) + (if (eq? item (car items)) + (trim-initial-segment (cdr items)) + (begin (locate-initial-segment items (cdr items)) + items)) + items))) + (locate-initial-segment + (lambda (last this) + (if (pair? this) + (if (eq? item (car this)) + (set-cdr! last (trim-initial-segment (cdr this))) + (locate-initial-segment this (cdr this))) + this)))) + (trim-initial-segment items))) -;;;; Lastness - -(define (last-pair l) - (if (pair? l) - (let loop ((l l)) - (if (pair? (cdr l)) - (loop (cdr l)) - l)) - (error "LAST-PAIR: Argument not a list" l))) - -(define (except-last-pair l) - (if (pair? l) - (let loop ((l l)) - (if (pair? (cdr l)) - (cons (car l) - (loop (cdr l))) - '())) - (error "EXCEPT-LAST-PAIR: Argument not a list" l))) - -(define (except-last-pair! l) - (if (pair? l) - (if (pair? (cdr l)) - (begin (let loop ((l l)) - (if (pair? (cddr l)) - (loop (cdr l)) - (set-cdr! l '()))) - l) - '()) - (error "EXCEPT-LAST-PAIR!: Argument not a list" l))) \ No newline at end of file +;;;; Lastness and Segments + +(define (last-pair list) + (if (not (pair? list)) + (error "LAST-PAIR: Argument not a pair" list)) + (let loop ((list list)) + (if (pair? (cdr list)) + (loop (cdr list)) + list))) + +(define (except-last-pair list) + (if (not (pair? list)) + (error "EXCEPT-LAST-PAIR: Argument not a pair" list)) + (let loop ((list list)) + (if (pair? (cdr list)) + (cons (car list) + (loop (cdr list))) + '()))) + +(define (except-last-pair! list) + (if (not (pair? list)) + (error "EXCEPT-LAST-PAIR!: Argument not a pair" list)) + (if (pair? (cdr list)) + (begin (let loop ((list list)) + (if (pair? (cddr list)) + (loop (cdr list)) + (set-cdr! list '()))) + list) + '())) \ No newline at end of file diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm index 8674a32c9..c6ee50379 100644 --- a/v7/src/runtime/load.scm +++ b/v7/src/runtime/load.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.1 1988/05/20 00:59:11 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.2 1988/06/13 11:47:32 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,7 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Code Loader -;;; package: load-package +;;; package: (runtime load) (declare (usual-integrations)) @@ -48,10 +48,10 @@ MIT in each case. |# (define fasload/default-types) (define (read-file filename) - (stream->list - (call-with-input-file - (pathname-default-version (->pathname filename) 'NEWEST) - read-stream))) + (call-with-input-file + (pathname-default-version (->pathname filename) 'NEWEST) + (lambda (port) + (stream->list (read-stream port))))) (define (fasload filename) (fasload/internal @@ -66,10 +66,15 @@ MIT in each case. |# (write-string " -- done" port) value))) -(define (load-noisily filename #!optional environment) +(define (load-noisily filename #!optional environment syntax-table purify?) (fluid-let ((load-noisily? true)) (load filename - (if (default-object? environment) default-object environment)))) + ;; This defaulting is a kludge until we get the optional + ;; defaulting fixed. Right now it must match the defaulting + ;; of `load'. + (if (default-object? environment) default-object environment) + (if (default-object? syntax-table) default-object syntax-table) + (if (default-object? purify?) default-object purify?)))) (define (load-init-file) (let ((truename (init-file-truename))) @@ -80,10 +85,24 @@ MIT in each case. |# ;;; This is careful to do the minimum number of file existence probes ;;; before opening the input file. -(define (load filename/s #!optional environment) +(define (load filename/s #!optional environment syntax-table purify?) (let ((environment ;; Kludge until optional defaulting fixed. - (if (default-object? environment) default-object environment))) + (if (or (default-object? environment) + (eq? environment default-object)) + default-object + (->environment environment))) + (syntax-table + ;; Kludge until optional defaulting fixed. + (if (or (default-object? syntax-table) + (eq? syntax-table default-object)) + default-object + (guarantee-syntax-table syntax-table))) + (purify? + (if (or (default-object? purify?) + (eq? purify? default-object)) + false + purify?))) (let ((kernel (lambda (filename last-file?) (let ((value @@ -92,6 +111,8 @@ MIT in each case. |# (find-true-filename pathname load/default-types) environment + syntax-table + purify? load-noisily?)))) (cond (last-file? value) (load-noisily? (write-line value))))))) @@ -106,19 +127,22 @@ MIT in each case. |# (define default-object "default-object") -(define (load/internal pathname true-filename environment load-noisily?) +(define (load/internal pathname true-filename environment syntax-table + purify? load-noisily?) (let ((port (open-input-file/internal pathname true-filename))) (if (= 250 (char->ascii (peek-char port))) (begin (close-input-port port) - (scode-eval (fasload/internal true-filename) + (scode-eval (let ((scode (fasload/internal true-filename))) + (if purify? (purify scode)) + scode) (if (eq? environment default-object) (standard-repl-environment) environment))) - (write-stream (eval-stream (read-stream port) environment) + (write-stream (eval-stream (read-stream port) environment syntax-table) (if load-noisily? (lambda (value) (hook/repl-write (nearest-repl) value)) - (lambda (value) value false)))))) + (lambda (value) value false)))))) (define (find-true-filename pathname default-types) (pathname->string (or (let ((try @@ -133,7 +157,7 @@ MIT in each case. |# (or (try (pathname-new-type pathname (car types))) (loop (cdr types)))))))) (error "No such file" pathname)))) - + (define (read-stream port) (parse-objects port (current-parser-table) @@ -142,14 +166,18 @@ MIT in each case. |# (begin (close-input-port port) true))))) -(define (eval-stream stream environment) +(define (eval-stream stream environment syntax-table) (stream-map stream (lambda (s-expression) - (hook/repl-eval (nearest-repl) - s-expression - (if (eq? environment default-object) - (standard-repl-environment) - environment))))) + (let ((repl (nearest-repl))) + (hook/repl-eval repl + s-expression + (if (eq? environment default-object) + (repl/environment repl) + environment) + (if (eq? syntax-table default-object) + (repl/syntax-table repl) + syntax-table)))))) (define (write-stream stream write) (if (stream-pair? stream) diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm index 017da43fc..48e0d2e48 100644 --- a/v7/src/runtime/make.scm +++ b/v7/src/runtime/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.1 1988/05/20 00:59:28 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.2 1988/06/13 11:47:44 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -38,9 +38,8 @@ MIT in each case. |# ((ucode-primitive set-interrupt-enables!) 0) (define system-global-environment (the-environment)) -(define system-packages (let () (the-environment))) -(let () +(let ((environment-for-package (let () (the-environment)))) (define-primitives (+ &+) @@ -49,6 +48,7 @@ MIT in each case. |# (file-exists? 1) garbage-collect get-fixed-objects-vector + get-next-constant get-primitive-address get-primitive-name lexical-reference @@ -63,7 +63,9 @@ MIT in each case. |# substring=? substring-move-right! substring-upcase! + tty-beep tty-flush-output + tty-read-char-immediate tty-write-char tty-write-string vector-ref @@ -85,10 +87,32 @@ MIT in each case. |# (tty-write-char newline-char) (tty-flush-output) (exit)) + +(define (prompt-for-confirmation prompt) + (let loop () + (tty-write-char newline-char) + (tty-write-string prompt) + (tty-write-string "(y or n) ") + (tty-flush-output) + (let ((char (tty-read-char-immediate))) + (cond ((or (eq? #\y char) + (eq? #\Y char)) + (tty-write-string "Yes") + (tty-flush-output) + true) + ((or (eq? #\n char) + (eq? #\N char)) + (tty-write-string "No") + (tty-flush-output) + false) + (else + (tty-beep) + (loop)))))) ;;;; GC, Interrupts, Errors (define safety-margin 4500) +(define constant-space/base (get-next-constant)) (let ((condition-handler/gc (lambda (interrupt-code interrupt-enables) @@ -142,7 +166,8 @@ MIT in each case. |# (get-primitive-address (get-primitive-name (object-datum primitive)) false)) (define map-filename - (if (implemented-primitive-procedure? file-exists?) + (if (and (implemented-primitive-procedure? file-exists?) + (not (prompt-for-confirmation "Load interpreted? "))) (lambda (filename) (let ((com-file (string-append filename ".com"))) (if (file-exists? com-file) @@ -172,22 +197,23 @@ MIT in each case. |# (define (package-initialize package-name procedure-name) (tty-write-char newline-char) - (tty-write-string "initialize:") + (tty-write-string "initialize: (") (let loop ((name package-name)) (if (not (null? name)) - (begin (tty-write-string " ") + (begin (if (not (eq? name package-name)) + (tty-write-string " ")) (tty-write-string (system-pair-car (car name))) (loop (cdr name))))) + (tty-write-string ")") + (if (not (eq? procedure-name 'INITIALIZE-PACKAGE!)) + (begin (tty-write-string " [") + (tty-write-string (system-pair-car procedure-name)) + (tty-write-string "]"))) (tty-flush-output) ((lexical-reference (package-reference package-name) procedure-name))) (define (package-reference name) - (if (null? name) - system-global-environment - (let loop ((name name) (environment system-packages)) - (if (null? name) - environment - (loop (cdr name) (lexical-reference environment (car name))))))) + (package/environment (find-package name))) (define (package-initialization-sequence packages) (let loop ((packages packages)) @@ -196,39 +222,66 @@ MIT in each case. |# (loop (cdr packages)))))) ;; Construct the package structure. +;; Lotta hair here to load the package code before its package is built. +(eval (cold-load/purify (fasload (map-filename "packag"))) + environment-for-package) +((access initialize-package! environment-for-package)) +(let loop ((names + '(FIND-PACKAGE + NAME->PACKAGE + PACKAGE/ADD-CHILD! + PACKAGE/CHILD + PACKAGE/CHILDREN + PACKAGE/ENVIRONMENT + PACKAGE/NAME + PACKAGE/PARENT + PACKAGE/REFERENCE + PACKAGE/SYSTEM-LOADER + PACKAGE? + SYSTEM-GLOBAL-PACKAGE))) + (if (not (null? names)) + (begin (environment-link-name system-global-environment + environment-for-package + (car names)) + (loop (cdr names))))) +(package/add-child! system-global-package 'PACKAGE environment-for-package) (eval (fasload "runtim.bcon") system-global-environment) ;; Global databases. Load, then initialize. - (let loop ((files - '(("gcdemn" . (GC-DAEMONS)) - ("poplat" . (POPULATION)) - ("prop1d" . (1D-PROPERTY)) - ("events" . (EVENT-DISTRIBUTOR)) - ("gdatab" . (GLOBAL-DATABASE)) + '(("gcdemn" . (RUNTIME GC-DAEMONS)) + ("poplat" . (RUNTIME POPULATION)) + ("prop1d" . (RUNTIME 1D-PROPERTY)) + ("events" . (RUNTIME EVENT-DISTRIBUTOR)) + ("gdatab" . (RUNTIME GLOBAL-DATABASE)) ("boot" . ()) ("queue" . ()) - ("gc" . (GARBAGE-COLLECTOR))))) + ("gc" . (RUNTIME GARBAGE-COLLECTOR))))) (if (not (null? files)) (begin (eval (cold-load/purify (fasload (map-filename (car (car files))))) (package-reference (cdr (car files)))) (loop (cdr files))))) -(package-initialize '(GC-DAEMONS) 'INITIALIZE-PACKAGE!) -(package-initialize '(POPULATION) 'INITIALIZE-PACKAGE!) -(package-initialize '(1D-PROPERTY) 'INITIALIZE-PACKAGE!) -(package-initialize '(EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE!) -(package-initialize '(GLOBAL-DATABASE) 'INITIALIZE-PACKAGE!) -(package-initialize '(POPULATION) 'INITIALIZE-UNPARSER!) -(package-initialize '(1D-PROPERTY) 'INITIALIZE-UNPARSER!) -(package-initialize '(EVENT-DISTRIBUTOR) 'INITIALIZE-UNPARSER!) -(package-initialize '(GARBAGE-COLLECTOR) 'INITIALIZE-PACKAGE!) +(package-initialize '(RUNTIME GC-DAEMONS) 'INITIALIZE-PACKAGE!) +(package-initialize '(RUNTIME POPULATION) 'INITIALIZE-PACKAGE!) +(package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-PACKAGE!) +(package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE!) +(package-initialize '(RUNTIME GLOBAL-DATABASE) 'INITIALIZE-PACKAGE!) +(package-initialize '(RUNTIME POPULATION) 'INITIALIZE-UNPARSER!) +(package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-UNPARSER!) +(package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-UNPARSER!) +(package-initialize '(PACKAGE) 'INITIALIZE-UNPARSER!) +(package-initialize '(RUNTIME GARBAGE-COLLECTOR) 'INITIALIZE-PACKAGE!) +(lexical-assignment (package-reference '(RUNTIME GARBAGE-COLLECTOR)) + 'CONSTANT-SPACE/BASE + constant-space/base) ;; Load everything else. ((eval (fasload "runtim.bldr") system-global-environment) (lambda (filename environment) - (if (not (or (string=? filename "gcdemn") + (if (not (or (string=? filename "packag") + (string=? filename "gcdemn") (string=? filename "poplat") (string=? filename "prop1d") (string=? filename "events") @@ -244,81 +297,75 @@ MIT in each case. |# (package-initialization-sequence '( ;; Microcode interface - (MICROCODE-TABLES) - (PRIMITIVE-IO) - (SAVE/RESTORE) - (STATE-SPACE) - (SYSTEM-CLOCK) + (RUNTIME MICROCODE-TABLES) + (RUNTIME PRIMITIVE-IO) + (RUNTIME SAVE/RESTORE) + (RUNTIME STATE-SPACE) + (RUNTIME SYSTEM-CLOCK) ;; Basic data structures - (NUMBER) - (LIST) - (CHARACTER) - (CHARACTER-SET) - (GENSYM) - (STREAM) - (2D-PROPERTY) - (HASH) - (RANDOM-NUMBER) + (RUNTIME NUMBER) + (RUNTIME LIST) + (RUNTIME CHARACTER) + (RUNTIME CHARACTER-SET) + (RUNTIME GENSYM) + (RUNTIME STREAM) + (RUNTIME 2D-PROPERTY) + (RUNTIME HASH) + (RUNTIME RANDOM-NUMBER) ;; Microcode data structures - (HISTORY) - (LAMBDA-ABSTRACTION) - (SCODE) - (SCODE-COMBINATOR) - (SCODE-SCAN) - (SCODE-WALKER) - (CONTINUATION-PARSER) - - ;; I/O ports - (CONSOLE-INPUT) - (CONSOLE-OUTPUT) - (FILE-INPUT) - (FILE-OUTPUT) - (STRING-INPUT) - (STRING-OUTPUT) - (TRUNCATED-STRING-OUTPUT) - (INPUT-PORT) - (OUTPUT-PORT) - (WORKING-DIRECTORY) - (LOAD) + (RUNTIME HISTORY) + (RUNTIME LAMBDA-ABSTRACTION) + (RUNTIME SCODE) + (RUNTIME SCODE-COMBINATOR) + (RUNTIME SCODE-SCAN) + (RUNTIME SCODE-WALKER) + (RUNTIME CONTINUATION-PARSER) + + ;; I/O + (RUNTIME CONSOLE-INPUT) + (RUNTIME CONSOLE-OUTPUT) + (RUNTIME FILE-INPUT) + (RUNTIME FILE-OUTPUT) + (RUNTIME STRING-INPUT) + (RUNTIME STRING-OUTPUT) + (RUNTIME TRUNCATED-STRING-OUTPUT) + (RUNTIME INPUT-PORT) + (RUNTIME OUTPUT-PORT) + (RUNTIME WORKING-DIRECTORY) + (RUNTIME DIRECTORY) + (RUNTIME LOAD) ;; Syntax - (PARSER) - (NUMBER-UNPARSER) - (UNPARSER) - (SYNTAXER) - (MACROS) - (SYSTEM-MACROS) - (DEFSTRUCT) - (UNSYNTAXER) - (PRETTY-PRINTER) - + (RUNTIME PARSER) + (RUNTIME NUMBER-UNPARSER) (RUNTIME UNPARSER) + (RUNTIME SYNTAXER) + (RUNTIME MACROS) + (RUNTIME SYSTEM-MACROS) + (RUNTIME DEFSTRUCT) + (RUNTIME UNSYNTAXER) + (RUNTIME PRETTY-PRINTER) ;; REP Loops - (ERROR-HANDLER) - (MICROCODE-ERRORS) - (INTERRUPT-HANDLER) - (GC-STATISTICS) - (REP) + (RUNTIME ERROR-HANDLER) + (RUNTIME MICROCODE-ERRORS) + (RUNTIME INTERRUPT-HANDLER) + (RUNTIME GC-STATISTICS) + (RUNTIME REP) ;; Debugging - (ADVICE) - (DEBUGGER-COMMAND-LOOP) - (DEBUGGER-UTILITIES) - (ENVIRONMENT-INSPECTOR) - (DEBUGGING-INFO) - (DEBUGGER) - + (RUNTIME ADVICE) + (RUNTIME DEBUGGER-COMMAND-LOOP) + (RUNTIME DEBUGGER-UTILITIES) + (RUNTIME ENVIRONMENT-INSPECTOR) + (RUNTIME DEBUGGING-INFO) + (RUNTIME DEBUGGER) + + (RUNTIME) ;; Emacs -- last because it grabs the kitchen sink. - (EMACS-INTERFACE) + (RUNTIME EMACS-INTERFACE) )) - + ) -(add-system! (make-system "Microcode" - microcode-id/version - microcode-id/modification - '())) -(add-system! (make-system "Runtime" 14 0 '())) -(remove-environment-parent! system-packages) (initial-top-level-repl) \ No newline at end of file diff --git a/v7/src/runtime/msort.scm b/v7/src/runtime/msort.scm index cff751b5f..0fe9902a6 100644 --- a/v7/src/runtime/msort.scm +++ b/v7/src/runtime/msort.scm @@ -1,43 +1,39 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/msort.scm,v 13.42 1987/11/21 18:06:51 jinx Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/msort.scm,v 14.1 1988/06/13 11:47:52 cph Rel $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; Merge Sort +;;; package: () (declare (usual-integrations)) diff --git a/v7/src/runtime/numpar.scm b/v7/src/runtime/numpar.scm index b230c5535..a0faa3f29 100644 --- a/v7/src/runtime/numpar.scm +++ b/v7/src/runtime/numpar.scm @@ -1,75 +1,65 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/numpar.scm,v 13.43 1987/08/25 20:49:23 cph Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/numpar.scm,v 14.1 1988/06/13 11:48:26 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; Number Parser +;;; package: (runtime number-parser) (declare (usual-integrations)) -(define string->number) - -(define number-parser-package - (make-environment - ;;; These are not supported right now. -(define ->exact identity-procedure) -(define ->inexact identity-procedure) -(define ->long-flonum identity-procedure) -(define ->short-flonum identity-procedure) +(define-integrable (->exact number) number) +(define-integrable (->inexact number) number) +(define-integrable (->long-flonum number) number) +(define-integrable (->short-flonum number) number) (define *radix*) -(set! string->number - (named-lambda (string->number string #!optional exactness radix) - ((cond ((or (unassigned? exactness) (not exactness)) identity-procedure) - ((eq? exactness 'E) ->exact) - ((eq? exactness 'I) ->inexact) - (else (error "Illegal exactness argument" exactness))) - (fluid-let ((*radix* - (cond ((unassigned? radix) *parser-radix*) - ((memv radix '(2 8 10 16)) radix) - ((eq? radix 'B) 2) - ((eq? radix 'O) 8) - ((eq? radix 'D) 10) - ((eq? radix 'X) 16) - (else (error "Illegal radix argument" radix))))) - (parse-number (string->list string)))))) +(define (string->number string #!optional exactness radix) + ((cond ((or (default-object? exactness) (not exactness)) identity-procedure) + ((eq? exactness 'E) ->exact) + ((eq? exactness 'I) ->inexact) + (else (error "Illegal exactness argument" exactness))) + (fluid-let ((*radix* + (cond ((default-object? radix) *parser-radix*) + ((memv radix '(2 8 10 16)) radix) + ((eq? radix 'B) 2) + ((eq? radix 'O) 8) + ((eq? radix 'D) 10) + ((eq? radix 'X) 16) + (else (error "Illegal radix argument" radix))))) + (parse-number (string->list string))))) (define (parse-number chars) (parse-real chars @@ -246,6 +236,7 @@ (define (loop chars integer place-value) (parse-digit/sharp chars (lambda (chars count) + count (finish chars (->inexact integer) place-value)) (lambda (chars digit) (loop chars @@ -277,7 +268,4 @@ (let ((digit (char->digit (car chars) *radix*))) (if digit (if-digit (cdr chars) digit) - (otherwise chars)))))) - -;;; end NUMBER-PARSER-PACKAGE -)) \ No newline at end of file + (otherwise chars)))))) \ No newline at end of file diff --git a/v7/src/runtime/output.scm b/v7/src/runtime/output.scm index ad94f78cf..0afc5e749 100644 --- a/v7/src/runtime/output.scm +++ b/v7/src/runtime/output.scm @@ -1,342 +1,249 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/output.scm,v 13.46 1987/06/17 21:03:20 cph Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- -;;;; Output +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/output.scm,v 14.1 1988/06/13 11:48:42 cph Exp $ -(declare (usual-integrations)) - -;;;; Output Ports +Copyright (c) 1988 Massachusetts Institute of Technology -(define output-port-tag - "Output Port") +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. -(define (output-port? object) - (and (environment? object) - (not (lexical-unreferenceable? object ':TYPE)) - (eq? (access :type object) output-port-tag))) +1. Any copy made of this software must include this copyright notice +in full. -(define *current-output-port*) +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. -(define (current-output-port) - *current-output-port*) +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. -(define (with-output-to-port port thunk) - (if (not (output-port? port)) (error "Bad output port" port)) - (fluid-let ((*current-output-port* port)) - (thunk))) +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. -(define (with-output-to-file output-specifier thunk) - (define new-port (open-output-file output-specifier)) - (define old-port) - (dynamic-wind (lambda () - (set! old-port - (set! *current-output-port* - (set! new-port)))) - thunk - (lambda () - (let ((port)) - ;; Only SET! is guaranteed to do the right thing with - ;; an unassigned value. Binding may not work right. - (set! port (set! *current-output-port* (set! old-port))) - (if (not (unassigned? port)) - (close-output-port port)))))) +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. |# -(define (call-with-output-file output-specifier receiver) - (let ((port (open-output-file output-specifier))) - (let ((value (receiver port))) - (close-output-port port) - value))) +;;;; Output +;;; package: (runtime output-port) -(define (close-output-port port) - ((access :close port))) +(declare (usual-integrations)) -;;;; Console Output Port - -(define beep - (make-primitive-procedure 'TTY-BEEP)) - -(define (screen-clear) - ((access :clear-screen console-output-port)) - ((access :flush-output console-output-port))) - -(define console-output-port) -(let () - -(define tty-write-char - (make-primitive-procedure 'TTY-WRITE-CHAR)) - -(define tty-write-string - (make-primitive-procedure 'TTY-WRITE-STRING)) - -(define tty-flush-output - (make-primitive-procedure 'TTY-FLUSH-OUTPUT)) - -(define tty-clear - (make-primitive-procedure 'TTY-CLEAR)) - -(set! console-output-port - (make-environment - -(define :type output-port-tag) +;;;; Output Ports -(define (:print-self) - (unparse-with-brackets - (lambda () - (write-string "Console output port")))) +(define (initialize-package!) + (set! *current-output-port* console-output-port) + (set! beep (wrap-custom-operation-0 'BEEP)) + (set! clear (wrap-custom-operation-0 'CLEAR))) + +(define (output-port/unparse state port) + ((unparser/standard-method 'OUTPUT-PORT + (output-port/custom-operation port 'PRINT-SELF)) + state + port)) + +(define-structure (output-port (conc-name output-port/) + (constructor %make-output-port) + (copier %output-port/copy) + (print-procedure output-port/unparse)) + state + (operation/write-char false read-only true) + (operation/write-string false read-only true) + (operation/flush-output false read-only true) + (custom-operations false read-only true)) + +(define (guarantee-output-port port) + (if (not (output-port? port)) (error "Bad output port" port)) + port) -(define (:close) 'DONE) -(define :write-char tty-write-char) -(define :write-string tty-write-string) -(define :flush-output tty-flush-output) -(define :clear-screen tty-clear) +(define (output-port/custom-operation port name) + (let ((entry (assq name (output-port/custom-operations port)))) + (and entry + (cdr entry)))) -(define (:x-size) - (access printer-width implementation-dependencies)) +(define (output-port/copy port state) + (let ((result (%output-port/copy port))) + (set-output-port/state! result state) + result)) -(define (:y-size) - (access printer-length implementation-dependencies)) +(define (output-port/write-char port char) + ((output-port/operation/write-char port) port char)) -;;; end CONSOLE-OUTPUT-PORT. -)) +(define (output-port/write-string port string) + ((output-port/operation/write-string port) port string)) -) +(define (output-port/flush-output port) + ((output-port/operation/flush-output port) port)) -(set! *current-output-port* console-output-port) +(define (output-port/x-size port) + (or (let ((operation (output-port/custom-operation port 'X-SIZE))) + (and operation + (operation port))) + 79)) -;;; File Output Ports - -(define open-output-file) -(let () -#| -(declare (integrate-primitive-procedures file-write-char file-write-string)) -|# -(define file-write-char - (make-primitive-procedure 'FILE-WRITE-CHAR)) - -(define file-write-string - (make-primitive-procedure 'FILE-WRITE-STRING)) - -(set! open-output-file -(named-lambda (open-output-file filename) - (make-file-output-port - ((access open-output-channel primitive-io) - (canonicalize-output-filename filename))))) - -(define (make-file-output-port file-channel) - -(define :type output-port-tag) - -(define (:print-self) - (unparse-with-brackets - (lambda () - (write-string "Output port for file: ") - (write ((access channel-name primitive-io) file-channel))))) - -(define (:close) - ((access close-physical-channel primitive-io) file-channel)) - -(define (:write-char char) - (file-write-char char file-channel)) - -(define (:write-string string) - (file-write-string string file-channel)) - -(define (:flush-output) 'DONE) -(define (:x-size) false) -(define (:y-size) false) - -;;; end MAKE-FILE-OUTPUT-PORT. -(the-environment)) - -) +(define (make-output-port operations state) + (let ((operations + (map (lambda (entry) + (cons (car entry) (cadr entry))) + operations))) + (let ((operation + (lambda (name default) + (let ((entry (assq name operations))) + (if entry + (begin (set! operations (delq! entry operations)) + (cdr entry)) + (or default + (error "MAKE-OUTPUT-PORT: missing operation" name))))))) + (let ((write-char (operation 'WRITE-CHAR false)) + (write-string + (operation 'WRITE-STRING default-operation/write-string)) + (flush-output + (operation 'FLUSH-OUTPUT default-operation/flush-output))) + (%make-output-port state + write-char + write-string + flush-output + operations))))) + +(define (default-operation/write-string port string) + (let ((write-char (output-port/operation/write-char port)) + (end (string-length string))) + (let loop ((index 0)) + (if (< index end) + (begin (write-char port (string-ref string index)) + (loop (1+ index))))))) + +(define (default-operation/flush-output port) + port + false) -;;;; String Output Ports - -(define (write-to-string object #!optional max) - (if (unassigned? max) (set! max false)) - (if (not max) - (with-output-to-string - (lambda () - (write object))) - (with-output-to-truncated-string max - (lambda () - (write object))))) - -(define (with-output-to-string thunk) - (let ((port (string-output-port))) - (fluid-let ((*current-output-port* port)) - (thunk)) - ((access :value port)))) - -(define (string-output-port) - -(define :type output-port-tag) - -(define (:print-self) - (unparse-with-brackets - (lambda () - (write-string "Output port to string")))) - -(define accumulator '()) - -(define (:value) - (let ((string (apply string-append (reverse! accumulator)))) - (set! accumulator (list string)) - string)) +(define *current-output-port*) -(define (:write-char char) - (set! accumulator (cons (char->string char) accumulator))) +(define-integrable (current-output-port) + *current-output-port*) -(define (:write-string string) - (set! accumulator (cons string accumulator))) +(define (with-output-to-port port thunk) + (cond ((eq? port *current-output-port*) (thunk)) + ((not (output-port? port)) (error "Bad output port" port)) + (else (fluid-let ((*current-output-port* port)) (thunk))))) -(define (:close) 'DONE) -(define (:flush-output) 'DONE) -(define (:x-size) false) -(define (:y-size) false) +(define (with-output-to-file output-specifier thunk) + (let ((new-port (open-output-file output-specifier)) + (old-port false)) + (dynamic-wind (lambda () + (set! old-port *current-output-port*) + (set! *current-output-port* new-port) + (set! new-port false)) + thunk + (lambda () + (if *current-output-port* + (close-output-port *current-output-port*)) + (set! *current-output-port* old-port) + (set! old-port false))))) -;;; end STRING-OUTPUT-PORT. -(the-environment)) - -(define (with-output-to-truncated-string maxsize thunk) - (call-with-current-continuation - (lambda (return) - -(define :type output-port-tag) - -(define (:print-self) - (unparse-with-brackets - (lambda () - (write-string "Output port to truncated string")))) - -(define accumulator '()) -(define counter maxsize) - -(define (:write-char char) - (:write-string (char->string char))) - -(define (:write-string string) - (set! accumulator (cons string accumulator)) - (set! counter (- counter (string-length string))) - (if (negative? counter) - (return (cons true - (substring (apply string-append (reverse! accumulator)) - 0 maxsize))))) - -(define (:close) 'DONE) -(define (:flush-output) 'DONE) -(define (:x-size) false) -(define (:y-size) false) - -(fluid-let ((*current-output-port* (the-environment))) - (thunk)) -(cons false (apply string-append (reverse! accumulator))) - -;;; end WITH-OUTPUT-TO-TRUNCATED-STRING. -))) +(define (call-with-output-file output-specifier receiver) + (let ((port (open-output-file output-specifier))) + (let ((value (receiver port))) + (close-output-port port) + value))) ;;;; Output Procedures (define (newline #!optional port) - (cond ((unassigned? port) (set! port *current-output-port*)) - ((not (output-port? port)) (error "Bad output port" port))) - ((access :write-char port) char:newline) - ((access :flush-output port)) + (let ((port + (if (default-object? port) + (current-output-port) + (guarantee-output-port port)))) + (output-port/write-char port #\Newline) + (output-port/flush-output port)) *the-non-printing-object*) (define (write-char char #!optional port) - (cond ((unassigned? port) (set! port *current-output-port*)) - ((not (output-port? port)) (error "Bad output port" port))) - ((access :write-char port) char) - ((access :flush-output port)) + (let ((port + (if (default-object? port) + (current-output-port) + (guarantee-output-port port)))) + (output-port/write-char port char) + (output-port/flush-output port)) *the-non-printing-object*) (define (write-string string #!optional port) - (cond ((unassigned? port) (set! port *current-output-port*)) - ((not (output-port? port)) (error "Bad output port" port))) - ((access :write-string port) string) - ((access :flush-output port)) + (let ((port + (if (default-object? port) + (current-output-port) + (guarantee-output-port port)))) + (output-port/write-string port string) + (output-port/flush-output port)) + *the-non-printing-object*) + +(define (close-output-port port) + (let ((operation (output-port/custom-operation port 'CLOSE))) + (if operation + (operation port))) *the-non-printing-object*) -(define (unparse-with-brackets thunk) - ((access unparse-with-brackets unparser-package) thunk)) +(define (wrap-custom-operation-0 operation-name) + (lambda (#!optional port) + (let ((port + (if (default-object? port) + (current-output-port) + (guarantee-output-port port)))) + (let ((operation (output-port/custom-operation port operation-name))) + (if operation + (begin + (operation port) + (output-port/flush-output port))))) + *the-non-printing-object*)) + +(define beep) +(define clear) -(define non-printing-object? - (let ((objects - (list *the-non-printing-object* - undefined-conditional-branch - (vector-ref (get-fixed-objects-vector) - (fixed-objects-vector-slot 'NON-OBJECT))))) - (named-lambda (non-printing-object? object) - (and (not (future? object)) - (memq object objects))))) - -(define display) -(define write) -(define write-line) - -(let ((make-unparser - (lambda (handler) - (lambda (object #!optional port) - (if (not (non-printing-object? object)) - (if (unassigned? port) - (handler object *current-output-port*) - (with-output-to-port port - (lambda () - (handler object port))))) - *the-non-printing-object*)))) - (set! display - (make-unparser - (lambda (object port) - (if (and (not (future? object)) - (string? object)) - ((access :write-string port) object) - ((access unparse-object unparser-package) object port false)) - ((access :flush-output port))))) - (set! write - (make-unparser - (lambda (object port) - ((access unparse-object unparser-package) object port true) - ((access :flush-output port))))) - (set! write-line - (make-unparser - (lambda (object port) - ((access :write-char port) char:newline) - ((access unparse-object unparser-package) object port true) - ((access :flush-output port)))))) \ No newline at end of file +(define (display object #!optional port unparser-table) + (let ((port + (if (default-object? port) + (current-output-port) + (guarantee-output-port port))) + (unparser-table + (if (default-object? unparser-table) + (current-unparser-table) + (guarantee-unparser-table unparser-table)))) + (if (string? object) + (output-port/write-string port object) + (unparse-object/internal object port 0 false unparser-table)) + (output-port/flush-output port)) + *the-non-printing-object*) + +(define (write object #!optional port unparser-table) + (let ((port + (if (default-object? port) + (current-output-port) + (guarantee-output-port port))) + (unparser-table + (if (default-object? unparser-table) + (current-unparser-table) + (guarantee-unparser-table unparser-table)))) + (unparse-object/internal object port 0 true unparser-table) + (output-port/flush-output port)) + *the-non-printing-object*) + +(define (write-line object #!optional port unparser-table) + (let ((port + (if (default-object? port) + (current-output-port) + (guarantee-output-port port))) + (unparser-table + (if (default-object? unparser-table) + (current-unparser-table) + (guarantee-unparser-table unparser-table)))) + (output-port/write-char port #\Newline) + (unparse-object/internal object port 0 true unparser-table) + (output-port/flush-output port)) + *the-non-printing-object*) \ No newline at end of file diff --git a/v7/src/runtime/packag.scm b/v7/src/runtime/packag.scm index 0efecfce5..2647663dc 100644 --- a/v7/src/runtime/packag.scm +++ b/v7/src/runtime/packag.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/packag.scm,v 14.1 1988/06/13 10:49:50 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/packag.scm,v 14.2 1988/06/13 11:48:57 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Simple Package Namespace +;;; package: (package) (declare (usual-integrations)) diff --git a/v7/src/runtime/parse.scm b/v7/src/runtime/parse.scm index 9c5c574c7..1b73167b9 100644 --- a/v7/src/runtime/parse.scm +++ b/v7/src/runtime/parse.scm @@ -1,483 +1,459 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/parse.scm,v 13.44 1988/03/05 00:20:30 cph Rel $ -;;; -;;; Copyright (c) 1988 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions and -;;; understandings. -;;; -;;; 1. Any copy made of this software must include this copyright -;;; notice in full. -;;; -;;; 2. Users of this software agree to make their best efforts (a) -;;; to return to the MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. All materials developed as a consequence of the use of this -;;; software shall duly acknowledge such use, in accordance with -;;; the usual standards of acknowledging credit in academic -;;; research. -;;; -;;; 4. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/parse.scm,v 14.1 1988/06/13 11:49:02 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; Scheme Parser +;;; package: (runtime parser) (declare (usual-integrations)) -(define *parser-radix* #d10) -(define *parser-table*) +(define (initialize-package!) + (set! char-set/undefined-atom-delimiters (char-set #\[ #\] #\{ #\} #\|)) + (set! char-set/whitespace + (char-set #\Tab #\Linefeed #\Page #\Return #\Space)) + (set! char-set/non-whitespace (char-set-invert char-set/whitespace)) + (set! char-set/comment-delimiters (char-set #\Newline)) + (set! char-set/special-comment-leaders (char-set #\# #\|)) + (set! char-set/string-delimiters (char-set #\" #\\)) + (set! char-set/atom-delimiters + (char-set-union char-set/whitespace + (char-set-union char-set/undefined-atom-delimiters + (char-set #\( #\) #\; #\" #\' #\`)))) + (set! char-set/atom-constituents (char-set-invert char-set/atom-delimiters)) + (set! char-set/char-delimiters + (char-set-union (char-set #\- #\\) char-set/atom-delimiters)) + (set! char-set/symbol-leaders + (char-set-difference char-set/atom-constituents + (char-set #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 + #\+ #\- #\. #\#))) + + (set! lambda-optional-tag (intern "#!optional")) + (set! lambda-rest-tag (intern "#!rest")) + (set! dot-symbol (intern ".")) + (set! named-objects + `((NULL . ,(list)) + (FALSE . ,false) + (TRUE . ,true) + (OPTIONAL . ,lambda-optional-tag) + (REST . ,lambda-rest-tag))) + + (set! *parser-radix* 10) + (set! system-global-parser-table (make-system-global-parser-table)) + (set-current-parser-table! system-global-parser-table)) + +(define char-set/undefined-atom-delimiters) +(define char-set/whitespace) +(define char-set/non-whitespace) +(define char-set/comment-delimiters) +(define char-set/special-comment-leaders) +(define char-set/string-delimiters) +(define char-set/atom-delimiters) +(define char-set/atom-constituents) +(define char-set/char-delimiters) +(define char-set/symbol-leaders) + +(define lambda-optional-tag) +(define lambda-rest-tag) +(define *parser-radix*) +(define system-global-parser-table) + +(define (make-system-global-parser-table) + (let ((table + (make-parser-table parse-object/atom + (collect-list-wrapper parse-object/atom) + parse-object/special-undefined + collect-list/special-undefined))) + (for-each (lambda (entry) + (parser-table/set-entry! + table + (car entry) + (cadr entry) + (if (null? (cddr entry)) + (collect-list-wrapper (cadr entry)) + (caddr entry)))) + `(("#" ,parse-object/special ,collect-list/special) + (,char-set/symbol-leaders ,parse-object/symbol) + (("#b" "#B") ,parse-object/numeric-prefix) + (("#o" "#O") ,parse-object/numeric-prefix) + (("#d" "#D") ,parse-object/numeric-prefix) + (("#x" "#X") ,parse-object/numeric-prefix) + (("#i" "#I") ,parse-object/numeric-prefix) + (("#e" "#E") ,parse-object/numeric-prefix) + (("#s" "#S") ,parse-object/numeric-prefix) + (("#l" "#L") ,parse-object/numeric-prefix) + ("#*" ,parse-object/bit-string) + ("(" ,parse-object/list-open) + ("#(" ,parse-object/vector-open) + (")" ,parse-object/list-close ,collect-list/list-close) + (,char-set/whitespace + ,parse-object/whitespace + ,collect-list/whitespace) + (,char-set/undefined-atom-delimiters + ,parse-object/undefined-atom-delimiter + ,collect-list/undefined-atom-delimiter) + (";" ,parse-object/comment ,collect-list/comment) + ("#|" + ,parse-object/special-comment + ,collect-list/special-comment) + ("'" ,parse-object/quote) + ("`" ,parse-object/quasiquote) + ("," ,parse-object/unquote) + ("\"" ,parse-object/string-quote) + ("#\\" ,parse-object/char-quote) + (("#f" "#F") ,parse-object/false) + (("#t" "#T") ,parse-object/true) + ("#!" ,parse-object/named-constant))) + table)) + +;;;; Top Level -(define parser-package - (make-environment +(define (parse-object port parser-table) + (if (not (parser-table? parser-table)) + (error "Not a valid parser table" parser-table)) + (parse-object/internal port parser-table)) -(define *parser-parse-object-table*) -(define *parser-collect-list-table*) -(define *parser-parse-object-special-table*) -(define *parser-collect-list-special-table*) -(define *parser-peek-char*) -(define *parser-discard-char*) -(define *parser-read-char*) -(define *parser-read-string*) -(define *parser-discard-chars*) -(define *parser-input-port*) +(define (parse-objects port parser-table last-object?) + (if (not (parser-table? parser-table)) + (error "Not a valid parser table" parser-table)) + (parse-objects/internal port parser-table last-object?)) + +(define (parse-object/internal port parser-table) + (within-parser port parser-table parse-object/dispatch)) -(define (*parse-object port) - (fluid-let ((*parser-input-port* port) - (*parser-parse-object-table* (caar *parser-table*)) - (*parser-collect-list-table* (cdar *parser-table*)) - (*parser-parse-object-special-table* (cadr *parser-table*)) - (*parser-collect-list-special-table* (cddr *parser-table*)) - (*parser-peek-char* (access :peek-char port)) - (*parser-discard-char* (access :discard-char port)) - (*parser-read-char* (access :read-char port)) - (*parser-read-string* (access :read-string port)) - (*parser-discard-chars* (access :discard-chars port))) - (parse-object))) - -(define (*parse-objects-until-eof port) - (fluid-let ((*parser-input-port* port) - (*parser-parse-object-table* (caar *parser-table*)) - (*parser-collect-list-table* (cdar *parser-table*)) - (*parser-parse-object-special-table* (cadr *parser-table*)) - (*parser-collect-list-special-table* (cddr *parser-table*)) - (*parser-peek-char* (access :peek-char port)) - (*parser-discard-char* (access :discard-char port)) - (*parser-read-char* (access :read-char port)) - (*parser-read-string* (access :read-string port)) - (*parser-discard-chars* (access :discard-chars port))) - (define (loop object) - (if (eof-object? object) +(define (parse-objects/internal port parser-table last-object?) + (let loop () + (let ((object (parse-object/internal port parser-table))) + (if (last-object? object) '() - (cons object (loop (parse-object))))) - (loop (parse-object)))) + (cons-stream object (loop)))))) + +(define (within-parser port parser-table thunk) + (fluid-let + ((*parser-input-port* port) + (*parser-peek-char* (input-port/operation/peek-char port)) + (*parser-discard-char* (input-port/operation/discard-char port)) + (*parser-read-char* (input-port/operation/read-char port)) + (*parser-read-string* (input-port/operation/read-string port)) + (*parser-discard-chars* (input-port/operation/discard-chars port)) + (*parser-parse-object-table* (parser-table/parse-object parser-table)) + (*parser-collect-list-table* (parser-table/collect-list parser-table)) + (*parser-parse-object-special-table* + (parser-table/parse-object-special parser-table)) + (*parser-collect-list-special-table* + (parser-table/collect-list-special parser-table))) + (thunk))) ;;;; Character Operations -(declare (integrate peek-char read-char discard-char - read-string discard-chars)) +(define *parser-input-port*) +(define *parser-peek-char*) +(define *parser-discard-char*) +(define *parser-read-char*) +(define *parser-read-string*) +(define *parser-discard-chars*) -(define (peek-char) - (or (*parser-peek-char*) - (error "End of file within READ"))) +(define-integrable (peek-char) + (or (peek-char/eof-ok) + (parse-error/end-of-file))) -(define (read-char) - (or (*parser-read-char*) - (error "End of file within READ"))) +(define-integrable (peek-char/eof-ok) + (*parser-peek-char* *parser-input-port*)) -(define (discard-char) - (*parser-discard-char*)) +(define-integrable (read-char) + (or (read-char/eof-ok) + (parse-error/end-of-file))) -(define (read-string delimiters) - (declare (integrate delimiters)) - (*parser-read-string* delimiters)) +(define-integrable (read-char/eof-ok) + (*parser-read-char* *parser-input-port*)) -(define (discard-chars delimiters) - (declare (integrate delimiters)) - (*parser-discard-chars* delimiters)) - -;;; There are two major dispatch tables, one for parsing at top level, -;;; the other for parsing the elements of a list. Most of the entries -;;; for each table are have similar actions. +(define-integrable (discard-char) + (*parser-discard-char* *parser-input-port*)) -;;; Default is atomic object. Parsing an atomic object does not -;;; consume its terminator. Thus different terminators [such as open -;;; paren, close paren, and whitespace], can have different effects on -;;; parser. +(define-integrable (read-string delimiters) + (*parser-read-string* *parser-input-port* delimiters)) -(define (parse-object:atom) - (build-atom (read-atom))) +(define-integrable (discard-chars delimiters) + (*parser-discard-chars* *parser-input-port* delimiters)) -(define ((collect-list-wrapper object-parser)) - (let ((first (object-parser))) ;forces order. - (let ((rest (collect-list))) - (if (and (pair? rest) - (eq? dot-symbol (car rest))) - (if (and (pair? (cdr rest)) - (null? (cddr rest))) - (cons first (cadr rest)) - (error "PARSE-OBJECT: Improperly formed dotted list" - (cons first rest))) - (cons first rest))))) +(define (parse-error/end-of-file) + (parse-error "end of file")) -(define dot-symbol - (string->symbol ".")) - -(define (parse-undefined-special) - (error "No such special reader macro" (peek-char))) - -(set! *parser-table* - (cons (cons (vector-cons 256 parse-object:atom) - (vector-cons 256 (collect-list-wrapper parse-object:atom))) - (cons (vector-cons 256 parse-undefined-special) - (vector-cons 256 parse-undefined-special)))) - -(define ((parser-char-definer tables) - char/chars procedure #!optional list-procedure) - (if (unassigned? list-procedure) - (set! list-procedure (collect-list-wrapper procedure))) - (define (do-it char) - (vector-set! (car tables) (char->ascii char) procedure) - (vector-set! (cdr tables) (char->ascii char) list-procedure)) - (cond ((char? char/chars) (do-it char/chars)) - ((char-set? char/chars) - (for-each do-it (char-set-members char/chars))) - ((pair? char/chars) (for-each do-it char/chars)) - (else (error "Unknown character" char/chars)))) - -(define define-char - (parser-char-definer (car *parser-table*))) - -(define define-char-special - (parser-char-definer (cdr *parser-table*))) +(define (parse-error message #!optional irritant) + (error (string-append "PARSE-OBJECT: " message) + (if (default-object? irritant) *the-non-printing-object* irritant))) -(declare (integrate peek-ascii parse-object collect-list)) +;;;; Dispatch Points -(define (peek-ascii) - (or (char-ascii? (peek-char)) - (non-ascii-error))) - -(define (non-ascii-error) - (error "Non-ASCII character encountered during parse" (read-char))) +(define *parser-parse-object-table*) +(define *parser-collect-list-table*) +(define *parser-parse-object-special-table*) +(define *parser-collect-list-special-table*) -(define (parse-object) - (let ((char (*parser-peek-char*))) +(define-integrable (parse-object/dispatch) + (let ((char (peek-char/eof-ok))) (if char ((vector-ref *parser-parse-object-table* - (or (char-ascii? char) - (non-ascii-error)))) - eof-object))) + (or (char-ascii? char) (parse-error/non-ascii)))) + (make-eof-object *parser-input-port*)))) -(define (collect-list) +(define-integrable (collect-list/dispatch) ((vector-ref *parser-collect-list-table* (peek-ascii)))) -(define-char #\# - (lambda () - (discard-char) - ((vector-ref *parser-parse-object-special-table* (peek-ascii)))) - (lambda () - (discard-char) - ((vector-ref *parser-collect-list-special-table* (peek-ascii))))) - -(define numeric-leaders - (char-set-union char-set:numeric - (char-set #\+ #\- #\. #\#))) +(define (parse-object/special) + (discard-char) + ((vector-ref *parser-parse-object-special-table* (peek-ascii)))) -(define undefined-atom-delimiters - (char-set #\[ #\] #\{ #\} #\|)) +(define (collect-list/special) + (discard-char) + ((vector-ref *parser-collect-list-special-table* (peek-ascii)))) -(define atom-delimiters - (char-set-union char-set:whitespace - (char-set-union undefined-atom-delimiters - (char-set #\( #\) #\; #\" #\' #\`)))) +(define-integrable (peek-ascii) + (or (char-ascii? (peek-char)) + (parse-error/non-ascii))) -(define atom-constituents - (char-set-invert atom-delimiters)) +(define (parse-error/non-ascii) + (parse-error "Non-ASCII character encountered" (read-char))) -(declare (integrate read-atom)) +(define (parse-object/special-undefined) + (parse-error "No such special reader macro" (peek-char)) + (parse-object/dispatch)) -(define (read-atom) - (read-string atom-delimiters)) +(define (collect-list/special-undefined) + (parse-error "No such special reader macro" (peek-char)) + (collect-list/dispatch)) +;;;; Symbols/Numbers + +(define (parse-object/atom) + (build-atom (read-atom))) + +(define-integrable (read-atom) + (read-string char-set/atom-delimiters)) + (define (build-atom string) (or (parse-number string) (intern-string! string))) -(declare (integrate parse-number)) - -(define (parse-number string) - (declare (integrate string)) +(define-integrable (parse-number string) (string->number string false *parser-radix*)) (define (intern-string! string) + ;; Special version of `intern' to reduce consing and increase speed. (substring-upcase! string 0 (string-length string)) (string->symbol string)) -(define-char (char-set-difference atom-constituents numeric-leaders) - (lambda () - (intern-string! (read-atom)))) - -(let ((numeric-prefix - (lambda () - (let ((number - (let ((char (read-char))) - (string-append (char->string #\# char) (read-atom))))) - (or (parse-number number) - (error "READ: Bad number syntax" number)))))) - (define-char-special '(#\b #\B) numeric-prefix) - (define-char-special '(#\o #\O) numeric-prefix) - (define-char-special '(#\d #\D) numeric-prefix) - (define-char-special '(#\x #\X) numeric-prefix) - (define-char-special '(#\i #\I) numeric-prefix) - (define-char-special '(#\e #\E) numeric-prefix) - (define-char-special '(#\s #\S) numeric-prefix) - (define-char-special '(#\l #\L) numeric-prefix)) - -(define-char #\( - (lambda () - (discard-char) - (collect-list/top-level))) +(define (parse-object/symbol) + (intern-string! (read-atom))) + +(define (parse-object/numeric-prefix) + (let ((number + (let ((char (read-char))) + (string-append (char->string #\# char) (read-atom))))) + (or (parse-number number) + (parse-error "Bad number syntax" number)))) -(define-char-special #\( - (lambda () - (discard-char) - (list->vector (collect-list/top-level)))) +(define (parse-object/bit-string) + (discard-char) + (let ((string (read-atom))) + (unsigned-integer->bit-string + (string-length string) + (or (string->number string false 2) + (error "READ: bad syntax for bit-string"))))) +;;;; Lists/Vectors + +(define (parse-object/list-open) + (discard-char) + (collect-list/top-level)) + +(define (parse-object/vector-open) + (discard-char) + (list->vector (collect-list/top-level))) + +(define (parse-object/list-close) + (if (and ignore-extra-list-closes + (eq? console-input-port *parser-input-port*)) + (discard-char) + (parse-error "Unmatched close paren" (read-char))) + (parse-object/dispatch)) + +(define (collect-list/list-close) + (discard-char) + '()) + +(define ignore-extra-list-closes + true) (define (collect-list/top-level) - (let ((value (collect-list))) + (let ((value (collect-list/dispatch))) (if (and (pair? value) (eq? dot-symbol (car value))) - (error "PARSE-OBJECT: Improperly formed dotted list" value) + (parse-error "Improperly formed dotted list" value) value))) -(define ignore-extra-close-parens - true) +(define ((collect-list-wrapper parse-object)) + (let ((first (parse-object))) ;forces order. + (let ((rest (collect-list/dispatch))) + (if (and (pair? rest) + (eq? dot-symbol (car rest))) + (if (and (pair? (cdr rest)) + (null? (cddr rest))) + (cons first (cadr rest)) + (parse-error "Improperly formed dotted list" (cons first rest))) + (cons first rest))))) -(define-char #\) - (lambda () - (if (and ignore-extra-close-parens - (eq? console-input-port *parser-input-port*)) - (discard-char) - (error "PARSE-OBJECT: Unmatched close paren" (read-char))) - (parse-object)) - (lambda () - (discard-char) - '())) +(define dot-symbol) -(define-char undefined-atom-delimiters - (lambda () - (error "PARSE-OBJECT: Undefined atom delimiter" (read-char)) - (parse-object)) - (lambda () - (error "PARSE-OBJECT: Undefined atom delimiter" (read-char)) - (collect-list))) - -(let () - -(define-char char-set:whitespace - (lambda () - (discard-whitespace) - (parse-object)) - (lambda () - (discard-whitespace) - (collect-list))) +;;;; Whitespace/Comments + +(define (parse-object/whitespace) + (discard-whitespace) + (parse-object/dispatch)) + +(define (collect-list/whitespace) + (discard-whitespace) + (collect-list/dispatch)) (define (discard-whitespace) - (discard-chars non-whitespace)) + (discard-chars char-set/non-whitespace)) -(define non-whitespace - (char-set-invert char-set:whitespace)) +(define (parse-object/undefined-atom-delimiter) + (parse-error "Undefined atom delimiter" (read-char)) + (parse-object/dispatch)) -) - -(let () +(define (collect-list/undefined-atom-delimiter) + (parse-error "Undefined atom delimiter" (read-char)) + (collect-list/dispatch)) -(define-char #\; - (lambda () - (discard-comment) - (parse-object)) - (lambda () - (discard-comment) - (collect-list))) +(define (parse-object/comment) + (discard-comment) + (parse-object/dispatch)) + +(define (collect-list/comment) + (discard-comment) + (collect-list/dispatch)) (define (discard-comment) (discard-char) - (discard-chars comment-delimiters) + (discard-chars char-set/comment-delimiters) (discard-char)) -(define comment-delimiters - (char-set char:newline)) - -) - -(let () +(define (parse-object/special-comment) + (discard-special-comment) + (parse-object/dispatch)) -(define-char-special #\| - (lambda () - (discard-char) - (discard-special-comment) - (parse-object)) - (lambda () - (discard-char) - (discard-special-comment) - (collect-list))) +(define (collect-list/special-comment) + (discard-special-comment) + (collect-list/dispatch)) (define (discard-special-comment) - (discard-chars special-comment-leaders) - (if (char=? #\| (read-char)) - (if (char=? #\# (peek-char)) - (discard-char) - (discard-special-comment)) - (begin (if (char=? #\| (peek-char)) - (begin (discard-char) - (discard-special-comment))) - (discard-special-comment)))) - -(define special-comment-leaders - (char-set #\# #\|)) - -) - -(define-char #\' - (lambda () - (discard-char) - (list 'QUOTE (parse-object)))) - -(define-char #\` - (lambda () - (discard-char) - (list 'QUASIQUOTE (parse-object)))) - -(define-char #\, - (lambda () - (discard-char) - (if (char=? #\@ (peek-char)) - (begin (discard-char) - (list 'UNQUOTE-SPLICING (parse-object))) - (list 'UNQUOTE (parse-object))))) - -(define-char #\" - (let ((delimiters (char-set #\" #\\))) - (lambda () - (define (loop string) - (if (char=? #\" (read-char)) - string - (let ((char (read-char))) - (string-append string - (char->string - (cond ((char-ci=? char #\t) #\Tab) - ((char-ci=? char #\n) char:newline) - ((char-ci=? char #\f) #\Page) - (else char))) - (loop (read-string delimiters)))))) - (discard-char) - (loop (read-string delimiters))))) + (discard-char) + (let loop () + (discard-chars char-set/special-comment-leaders) + (if (char=? #\| (read-char)) + (if (char=? #\# (peek-char)) + (discard-char) + (loop)) + (begin (if (char=? #\| (peek-char)) + (begin (discard-char) + (loop))) + (loop))))) -(define-char-special #\\ - (let ((delimiters (char-set-union (char-set #\- #\\) atom-delimiters))) - (lambda () - (define (loop) - (cond ((char=? #\\ (peek-char)) - (discard-char) - (char->string (read-char))) - ((char-set-member? delimiters (peek-char)) - (char->string (read-char))) - (else - (let ((string (read-string delimiters))) - (if (let ((char (*parser-peek-char*))) - (and char - (char=? #\- char))) - (begin (discard-char) - (string-append string "-" (loop))) - string))))) - (discard-char) - (if (char=? #\\ (peek-char)) - (read-char) - (name->char (loop)))))) +;;;; Quoting -(define ((fixed-object-parser object)) +(define (parse-object/quote) (discard-char) - object) - -(define-char-special '(#\f #\F) (fixed-object-parser false)) -(define-char-special '(#\t #\T) (fixed-object-parser true)) - -(define-char-special #\! - (lambda () - (discard-char) - (let ((object-name (parse-object))) - (cdr (or (assq object-name named-objects) - (error "No object by this name" object-name)))))) - -(define named-objects - `((NULL . ,(list)) - (FALSE . ,(eq? 'TRUE 'FALSE)) - (TRUE . ,(eq? 'TRUE 'TRUE)) - (OPTIONAL . ,(access lambda-optional-tag lambda-package)) - (REST . ,(access lambda-rest-tag lambda-package)))) - -;;; end PARSER-PACKAGE. -)) - -;;;; Parser Tables - -(define (parser-table-copy table) - (cons (cons (vector-copy (caar table)) - (vector-copy (cdar table))) - (cons (vector-copy (cadr table)) - (vector-copy (cddr table))))) - -(define parser-table-entry) -(define set-parser-table-entry!) -(let () - -(define (decode-parser-char table char receiver) - (cond ((char? char) - (receiver (car table) (char->ascii char))) - ((string? char) - (cond ((= (string-length char) 1) - (receiver (car table) (char->ascii (string-ref char 0)))) - ((and (= (string-length char) 2) - (char=? #\# (string-ref char 0))) - (receiver (cdr table) (char->ascii (string-ref char 1)))) - (else - (error "Bad character" 'DECODE-PARSER-CHAR char)))) - (else - (error "Bad character" 'DECODE-PARSER-CHAR char)))) + (list 'QUOTE (parse-object/dispatch))) -(define (ptable-ref table index) - (cons (vector-ref (car table) index) - (vector-ref (cdr table) index))) +(define (parse-object/quasiquote) + (discard-char) + (list 'QUASIQUOTE (parse-object/dispatch))) -(define (ptable-set! table index value) - (vector-set! (car table) index (car value)) - (vector-set! (cdr table) index (cdr value))) +(define (parse-object/unquote) + (discard-char) + (if (char=? #\@ (peek-char)) + (begin (discard-char) + (list 'UNQUOTE-SPLICING (parse-object/dispatch))) + (list 'UNQUOTE (parse-object/dispatch)))) -(set! parser-table-entry -(named-lambda (parser-table-entry table char) - (decode-parser-char table char ptable-ref))) +(define (parse-object/string-quote) + (discard-char) + (let loop () + (let ((string (read-string char-set/string-delimiters))) + (if (char=? #\" (read-char)) + string + (let ((char (read-char))) + (string-append string + (char->string + (cond ((char-ci=? char #\t) #\Tab) + ((char-ci=? char #\n) #\Newline) + ((char-ci=? char #\f) #\Page) + (else char))) + (loop))))))) + +(define (parse-object/char-quote) + (discard-char) + (if (char=? #\\ (peek-char)) + (read-char) + (name->char + (let loop () + (cond ((char=? #\\ (peek-char)) + (discard-char) + (char->string (read-char))) + ((char-set-member? char-set/char-delimiters (peek-char)) + (char->string (read-char))) + (else + (let ((string (read-string char-set/char-delimiters))) + (if (let ((char (peek-char/eof-ok))) + (and char + (char=? #\- char))) + (begin (discard-char) + (string-append string "-" (loop))) + string)))))))) + +;;;; Constants -(set! set-parser-table-entry! -(named-lambda (set-parser-table-entry! table char entry) - (decode-parser-char table char - (lambda (sub-table index) - (ptable-set! sub-table index entry))))) +(define (parse-object/false) + (discard-char) + false) -) +(define (parse-object/true) + (discard-char) + true) + +(define (parse-object/named-constant) + (discard-char) + (let ((object-name (parse-object/dispatch))) + (cdr (or (assq object-name named-objects) + (parse-error "No object by this name" object-name))))) +(define named-objects) \ No newline at end of file diff --git a/v7/src/runtime/partab.scm b/v7/src/runtime/partab.scm index 8a40ead0e..a37fab566 100644 --- a/v7/src/runtime/partab.scm +++ b/v7/src/runtime/partab.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/partab.scm,v 14.1 1988/05/20 00:59:48 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/partab.scm,v 14.2 1988/06/13 11:49:18 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,7 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Parser Tables -;;; package: parser-table-package +;;; package: (runtime parser-table) (declare (usual-integrations)) diff --git a/v7/src/runtime/pathnm.scm b/v7/src/runtime/pathnm.scm index 8e648c8ea..f8aa6ae15 100644 --- a/v7/src/runtime/pathnm.scm +++ b/v7/src/runtime/pathnm.scm @@ -1,43 +1,39 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pathnm.scm,v 13.44 1987/08/20 04:03:53 cph Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pathnm.scm,v 14.1 1988/06/13 11:49:23 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; Pathnames +;;; package: (runtime pathname) (declare (usual-integrations)) #| @@ -98,65 +94,34 @@ See the files unkpth.scm, vmspth.scm, or unxpth.scm for examples.|# ;;;; Basic Pathnames -;;; The following definition won't work because the type system isn't -;;; defined when this file is loaded: - -;;; (define-structure pathname -;;; (device false read-only true) -;;; (directory false read-only true) -;;; (name false read-only true) -;;; (type false read-only true) -;;; (version false read-only true)) - -(define make-pathname) -(define pathname?) -(let ((pathname-tag "pathname")) - (set! make-pathname - (named-lambda (make-pathname device directory name type version) - (vector pathname-tag device directory name type version))) - (set! pathname? - (named-lambda (pathname? object) - (and (vector? object) - (not (zero? (vector-length object))) - (eq? pathname-tag (vector-ref object 0)))))) - -(declare (integrate-operator pathname-device - pathname-directory - pathname-name - pathname-type - pathname-version)) - -(define (pathname-device pathname) - (declare (integrate pathname)) - (vector-ref pathname 1)) - -(define (pathname-directory pathname) - (declare (integrate pathname)) - (vector-ref pathname 2)) - -(define (pathname-name pathname) - (declare (integrate pathname)) - (vector-ref pathname 3)) - -(define (pathname-type pathname) - (declare (integrate pathname)) - (vector-ref pathname 4)) - -(define (pathname-version pathname) - (declare (integrate pathname)) - (vector-ref pathname 5)) - -(declare (integrate copy-pathname)) - -(define copy-pathname - vector-copy) - +(define-structure (pathname + (copier pathname-copy) + (print-procedure + (unparser/standard-method 'PATHNAME + (lambda (state pathname) + (unparse-object state (pathname->string pathname)))))) + (host false read-only true) + (device false read-only true) + (directory false read-only true) + (name false read-only true) + (type false read-only true) + (version false read-only true)) + +(define (pathname-components pathname receiver) + (receiver (pathname-host pathname) + (pathname-device pathname) + (pathname-directory pathname) + (pathname-name pathname) + (pathname-type pathname) + (pathname-version pathname))) + (define (pathname-absolute? pathname) (let ((directory (pathname-directory pathname))) (and (pair? directory) (eq? (car directory) 'ROOT)))) (define (pathname-directory-path pathname) - (make-pathname (pathname-device pathname) + (make-pathname (pathname-host pathname) + (pathname-device pathname) (pathname-directory pathname) false false @@ -164,46 +129,98 @@ See the files unkpth.scm, vmspth.scm, or unxpth.scm for examples.|# (define (pathname-name-path pathname) (make-pathname false + false false (pathname-name pathname) (pathname-type pathname) (pathname-version pathname))) + +(define (pathname-new-host pathname host) + (make-pathname host + (pathname-device pathname) + (pathname-directory pathname) + (pathname-name pathname) + (pathname-type pathname) + (pathname-version pathname))) (define (pathname-new-device pathname device) - (make-pathname device + (make-pathname (pathname-host pathname) + device (pathname-directory pathname) (pathname-name pathname) (pathname-type pathname) (pathname-version pathname))) (define (pathname-new-directory pathname directory) - (make-pathname (pathname-device pathname) + (make-pathname (pathname-host pathname) + (pathname-device pathname) directory (pathname-name pathname) (pathname-type pathname) (pathname-version pathname))) (define (pathname-new-name pathname name) - (make-pathname (pathname-device pathname) + (make-pathname (pathname-host pathname) + (pathname-device pathname) (pathname-directory pathname) name (pathname-type pathname) (pathname-version pathname))) (define (pathname-new-type pathname type) - (make-pathname (pathname-device pathname) + (make-pathname (pathname-host pathname) + (pathname-device pathname) (pathname-directory pathname) (pathname-name pathname) type (pathname-version pathname))) (define (pathname-new-version pathname version) - (make-pathname (pathname-device pathname) + (make-pathname (pathname-host pathname) + (pathname-device pathname) (pathname-directory pathname) (pathname-name pathname) (pathname-type pathname) version)) +(define (pathname-default-host pathname host) + (if (pathname-host pathname) + pathname + (pathname-new-host pathname host))) + +(define (pathname-default-device pathname device) + (if (pathname-device pathname) + pathname + (pathname-new-device pathname device))) + +(define (pathname-default-directory pathname directory) + (if (pathname-directory pathname) + pathname + (pathname-new-directory pathname directory))) + +(define (pathname-default-name pathname name) + (if (pathname-name pathname) + pathname + (pathname-new-name pathname name))) + +(define (pathname-default-type pathname type) + (if (pathname-type pathname) + pathname + (pathname-new-type pathname type))) + +(define (pathname-default-version pathname version) + (if (pathname-version pathname) + pathname + (pathname-new-version pathname version))) + +(define (pathname-default pathname host device directory name type version) + (make-pathname (or (pathname-host pathname) host) + (or (pathname-device pathname) device) + (or (pathname-directory pathname) directory) + (or (pathname-name pathname) name) + (or (pathname-type pathname) type) + (or (pathname-version pathname) version))) + ;;;; Pathname Syntax (define (->pathname object) @@ -216,14 +233,16 @@ See the files unkpth.scm, vmspth.scm, or unxpth.scm for examples.|# (parse-pathname string make-pathname)) (define (pathname->string pathname) - (pathname-unparse (pathname-device pathname) + (pathname-unparse (pathname-host pathname) + (pathname-device pathname) (pathname-directory pathname) (pathname-name pathname) (pathname-type pathname) (pathname-version pathname))) (define (pathname-directory-string pathname) - (pathname-unparse (pathname-device pathname) + (pathname-unparse (pathname-host pathname) + (pathname-device pathname) (pathname-directory pathname) false false @@ -231,42 +250,12 @@ See the files unkpth.scm, vmspth.scm, or unxpth.scm for examples.|# (define (pathname-name-string pathname) (pathname-unparse false + false false (pathname-name pathname) (pathname-type pathname) (pathname-version pathname))) -(define (pathname-components pathname receiver) - (receiver (pathname-device pathname) - (pathname-directory pathname) - (pathname-name pathname) - (pathname-type pathname) - (pathname-version pathname))) - -(define (pathname-extract pathname . fields) - (make-pathname (and (memq 'DEVICE fields) - (pathname-device pathname)) - (and (memq 'DIRECTORY fields) - (pathname-directory pathname)) - (and (memq 'NAME fields) - (pathname-name pathname)) - (and (memq 'TYPE fields) - (pathname-type pathname)) - (and (memq 'VERSION fields) - (pathname-version pathname)))) - -(define (pathname-extract-string pathname . fields) - (pathname-unparse (and (memq 'DEVICE fields) - (pathname-device pathname)) - (and (memq 'DIRECTORY fields) - (pathname-directory pathname)) - (and (memq 'NAME fields) - (pathname-name pathname)) - (and (memq 'TYPE fields) - (pathname-type pathname)) - (and (memq 'VERSION fields) - (pathname-version pathname)))) - ;;;; Pathname Merging (define (pathname->absolute-pathname pathname) @@ -274,6 +263,7 @@ See the files unkpth.scm, vmspth.scm, or unxpth.scm for examples.|# (define (merge-pathnames pathname default) (make-pathname + (or (pathname-host pathname) (pathname-host default)) (or (pathname-device pathname) (pathname-device default)) (simplify-directory (let ((directory (pathname-directory pathname)) @@ -292,47 +282,52 @@ See the files unkpth.scm, vmspth.scm, or unxpth.scm for examples.|# (or (pathname-type pathname) (pathname-type default)) (or (pathname-version pathname) (pathname-version default)))) -(define simplify-directory) -(let () - -(set! simplify-directory - (named-lambda (simplify-directory directory) - (cond ((not (pair? directory)) directory) - ((eq? (car directory) 'ROOT) - (cons 'ROOT (simplify-tail (simplify-root-tail (cdr directory))))) - (else (simplify-tail directory))))) +(define (simplify-directory directory) + (if (or (null? directory) + (not (list? directory))) + directory + (let ((directory (delq 'SELF directory))) + (cond ((null? directory) + directory) + ((eq? (car directory) 'ROOT) + (cons 'ROOT + (simplify-tail (simplify-root-tail (cdr directory))))) + (else + (simplify-tail directory)))))) (define (simplify-root-tail directory) - (if (and (pair? directory) - (memq (car directory) '(SELF UP))) + (if (and (not (null? directory)) + (eq? (car directory) 'UP)) (simplify-root-tail (cdr directory)) directory)) (define (simplify-tail directory) - (cond ((not (pair? directory)) directory) - ((eq? (car directory) 'SELF) (simplify-tail (cdr directory))) - ((not (pair? (cdr directory))) directory) - ((eq? (cadr directory) 'UP) (simplify-tail (cddr directory))) - (else (cons (car directory) (simplify-tail (cdr directory)))))) - -) + (reverse! + (let loop ((elements (reverse directory))) + (if (null? elements) + '() + (let ((head (car elements)) + (tail (loop (cdr elements)))) + (if (and (eq? head 'UP) + (not (null? tail)) + (not (eq? (car tail) 'UP))) + (cdr tail) + (cons head tail))))))) ;;;; Truenames -(define pathname->input-truename - (let ((truename-exists? - (let ((file-exists? (make-primitive-procedure 'FILE-EXISTS?))) - (lambda (pathname) - (and (file-exists? (pathname->string pathname)) - pathname))))) - (named-lambda (pathname->input-truename pathname) - (let ((pathname (pathname->absolute-pathname pathname))) - (cond ((not (eq? 'NEWEST (pathname-version pathname))) - (truename-exists? pathname)) - ((not pathname-newest) - (truename-exists? (pathname-new-version pathname false))) - (else - (pathname-newest pathname))))))) +(define (pathname->input-truename pathname) + (let ((pathname (pathname->absolute-pathname pathname)) + (truename-exists? + (lambda (pathname) + (and ((ucode-primitive file-exists?) (pathname->string pathname)) + pathname)))) + (cond ((not (eq? 'NEWEST (pathname-version pathname))) + (truename-exists? pathname)) + ((not pathname-newest) + (truename-exists? (pathname-new-version pathname false))) + (else + (pathname-newest pathname))))) (define (pathname->output-truename pathname) (let ((pathname (pathname->absolute-pathname pathname))) @@ -358,4 +353,12 @@ See the files unkpth.scm, vmspth.scm, or unxpth.scm for examples.|# (pathname->string (pathname->output-truename (->pathname filename)))) (define (file-exists? filename) - (pathname->input-truename (->pathname filename))) \ No newline at end of file + (pathname->input-truename (->pathname filename))) + +(define (init-file-truename) + (let ((pathname (init-file-pathname))) + (and pathname + (or (pathname->input-truename + (merge-pathnames pathname (working-directory-pathname))) + (pathname->input-truename + (merge-pathnames pathname (home-directory-pathname))))))) \ No newline at end of file diff --git a/v7/src/runtime/poplat.scm b/v7/src/runtime/poplat.scm index 979251857..b5d376e94 100644 --- a/v7/src/runtime/poplat.scm +++ b/v7/src/runtime/poplat.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/poplat.scm,v 14.1 1988/05/20 01:00:04 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/poplat.scm,v 14.2 1988/06/13 11:49:48 cph Rel $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,7 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Populations -;;; package: population-package +;;; package: (runtime population) (declare (usual-integrations)) diff --git a/v7/src/runtime/pp.scm b/v7/src/runtime/pp.scm index 85213ed8b..7ca1457d1 100644 --- a/v7/src/runtime/pp.scm +++ b/v7/src/runtime/pp.scm @@ -1,91 +1,122 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pp.scm,v 13.44 1987/06/26 04:31:51 jinx Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- -;;;; Pretty Printer +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pp.scm,v 14.1 1988/06/13 11:49:53 cph Exp $ -(declare (usual-integrations)) - -(define scheme-pretty-printer - (make-environment +Copyright (c) 1988 Massachusetts Institute of Technology -(define *pp-primitives-by-name* true) -(define *forced-x-size* false) -(define *default-x-size* 80) +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. -(define x-size) -(define next-coords) -(define add-sc-entry!) -(define sc-relink!) - -(declare (integrate *unparse-string *unparse-char)) +1. Any copy made of this software must include this copyright notice +in full. -(define (*unparse-string string) - (declare (integrate string)) - ((access :write-string *current-output-port*) string)) +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. -(define (*unparse-char char) - (declare (integrate char)) - ((access :write-char *current-output-port*) char)) +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. -(define (*unparse-open) - (*unparse-char #\()) +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. -(define (*unparse-close) - (*unparse-char #\))) +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. |# -(define (*unparse-space) - (*unparse-char #\Space)) +;;;; Pretty Printer +;;; package: (runtime pretty-printer) -(define (*unparse-newline) - (*unparse-char char:newline)) +(declare (usual-integrations)) -;;;; Top Level - -(define (pp expression as-code?) - (fluid-let ((x-size (get-x-size))) +(define (initialize-package!) + (set! forced-indentation (special-printer kernel/forced-indentation)) + (set! pressured-indentation (special-printer kernel/pressured-indentation)) + (set! print-procedure (special-printer kernel/print-procedure)) + (set! print-let-expression (special-printer kernel/print-let-expression)) + (set! dispatch-list + `((COND . ,forced-indentation) + (IF . ,forced-indentation) + (OR . ,forced-indentation) + (AND . ,forced-indentation) + (LET . ,print-let-expression) + (FLUID-LET . ,print-let-expression) + (DEFINE . ,print-procedure) + (LAMBDA . ,print-procedure) + (NAMED-LAMBDA . ,print-procedure))) + (set! walk-dispatcher default/walk-dispatcher)) + +(define (pp scode . optionals) + (let ((kernel + (lambda (as-code?) + (let ((port (current-output-port))) + (if (and (not (compound-procedure? scode)) + (scode-constant? scode)) + (pp-top-level port scode as-code?) + (pp-top-level port + (let ((sexp (unsyntax scode))) + (if (and (pair? sexp) + (eq? (car sexp) 'NAMED-LAMBDA)) + `(DEFINE ,@(cdr sexp)) + sexp)) + true))))) + (bad-arg + (lambda (argument) + (error "PP: Bad optional argument" argument)))) + (cond ((null? optionals) + (kernel false)) + ((null? (cdr optionals)) + (cond ((eq? (car optionals) 'AS-CODE) + (kernel true)) + ((output-port? (car optionals)) + (with-output-to-port (car optionals) + (lambda () + (kernel false)))) + (else + (bad-arg (car optionals))))) + ((null? (cddr optionals)) + (cond ((eq? (car optionals) 'AS-CODE) + (if (output-port? (cadr optionals)) + (with-output-to-port (cadr optionals) + (lambda () + (kernel true))) + (bad-arg (cadr optionals)))) + ((output-port? (car optionals)) + (if (eq? (cadr optionals) 'AS-CODE) + (with-output-to-port (car optionals) + (lambda () + (kernel true))) + (bad-arg (cadr optionals)))) + (else + (bad-arg (car optionals))))) + (else + (error "PP: Too many optional arguments" optionals)))) + *the-non-printing-object*) + +(define (pp-top-level port expression as-code?) + (fluid-let + ((x-size (get-x-size port)) + (output-port port) + (operation/write-char (output-port/operation/write-char port)) + (operation/write-string (output-port/operation/write-string port))) (let ((node (numerical-walk expression))) - (*unparse-newline) - ((if as-code? print-node print-non-code-node) node 0 0) - ((access :flush-output *current-output-port*))))) + (*unparse-newline) ((if as-code? print-node print-non-code-node) node 0 0) + (output-port/flush-output port)))) (define (stepper-pp expression port p-wrapper table nc relink! sc! offset) - (fluid-let ((x-size (get-x-size)) + (fluid-let ((x-size (get-x-size port)) + (output-port port) + (operation/write-char (output-port/operation/write-char port)) + (operation/write-string + (output-port/operation/write-string port)) (walk-dispatcher table) (next-coords nc) (sc-relink! relink!) @@ -98,16 +129,43 @@ (print-node (p-wrapper print-node)) (print-guaranteed-node (p-wrapper print-guaranteed-node))) (let ((node (numerical-walk expression))) - (with-output-to-port port - (lambda () - (print-node node (car offset) 0) - ((access :flush-output *current-output-port*))))))) + (print-node node (car offset) 0) + (output-port/flush-output port)))) -(define (get-x-size) +(define (get-x-size port) (or *forced-x-size* - ((access :x-size *current-output-port*)) - *default-x-size*)) + (output-port/x-size port))) + +(define *pp-primitives-by-name* true) +(define *forced-x-size* false) +(define x-size) +(define output-port) +(define operation/write-char) +(define operation/write-string) + +(define next-coords) +(define add-sc-entry!) +(define sc-relink!) + +(define-integrable (*unparse-char char) + (operation/write-char output-port char)) + +(define-integrable (*unparse-string string) + (operation/write-string output-port string)) + +(define-integrable (*unparse-open) + (*unparse-char #\()) + +(define-integrable (*unparse-close) + (*unparse-char #\))) + +(define-integrable (*unparse-space) + (*unparse-char #\Space)) + +(define-integrable (*unparse-newline) + (*unparse-char #\Newline)) + (define (print-non-code-node node column depth) (fluid-let ((dispatch-list '())) (print-node node column depth))) @@ -181,6 +239,8 @@ (print-column nodes column depth)))) (*unparse-close)) +(define dispatch-list) + (define ((special-printer procedure) nodes column depth) (*unparse-open) (*unparse-symbol (car nodes)) @@ -194,34 +254,32 @@ ;;; Force the indentation to be an optimistic column. -(define forced-indentation - (special-printer - (lambda (nodes optimistic pessimistic depth) - (print-column nodes optimistic depth)))) +(define forced-indentation) +(define (kernel/forced-indentation nodes optimistic pessimistic depth) + pessimistic + (print-column nodes optimistic depth)) ;;; Pressure the indentation to be an optimistic column; no matter ;;; what happens, insist on a column, but accept a pessimistic one if ;;; necessary. -(define pressured-indentation - (special-printer - (lambda (nodes optimistic pessimistic depth) - (if (fits-as-column? nodes optimistic depth) - (print-guaranteed-column nodes optimistic) - (begin (tab-to pessimistic) - (print-column nodes pessimistic depth)))))) +(define pressured-indentation) +(define (kernel/pressured-indentation nodes optimistic pessimistic depth) + (if (fits-as-column? nodes optimistic depth) + (print-guaranteed-column nodes optimistic) + (begin (tab-to pessimistic) + (print-column nodes pessimistic depth)))) ;;; Print a procedure definition. The bound variable pattern goes on ;;; the same line as the keyword, while everything else gets indented ;;; pessimistically. We may later want to modify this to make higher ;;; order procedure patterns be printed more carefully. -(define print-procedure - (special-printer - (lambda (nodes optimistic pessimistic depth) - (print-node (car nodes) optimistic 0) - (tab-to pessimistic) - (print-column (cdr nodes) pessimistic depth)))) +(define print-procedure) +(define (kernel/print-procedure nodes optimistic pessimistic depth) + (print-node (car nodes) optimistic 0) + (tab-to pessimistic) + (print-column (cdr nodes) pessimistic depth)) ;;; Print a binding form. There is a great deal of complication here, ;;; some of which is to gracefully handle the case of a badly-formed @@ -231,57 +289,43 @@ ;;; start on that line if possible; otherwise they line up under the ;;; name. The body, of course, is always indented pessimistically. -(define print-let-expression - (special-printer - (lambda (nodes optimistic pessimistic depth) - (define (print-body nodes) - (if (not (null? nodes)) - (begin (tab-to pessimistic) - (print-column nodes pessimistic depth)))) - (cond ((null? (cdr nodes)) ;Screw case. - (print-node (car nodes) optimistic depth)) - ((symbol? (car nodes)) ;Named LET. - (*unparse-symbol (car nodes)) - (let ((new-optimistic - (1+ (+ optimistic (symbol-length (car nodes)))))) - (cond ((fits-within? (cadr nodes) new-optimistic 0) - (*unparse-space) - (print-guaranteed-node (cadr nodes)) - (print-body (cddr nodes))) - ((fits-as-column? (node-subnodes (cadr nodes)) - (+ new-optimistic 2) - 0) - (*unparse-space) - (*unparse-open) - (print-guaranteed-column (node-subnodes (cadr nodes)) - (1+ new-optimistic)) - (*unparse-close) - (print-body (cddr nodes))) - (else - (tab-to optimistic) - (print-node (cadr nodes) optimistic 0) - (print-body (cddr nodes)))))) - (else ;Ordinary LET. - (print-node (car nodes) optimistic 0) - (print-body (cdr nodes))))))) +(define print-let-expression) +(define (kernel/print-let-expression nodes optimistic pessimistic depth) + (let ((print-body + (lambda (nodes) + (if (not (null? nodes)) + (begin (tab-to pessimistic) + (print-column nodes pessimistic depth)))))) + (cond ((null? (cdr nodes)) ;Screw case. + (print-node (car nodes) optimistic depth)) + ((symbol? (car nodes)) ;Named LET. + (*unparse-symbol (car nodes)) + (let ((new-optimistic + (1+ (+ optimistic (symbol-length (car nodes)))))) + (cond ((fits-within? (cadr nodes) new-optimistic 0) + (*unparse-space) + (print-guaranteed-node (cadr nodes)) + (print-body (cddr nodes))) + ((fits-as-column? (node-subnodes (cadr nodes)) + (+ new-optimistic 2) + 0) + (*unparse-space) + (*unparse-open) + (print-guaranteed-column (node-subnodes (cadr nodes)) + (1+ new-optimistic)) + (*unparse-close) + (print-body (cddr nodes))) + (else + (tab-to optimistic) + (print-node (cadr nodes) optimistic 0) + (print-body (cddr nodes)))))) + (else ;Ordinary LET. + (print-node (car nodes) optimistic 0) + (print-body (cdr nodes)))))) -(define dispatch-list - `((COND . ,forced-indentation) - (IF . ,forced-indentation) - (OR . ,forced-indentation) - (AND . ,forced-indentation) - (LET . ,print-let-expression) - (FLUID-LET . ,print-let-expression) - (DEFINE . ,print-procedure) - (LAMBDA . ,print-procedure) - (NAMED-LAMBDA . ,print-procedure))) - ;;;; Alignment -(declare (integrate fits-within?)) - -(define (fits-within? node column depth) - (declare (integrate node column depth)) +(define-integrable (fits-within? node column depth) (> (- x-size depth) (+ column (node-size node)))) @@ -315,7 +359,20 @@ (define (numerical-walk object) ((walk-dispatcher object) object)) -(define (walk-general object) +(define walk-dispatcher) +(define (default/walk-dispatcher x) + (cond ((object-type? (ucode-type interned-symbol) x) identity-procedure) + ((primitive-procedure? x) walk-primitive) + ((and (pair? x) + (not (unparse-list/unparser x))) + walk-pair) + ((and (vector? x) + (not (zero? (vector-length x))) + (not (unparse-vector/unparser x))) + walk-vector) + (else walk-general))) + +(define-integrable (walk-general object) (write-to-string object)) (define (walk-primitive primitive) @@ -324,41 +381,18 @@ (write-to-string primitive))) (define (walk-pair pair) - (if (and (eq? (car pair) 'QUOTE) - (pair? (cdr pair)) - (null? (cddr pair))) - (make-prefix-node "'" (numerical-walk (cadr pair))) - (walk-unquoted-pair pair))) - -(define (walk-unquoted-pair pair) - (cond (((access unparse-list/unparser unparser-package) pair) - (walk-general pair)) - ((null? (cdr pair)) - (make-singleton-list-node (numerical-walk (car pair)))) - (else - (make-list-node - (numerical-walk (car pair)) - (if (and (pair? (cdr pair)) - (not - ((access unparse-list/unparser unparser-package) - (cdr pair)))) - (walk-unquoted-pair (cdr pair)) - (make-singleton-list-node - (make-prefix-node ". " (numerical-walk (cdr pair))))))))) + (if (null? (cdr pair)) + (make-singleton-list-node (numerical-walk (car pair))) + (make-list-node + (numerical-walk (car pair)) + (if (and (pair? (cdr pair)) + (not (unparse-list/unparser (cdr pair)))) + (walk-pair (cdr pair)) + (make-singleton-list-node + (make-prefix-node ". " (numerical-walk (cdr pair)))))))) (define (walk-vector vector) - (if (zero? (vector-length vector)) - "#()" - (make-prefix-node "#" (walk-unquoted-pair (vector->list vector))))) - -(define walk-dispatcher - (make-type-dispatcher - `((,symbol-type ,identity-procedure) - (,primitive-procedure-type ,walk-primitive) - (,(microcode-type-object 'PAIR) ,walk-pair) - (,(microcode-type-object 'VECTOR) ,walk-vector) - (,unparser-special-object-type ,walk-general)) - walk-general)) + (make-prefix-node "#" (walk-pair (vector->list vector)))) ;;;; Node Model ;;; Carefully crafted to use the least amount of memory, while at the @@ -368,13 +402,10 @@ ;;; or the print-name of a symbol wasn't worth the speed that would ;;; be gained by keeping it around. -(declare (integrate symbol-length)) - -(define (symbol-length symbol) - (declare (integrate symbol)) +(define-integrable (symbol-length symbol) (string-length (symbol->string symbol))) -(define (*unparse-symbol symbol) +(define-integrable (*unparse-symbol symbol) (*unparse-string (symbol->string symbol))) (define (make-prefix-node prefix subnode) @@ -388,11 +419,18 @@ (node-subnode subnode))) (else (string-append prefix subnode)))) -(define prefix-node? vector?) -(define prefix-node-size vector-first) -(define node-prefix vector-second) -(define node-subnode vector-third) +(define-integrable (prefix-node? object) + (vector? object)) + +(define-integrable (prefix-node-size node) + (vector-ref node 0)) +(define-integrable (node-prefix node) + (vector-ref node 1)) + +(define-integrable (node-subnode node) + (vector-ref node 2)) + (define (make-list-node car-node cdr-node) (cons (1+ (+ (node-size car-node) (list-node-size cdr-node))) ;+1 space. (cons car-node (node-subnodes cdr-node)))) @@ -401,70 +439,18 @@ (cons (+ 2 (node-size car-node)) ;+1 each parenthesis. (list car-node))) -(declare (integrate list-node? list-node-size node-subnodes)) +(define-integrable (list-node? object) + (pair? object)) + +(define-integrable (list-node-size node) + (car node)) -(define list-node? pair?) -(define list-node-size car) -(define node-subnodes cdr) +(define-integrable (node-subnodes node) + (cdr node)) (define (node-size node) ((cond ((list-node? node) list-node-size) ((symbol? node) symbol-length) ((prefix-node? node) prefix-node-size) (else string-length)) - node)) - -;;; end SCHEME-PRETTY-PRINTER package. -)) - -;;;; Exports - -(define pp - (let () - (define (prepare scode) - (let ((s-expression (unsyntax scode))) - (if (and (pair? s-expression) - (eq? (car s-expression) 'NAMED-LAMBDA)) - `(DEFINE ,@(cdr s-expression)) - s-expression))) - - (define (bad-arg argument) - (error "Bad optional argument" 'PP argument)) - - (lambda (scode . optionals) - (define (kernel as-code?) - (if (scode-constant? scode) - ((access pp scheme-pretty-printer) scode as-code?) - ((access pp scheme-pretty-printer) (prepare scode) true))) - - (cond ((null? optionals) - (kernel false)) - ((null? (cdr optionals)) - (cond ((eq? (car optionals) 'AS-CODE) - (kernel true)) - ((output-port? (car optionals)) - (with-output-to-port (car optionals) - (lambda () (kernel false)))) - (else - (bad-arg (car optionals))))) - ((null? (cddr optionals)) - (cond ((eq? (car optionals) 'AS-CODE) - (if (output-port? (cadr optionals)) - (with-output-to-port (cadr optionals) - (lambda () (kernel true))) - (bad-arg (cadr optionals)))) - ((output-port? (car optionals)) - (if (eq? (cadr optionals) 'AS-CODE) - (with-output-to-port (car optionals) - (lambda () (kernel true))) - (bad-arg (cadr optionals)))) - (else - (bad-arg (car optionals))))) - (else - (error "Too many optional arguments" 'PP optionals))) - *the-non-printing-object*))) - -(define (pa procedure) - (if (not (compound-procedure? procedure)) - (error "Must be a compound procedure" procedure)) - (pp (unsyntax-lambda-list (procedure-lambda procedure)))) \ No newline at end of file + node)) \ No newline at end of file diff --git a/v7/src/runtime/prop1d.scm b/v7/src/runtime/prop1d.scm index e1a588f16..99f73c8da 100644 --- a/v7/src/runtime/prop1d.scm +++ b/v7/src/runtime/prop1d.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/prop1d.scm,v 14.1 1988/05/20 01:00:22 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/prop1d.scm,v 14.2 1988/06/13 11:50:11 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,7 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; One Dimensional Property Tables -;;; package: 1d-property-package +;;; package: (runtime 1d-property) (declare (usual-integrations)) @@ -88,6 +88,12 @@ MIT in each case. |# (system-pair-cdr entry) default))) +(define (1d-table/lookup table key if-found if-not-found) + (let ((entry (weak-assq (or key false-key) table))) + (if entry + (if-found (system-pair-cdr entry)) + (if-not-found)))) + (define (1d-table/put! table key value) (let ((key (or key false-key))) (let ((entry (weak-assq key table))) diff --git a/v7/src/runtime/prop2d.scm b/v7/src/runtime/prop2d.scm index 785f1443b..3f0f7d667 100644 --- a/v7/src/runtime/prop2d.scm +++ b/v7/src/runtime/prop2d.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/prop2d.scm,v 14.1 1988/05/20 01:00:38 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/prop2d.scm,v 14.2 1988/06/13 11:50:17 cph Rel $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,7 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Two Dimensional Property Tables -;;; package: 2D-property-package +;;; package: (runtime 2D-property) (declare (usual-integrations)) diff --git a/v7/src/runtime/qsort.scm b/v7/src/runtime/qsort.scm index 51483a837..290884ac2 100644 --- a/v7/src/runtime/qsort.scm +++ b/v7/src/runtime/qsort.scm @@ -1,95 +1,88 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/qsort.scm,v 13.41 1987/01/23 00:18:12 jinx Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/qsort.scm,v 14.1 1988/06/13 11:50:22 cph Rel $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; Quick Sort +;;; package: () (declare (usual-integrations)) -(define (sort obj pred) - (if (vector? obj) - (sort! (vector-copy obj) pred) - (vector->list (sort! (list->vector obj) pred)))) - -(define sort! - (let () - - (define (exchange! vec i j) - ;; Speedup hack uses value of VECTOR-SET!. - (vector-set! vec j (vector-set! vec i (vector-ref vec j)))) - - (named-lambda (sort! obj pred) - (define (sort-internal! vec l r) - (cond - ((<= r l) - vec) - ((= r (1+ l)) - (if (pred (vector-ref vec r) - (vector-ref vec l)) - (exchange! vec l r) - vec)) - (else - (quick-merge vec l r)))) - - (define (quick-merge vec l r) - (let ((first (vector-ref vec l))) - (define (increase-i i) - (if (or (> i r) - (pred first (vector-ref vec i))) - i - (increase-i (1+ i)))) - (define (decrease-j j) - (if (or (<= j l) - (not (pred first (vector-ref vec j)))) - j - (decrease-j (-1+ j)))) - (define (loop i j) - (if (< i j) ;* used to be <= - (begin (exchange! vec i j) - (loop (increase-i (1+ i)) (decrease-j (-1+ j)))) - (begin (if (> j l) - (exchange! vec j l)) - (sort-internal! vec (1+ j) r) - (sort-internal! vec l (-1+ j))))) - (loop (increase-i (1+ l)) - (decrease-j r)))) - - (if (vector? obj) - (begin (sort-internal! obj 0 (-1+ (vector-length obj))) - obj) - (error "SORT! works on vectors only" obj))))) +(define (sort vector predicate) + (if (vector? vector) + (sort! (vector-copy vector) predicate) + (vector->list (sort! (list->vector vector) predicate)))) + +(define (sort! vector predicate) + + (define (outer-loop l r) + (if (> r l) + (if (= r (1+ l)) + (if (predicate (vector-ref vector r) + (vector-ref vector l)) + (exchange! l r)) + (let ((lth-element (vector-ref vector l))) + + (define (increase-i i) + (if (or (> i r) + (predicate lth-element (vector-ref vector i))) + i + (increase-i (1+ i)))) + + (define (decrease-j j) + (if (or (<= j l) + (not (predicate lth-element (vector-ref vector j)))) + j + (decrease-j (-1+ j)))) + + (define (inner-loop i j) + (if (< i j) ;used to be <= + (begin (exchange! i j) + (inner-loop (increase-i (1+ i)) + (decrease-j (-1+ j)))) + (begin (if (> j l) + (exchange! j l)) + (outer-loop (1+ j) r) + (outer-loop l (-1+ j))))) + + (inner-loop (increase-i (1+ l)) + (decrease-j r)))))) + + (define-integrable (exchange! i j) + (let ((ith-element (vector-ref vector i))) + (vector-set! vector i (vector-ref vector j)) + (vector-set! vector j ith-element))) + + (if (not (vector? vector)) + (error "SORT! works on vectors only" vector)) + (outer-loop 0 (-1+ (vector-length vector))) + vector) \ No newline at end of file diff --git a/v7/src/runtime/queue.scm b/v7/src/runtime/queue.scm index 12473c17e..5347f56eb 100644 --- a/v7/src/runtime/queue.scm +++ b/v7/src/runtime/queue.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/queue.scm,v 14.1 1988/05/20 01:00:54 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/queue.scm,v 14.2 1988/06/13 11:50:28 cph Rel $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Simple Queue Abstraction +;;; package: () (declare (usual-integrations)) diff --git a/v7/src/runtime/random.scm b/v7/src/runtime/random.scm index 7e8055415..f97caa6a3 100644 --- a/v7/src/runtime/random.scm +++ b/v7/src/runtime/random.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/random.scm,v 14.1 1988/05/20 01:01:13 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/random.scm,v 14.2 1988/06/13 11:50:32 cph Rel $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,7 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Random Number Generator -;;; package: random-number-package +;;; package: (runtime random-number) (declare (usual-integrations)) diff --git a/v7/src/runtime/rep.scm b/v7/src/runtime/rep.scm index 4e174feee..b9ffaf5c4 100644 --- a/v7/src/runtime/rep.scm +++ b/v7/src/runtime/rep.scm @@ -1,339 +1,556 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 13.44 1988/04/26 19:41:15 cph Exp $ -;;; -;;; Copyright (c) 1988 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions and -;;; understandings. -;;; -;;; 1. Any copy made of this software must include this copyright -;;; notice in full. -;;; -;;; 2. Users of this software agree to make their best efforts (a) -;;; to return to the MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. All materials developed as a consequence of the use of this -;;; software shall duly acknowledge such use, in accordance with -;;; the usual standards of acknowledging credit in academic -;;; research. -;;; -;;; 4. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 14.1 1988/06/13 11:50:36 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; Read-Eval-Print Loop +;;; package: (runtime rep) (declare (usual-integrations)) +(define (initialize-package!) + (set! *nearest-cmdl* false) + (set! hook/cmdl-prompt default/cmdl-prompt) + (set! hook/cmdl-message default/cmdl-message) + (set! cmdl-interrupt/breakpoint default/breakpoint) + (set! cmdl-interrupt/abort-top-level default/abort-top-level) + (set! cmdl-interrupt/abort-previous default/abort-previous) + (set! cmdl-interrupt/abort-nearest default/abort-nearest) + (set! hook/repl-environment default/repl-environment) + (set! hook/repl-read default/repl-read) + (set! hook/repl-write default/repl-write) + (set! hook/repl-eval default/repl-eval) + (set! hook/read-command-char default/read-command-char) + (set! hook/prompt-for-confirmation default/prompt-for-confirmation) + (set! hook/prompt-for-expression default/prompt-for-expression)) + +(define (initial-top-level-repl) + (fluid-let ((user-repl-environment user-initial-environment) + (user-repl-syntax-table user-initial-syntax-table)) + (let loop ((message "Cold load finished")) + (with-standard-proceed-point + (lambda () + (make-repl false + user-repl-environment + user-repl-syntax-table + user-initial-prompt + console-input-port + console-output-port + (cmdl-message/standard message)))) + (loop "Reset!")))) + ;;;; Command Loops -(define make-command-loop) -(define push-command-loop) -(define push-command-hook) -(define with-rep-continuation) -(define continue-rep) -(define rep-continuation) -(define rep-state) -(define rep-level) -(define abort->nearest) -(define abort->previous) -(define abort->top-level) -(let () - -(define top-level-driver-hook) -(define previous-driver-hook) -(define nearest-driver-hook) -(define current-continuation) -(define current-state) -(define current-level 0) - -;; PUSH-COMMAND-HOOK is provided so that the Butterfly, in particular, -;; can add its own little code just before creating a REP loop -(set! push-command-hook - (lambda (startup driver state continuation) - (continuation startup driver state (lambda () 'ignore)))) - -(set! make-command-loop - (named-lambda (make-command-loop message driver) - (define (driver-loop message) - (driver-loop - (with-rep-continuation - (lambda (quit) - (set! top-level-driver-hook quit) - (set! nearest-driver-hook quit) - (driver message))))) - (set-interrupt-enables! interrupt-mask-gc-ok) - (fluid-let ((top-level-driver-hook) - (nearest-driver-hook)) - (driver-loop message)))) - -(set! push-command-loop -(named-lambda (push-command-loop startup-hook driver initial-state) - (define (restart entry-hook each-time) - (let ((reentry-hook - (call-with-current-continuation - (lambda (again) - (set! nearest-driver-hook again) - (set-interrupt-enables! interrupt-mask-all) - (each-time) - (entry-hook) - (loop))))) - (set-interrupt-enables! interrupt-mask-gc-ok) - (restart reentry-hook each-time))) - - (define (loop) - (set! current-state (driver current-state)) - (loop)) - - (fluid-let ((current-level (1+ current-level)) - (previous-driver-hook nearest-driver-hook) - (nearest-driver-hook) - (current-state)) - (push-command-hook - startup-hook driver initial-state - (lambda (startup-hook driver initial-state each-time) - (set! current-state initial-state) - (restart startup-hook each-time)))))) +(define-structure (cmdl (conc-name cmdl/) (constructor %make-cmdl)) + (parent false read-only true) + (level false read-only true) + (driver false read-only true) + (proceed-continuation false read-only true) + continuation + input-port + output-port + state) + +(define (make-cmdl parent input-port output-port driver state message) + (if (and parent (not (cmdl? parent))) + (error "MAKE-CMDL: illegal parent" parent)) + (let ((cmdl + (%make-cmdl parent + (let loop ((parent parent)) + (if parent + (1+ (loop (cmdl/parent parent))) + 1)) + driver + (current-proceed-continuation) + false + input-port + output-port + state))) + (let loop ((message message)) + (loop + (call-with-current-continuation + (lambda (continuation) + (set-cmdl/continuation! cmdl continuation) + (fluid-let + ((*nearest-cmdl* cmdl) + (cmdl-interrupt/abort-nearest default/abort-nearest) + (cmdl-interrupt/abort-previous default/abort-previous) + (cmdl-interrupt/abort-top-level default/abort-top-level) + (cmdl-interrupt/breakpoint default/breakpoint)) + (with-interrupt-mask interrupt-mask/all + (lambda (interrupt-mask) + interrupt-mask + (message cmdl) + (driver cmdl)))))))))) + +(define *nearest-cmdl*) + +(define (nearest-cmdl) + (if (not *nearest-cmdl*) (error "NEAREST-CMDL: no cmdl")) + *nearest-cmdl*) + +(define (push-cmdl driver state message) + (let ((cmdl (nearest-cmdl))) + (make-cmdl cmdl + (cmdl/input-port cmdl) + (cmdl/output-port cmdl) + driver + state + message))) + +(define (cmdl/base cmdl) + (let ((parent (cmdl/parent cmdl))) + (if parent + (cmdl/base parent) + cmdl))) -(set! with-rep-continuation -(named-lambda (with-rep-continuation receiver) - (call-with-current-continuation - (lambda (raw-continuation) - (let ((continuation (raw-continuation->continuation raw-continuation))) - (fluid-let ((current-continuation continuation)) - (receiver continuation))))))) - -(set! continue-rep -(named-lambda (continue-rep value) - (current-continuation - (if (eq? current-continuation top-level-driver-hook) - (lambda () - (write-line value)) - value)))) +;;;; Messages -(set! abort->nearest -(named-lambda (abort->nearest message) - (nearest-driver-hook message))) +(define hook/cmdl-prompt) -(set! abort->previous -(named-lambda (abort->previous message) - ((if (null? previous-driver-hook) - nearest-driver-hook - previous-driver-hook) - message))) +(define (default/cmdl-prompt cmdl prompt) + (write-string + (string-append "\n\n" (number->string (cmdl/level cmdl)) " " prompt " ") + (cmdl/output-port cmdl))) -(set! abort->top-level -(named-lambda (abort->top-level message) - (top-level-driver-hook message))) +(define ((cmdl-message/standard string) cmdl) + (hook/cmdl-message cmdl string)) -(set! rep-continuation -(named-lambda (rep-continuation) - current-continuation)) +(define hook/cmdl-message) -(set! rep-state -(named-lambda (rep-state) - current-state)) +(define (default/cmdl-message cmdl string) + (write-string (string-append "\n" string) (cmdl/output-port cmdl))) -(set! rep-level -(named-lambda (rep-level) - current-level)) +(define ((cmdl-message/strings . strings) cmdl) + (let ((port (cmdl/output-port cmdl))) + (for-each (lambda (string) + (write-string (string-append "\n" string) port)) + strings))) -) ; LET - -;;;; Read-Eval-Print Loops - -(define *rep-base-environment*) -(define *rep-current-environment*) -(define *rep-base-syntax-table*) -(define *rep-current-syntax-table*) -(define *rep-base-prompt*) -(define *rep-current-prompt*) -(define *rep-base-input-port*) -(define *rep-current-input-port*) -(define *rep-base-output-port*) -(define *rep-current-output-port*) -(define *rep-keyboard-map*) -(define *rep-error-hook*) - -(define (rep-environment) - *rep-current-environment*) - -(define (rep-base-environment) - *rep-base-environment*) - -(define (set-rep-environment! environment) - (set! *rep-current-environment* environment) - (environment-warning-hook *rep-current-environment*)) - -(define (set-rep-base-environment! environment) - (set! *rep-base-environment* environment) - (set! *rep-current-environment* environment) - (environment-warning-hook *rep-current-environment*)) - -(define (rep-syntax-table) - *rep-current-syntax-table*) - -(define (rep-base-syntax-table) - *rep-base-syntax-table*) - -(define (set-rep-syntax-table! syntax-table) - (set! *rep-current-syntax-table* syntax-table)) - -(define (set-rep-base-syntax-table! syntax-table) - (set! *rep-base-syntax-table* syntax-table) - (set! *rep-current-syntax-table* syntax-table)) +(define ((cmdl-message/null) cmdl) + cmdl + false) + +(define ((cmdl-message/active thunk) cmdl) + (with-output-to-port (cmdl/output-port cmdl) + thunk)) + +(define ((cmdl-message/append . messages) cmdl) + (for-each (lambda (message) (message cmdl)) messages)) -(define (rep-prompt) - *rep-current-prompt*) +;;;; Interrupts -(define (set-rep-prompt! prompt) - (set! *rep-current-prompt* prompt)) +(define cmdl-interrupt/abort-nearest) +(define cmdl-interrupt/abort-previous) +(define cmdl-interrupt/abort-top-level) +(define cmdl-interrupt/breakpoint) -(define (rep-base-prompt) - *rep-base-prompt*) +(define (default/abort-nearest) + (abort-to-nearest-driver "Abort!")) -(define (set-rep-base-prompt! prompt) - (set! *rep-base-prompt* prompt) - (set! *rep-current-prompt* prompt)) +(define (abort-to-nearest-driver message) + (abort->nearest (cmdl-message/standard message))) -(define (rep-input-port) - *rep-current-input-port*) +(define (abort->nearest message) + ((cmdl/continuation (nearest-cmdl)) message)) -(define (rep-output-port) - *rep-current-output-port*) +(define (default/abort-previous) + (abort-to-previous-driver "Up!")) -(define environment-warning-hook - identity-procedure) +(define (abort-to-previous-driver message) + (abort->previous (cmdl-message/standard message))) -(define rep-read-hook - read) +(define (abort->previous message) + ((cmdl/continuation + (let ((cmdl (nearest-cmdl))) + (or (cmdl/parent cmdl) + cmdl))) + message)) -(define rep-value-hook - write-line) +(define (default/abort-top-level) + (abort-to-top-level-driver "Quit!")) -(define make-rep) -(define push-rep) -(define rep-eval-hook) -(define rep-value) -(define reader-history) -(define printer-history) -(let () - -(set! make-rep -(named-lambda (make-rep environment syntax-table prompt input-port output-port - message) - (fluid-let ((*rep-base-environment* environment) - (*rep-base-syntax-table* syntax-table) - (*rep-base-prompt* prompt) - (*rep-base-input-port* input-port) - (*rep-base-output-port* output-port) - (*rep-keyboard-map* (keyboard-interrupt-dispatch-table)) - (*rep-error-hook* (access *error-hook* error-system))) - (make-command-loop message rep-top-driver)))) - -(define (rep-top-driver message) - (push-rep *rep-base-environment* message *rep-base-prompt*)) - -(set! push-rep -(named-lambda (push-rep environment message prompt) - (fluid-let ((*rep-current-environment* environment) - (*rep-current-syntax-table* *rep-base-syntax-table*) - (*rep-current-prompt* prompt) - (*rep-current-input-port* *rep-base-input-port*) - (*rep-current-output-port* *rep-base-output-port*) - (*current-input-port* *rep-base-input-port*) - (*current-output-port* *rep-base-output-port*) - ((access *error-hook* error-system) *rep-error-hook*)) - (with-keyboard-interrupt-dispatch-table *rep-keyboard-map* - (lambda () - (environment-warning-hook *rep-current-environment*) - (push-command-loop message - rep-driver - (make-rep-state (make-history 5) - (make-history 10)))))))) - -(define (rep-driver state) - (*rep-current-prompt*) - (rep-value (rep-eval-hook (rep-read-hook) - *rep-current-environment* - *rep-current-syntax-table*)) - state) +(define (abort-to-top-level-driver message) + (abort->top-level (cmdl-message/standard message))) -(set! rep-eval-hook - (named-lambda (rep-eval-hook s-expression environment syntax-table) - (record-in-history! (rep-state-reader-history (rep-state)) s-expression) - (with-new-history - (let ((scode (syntax s-expression syntax-table))) - (lambda () (scode-eval scode environment)))))) - -(set! rep-value - (named-lambda (rep-value object) - (record-in-history! (rep-state-printer-history (rep-state)) object) - (rep-value-hook object))) - -;;; History Manipulation +(define (abort->top-level message) + ((let ((cmdl (cmdl/base (nearest-cmdl)))) + (if cmdl-interrupt/abort-top-level/reset? + (cmdl/proceed-continuation cmdl) + (cmdl/continuation cmdl))) + message)) -(define (make-history size) - (let ((list (make-list size '()))) - (append! list list) - (vector history-tag size list))) +;; User option variable +(define cmdl-interrupt/abort-top-level/reset? false) -(define history-tag - '(REP-HISTORY)) +(define (default/breakpoint) + (with-standard-proceed-point + (lambda () + (breakpoint (cmdl-message/standard "^B interrupt") + (standard-repl-environment))))) + +;;;; Proceed -(define (record-in-history! history object) - (if (not (null? (vector-ref history 2))) - (begin (set-car! (vector-ref history 2) object) - (vector-set! history 2 (cdr (vector-ref history 2)))))) +(define (with-proceed-point value-filter thunk) + (call-with-current-continuation + (lambda (continuation) + (fluid-let ((proceed-continuation continuation) + (proceed-value-filter value-filter)) + (thunk))))) -(define (read-history history n) - (if (not (and (integer? n) - (not (negative? n)) - (< n (vector-ref history 1)))) - (error "Bad argument: READ-HISTORY" n)) - (list-ref (vector-ref history 2) - (- (-1+ (vector-ref history 1)) n))) +(define (current-proceed-continuation) + proceed-continuation) -(define ((history-reader selector name) n) - (let ((state (rep-state))) - (if (rep-state? state) - (read-history (selector state) n) - (error "Not in REP loop" name)))) +(define (proceed . arguments) + (proceed-value-filter proceed-continuation arguments)) -(define rep-state-tag - "REP State") +(define proceed-continuation false) +(define proceed-value-filter) -(define (make-rep-state reader-history printer-history) - (vector rep-state-tag reader-history printer-history)) +(define (with-standard-proceed-point thunk) + (with-proceed-point standard-value-filter thunk)) -(define (rep-state? object) - (and (vector? object) - (not (zero? (vector-length object))) - (eq? (vector-ref object 0) rep-state-tag))) +(define (standard-value-filter continuation arguments) + (continuation + (if (null? arguments) + *the-non-printing-object* + (car arguments)))) + +;;;; REP Loops + +(define-structure (repl-state (conc-name repl-state/)) + prompt + environment + syntax-table + reader-history + printer-history) + +(define (make-repl parent environment syntax-table prompt input-port + output-port message) + (make-cmdl parent + input-port + output-port + repl-driver + (make-repl-state prompt + environment + syntax-table + (make-repl-history reader-history-size) + (make-repl-history printer-history-size)) + message)) + +(define (repl-driver repl) + (fluid-let ((hook/error-handler default/error-handler)) + (hook/cmdl-prompt repl (repl/prompt repl)) + (let ((s-expression (hook/repl-read repl))) + (cmdl-message/value + (hook/repl-eval repl + s-expression + (repl/environment repl) + (repl/syntax-table repl)))))) + +(define (repl? object) + (and (cmdl? object) + (repl-state? (cmdl/state object)))) + +(define-integrable (repl/prompt repl) + (repl-state/prompt (cmdl/state repl))) + +(define-integrable (set-repl/prompt! repl prompt) + (set-repl-state/prompt! (cmdl/state repl) prompt)) + +(define-integrable (repl/environment repl) + (repl-state/environment (cmdl/state repl))) + +(define-integrable (set-repl/environment! repl environment) + (set-repl-state/environment! (cmdl/state repl) environment)) + +(define-integrable (repl/syntax-table repl) + (repl-state/syntax-table (cmdl/state repl))) + +(define-integrable (set-repl/syntax-table! repl syntax-table) + (set-repl-state/syntax-table! (cmdl/state repl) syntax-table)) + +(define-integrable (repl/reader-history repl) + (repl-state/reader-history (cmdl/state repl))) + +(define-integrable (set-repl/reader-history! repl reader-history) + (set-repl-state/reader-history! (cmdl/state repl) reader-history)) + +(define-integrable (repl/printer-history repl) + (repl-state/printer-history (cmdl/state repl))) + +(define-integrable (set-repl/printer-history! repl printer-history) + (set-repl-state/printer-history! (cmdl/state repl) printer-history)) + +(define (repl/parent repl) + (skip-non-repls (cmdl/parent repl))) + +(define (nearest-repl) + (or (skip-non-repls (nearest-cmdl)) + (error "NEAREST-REPL: no REPLs"))) + +(define (skip-non-repls cmdl) + (and cmdl + (if (repl-state? (cmdl/state cmdl)) + cmdl + (skip-non-repls (cmdl/parent cmdl))))) + +(define (repl/base repl) + (let ((parent (repl/parent repl))) + (if parent + (repl/base parent) + repl))) + +(define (standard-repl-environment) + (let ((repl (nearest-repl))) + (if repl + (repl/environment repl) + user-initial-environment))) + +(define (standard-repl-syntax-table) + (let ((repl (nearest-repl))) + (if repl + (repl/syntax-table repl) + user-initial-syntax-table))) + +(define (push-repl environment message prompt) + (let ((parent (nearest-cmdl))) + (make-repl parent + environment + (standard-repl-syntax-table) + prompt + (cmdl/input-port parent) + (cmdl/output-port parent) + message))) + +(define (read-eval-print environment message prompt) + (with-standard-proceed-point + (lambda () + (push-repl environment message prompt)))) + +(define (breakpoint message environment) + (push-repl environment message "Bkpt->")) + +(define (breakpoint-procedure environment message . irritants) + (with-history-disabled + (lambda () + (with-standard-proceed-point + (lambda () + (breakpoint (apply cmdl-message/error message irritants) + environment)))))) + +;;;; Hooks + +(define hook/repl-environment) +(define hook/repl-read) +(define hook/repl-eval) +(define hook/repl-write) + +(define (default/repl-environment repl environment) + repl environment + false) + +(define (default/repl-read repl) + (let ((s-expression (read (cmdl/input-port repl)))) + (repl-history/record! (repl/reader-history repl) s-expression) + s-expression)) + +(define (default/repl-eval repl s-expression environment syntax-table) + repl ;ignore + (let ((scode (syntax s-expression syntax-table))) + (with-new-history (lambda () (scode-eval scode environment))))) +(define ((cmdl-message/value value) repl) + (hook/repl-write repl value)) + +(define (default/repl-write repl object) + (repl-history/record! (repl/printer-history repl) object) + (let ((port (cmdl/output-port repl))) + (if (undefined-value? object) + (write-string "\n;No value" port) + (write-line object port)))) + +;;;; History -(define rep-state-reader-history vector-second) -(define rep-state-printer-history vector-third) +(define reader-history-size 5) +(define printer-history-size 10) -(set! reader-history - (history-reader rep-state-reader-history 'READER-HISTORY)) +(define-structure (repl-history (constructor %make-repl-history) + (conc-name repl-history/)) + (size false read-only true) + elements) -(set! printer-history - (history-reader rep-state-printer-history 'PRINTER-HISTORY)) +(define (make-repl-history size) + (%make-repl-history size (make-circular-list size '()))) -) \ No newline at end of file +(define (repl-history/record! history object) + (let ((elements (repl-history/elements history))) + (if (not (null? elements)) + (begin (set-car! elements object) + (set-repl-history/elements! history (cdr elements)))))) + +(define (repl-history/read history n) + (if (not (and (integer? n) + (not (negative? n)) (< n (repl-history/size history)))) + (error "REPL-HISTORY/READ: Bad argument" n)) + (list-ref (repl-history/elements history) + (- (-1+ (repl-history/size history)) n))) + +;;; User Interface Stuff + +(define user-repl-environment) +(define user-repl-syntax-table) + +(define (ge environment) + (let ((repl (nearest-repl)) + (environment (->environment environment))) + (set! user-repl-environment environment) + (set-repl-state/environment! (cmdl/state repl) environment) + (hook/repl-environment repl environment) + environment)) + +(define (ve environment) + (let ((repl (nearest-repl)) + (environment (->environment environment))) + (set-repl-state/environment! (cmdl/state repl) environment) + (set-repl-state/prompt! (cmdl/state repl) "Visiting->") + (hook/repl-environment repl environment) + environment)) + +(define (->environment object) + (cond ((or (eq? object system-global-environment) + (environment? object)) + object) + ((compound-procedure? object) (procedure-environment object)) + ((promise? object) + (promise-environment object)) + (else + (let ((package + (let ((package-name + (cond ((symbol? object) (list object)) + ((list? object) object) + (else false)))) + (and package-name + (name->package package-name))))) + (if (not package) + (error "->ENVIRONMENT: Not an environment" object)) + (package/environment package))))) + +(define (gst syntax-table) + (guarantee-syntax-table syntax-table) + (set! user-repl-syntax-table syntax-table) + (set-repl-state/syntax-table! (cmdl/state (nearest-repl)) syntax-table) + *the-non-printing-object*) + +(define (vst syntax-table) + (guarantee-syntax-table syntax-table) + (set-repl-state/syntax-table! (cmdl/state (nearest-repl)) syntax-table) + *the-non-printing-object*) + +(define (re #!optional index) + (let ((repl (nearest-repl))) + (hook/repl-eval repl + (repl-history/read (repl/reader-history repl) + (if (default-object? index) 1 index)) + (repl/environment repl) + (repl/syntax-table repl)))) + +(define (in #!optional index) + (repl-history/read (repl/reader-history (nearest-repl)) + (if (default-object? index) 1 index))) + +(define (out #!optional index) + (repl-history/read (repl/printer-history (nearest-repl)) + (-1+ (if (default-object? index) 1 index)))) + +;; Compatibility. +(define %ge ge) +(define %ve ve) +(define %gst gst) +(define %vst vst) +(define %in in) +(define %out out) + +;;;; Prompting + +(define (prompt-for-command-char prompt #!optional cmdl) + (let ((cmdl (if (default-object? cmdl) (nearest-cmdl) cmdl))) + (hook/cmdl-prompt cmdl prompt) + (hook/read-command-char cmdl prompt))) + +(define (prompt-for-confirmation prompt #!optional cmdl) + (hook/prompt-for-confirmation (if (default-object? cmdl) (nearest-cmdl) cmdl) + prompt)) + +(define (prompt-for-expression prompt #!optional cmdl) + (hook/prompt-for-expression (if (default-object? cmdl) (nearest-cmdl) cmdl) + prompt)) + +(define hook/read-command-char) +(define hook/prompt-for-confirmation) +(define hook/prompt-for-expression) + +(define (default/read-command-char cmdl prompt) + ;; Prompt argument is random. Emacs interface needs it right now. + prompt + (read-char-internal (cmdl/input-port cmdl))) + +(define (default/prompt-for-confirmation cmdl prompt) + (let ((input-port (cmdl/input-port cmdl)) + (output-port (cmdl/output-port cmdl))) + (let loop () + (newline output-port) + (write-string prompt output-port) + (write-string "(y or n) " output-port) + (let ((char (char-upcase (read-char-internal input-port)))) + (cond ((or (char=? #\Y char) + (char=? #\Space char)) + (write-string "Yes" output-port) + true) + ((or (char=? #\N char) + (char=? #\Rubout char)) + (write-string "No" output-port) + false) + (else + (beep output-port) + (loop))))))) + +(define (default/prompt-for-expression cmdl prompt) + (let ((output-port (cmdl/output-port cmdl))) + (newline output-port) + (write-string prompt output-port) (read (cmdl/input-port cmdl)))) + +(define (read-char-internal input-port) + (let loop () + (let ((char (read-char input-port))) + (if (char=? char char:newline) + (loop) + char)))) \ No newline at end of file diff --git a/v7/src/runtime/savres.scm b/v7/src/runtime/savres.scm index d71249900..03be208bd 100644 --- a/v7/src/runtime/savres.scm +++ b/v7/src/runtime/savres.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/savres.scm,v 14.1 1988/05/20 01:01:33 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/savres.scm,v 14.2 1988/06/13 11:50:50 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,7 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Save/Restore World -;;; package: save/restore-package +;;; package: (runtime save/restore) (declare (usual-integrations)) diff --git a/v7/src/runtime/scan.scm b/v7/src/runtime/scan.scm index 8bbc62d33..e6af8a3df 100644 --- a/v7/src/runtime/scan.scm +++ b/v7/src/runtime/scan.scm @@ -1,43 +1,39 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scan.scm,v 13.42 1987/11/17 00:25:34 cph Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scan.scm,v 14.1 1988/06/13 11:50:55 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; Definition Scanner +;;; package: (runtime scode-scan) (declare (usual-integrations)) @@ -57,16 +53,30 @@ ;;; OPEN-BLOCK-COMPONENTS, will connect directly to SCAN-DEFINES and ;;; UNSCAN-DEFINES, respectively. -(define scan-defines) -(define unscan-defines) -(define make-open-block) -(define open-block?) -(define open-block-components) +(define (initialize-package!) + (set! open-block-tag (make-named-tag "OPEN-BLOCK"))) + +(define open-block-tag) -(let ((open-block-tag (make-named-tag "OPEN-BLOCK")) - (sequence-2-type (microcode-type 'SEQUENCE-2)) - (sequence-3-type (microcode-type 'SEQUENCE-3)) - (null-sequence '(NULL-SEQUENCE))) +(define-integrable sequence-2-type + (ucode-type sequence-2)) + +(define-integrable sequence-3-type + (ucode-type sequence-3)) + +(define null-sequence + '(NULL-SEQUENCE)) + +(define (cons-sequence action sequence) + (cond ((object-type? sequence-2-type sequence) + (&typed-triple-cons sequence-3-type + action + (&pair-car sequence) + (&pair-cdr sequence))) + ((eq? sequence null-sequence) + action) + (else + (&typed-pair-cons sequence-2-type action sequence)))) ;;;; Scanning @@ -75,16 +85,15 @@ ;;; of auxiliaries will result in LAMBDA-COMPONENTS returning an ;;; EQUAL? list. -(set! scan-defines -(named-lambda (scan-defines expression receiver) - ((scan-loop expression receiver) '() '() null-sequence))) +(define (scan-defines expression receiver) + ((scan-loop expression receiver) '() '() null-sequence)) (define (scan-loop expression receiver) - (cond ((primitive-type? sequence-2-type expression) + (cond ((object-type? sequence-2-type expression) (scan-loop (&pair-cdr expression) (scan-loop (&pair-car expression) receiver))) - ((primitive-type? sequence-3-type expression) + ((object-type? sequence-3-type expression) (let ((first (&triple-first expression))) (if (and (vector? first) (not (zero? (vector-length first))) @@ -119,19 +128,7 @@ declarations (cons-sequence expression body)))))) -(define (cons-sequence action sequence) - (cond ((primitive-type? sequence-2-type sequence) - (&typed-triple-cons sequence-3-type - action - (&pair-car sequence) - (&pair-cdr sequence))) - ((eq? sequence null-sequence) - action) - (else - (&typed-pair-cons sequence-2-type action sequence)))) - -(set! unscan-defines -(named-lambda (unscan-defines names declarations body) +(define (unscan-defines names declarations body) (unscan-loop names body (lambda (names* body*) (if (not (null? names*)) @@ -142,7 +139,7 @@ body* (&typed-pair-cons sequence-2-type (make-block-declaration declarations) - body*)))))) + body*))))) (define (unscan-loop names body receiver) (cond ((null? names) (receiver '() body)) @@ -154,7 +151,7 @@ (make-definition name value)) (receiver names body))))) - ((primitive-type? sequence-2-type body) + ((object-type? sequence-2-type body) (unscan-loop names (&pair-car body) (lambda (names* body*) (unscan-loop names* (&pair-cdr body) @@ -163,7 +160,7 @@ (&typed-pair-cons sequence-2-type body* body**))))))) - ((primitive-type? sequence-3-type body) + ((object-type? sequence-3-type body) (unscan-loop names (&triple-first body) (lambda (names* body*) (unscan-loop names* (&triple-second body) @@ -181,8 +178,7 @@ ;;;; Open Block -(set! make-open-block -(named-lambda (make-open-block names declarations body) +(define (make-open-block names declarations body) (if (and (null? names) (null? declarations)) body @@ -191,24 +187,15 @@ (vector open-block-tag names declarations) (if (null? names) '() - (make-sequence - (map (lambda (name) - (make-definition name (make-unassigned-object))) - names))) - body)))) - - -(set! open-block? -(named-lambda (open-block? object) - (and (primitive-type? sequence-3-type object) + (make-sequence (map make-definition names))) + body))) + +(define (open-block? object) + (and (object-type? sequence-3-type object) (vector? (&triple-first object)) - (eq? (vector-ref (&triple-first object) 0) open-block-tag)))) + (eq? (vector-ref (&triple-first object) 0) open-block-tag))) -(set! open-block-components -(named-lambda (open-block-components open-block receiver) +(define (open-block-components open-block receiver) (receiver (vector-ref (&triple-first open-block) 1) (vector-ref (&triple-first open-block) 2) - (&triple-third open-block)))) - -;;; end LET -) \ No newline at end of file + (&triple-third open-block))) \ No newline at end of file diff --git a/v7/src/runtime/scode.scm b/v7/src/runtime/scode.scm index 74a291f39..538e44830 100644 --- a/v7/src/runtime/scode.scm +++ b/v7/src/runtime/scode.scm @@ -1,353 +1,317 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scode.scm,v 13.45 1987/10/09 17:13:54 jinx Rel $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions and -;;; understandings. -;;; -;;; 1. Any copy made of this software must include this copyright -;;; notice in full. -;;; -;;; 2. Users of this software agree to make their best efforts (a) -;;; to return to the MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. All materials developed as a consequence of the use of this -;;; software shall duly acknowledge such use, in accordance with -;;; the usual standards of acknowledging credit in academic -;;; research. -;;; -;;; 4. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; SCODE Grab Bag +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scode.scm,v 14.1 1988/06/13 11:51:00 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; SCode Abstraction +;;; package: (runtime scode) (declare (usual-integrations)) -;;;; Constants +(define (initialize-package!) + (set! scode-constant/type-vector (make-scode-constant/type-vector)) + (set! declaration-tag (make-named-tag "DECLARATION"))) -(define scode-constant? - (let ((type-vector (make-vector number-of-microcode-types false))) +;;;; Constant + +(define scode-constant/type-vector) + +(define (scode-constant? object) + (vector-ref scode-constant/type-vector (object-type object))) +(define (make-scode-constant/type-vector) + (let ((type-vector (make-vector (microcode-type/code-limit) false))) (for-each (lambda (name) (vector-set! type-vector (microcode-type name) true)) - '(NULL TRUE UNASSIGNED - FIXNUM BIGNUM FLONUM - CHARACTER STRING UNINTERNED-SYMBOL INTERNED-SYMBOL - NON-MARKED-VECTOR VECTOR-1B VECTOR-16B - PAIR TRIPLE VECTOR QUOTATION PRIMITIVE)) - (named-lambda (scode-constant? object) - (vector-ref type-vector (primitive-type object))))) - -(define make-null) -(define make-false) -(define make-true) - -(let () - (define (make-constant-maker name) - (let ((type (microcode-type name))) - (lambda () - (primitive-set-type type 0)))) - (set! make-null (make-constant-maker 'NULL)) - (set! make-false (make-constant-maker 'FALSE)) - (set! make-true (make-constant-maker 'TRUE))) - -(define undefined-conditional-branch - (primitive-set-type (microcode-type 'TRUE) 1)) - -;;;; QUOTATION - -(define quotation?) -(define make-quotation) - -(let ((type (microcode-type 'QUOTATION))) - (set! quotation? - (named-lambda (quotation? object) - (primitive-type? type object))) - (set! make-quotation - (named-lambda (make-quotation expression) - (&typed-singleton-cons type expression)))) - -(define quotation-expression &singleton-element) + '(BIGNUM + CHARACTER + COMPILED-CODE-BLOCK + CONTROL-POINT + DELAYED + ENTITY + ENVIRONMENT + EXTENDED-PROCEDURE + FIXNUM + FLONUM + HUNK3-A + INTERNED-SYMBOL + NON-MARKED-VECTOR + NULL + PAIR + PRIMITIVE + PROCEDURE + QUAD + RATNUM + RECNUM + REFERENCE-TRAP + RETURN-CODE + STRING + TRIPLE + TRUE + UNINTERNED-SYMBOL + VECTOR + VECTOR-16B + VECTOR-1B)) + type-vector)) -;;;; SYMBOL +;;;; Quotation -(define symbol?) -(define string->uninterned-symbol) -(let () +(define-integrable (make-quotation expression) + (&typed-singleton-cons (ucode-type quotation) expression)) -(define utype - (microcode-type 'UNINTERNED-SYMBOL)) +(define-integrable (quotation? object) + (object-type? (ucode-type quotation) object)) -(define itype - (microcode-type 'INTERNED-SYMBOL)) +(define-integrable (quotation-expression quotation) + (&singleton-element quotation)) -(set! symbol? -(named-lambda (symbol? object) - (or (primitive-type? itype object) - (primitive-type? utype object)))) +;;;; Symbol -(set! string->uninterned-symbol -(named-lambda (string->uninterned-symbol string) - (&typed-pair-cons utype - string - (make-unbound-object)))) +(define (symbol? object) + (or (object-type? (ucode-type interned-symbol) object) + (object-type? (ucode-type uninterned-symbol) object))) -) - -(define string->symbol - (make-primitive-procedure 'STRING->SYMBOL)) - -(define (symbol->string symbol) - (&pair-car symbol)) - -(define make-symbol string->uninterned-symbol) -(define make-interned-symbol string->symbol) -(define symbol-print-name symbol->string) - -;; NOTE: Both of these assume that there are no reference traps. -;; They can cause great harm if used indiscriminately. +(define-integrable (string->uninterned-symbol string) + (&typed-pair-cons (ucode-type uninterned-symbol) + string + (make-unbound-reference-trap))) -(define (symbol-global-value symbol) - (&pair-cdr symbol)) +(define-integrable string->symbol + (ucode-primitive string->symbol)) -(define (set-symbol-global-value! symbol value) - (&pair-set-cdr! symbol value)) +(define-integrable (symbol->string symbol) + (string-copy (system-pair-car symbol))) (define (make-named-tag name) (string->symbol (string-append "#[" name "]"))) - -;;;; VARIABLE -(define variable?) -(define make-variable) +(define-integrable (intern string) + (string->symbol (string-upcase string))) -(let ((type (microcode-type 'VARIABLE))) - (set! variable? - (named-lambda (variable? object) - (primitive-type? type object))) - (set! make-variable - (named-lambda (make-variable name) - (system-hunk3-cons type name (make-true) (make-null))))) +;;;; Variable -(define variable-name system-hunk3-cxr0) +(define-integrable (make-variable name) + (system-hunk3-cons (ucode-type variable) name true '())) -(define (variable-components variable receiver) +(define-integrable (variable? object) + (object-type? (ucode-type variable) object)) + +(define-integrable (variable-name variable) + (system-hunk3-cxr0 variable)) + +(define-integrable (variable-components variable receiver) (receiver (variable-name variable))) + +;;;; Definition/Assignment -;;;; DEFINITION +(define (make-definition name #!optional value) + (&typed-pair-cons (ucode-type definition) + name + (if (default-object? value) + (make-unassigned-reference-trap) + value))) -(define definition?) -(define make-definition) +(define-integrable (definition? object) + (object-type? (ucode-type definition) object)) -(let ((type (microcode-type 'DEFINITION))) - (set! definition? - (named-lambda (definition? object) - (primitive-type? type object))) - (set! make-definition - (named-lambda (make-definition name value) - (&typed-pair-cons type name value)))) +(define-integrable (definition-name definition) + (system-pair-car definition)) + +(define-integrable (definition-value definition) + (&pair-cdr definition)) (define (definition-components definition receiver) (receiver (definition-name definition) (definition-value definition))) -(define definition-name system-pair-car) -(define set-definition-name! system-pair-set-car!) -(define definition-value &pair-cdr) -(define set-definition-value! &pair-set-cdr!) - -;;;; ASSIGNMENT +(define-integrable (assignment? object) + (object-type? (ucode-type assignment) object)) -(define assignment?) -(define make-assignment-from-variable) +(define (make-assignment-from-variable variable #!optional value) + (&typed-pair-cons (ucode-type assignment) + variable + (if (default-object? value) + (make-unassigned-reference-trap) + value))) -(let ((type (microcode-type 'ASSIGNMENT))) - (set! assignment? - (named-lambda (assignment? object) - (primitive-type? type object))) - (set! make-assignment-from-variable - (named-lambda (make-assignment-from-variable variable value) - (&typed-pair-cons type variable value)))) +(define-integrable (assignment-variable assignment) + (system-pair-car assignment)) + +(define-integrable (assignment-value assignment) + (&pair-cdr assignment)) (define (assignment-components-with-variable assignment receiver) (receiver (assignment-variable assignment) (assignment-value assignment))) -(define assignment-variable system-pair-car) -(define set-assignment-variable! system-pair-set-car!) -(define assignment-value &pair-cdr) -(define set-assignment-value! &pair-set-cdr!) +(define (make-assignment name #!optional value) + (make-assignment-from-variable (make-variable name) + (if (default-object? value) + (make-unassigned-reference-trap) + value))) -(define (make-assignment name value) - (make-assignment-from-variable (make-variable name) value)) +(define-integrable (assignment-name assignment) + (variable-name (assignment-variable assignment))) (define (assignment-components assignment receiver) - (assignment-components-with-variable assignment - (lambda (variable value) - (receiver (variable-name variable) value)))) - -(define (assignment-name assignment) - (variable-name (assignment-variable assignment))) + (receiver (assignment-name assignment) + (assignment-value assignment))) -;;;; COMMENT +;;;; Comment + +(define-integrable (make-comment text expression) + (&typed-pair-cons (ucode-type comment) expression text)) -(define comment?) -(define make-comment) +(define-integrable (comment? object) + (object-type? (ucode-type comment) object)) -(let ((type (microcode-type 'COMMENT))) - (set! comment? - (named-lambda (comment? object) - (primitive-type? type object))) - (set! make-comment - (named-lambda (make-comment text expression) - (&typed-pair-cons type expression text)))) +(define-integrable (comment-text comment) + (system-pair-cdr comment)) + +(define-integrable (set-comment-text! comment text) + (system-pair-set-cdr! comment text)) + +(define-integrable (comment-expression comment) + (&pair-car comment)) + +(define-integrable (set-comment-expression! comment expression) + (&pair-set-car! comment expression)) (define (comment-components comment receiver) (receiver (comment-text comment) (comment-expression comment))) -(define comment-text &pair-cdr) -(define set-comment-text! &pair-set-cdr!) -(define comment-expression &pair-car) -(define set-comment-expression! &pair-set-car!) - -;;;; DECLARATION - -(define declaration?) -(define make-declaration) - -(let ((tag (make-named-tag "DECLARATION"))) - (set! declaration? - (named-lambda (declaration? object) - (and (comment? object) - (let ((text (comment-text object))) - (and (pair? text) - (eq? (car text) tag)))))) - (set! make-declaration - (named-lambda (make-declaration text expression) - (make-comment (cons tag text) expression)))) - -(define (declaration-components declaration receiver) - (comment-components declaration - (lambda (text expression) - (receiver (cdr text) expression)))) +;;;; Declaration -(define (declaration-text tagged-comment) - (cdr (comment-text tagged-comment))) +(define-integrable (make-declaration text expression) + (make-comment (cons declaration-tag text) expression)) -(define (set-declaration-text! tagged-comment new-text) - (set-cdr! (comment-text tagged-comment) new-text)) +(define (declaration? object) + (and (comment? object) + (let ((text (comment-text object))) + (and (pair? text) + (eq? (car text) declaration-tag))))) -(define declaration-expression - comment-expression) +(define declaration-tag) -(define set-declaration-expression! - set-comment-expression!) +(define-integrable (declaration-text declaration) + (cdr (comment-text declaration))) -(define make-block-declaration) -(define block-declaration?) -(let () +(define-integrable (set-declaration-text! declaration text) + (set-cdr! (comment-text declaration) text)) -(define tag - (make-named-tag "Block Declaration")) +(define-integrable (declaration-expression declaration) + (comment-expression declaration)) -(set! make-block-declaration -(named-lambda (make-block-declaration text) - (cons tag text))) +(define-integrable (set-declaration-expression! declaration expression) + (set-comment-expression! declaration expression)) -(set! block-declaration? -(named-lambda (block-declaration? object) - (and (pair? object) (eq? (car object) tag)))) +(define (declaration-components declaration receiver) + (receiver (declaration-text declaration) + (declaration-expression declaration))) + +;;;; The-Environment -) +(define-integrable (make-the-environment) + (object-new-type (ucode-type the-environment) 0)) -(define block-declaration-text - cdr) - -;;;; THE-ENVIRONMENT +(define-integrable (the-environment? object) + (object-type? (ucode-type the-environment) object)) -(define the-environment?) -(define make-the-environment) +;;;; Access -(let ((type (microcode-type 'THE-ENVIRONMENT))) - (set! the-environment? - (named-lambda (the-environment? object) - (primitive-type? type object))) - (set! make-the-environment - (named-lambda (make-the-environment) - (primitive-set-type type 0)))) +(define-integrable (make-access environment name) + (&typed-pair-cons (ucode-type access) environment name)) -;;;; ACCESS +(define-integrable (access? object) + (object-type? (ucode-type access) object)) -(define access?) -(define make-access) +(define (access-environment expression) + (&pair-car expression)) -(let ((type (microcode-type 'ACCESS))) - (set! access? - (named-lambda (access? object) - (primitive-type? type object))) - (set! make-access - (named-lambda (make-access environment name) - (&typed-pair-cons type environment name)))) +(define-integrable (access-name expression) + (system-pair-cdr expression)) (define (access-components access receiver) (receiver (access-environment access) (access-name access))) -(define access-environment &pair-car) -(define access-name system-pair-cdr) +;;;; Absolute Reference + +(define (make-absolute-reference name . rest) + (let loop ((reference (make-access system-global-environment name)) + (rest rest)) + (if (null? rest) + reference + (loop (make-access reference (car rest)) (cdr rest))))) -;;;; IN-PACKAGE +(define (absolute-reference? object) + (and (access? object) + (eq? (access-environment object) system-global-environment))) -(define in-package?) -(define make-in-package) +(define-integrable (absolute-reference-name reference) + (access-name reference)) -(let ((type (microcode-type 'IN-PACKAGE))) - (set! in-package? - (named-lambda (in-package? object) - (primitive-type? type object))) - (set! make-in-package - (named-lambda (make-in-package environment expression) - (&typed-pair-cons type environment expression)))) +(define (absolute-reference-to? object name) + (and (absolute-reference? object) + (eq? (absolute-reference-name object) name))) + +;;;; In-Package + +(define-integrable (make-in-package environment expression) + (&typed-pair-cons (ucode-type in-package) environment expression)) + +(define-integrable (in-package? object) + (object-type? (ucode-type in-package) object)) + +(define-integrable (in-package-environment expression) + (&pair-car expression)) + +(define-integrable (in-package-expression expression) + (&pair-cdr expression)) (define (in-package-components in-package receiver) (receiver (in-package-environment in-package) (in-package-expression in-package))) -(define in-package-environment &pair-car) -(define in-package-expression &pair-cdr) - -;;;; DELAY +;;;; Delay -(define delay?) -(define make-delay) +(define-integrable (make-delay expression) + (&typed-singleton-cons (ucode-type delay) expression)) -(let ((type (microcode-type 'DELAY))) - (set! delay? - (named-lambda (delay? object) - (primitive-type? type object))) - (set! make-delay - (named-lambda (make-delay expression) - (&typed-singleton-cons type expression)))) +(define-integrable (delay? object) + (object-type? (ucode-type delay) object)) -(define delay-expression &singleton-element) +(define-integrable (delay-expression expression) + (&singleton-element expression)) -(define (delay-components delay receiver) +(define-integrable (delay-components delay receiver) (receiver (delay-expression delay))) \ No newline at end of file diff --git a/v7/src/runtime/scomb.scm b/v7/src/runtime/scomb.scm index 6afcbfb7e..672bbfa76 100644 --- a/v7/src/runtime/scomb.scm +++ b/v7/src/runtime/scomb.scm @@ -1,227 +1,184 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scomb.scm,v 13.43 1987/08/17 18:16:27 cph Rel $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions and -;;; understandings. -;;; -;;; 1. Any copy made of this software must include this copyright -;;; notice in full. -;;; -;;; 2. Users of this software agree to make their best efforts (a) -;;; to return to the MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. All materials developed as a consequence of the use of this -;;; software shall duly acknowledge such use, in accordance with -;;; the usual standards of acknowledging credit in academic -;;; research. -;;; -;;; 4. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; SCODE Combinator Abstractions +#| -*-Scheme-*- -(declare (usual-integrations)) - -;;;; SEQUENCE +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scomb.scm,v 14.1 1988/06/13 11:51:13 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. -(define sequence?) -(define make-sequence) -(define sequence-actions) -(let () +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. -(define type-2 - (microcode-type 'SEQUENCE-2)) +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. -(define type-3 - (microcode-type 'SEQUENCE-3)) +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; SCode Combinator Abstractions +;;; package: (runtime scode-combinator) + +(declare (usual-integrations)) + +(define (initialize-package!) + (set! combination/constant-folding-operators + (map make-primitive-procedure + '(PRIMITIVE-TYPE + &+ &- &* &/ INTEGER-DIVIDE 1+ -1+ + TRUNCATE ROUND FLOOR CEILING + SQRT EXP LOG SIN COS &ATAN)))) -(set! sequence? -(named-lambda (sequence? object) - (or (primitive-type? type-2 object) - (primitive-type? type-3 object)))) +;;;; Sequence -(set! make-sequence -(lambda (actions) +(define (make-sequence actions) (if (null? actions) - (error "MAKE-SEQUENCE: No actions") - (actions->sequence actions)))) - -(define (actions->sequence actions) - (cond ((null? (cdr actions)) - (car actions)) - ((null? (cddr actions)) - (&typed-pair-cons type-2 - (car actions) - (cadr actions))) - (else - (&typed-triple-cons type-3 + (error "MAKE-SEQUENCE: No actions")) + (let loop ((actions actions)) + (cond ((null? (cdr actions)) + (car actions)) + ((null? (cddr actions)) + (&typed-pair-cons (ucode-type sequence-2) (car actions) - (cadr actions) - (actions->sequence (cddr actions)))))) - -(set! sequence-actions -(named-lambda (sequence-actions sequence) - (cond ((primitive-type? type-2 sequence) + (cadr actions))) + (else + (&typed-triple-cons (ucode-type sequence-3) + (car actions) + (cadr actions) + (loop (cddr actions))))))) + +(define (sequence? object) + (or (object-type? (ucode-type sequence-2) object) + (object-type? (ucode-type sequence-3) object))) + +(define (sequence-actions sequence) + (cond ((object-type? (ucode-type sequence-2) sequence) (append! (sequence-actions (&pair-car sequence)) (sequence-actions (&pair-cdr sequence)))) - ((primitive-type? type-3 sequence) + ((object-type? (ucode-type sequence-3) sequence) (append! (sequence-actions (&triple-first sequence)) (sequence-actions (&triple-second sequence)) (sequence-actions (&triple-third sequence)))) (else - (list sequence))))) - -) + (list sequence)))) -(define (sequence-components sequence receiver) +(define-integrable (sequence-components sequence receiver) (receiver (sequence-actions sequence))) -;;;; CONDITIONAL - -(define conditional?) -(define make-conditional) -(let () - -(define type - (microcode-type 'CONDITIONAL)) - -(set! conditional? -(named-lambda (conditional? object) - (primitive-type? type object))) - -(set! make-conditional -(named-lambda (make-conditional predicate consequent alternative) - (if (combination? predicate) - (combination-components predicate - (lambda (operator operands) - (if (eq? operator not) - (make-conditional (first operands) - alternative - consequent) - (&typed-triple-cons type - predicate - consequent - alternative)))) - (&typed-triple-cons type predicate consequent alternative)))) - -) +;;;; Conditional + +(define (make-conditional predicate consequent #!optional alternative) + (let ((alternative + (if (default-object? alternative) + undefined-conditional-branch + alternative))) + (if (and (combination? predicate) + (eq? (combination-operator predicate) (ucode-primitive not))) + (make-conditional (car (combination-operands predicate)) + alternative + consequent) + (&typed-triple-cons (ucode-type conditional) + predicate + consequent + alternative)))) + +(define (conditional? object) + (object-type? (ucode-type conditional) object)) + +(define undefined-conditional-branch + (object-new-type (ucode-type true) 1)) + +(define-integrable (conditional-predicate conditional) + (&triple-first conditional)) + +(define-integrable (conditional-consequent conditional) + (&triple-second conditional)) + +(define-integrable (conditional-alternative conditional) + (&triple-third conditional)) (define (conditional-components conditional receiver) (receiver (conditional-predicate conditional) (conditional-consequent conditional) (conditional-alternative conditional))) - -(define conditional-predicate &triple-first) -(define conditional-consequent &triple-second) -(define conditional-alternative &triple-third) -;;;; DISJUNCTION - -(define disjunction?) -(define make-disjunction) -(let () +;;;; Disjunction -(define type - (microcode-type 'DISJUNCTION)) +(define (make-disjunction predicate alternative) + (if (and (combination? predicate) + (eq? (combination-operator predicate) (ucode-primitive not))) + (make-conditional (car (combination-operands predicate)) + alternative + true) + (&typed-pair-cons (ucode-type disjunction) predicate alternative))) -(set! disjunction? -(named-lambda (disjunction? object) - (primitive-type? type object))) +(define-integrable (disjunction? object) + (object-type? (ucode-type disjunction) object)) -(set! make-disjunction -(named-lambda (make-disjunction predicate alternative) - (if (combination? predicate) - (combination-components predicate - (lambda (operator operands) - (if (eq? operator not) - (make-conditional (first operands) alternative true) - (&typed-pair-cons type predicate alternative)))) - (&typed-pair-cons type predicate alternative)))) +(define-integrable (disjunction-predicate disjunction) + (&pair-car disjunction)) -) +(define-integrable (disjunction-alternative disjunction) + (&pair-cdr disjunction)) (define (disjunction-components disjunction receiver) (receiver (disjunction-predicate disjunction) (disjunction-alternative disjunction))) - -(define disjunction-predicate &pair-car) -(define disjunction-alternative &pair-cdr) - -;;;; COMBINATION - -(define combination?) -(define make-combination) -(define combination-size) -(define combination-components) -(define combination-operator) -(define combination-operands) -(let () - -(define type-1 (microcode-type 'COMBINATION-1)) -(define type-2 (microcode-type 'COMBINATION-2)) -(define type-N (microcode-type 'COMBINATION)) -(define p-type (microcode-type 'PRIMITIVE)) -(define p-type-0 (microcode-type 'PRIMITIVE-COMBINATION-0)) -(define p-type-1 (microcode-type 'PRIMITIVE-COMBINATION-1)) -(define p-type-2 (microcode-type 'PRIMITIVE-COMBINATION-2)) -(define p-type-3 (microcode-type 'PRIMITIVE-COMBINATION-3)) - -(define (primitive-procedure? object) - (primitive-type? p-type object)) - -(set! combination? -(named-lambda (combination? object) - (or (primitive-type? type-1 object) - (primitive-type? type-2 object) - (primitive-type? type-N object) - (primitive-type? p-type-0 object) - (primitive-type? p-type-1 object) - (primitive-type? p-type-2 object) - (primitive-type? p-type-3 object)))) -(set! make-combination -(lambda (operator operands) - (cond ((and (memq operator constant-folding-operators) - (all-constants? operands)) +;;;; Combination + +(define (combination? object) + (or (object-type? (ucode-type combination) object) + (object-type? (ucode-type combination-1) object) + (object-type? (ucode-type combination-2) object) + (object-type? (ucode-type primitive-combination-0) object) + (object-type? (ucode-type primitive-combination-1) object) + (object-type? (ucode-type primitive-combination-2) object) + (object-type? (ucode-type primitive-combination-3) object))) + +(define (make-combination operator operands) + (cond ((and (memq operator combination/constant-folding-operators) + (let loop ((operands operands)) + (or (null? operands) + (and (scode-constant? (car operands)) + (loop (cdr operands)))))) (apply operator operands)) ((null? operands) (if (and (primitive-procedure? operator) (= (primitive-procedure-arity operator) 0)) - (primitive-set-type p-type-0 operator) - (&typed-vector-cons type-N (cons operator '())))) + (object-new-type (ucode-type primitive-combination-0) operator) + (&typed-vector-cons (ucode-type combination) + (cons operator '())))) ((null? (cdr operands)) (&typed-pair-cons (if (and (primitive-procedure? operator) (= (primitive-procedure-arity operator) 1)) - p-type-1 - type-1) + (ucode-type primitive-combination-1) + (ucode-type combination-1)) operator (car operands))) ((null? (cddr operands)) (&typed-triple-cons (if (and (primitive-procedure? operator) (= (primitive-procedure-arity operator) 2)) - p-type-2 - type-2) + (ucode-type primitive-combination-2) + (ucode-type combination-2)) operator (car operands) (cadr operands))) @@ -230,138 +187,82 @@ (if (and (null? (cdddr operands)) (primitive-procedure? operator) (= (primitive-procedure-arity operator) 3)) - p-type-3 - type-N) - (cons operator operands)))))) - -(define constant-folding-operators - (map make-primitive-procedure - '(PRIMITIVE-TYPE - &+ &- &* &/ INTEGER-DIVIDE 1+ -1+ - TRUNCATE ROUND FLOOR CEILING - SQRT EXP LOG SIN COS &ATAN))) - -(define (all-constants? expressions) - (or (null? expressions) - (and (scode-constant? (car expressions)) - (all-constants? (cdr expressions))))) - -(set! combination-size -(lambda (combination) - (cond ((primitive-type? p-type-0 combination) - 1) - ((or (primitive-type? type-1 combination) - (primitive-type? p-type-1 combination)) - 2) - ((or (primitive-type? type-2 combination) - (primitive-type? p-type-2 combination)) - 3) - ((primitive-type? p-type-3 combination) - 4) - ((primitive-type? type-N combination) - (&vector-size combination)) - (else - (error "Not a combination -- COMBINATION-SIZE" combination))))) - -(set! combination-operator -(lambda (combination) - (cond ((primitive-type? p-type-0 combination) - (primitive-set-type p-type combination)) - ((or (primitive-type? type-1 combination) - (primitive-type? p-type-1 combination)) - (&pair-car combination)) - ((or (primitive-type? type-2 combination) - (primitive-type? p-type-2 combination)) - (&triple-first combination)) - ((or (primitive-type? p-type-3 combination) - (primitive-type? type-N combination)) - (&vector-ref combination 0)) - (else - (error "Not a combination -- COMBINATION-OPERATOR" - combination))))) - -(set! combination-operands -(lambda (combination) - (cond ((primitive-type? p-type-0 combination) - '()) - ((or (primitive-type? type-1 combination) - (primitive-type? p-type-1 combination)) - (list (&pair-cdr combination))) - ((or (primitive-type? type-2 combination) - (primitive-type? p-type-2 combination)) - (list (&triple-second combination) - (&triple-third combination))) - ((or (primitive-type? p-type-3 combination) - (primitive-type? type-N combination)) - (&subvector-to-list combination 1 (&vector-size combination))) - (else - (error "Not a combination -- COMBINATION-OPERANDS" - combination))))) + (ucode-type primitive-combination-3) + (ucode-type combination)) + (cons operator operands))))) + +(define combination/constant-folding-operators) -(set! combination-components -(lambda (combination receiver) - (cond ((primitive-type? p-type-0 combination) - (receiver (primitive-set-type p-type combination) - '())) - ((or (primitive-type? type-1 combination) - (primitive-type? p-type-1 combination)) - (receiver (&pair-car combination) - (list (&pair-cdr combination)))) - ((or (primitive-type? type-2 combination) - (primitive-type? p-type-2 combination)) - (receiver (&triple-first combination) - (list (&triple-second combination) - (&triple-third combination)))) - ((or (primitive-type? p-type-3 combination) - (primitive-type? type-N combination)) - (receiver (&vector-ref combination 0) - (&subvector-to-list combination 1 - (&vector-size combination)))) - (else - (error "Not a combination -- COMBINATION-COMPONENTS" - combination))))) +(let-syntax + ((combination-dispatch + (macro (name combination case-0 case-1 case-2 case-n) + `(COND ((OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-0) + ,combination) + ,case-0) + ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION-1) ,combination) + (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-1) + ,combination)) + ,case-1) + ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION-2) ,combination) + (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-2) + ,combination)) + ,case-2) + ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION) ,combination) + (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-3) + ,combination)) + ,case-n) + (ELSE + (ERROR ,(string-append (symbol->string name) + ": Illegal combination") + ,combination)))))) + +(define (combination-size combination) + (combination-dispatch combination-size combination + 1 2 3 (&vector-length combination))) + +(define (combination-operator combination) + (combination-dispatch combination-operator combination + (object-new-type (ucode-type primitive) combination) + (&pair-car combination) + (&triple-first combination) + (&vector-ref combination 0))) + +(define (combination-operands combination) + (combination-dispatch + combination-operands combination + '() + (list (&pair-cdr combination)) + (list (&triple-second combination) (&triple-third combination)) + (&subvector->list combination 1 (&vector-length combination)))) + +(define (combination-components combination receiver) + (combination-dispatch + combination-components combination + (receiver (object-new-type (ucode-type primitive) combination) '()) + (receiver (&pair-car combination) (list (&pair-cdr combination))) + (receiver (&triple-first combination) + (list (&triple-second combination) (&triple-third combination))) + (receiver (&vector-ref combination 0) + (&subvector->list combination 1 (&vector-length combination))))) ) -;;;; UNASSIGNED? +;;;; Unassigned? -(define unassigned??) -(define make-unassigned?) -(define unbound??) -(define make-unbound?) -(let () - -(define ((envop-characteristic envop) object) - (and (combination? object) - (combination-components object - (lambda (operator operands) - (and (eq? operator envop) - (the-environment? (first operands)) - (symbol? (second operands))))))) - -(define ((envop-maker envop) name) - (make-combination envop +(define (make-unassigned? name) + (make-combination (ucode-primitive lexical-unassigned?) (list (make-the-environment) name))) -(set! unassigned?? - (envop-characteristic lexical-unassigned?)) - -(set! make-unassigned? - (envop-maker lexical-unassigned?)) - -(set! unbound?? - (envop-characteristic lexical-unbound?)) - -(set! make-unbound? - (envop-maker lexical-unbound?)) - -) - -(define (unassigned?-name unassigned?) - (second (combination-operands unassigned?))) +(define (unassigned?? object) + (and (combination? object) + (eq? (combination-operator object) + (ucode-primitive lexical-unassigned?)) + (let ((operands (combination-operands object))) + (and (the-environment? (car operands)) + (symbol? (cadr operands)))))) -(define (unassigned?-components unassigned? receiver) - (receiver (unassigned?-name unassigned?))) +(define-integrable (unassigned?-name unassigned?) + (cadr (combination-operands unassigned?))) -(define unbound?-name unassigned?-name) -(define unbound?-components unassigned?-components) \ No newline at end of file +(define-integrable (unassigned?-components unassigned? receiver) + (receiver (unassigned?-name unassigned?))) \ No newline at end of file diff --git a/v7/src/runtime/sdata.scm b/v7/src/runtime/sdata.scm index 3e0c7015d..9b03eef77 100644 --- a/v7/src/runtime/sdata.scm +++ b/v7/src/runtime/sdata.scm @@ -1,230 +1,110 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sdata.scm,v 13.43 1987/04/24 13:37:01 cph Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sdata.scm,v 14.1 1988/06/13 11:51:27 cph Rel $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; Abstract Data Field +;;; package: (runtime scode-data) (declare (usual-integrations)) -(define unbound-object?) -(define make-unbound-object) - -(define unassigned-object?) -(define make-unassigned-object) - -(define &typed-singleton-cons) -(define &singleton-element) -(define &singleton-set-element!) - -(define &typed-pair-cons) -(define &pair-car) -(define &pair-set-car!) -(define &pair-cdr) -(define &pair-set-cdr!) - -(define &typed-triple-cons) -(define &triple-first) -(define &triple-set-first!) -(define &triple-second) -(define &triple-set-second!) -(define &triple-third) -(define &triple-set-third!) - -(define &typed-vector-cons) -(define &list-to-vector) -(define &vector-size) -(define &vector-ref) -(define &vector-to-list) -(define &subvector-to-list) - -(let ((&unbound-object '(&UNBOUND-OBJECT)) - (&unbound-datum 2) - (&unassigned-object '(&UNASSIGNED-OBJECT)) - (&unassigned-datum 0) - (&unassigned-type (microcode-type 'UNASSIGNED)) - (&make-object (make-primitive-procedure '&MAKE-OBJECT)) - (hunk3-cons (make-primitive-procedure 'HUNK3-CONS))) - -(define (map-unassigned object) - (cond ((eq? object &unbound-object) - (&make-object &unassigned-type &unbound-datum)) - ((eq? object &unassigned-object) - (&make-object &unassigned-type &unassigned-datum)) - (else object))) - -;;; This is no longer really right, given the other traps. -(define (map-from-unassigned datum) - (if (eq? datum &unassigned-datum) ;**** cheat for speed. - &unassigned-object - &unbound-object)) - -(define (map-unassigned-list list) - (if (null? list) - '() - (cons (map-unassigned (car list)) - (map-unassigned-list (cdr list))))) - -(set! make-unbound-object - (lambda () - &unbound-object)) - -(set! unbound-object? - (lambda (object) - (eq? object &unbound-object))) - -(set! make-unassigned-object - (lambda () - &unassigned-object)) - -(set! unassigned-object? - (let ((microcode-unassigned-object - (vector-ref (get-fixed-objects-vector) - (fixed-objects-vector-slot 'NON-OBJECT)))) - (lambda (object) - (or (eq? object &unassigned-object) - (eq? object microcode-unassigned-object))))) - -(set! &typed-singleton-cons - (lambda (type element) - (system-pair-cons type (map-unassigned element) '()))) - -(set! &singleton-element - (lambda (singleton) - (if (primitive-type? &unassigned-type (system-pair-car singleton)) - (map-from-unassigned (primitive-datum (system-pair-car singleton))) - (system-pair-car singleton)))) - -(set! &singleton-set-element! - (lambda (singleton new-element) - (system-pair-set-car! singleton (map-unassigned new-element)))) - -(set! &typed-pair-cons - (lambda (type car cdr) - (system-pair-cons type - (map-unassigned car) - (map-unassigned cdr)))) - -(set! &pair-car - (lambda (pair) - (if (primitive-type? &unassigned-type (system-pair-car pair)) - (map-from-unassigned (primitive-datum (system-pair-car pair))) - (system-pair-car pair)))) - -(set! &pair-set-car! - (lambda (pair new-car) - (system-pair-set-car! pair (map-unassigned new-car)))) - -(set! &pair-cdr - (lambda (pair) - (if (primitive-type? &unassigned-type (system-pair-cdr pair)) - (map-from-unassigned (primitive-datum (system-pair-cdr pair))) - (system-pair-cdr pair)))) - -(set! &pair-set-cdr! - (lambda (pair new-cdr) - (system-pair-set-cdr! pair (map-unassigned new-cdr)))) - -(set! &typed-triple-cons - (lambda (type first second third) - (primitive-set-type type - (hunk3-cons (map-unassigned first) - (map-unassigned second) - (map-unassigned third))))) - -(set! &triple-first - (lambda (triple) - (if (primitive-type? &unassigned-type (system-hunk3-cxr0 triple)) - (map-from-unassigned (primitive-datum (system-hunk3-cxr0 triple))) - (system-hunk3-cxr0 triple)))) - -(set! &triple-set-first! - (lambda (triple new-first) - (system-hunk3-set-cxr0! triple (map-unassigned new-first)))) - -(set! &triple-second - (lambda (triple) - (if (primitive-type? &unassigned-type (system-hunk3-cxr1 triple)) - (map-from-unassigned (primitive-datum (system-hunk3-cxr1 triple))) - (system-hunk3-cxr1 triple)))) - -(set! &triple-set-second! - (lambda (triple new-second) - (system-hunk3-set-cxr0! triple (map-unassigned new-second)))) - -(set! &triple-third - (lambda (triple) - (if (primitive-type? &unassigned-type (system-hunk3-cxr2 triple)) - (map-from-unassigned (primitive-datum (system-hunk3-cxr2 triple))) - (system-hunk3-cxr2 triple)))) - -(set! &triple-set-third! - (lambda (triple new-third) - (system-hunk3-set-cxr0! triple (map-unassigned new-third)))) +(define (&typed-singleton-cons type element) + (system-pair-cons type (unmap-reference-trap element) '())) + +(define (&singleton-element singleton) + (map-reference-trap (lambda () (system-pair-car singleton)))) + +(define (&singleton-set-element! singleton new-element) + (system-pair-set-car! singleton (unmap-reference-trap new-element))) + +(define (&typed-pair-cons type car cdr) + (system-pair-cons type + (unmap-reference-trap car) + (unmap-reference-trap cdr))) + +(define (&pair-car pair) + (map-reference-trap (lambda () (system-pair-car pair)))) + +(define (&pair-set-car! pair new-car) + (system-pair-set-car! pair (unmap-reference-trap new-car))) + +(define (&pair-cdr pair) + (map-reference-trap (lambda () (system-pair-cdr pair)))) + +(define (&pair-set-cdr! pair new-cdr) + (system-pair-set-cdr! pair (unmap-reference-trap new-cdr))) -(set! &typed-vector-cons - (lambda (type elements) - (system-list-to-vector type (map-unassigned-list elements)))) - -(set! &list-to-vector - list->vector) - -(set! &vector-size - system-vector-size) - -(set! &vector-ref - (lambda (vector index) - (if (primitive-type? &unassigned-type (system-vector-ref vector index)) - (map-from-unassigned - (primitive-datum (system-vector-ref vector index))) - (system-vector-ref vector index)))) - -(set! &vector-to-list - (lambda (vector) - (&subvector-to-list vector 0 (system-vector-size vector)))) - -(set! &subvector-to-list - (lambda (vector start stop) - (let loop ((sublist (system-subvector-to-list vector start stop))) - (if (null? sublist) - '() - (cons (if (primitive-type? &unassigned-type (car sublist)) - (map-from-unassigned (primitive-datum (car sublist))) - (car sublist)) - (loop (cdr sublist))))))) - -) \ No newline at end of file +(define (&typed-triple-cons type first second third) + (object-new-type type + (hunk3-cons (unmap-reference-trap first) + (unmap-reference-trap second) + (unmap-reference-trap third)))) + +(define (&triple-first triple) + (map-reference-trap (lambda () (system-hunk3-cxr0 triple)))) + +(define (&triple-set-first! triple new-first) + (system-hunk3-set-cxr0! triple (unmap-reference-trap new-first))) + +(define (&triple-second triple) + (map-reference-trap (lambda () (system-hunk3-cxr1 triple)))) + +(define (&triple-set-second! triple new-second) + (system-hunk3-set-cxr0! triple (unmap-reference-trap new-second))) + +(define (&triple-third triple) + (map-reference-trap (lambda () (system-hunk3-cxr2 triple)))) + +(define (&triple-set-third! triple new-third) + (system-hunk3-set-cxr0! triple (unmap-reference-trap new-third))) + +(define (&typed-vector-cons type elements) + (system-list->vector + type + (let loop ((elements elements)) + (if (null? elements) + '() + (cons (unmap-reference-trap (car elements)) + (loop (cdr elements))))))) + +(define (&vector-length vector) + (system-vector-length vector)) + +(define (&vector-ref vector index) + (map-reference-trap (lambda () (system-vector-ref vector index)))) + +(define (&subvector->list vector start stop) + (let loop ((sublist (system-subvector->list vector start stop))) + (if (null? sublist) + '() + (cons (map-reference-trap (lambda () (car sublist))) + (loop (cdr sublist)))))) \ No newline at end of file diff --git a/v7/src/runtime/sfile.scm b/v7/src/runtime/sfile.scm index e514be2f0..e654bb83e 100644 --- a/v7/src/runtime/sfile.scm +++ b/v7/src/runtime/sfile.scm @@ -1,59 +1,60 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sfile.scm,v 13.42 1987/08/20 03:06:21 cph Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sfile.scm,v 14.1 1988/06/13 11:51:34 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; Simple File Operations +;;; package: () (declare (usual-integrations)) -(define copy-file - (let ((p-copy-file (make-primitive-procedure 'COPY-FILE))) - (named-lambda (copy-file from to) - (p-copy-file (canonicalize-input-filename from) - (canonicalize-output-filename to))))) - -(define rename-file - (let ((p-rename-file (make-primitive-procedure 'RENAME-FILE))) - (named-lambda (rename-file from to) - (p-rename-file (canonicalize-input-filename from) - (canonicalize-output-filename to))))) - -(define delete-file - (let ((p-delete-file (make-primitive-procedure 'REMOVE-FILE))) - (named-lambda (delete-file name) - (p-delete-file (canonicalize-input-filename name))))) \ No newline at end of file +(define (copy-file from to) + ((ucode-primitive copy-file) (canonicalize-input-filename from) + (canonicalize-output-filename to))) + +(define (rename-file from to) + ((ucode-primitive rename-file) (canonicalize-input-filename from) + (canonicalize-output-filename to))) + +(define (delete-file name) + ((ucode-primitive remove-file) (canonicalize-input-filename name))) + +(define (transcript-on filename) + (if (not ((ucode-primitive photo-open) + (canonicalize-output-filename filename))) + (error "TRANSCRIPT-ON: Transcript file already open" filename)) + *the-non-printing-object*) + +(define (transcript-off) + (if (not ((ucode-primitive photo-close))) + (error "TRANSCRIPT-OFF: Transcript file already closed")) + *the-non-printing-object*) \ No newline at end of file diff --git a/v7/src/runtime/stream.scm b/v7/src/runtime/stream.scm index f00030a13..948dd2e5f 100644 --- a/v7/src/runtime/stream.scm +++ b/v7/src/runtime/stream.scm @@ -1,184 +1,133 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/stream.scm,v 13.41 1987/01/23 00:20:30 jinx Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; - -;;;; Stream Utilities +#| -*-Scheme-*- -(declare (usual-integrations)) - -;;;; General Streams - -(define (nth-stream n s) - (cond ((empty-stream? s) - (error "Empty stream -- NTH-STREAM" n)) - ((= n 0) - (head s)) - (else - (nth-stream (- n 1) (tail s))))) - -(define (accumulate combiner initial-value stream) - (if (empty-stream? stream) - initial-value - (combiner (head stream) - (accumulate combiner - initial-value - (tail stream))))) - -(define (filter pred stream) - (cond ((empty-stream? stream) - the-empty-stream) - ((pred (head stream)) - (cons-stream (head stream) - (filter pred (tail stream)))) - (else - (filter pred (tail stream))))) - -(define (map-stream proc stream) - (if (empty-stream? stream) - the-empty-stream - (cons-stream (proc (head stream)) - (map-stream proc (tail stream))))) - -(define (map-stream-2 proc s1 s2) - (if (or (empty-stream? s1) - (empty-stream? s2)) - the-empty-stream - (cons-stream (proc (head s1) (head s2)) - (map-stream-2 proc (tail s1) (tail s2))))) - -(define (append-streams s1 s2) - (if (empty-stream? s1) - s2 - (cons-stream (head s1) - (append-streams (tail s1) s2)))) - -(define (enumerate-fringe tree) - (if (pair? tree) - (append-streams (enumerate-fringe (car tree)) - (enumerate-fringe (cdr tree))) - (cons-stream tree the-empty-stream))) - -;;;; Numeric Streams +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/stream.scm,v 14.1 1988/06/13 11:51:38 cph Exp $ -(define (add-streams s1 s2) - (cond ((empty-stream? s1) s2) - ((empty-stream? s2) s1) - (else - (cons-stream (+ (head s1) (head s2)) - (add-streams (tail s1) (tail s2)))))) +Copyright (c) 1988 Massachusetts Institute of Technology -(define (scale-stream c s) - (map-stream (lambda (x) (* c x)) s)) +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. -(define (enumerate-interval n1 n2) - (if (> n1 n2) - the-empty-stream - (cons-stream n1 (enumerate-interval (1+ n1) n2)))) +1. Any copy made of this software must include this copyright notice +in full. -(define (integers-from n) - (cons-stream n (integers-from (1+ n)))) +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. -(define integers - (integers-from 0)) - -;;;; Some Hairier Stuff - -(define (merge s1 s2) - (cond ((empty-stream? s1) s2) - ((empty-stream? s2) s1) - (else - (let ((h1 (head s1)) - (h2 (head s2))) - (cond ((< h1 h2) - (cons-stream h1 - (merge (tail s1) - s2))) - ((> h1 h2) - (cons-stream h2 - (merge s1 - (tail s2)))) - (else - (cons-stream h1 - (merge (tail s1) - (tail s2))))))))) +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. |# + +;;;; Basic Stream Operations +;;; package: (runtime stream) + +(declare (usual-integrations)) -;;;; Printing - -(define print-stream - (let () - (define (iter s) - (if (empty-stream? s) - (write-string "}") - (begin (write-string " ") - (write (head s)) - (iter (tail s))))) - (lambda (s) - (newline) - (write-string "{") - (if (empty-stream? s) - (write-string "}") - (begin (write (head s)) - (iter (tail s))))))) +(define (stream-pair? stream) + (and (pair? stream) + (promise? (cdr stream)))) + +(define-integrable (stream-null? stream) + (null? stream)) + +(define-integrable (stream-car stream) + (car stream)) + +(define-integrable (stream-cdr stream) + (force (cdr stream))) + +(define (stream . list) + (list->stream list)) + +(define (list->stream list) + (if (pair? list) + (cons-stream (car list) (list->stream (cdr list))) + (begin (if (not (null? list)) + (error "LIST->STREAM: not a proper list" list)) + '()))) + +(define (stream->list stream) + (if (stream-pair? stream) + (cons (stream-car stream) (stream->list (stream-cdr stream))) + (begin (guarantee-stream-null stream 'STREAM->LIST) '()))) + +(define (stream-length stream) + (let loop ((stream stream) (length 0)) + (if (stream-pair? stream) + (loop (stream-cdr stream) (1+ length)) + (begin (guarantee-stream-null stream 'STREAM-LENGTH) length)))) + +(define (stream-ref stream index) + (let ((tail (stream-tail stream index))) + (if (not (stream-pair? tail)) + (error "STREAM-REF: index too large" index)) + (stream-car tail))) + +(define (stream-tail stream index) + (if (not (and (integer? index) (not (negative? index)))) + (error "STREAM-TAIL: index must be nonnegative integer" index)) (let loop ((stream stream) (index index)) + (if (zero? index) + stream + (begin (if (not (stream-pair? stream)) + (error "STREAM-TAIL: index too large" index)) + (loop (stream-cdr stream) (-1+ index)))))) -;;;; Support for COLLECT - -(define (flatmap f s) - (flatten (map-stream f s))) - -(define (flatten stream) - (accumulate-delayed interleave-delayed - the-empty-stream - stream)) - -(define (accumulate-delayed combiner initial-value stream) - (if (empty-stream? stream) - initial-value - (combiner (head stream) - (delay (accumulate-delayed combiner - initial-value - (tail stream)))))) - -(define (interleave-delayed s1 delayed-s2) - (if (empty-stream? s1) - (force delayed-s2) - (cons-stream (head s1) - (interleave-delayed (force delayed-s2) - (delay (tail s1)))))) - -(define ((spread-tuple procedure) tuple) - (apply procedure tuple)) +(define (stream-map stream procedure) + (let loop ((stream stream)) + (if (stream-pair? stream) + (cons-stream (procedure (stream-car stream)) + (loop (stream-cdr stream))) + (begin (guarantee-stream-null stream 'STREAM-MAP) '())))) + +(define (guarantee-stream-null stream name) + (if (not (null? stream)) + (error (string-append (symbol->string name) ": not a proper stream") + stream))) + +(define-integrable the-empty-stream + '()) + +(define-integrable (empty-stream? stream) + (stream-null? stream)) + +(define-integrable (head stream) + (stream-car stream)) + +(define-integrable (tail stream) + (stream-cdr stream)) + +(define prime-numbers-stream) + +(define (make-prime-numbers-stream) + (letrec ((primes + (cons-stream + (cons 2 4) + (let filter ((integer 3)) + (if (let loop ((primes primes)) + (let ((prime (stream-car primes))) + (or (> (cdr prime) integer) + (and (not (zero? (remainder integer + (car prime)))) + (loop (stream-cdr primes)))))) + (cons-stream (cons integer (* integer integer)) + (filter (1+ integer))) + (filter (1+ integer))))))) + (let loop ((primes primes)) + (cons-stream (car (stream-car primes)) + (loop (stream-cdr primes)))))) +(define (initialize-package!) + (set! prime-numbers-stream (make-prime-numbers-stream))) \ No newline at end of file diff --git a/v7/src/runtime/string.scm b/v7/src/runtime/string.scm index c6074baaa..339b36465 100644 --- a/v7/src/runtime/string.scm +++ b/v7/src/runtime/string.scm @@ -1,86 +1,74 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/string.scm,v 13.43 1987/12/17 20:32:25 cph Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/string.scm,v 14.1 1988/06/13 11:51:44 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; Character String Operations +;;; package: () (declare (usual-integrations)) ;;;; Primitives -(let-syntax ((define-primitives - (macro names - `(BEGIN ,@(map (lambda (name) - `(LOCAL-ASSIGNMENT - SYSTEM-GLOBAL-ENVIRONMENT - ',name - ,(make-primitive-procedure name))) - names))))) - (define-primitives - string-allocate string? string-ref string-set! - string-length string-maximum-length set-string-length! - substring=? substring-ci=? substringascii char))) -(define (substring-find-next-char string start end char) +(define-integrable (substring-find-next-char string start end char) (vector-8b-find-next-char string start end (char->ascii char))) -(define (substring-find-previous-char string start end char) +(define-integrable (substring-find-previous-char string start end char) (vector-8b-find-previous-char string start end (char->ascii char))) -(define (substring-find-next-char-ci string start end char) +(define-integrable (substring-find-next-char-ci string start end char) (vector-8b-find-next-char-ci string start end (char->ascii char))) -(define (substring-find-previous-char-ci string start end char) +(define-integrable (substring-find-previous-char-ci string start end char) (vector-8b-find-previous-char-ci string start end (char->ascii char))) ;;; Special, not implemented in microcode. @@ -178,13 +166,13 @@ ;;;; Basic Operations (define (make-string length #!optional char) - (if (unassigned? char) + (if (default-object? char) (string-allocate length) (let ((result (string-allocate length))) (substring-fill! result 0 length char) result))) -(define (string-null? string) +(define-integrable (string-null? string) (zero? (string-length string))) (define (substring string start end) @@ -192,6 +180,12 @@ (substring-move-right! string start end result 0) result)) +(define-integrable (string-head string end) + (substring string 0 end)) + +(define (string-tail string start) + (substring string start (string-length string))) + (define (list->string chars) (let ((result (string-allocate (length chars)))) (define (loop index chars) @@ -348,11 +342,23 @@ string2 0 (string-length string2))) (define (substring-prefix? string1 start1 end1 string2 start2 end2) - (and (<= (- end1 start1) (- end2 start2)) - (= (substring-match-forward string1 start1 end1 - string2 start2 end2) - end1))) + (let ((length (- end1 start1))) + (and (<= length (- end2 start2)) + (= (substring-match-forward string1 start1 end1 + string2 start2 end2) + length)))) + +(define (string-suffix? string1 string2) + (substring-suffix? string1 0 (string-length string1) + string2 0 (string-length string2))) +(define (substring-suffix? string1 start1 end1 string2 start2 end2) + (let ((length (- end1 start1))) + (and (<= length (- end2 start2)) + (= (substring-match-backward string1 start1 end1 + string2 start2 end2) + length)))) + (define (string-compare-ci string1 string2 if= if< if>) (let ((size1 (string-length string1)) (size2 (string-length string2))) @@ -369,15 +375,27 @@ string2 0 (string-length string2))) (define (substring-prefix-ci? string1 start1 end1 string2 start2 end2) - (and (<= (- end1 start1) (- end2 start2)) - (= (substring-match-forward-ci string1 start1 end1 - string2 start2 end2) - end1))) + (let ((length (- end1 start1))) + (and (<= length (- end2 start2)) + (= (substring-match-forward-ci string1 start1 end1 + string2 start2 end2) + length)))) + +(define (string-suffix-ci? string1 string2) + (substring-suffix-ci? string1 0 (string-length string1) + string2 0 (string-length string2))) + +(define (substring-suffix-ci? string1 start1 end1 string2 start2 end2) + (let ((length (- end1 start1))) + (and (<= length (- end2 start2)) + (= (substring-match-backward-ci string1 start1 end1 + string2 start2 end2) + length)))) ;;;; Trim/Pad (define (string-trim-left string #!optional char-set) - (if (unassigned? char-set) (set! char-set char-set:not-whitespace)) + (if (default-object? char-set) (set! char-set char-set:not-whitespace)) (let ((index (string-find-next-char-in-set string char-set)) (length (string-length string))) (if (not index) @@ -385,14 +403,14 @@ (substring string index length)))) (define (string-trim-right string #!optional char-set) - (if (unassigned? char-set) (set! char-set char-set:not-whitespace)) + (if (default-object? char-set) (set! char-set char-set:not-whitespace)) (let ((index (string-find-previous-char-in-set string char-set))) (if (not index) "" (substring string 0 (1+ index))))) (define (string-trim string #!optional char-set) - (if (unassigned? char-set) (set! char-set char-set:not-whitespace)) + (if (default-object? char-set) (set! char-set char-set:not-whitespace)) (let ((index (string-find-next-char-in-set string char-set))) (if (not index) "" @@ -400,7 +418,7 @@ (1+ (string-find-previous-char-in-set string char-set)))))) (define (string-pad-right string n #!optional char) - (if (unassigned? char) (set! char #\Space)) + (if (default-object? char) (set! char #\Space)) (let ((length (string-length string))) (if (= length n) string @@ -412,7 +430,7 @@ result)))) (define (string-pad-left string n #!optional char) - (if (unassigned? char) (set! char #\Space)) + (if (default-object? char) (set! char #\Space)) (let ((length (string-length string))) (if (= length n) string diff --git a/v7/src/runtime/strnin.scm b/v7/src/runtime/strnin.scm index a5982e744..aa8a40211 100644 --- a/v7/src/runtime/strnin.scm +++ b/v7/src/runtime/strnin.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/strnin.scm,v 14.1 1988/05/20 01:01:53 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/strnin.scm,v 14.2 1988/06/13 11:51:51 cph Rel $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,7 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; String I/O Ports -;;; package: string-io-package +;;; package: (runtime string-input) (declare (usual-integrations)) diff --git a/v7/src/runtime/strott.scm b/v7/src/runtime/strott.scm index 1313b9741..6fce9150c 100644 --- a/v7/src/runtime/strott.scm +++ b/v7/src/runtime/strott.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/strott.scm,v 14.1 1988/05/20 01:02:10 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/strott.scm,v 14.2 1988/06/13 11:51:56 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,7 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; String Output Ports (Truncated) -;;; package: truncated-string-output-package +;;; package: (runtime truncated-string-output) (declare (usual-integrations)) diff --git a/v7/src/runtime/strout.scm b/v7/src/runtime/strout.scm index 89147753d..670da734c 100644 --- a/v7/src/runtime/strout.scm +++ b/v7/src/runtime/strout.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/strout.scm,v 14.1 1988/05/20 01:02:26 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/strout.scm,v 14.2 1988/06/13 11:52:01 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,7 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; String Output Ports -;;; package: string-output-package +;;; package: (runtime string-output) (declare (usual-integrations)) diff --git a/v7/src/runtime/syntab.scm b/v7/src/runtime/syntab.scm index 475f22e98..c645683ce 100644 --- a/v7/src/runtime/syntab.scm +++ b/v7/src/runtime/syntab.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntab.scm,v 14.1 1988/05/20 01:02:42 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntab.scm,v 14.2 1988/06/13 11:52:05 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,7 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Syntax Table -;;; package: syntax-table-package +;;; package: (runtime syntax-table) (declare (usual-integrations)) @@ -43,17 +43,17 @@ MIT in each case. |# (parent false read-only true)) (define (make-syntax-table #!optional parent) - (if (default-object? parent) - (set! parent false) - (check-syntax-table parent 'MAKE-SYNTAX-TABLE)) - (%make-syntax-table '() parent)) + (%make-syntax-table '() + (if (default-object? parent) + false + (guarantee-syntax-table parent)))) -(define (check-syntax-table table name) - (if (not (syntax-table? table)) - (error "Not a syntax table" name table))) +(define (guarantee-syntax-table table) + (if (not (syntax-table? table)) (error "Illegal syntax table" table)) + table) -(define (syntax-table-ref table name) - (check-syntax-table table 'SYNTAX-TABLE-REF) +(define (syntax-table/ref table name) + (guarantee-syntax-table table) (let loop ((table table)) (and table (let ((entry (assq name (syntax-table/alist table)))) @@ -61,8 +61,11 @@ MIT in each case. |# (cdr entry) (loop (syntax-table/parent table))))))) -(define (syntax-table-define table name transform) - (check-syntax-table table 'SYNTAX-TABLE-DEFINE) +(define syntax-table-ref + syntax-table/ref) + +(define (syntax-table/define table name transform) + (guarantee-syntax-table table) (let ((entry (assq name (syntax-table/alist table)))) (if entry (set-cdr! entry transform) @@ -70,13 +73,16 @@ MIT in each case. |# (cons (cons name transform) (syntax-table/alist table)))))) +(define syntax-table-define + syntax-table/define) + (define (syntax-table/copy table) - (check-syntax-table table 'SYNTAX-TABLE/COPY) + (guarantee-syntax-table table) (let loop ((table table)) (and table (%make-syntax-table (alist-copy (syntax-table/alist table)) (loop (syntax-table/parent table)))))) (define (syntax-table/extend table alist) - (check-syntax-table table 'SYNTAX-TABLE/EXTEND) + (guarantee-syntax-table table) (%make-syntax-table (alist-copy alist) table)) \ No newline at end of file diff --git a/v7/src/runtime/syntax.scm b/v7/src/runtime/syntax.scm index 617ebaab5..be3b3bf53 100644 --- a/v7/src/runtime/syntax.scm +++ b/v7/src/runtime/syntax.scm @@ -1,104 +1,134 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 13.51 1987/11/17 20:11:13 jinx Rel $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; 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. -;;; +#| -*-Scheme-*- -;;;; SYNTAX: S-Expressions -> SCODE - -(declare (usual-integrations)) - -(define lambda-tag:unnamed - (make-named-tag "UNNAMED-PROCEDURE")) - -(define *fluid-let-type* - 'SHALLOW) +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 14.1 1988/06/13 11:54:32 cph Exp $ -(define lambda-tag:shallow-fluid-let - (make-named-tag "SHALLOW-FLUID-LET-PROCEDURE")) +Copyright (c) 1988 Massachusetts Institute of Technology -(define lambda-tag:deep-fluid-let - (make-named-tag "DEEP-FLUID-LET-PROCEDURE")) +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. -(define lambda-tag:common-lisp-fluid-let - (make-named-tag "COMMON-LISP-FLUID-LET-PROCEDURE")) +1. Any copy made of this software must include this copyright notice +in full. -(define lambda-tag:let - (make-named-tag "LET-PROCEDURE")) +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. -(define lambda-tag:make-environment - (make-named-tag "MAKE-ENVIRONMENT-PROCEDURE")) +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. -(define syntax) -(define syntax*) -(define macro-spreader) +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. -(define enable-scan-defines!) -(define with-scan-defines-enabled) -(define disable-scan-defines!) -(define with-scan-defines-disabled) +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. |# -;; Enable shallow vs fluid binding for FLUID-LET -(define shallow-fluid-let!) -(define deep-fluid-let!) -(define common-lisp-fluid-let!) +;;;; SYNTAX: S-Expressions -> SCODE +;;; package: (runtime syntaxer) +(declare (usual-integrations)) + +(define (initialize-package!) + (set-fluid-let-type! 'SHALLOW) + (enable-scan-defines!) + (set! lambda-tag:unnamed (make-named-tag "UNNAMED-PROCEDURE")) + (set! lambda-tag:let (make-named-tag "LET-PROCEDURE")) + (set! lambda-tag:fluid-let (make-named-tag "FLUID-LET-PROCEDURE")) + (set! lambda-tag:make-environment (make-named-tag "MAKE-ENVIRONMENT")) + (set! system-global-syntax-table (make-system-global-syntax-table)) + (set! user-initial-syntax-table + (make-syntax-table system-global-syntax-table))) + +(define lambda-tag:unnamed) +(define lambda-tag:let) +(define lambda-tag:fluid-let) +(define lambda-tag:make-environment) (define system-global-syntax-table) -(define syntax-table?) -(define make-syntax-table) -(define extend-syntax-table) -(define copy-syntax-table) -(define syntax-table-ref) -(define syntax-table-define) -(define syntax-table-shadow) -(define syntax-table-undefine) - -(define syntaxer-package) -(let ((external-make-sequence make-sequence) - (external-make-lambda make-lambda)) -(set! syntaxer-package (the-environment)) +(define user-initial-syntax-table) + +(define (make-system-global-syntax-table) + (let ((table (make-syntax-table))) + (for-each (lambda (entry) + (syntax-table-define table (car entry) + (make-primitive-syntaxer (cadr entry)))) + `( + ;; R*RS special forms + (BEGIN ,syntax/begin) + (COND ,syntax/cond) + (DEFINE ,syntax/define) + (DELAY ,syntax/delay) + (IF ,syntax/if) + (LAMBDA ,syntax/lambda) + (LET ,syntax/let) + (OR ,syntax/or) + (QUOTE ,syntax/quote) + (SET! ,syntax/set!) + + ;; Syntax extensions + (DEFINE-SYNTAX ,syntax/define-syntax) + (DEFINE-MACRO ,syntax/define-macro) + (LET-SYNTAX ,syntax/let-syntax) + (MACRO ,syntax/lambda) + (USING-SYNTAX ,syntax/using-syntax) + + ;; Environment extensions + (ACCESS ,syntax/access) + (IN-PACKAGE ,syntax/in-package) + (THE-ENVIRONMENT ,syntax/the-environment) + (UNASSIGNED? ,syntax/unassigned?) + ;; To facilitate upgrade to new option argument mechanism. + (DEFAULT-OBJECT? ,syntax/unassigned?) + + ;; Miscellaneous extensions + (DECLARE ,syntax/declare) + (FLUID-LET ,syntax/fluid-let) + (LOCAL-DECLARE ,syntax/local-declare) + (NAMED-LAMBDA ,syntax/named-lambda) + (SCODE-QUOTE ,syntax/scode-quote))) + table)) -;;;; Dispatch Point +;;;; Top Level Syntaxers + +(define *syntax-table*) +(define *current-keyword* false) + +(define (syntax expression #!optional table) + (cond ((default-object? table) (set! table *syntax-table*)) + ((not (syntax-table? table)) + (error "SYNTAX: not a syntax table" table))) + (syntax-top-level syntax-expression table expression)) + +(define (syntax* expressions #!optional table) + (cond ((default-object? table) (set! table *syntax-table*)) + ((not (syntax-table? table)) + (error "SYNTAX: not a syntax table" table))) + (syntax-top-level syntax-sequence table expressions)) + +(define (syntax-top-level syntax-expression table expression) + (fluid-let ((*syntax-table* table) + (*current-keyword* false)) + (syntax-expression expression))) (define (syntax-expression expression) (cond ((pair? expression) - (let ((quantum (syntax-table-ref syntax-table (car expression)))) - (if quantum - (fluid-let ((saved-keyword (car expression))) - (quantum expression)) + (let ((transform (syntax-table-ref *syntax-table* (car expression)))) + (if transform + (if (primitive-syntaxer? transform) + (transform-apply (primitive-syntaxer/transform transform) + expression) + (let ((result (transform-apply transform expression))) + (if (syntax-closure? result) + (syntax-closure/expression result) + (syntax-expression result)))) (make-combination (syntax-expression (car expression)) (syntax-expressions (cdr expression)))))) ((symbol? expression) @@ -106,39 +136,71 @@ (else expression))) -(define (syntax-expressions expressions) - (if (null? expressions) - '() - (cons (syntax-expression (car expressions)) - (syntax-expressions (cdr expressions))))) +;;; Two overlapping kludges here. This should go away and be replaced +;;; by a true syntactic closure mechanism like that described by +;;; Bawden and Rees. -(define ((spread-arguments kernel) expression) - (apply kernel (cdr expression))) +(define-integrable (make-syntax-closure expression) + (cons syntax-closure-tag expression)) -(define saved-keyword - (make-interned-symbol "")) +(define (syntax-closure? expression) + (and (pair? expression) + (eq? (car expression) syntax-closure-tag))) -(define (syntax-error message . irritant) - (error (string-append message - ": " - (symbol->string saved-keyword) - " SYNTAX") - (cond ((null? irritant) *the-non-printing-object*) - ((null? (cdr irritant)) (car irritant)) - (else irritant)))) +(define-integrable (syntax-closure/expression syntax-closure) + (cdr syntax-closure)) + +(define syntax-closure-tag + "syntax-closure") + +(define-integrable (make-primitive-syntaxer expression) + (cons primitive-syntaxer-tag expression)) + +(define (primitive-syntaxer? expression) + (and (pair? expression) + (eq? (car expression) primitive-syntaxer-tag))) + +(define-integrable (primitive-syntaxer/transform primitive-syntaxer) + (cdr primitive-syntaxer)) + +(define primitive-syntaxer-tag + "primitive-syntaxer") -(define (syntax-sequence subexpressions) - (if (null? subexpressions) - (syntax-error "No subforms in sequence") - (make-sequence (syntax-sequentially subexpressions)))) +(define (transform-apply transform expression) + (fluid-let ((*current-keyword* (car expression))) + (let ((n-arguments (length (cdr expression)))) + (if (not (procedure-arity-valid? transform n-arguments)) + (syntax-error "incorrect number of subforms" n-arguments))) + (apply transform (cdr expression)))) + +(define (syntax-error message . irritants) + (error (string-append "SYNTAX: " + (if *current-keyword* + (string-append (symbol->string *current-keyword*) + ": " + message) + message)) + (cond ((null? irritants) *the-non-printing-object*) + ((null? (cdr irritants)) (car irritants)) + (else irritants)))) -(define (syntax-sequentially expressions) +(define (syntax-expressions expressions) (if (null? expressions) '() - ;; force eval order. - (let ((first (syntax-expression (car expressions)))) - (cons first - (syntax-sequentially (cdr expressions)))))) + (cons (syntax-expression (car expressions)) + (syntax-expressions (cdr expressions))))) + +(define (syntax-sequence expressions) + (if (null? expressions) + (syntax-error "No subforms in sequence") + (make-scode-sequence + (let loop ((expressions expressions)) + (if (null? expressions) + '() + ;; Force eval order. This is required so that special + ;; forms such as `define-syntax' work correctly. + (let ((first (syntax-expression (car expressions)))) + (cons first (loop (cdr expressions))))))))) (define (syntax-bindings bindings receiver) (cond ((null? bindings) @@ -163,41 +225,31 @@ (syntax-error "Non-symbolic variable" (car chain)))) (define (expand-binding-value rest) - (cond ((null? rest) unassigned-object) + (cond ((null? rest) (make-unassigned-reference-trap)) ((null? (cdr rest)) (syntax-expression (car rest))) (else (syntax-error "Too many forms in value" rest)))) -(define expand-conjunction - (let () - (define (expander forms) - (if (null? (cdr forms)) - (syntax-expression (car forms)) - (make-conjunction (syntax-expression (car forms)) - (expander (cdr forms))))) - (named-lambda (expand-conjunction forms) - (if (null? forms) - true - (expander forms))))) - -(define expand-disjunction - (let () - (define (expander forms) - (if (null? (cdr forms)) - (syntax-expression (car forms)) - (make-disjunction (syntax-expression (car forms)) - (expander (cdr forms))))) - (named-lambda (expand-disjunction forms) - (if (null? forms) - false - (expander forms))))) +(define (expand-disjunction forms) + (if (null? forms) + false + (let loop ((forms forms)) + (if (null? (cdr forms)) + (syntax-expression (car forms)) + (make-disjunction (syntax-expression (car forms)) + (loop (cdr forms))))))) (define (expand-lambda pattern actions receiver) - (define (loop pattern body) - (if (pair? (car pattern)) - (loop (car pattern) - (make-lambda (cdr pattern) body)) - (receiver pattern body))) - ((if (pair? pattern) loop receiver) pattern (syntax-lambda-body actions))) + ((if (pair? pattern) + (letrec ((loop + (lambda (pattern body) + (if (pair? (car pattern)) + (loop (car pattern) + (make-simple-lambda (cdr pattern) body)) + (receiver pattern body))))) + loop) + receiver) + pattern + (syntax-lambda-body actions))) (define (syntax-lambda-body body) (syntax-sequence @@ -207,473 +259,255 @@ (cdr body) ;discard documentation string. body))) -;;;; Quasiquote - -(define expand-quasiquote) -(let () - -(define (descend-quasiquote x level return) - (cond ((pair? x) (descend-quasiquote-pair x level return)) - ((vector? x) (descend-quasiquote-vector x level return)) - (else (return 'QUOTE x)))) - -(define (descend-quasiquote-pair x level return) - (define (descend-quasiquote-pair* level) - (descend-quasiquote (car x) level - (lambda (car-mode car-arg) - (descend-quasiquote (cdr x) level - (lambda (cdr-mode cdr-arg) - (cond ((and (eq? car-mode 'QUOTE) - (eq? cdr-mode 'QUOTE)) - (return 'QUOTE x)) - ((eq? car-mode 'UNQUOTE-SPLICING) - (if (and (eq? cdr-mode 'QUOTE) - (null? cdr-arg)) - (return 'UNQUOTE car-arg) - (return (system 'APPEND) - (list car-arg - (finalize-quasiquote cdr-mode cdr-arg))))) - ((and (eq? cdr-mode 'QUOTE) - (null? cdr-arg)) - (return 'LIST - (list (finalize-quasiquote car-mode car-arg)))) - ((and (eq? cdr-mode 'QUOTE) - (list? cdr-arg)) - (return 'LIST - (cons (finalize-quasiquote car-mode car-arg) - (map (lambda (el) - (finalize-quasiquote 'QUOTE el)) - cdr-arg)))) - ((memq cdr-mode '(LIST CONS)) - (return cdr-mode - (cons (finalize-quasiquote car-mode car-arg) - cdr-arg))) - (else - (return - 'CONS - (list (finalize-quasiquote car-mode car-arg) - (finalize-quasiquote cdr-mode cdr-arg)))))))))) - (case (car x) - ((QUASIQUOTE) (descend-quasiquote-pair* (1+ level))) - ((UNQUOTE UNQUOTE-SPLICING) - (if (zero? level) - (return (car x) (cadr x)) - (descend-quasiquote-pair* (- level 1)))) - (else (descend-quasiquote-pair* level)))) - -(define (descend-quasiquote-vector x level return) - (descend-quasiquote (vector->list x) level - (lambda (mode arg) - (case mode - ((QUOTE) - (return 'QUOTE x)) - ((LIST) - (return (system 'VECTOR) arg)) - (else - (return (system 'LIST->VECTOR) - (list (finalize-quasiquote mode arg)))))))) - -(define (finalize-quasiquote mode arg) - (case mode - ((QUOTE) `',arg) - ((UNQUOTE) arg) - ((UNQUOTE-SPLICING) (error ",@ in illegal context" arg)) - ((LIST) `(,(system 'LIST) ,@arg)) - ((CONS) - (if (= (length arg) 2) - `(,(system 'CONS) ,@arg) - `(,(system 'CONS*) ,@arg))) - (else `(,mode ,@arg)))) - -(define (system name) - `(ACCESS ,name #F)) - -(set! expand-quasiquote - (named-lambda (expand-quasiquote expression) - (syntax-expression (descend-quasiquote expression 0 finalize-quasiquote)))) - -) - ;;;; Basic Syntax -(define syntax-SCODE-QUOTE-form - (spread-arguments - (lambda (expression) - (make-quotation (syntax-expression expression))))) - -(define syntax-QUOTE-form - (spread-arguments identity-procedure)) - -(define syntax-THE-ENVIRONMENT-form - (spread-arguments make-the-environment)) - -(define syntax-UNASSIGNED?-form - (spread-arguments make-unassigned?)) - -(define syntax-UNBOUND?-form - (spread-arguments make-unbound?)) - -(define syntax-ACCESS-form - (spread-arguments - (lambda chain - (expand-access chain make-access)))) - -(define syntax-SET!-form - (spread-arguments - (lambda (name . rest) - ((invert-expression (syntax-expression name)) - (expand-binding-value rest))))) - -(define syntax-DEFINE-form - (spread-arguments - (lambda (pattern . rest) - (cond ((symbol? pattern) - (make-definition pattern - (expand-binding-value - (if (and (= (length rest) 2) - (string? (cadr rest))) - (list (car rest)) - rest)))) - ((pair? pattern) - (expand-lambda pattern rest - (lambda (pattern body) - (make-definition (car pattern) - (make-named-lambda (car pattern) (cdr pattern) - body))))) - (else - (syntax-error "Bad pattern" pattern)))))) - -(define syntax-SEQUENCE-form - (spread-arguments - (lambda actions - (syntax-sequence actions)))) - -(define syntax-IN-PACKAGE-form - (spread-arguments - (lambda (environment . body) - (make-in-package (syntax-expression environment) - (syntax-sequence body))))) - -(define syntax-DELAY-form - (spread-arguments - (lambda (expression) - (make-delay (syntax-expression expression))))) - -(define syntax-CONS-STREAM-form - (spread-arguments - (lambda (head tail) - (make-combination* cons - (syntax-expression head) - (make-delay (syntax-expression tail)))))) +(define (syntax/scode-quote expression) + (make-quotation (syntax-expression expression))) + +(define (syntax/quote expression) + expression) + +(define (syntax/the-environment) + (make-the-environment)) + +(define (syntax/unassigned? name) + (make-unassigned? name)) + +(define (syntax/access . chain) + (expand-access chain make-access)) + +(define (syntax/set! name . rest) + ((invert-expression (syntax-expression name)) (expand-binding-value rest))) + +(define (syntax/define pattern . rest) + (cond ((symbol? pattern) + (make-definition pattern + (expand-binding-value + (if (and (= (length rest) 2) + (string? (cadr rest))) + (list (car rest)) + rest)))) + ((pair? pattern) + (expand-lambda pattern rest + (lambda (pattern body) + (make-definition (car pattern) + (make-named-lambda (car pattern) (cdr pattern) + body))))) + (else + (syntax-error "Bad pattern" pattern)))) + +(define (syntax/begin . actions) + (syntax-sequence actions)) + +(define (syntax/in-package environment . body) + (make-in-package (syntax-expression environment) + (syntax-sequence body))) + +(define (syntax/delay expression) + (make-delay (syntax-expression expression))) ;;;; Conditionals -(define syntax-IF-form - (spread-arguments - (lambda (predicate consequent . rest) - (make-conditional (syntax-expression predicate) - (syntax-expression consequent) - (cond ((null? rest) undefined-conditional-branch) - ((null? (cdr rest)) - (syntax-expression (car rest))) - (else - (syntax-error "Too many forms" (cdr rest)))))))) - -(define syntax-CONJUNCTION-form - (spread-arguments - (lambda forms - (expand-conjunction forms)))) - -(define syntax-DISJUNCTION-form - (spread-arguments - (lambda forms - (expand-disjunction forms)))) - -(define syntax-COND-form - (let () - (define (process-cond-clauses clause rest) - (cond ((eq? (car clause) 'ELSE) - (if (null? rest) - (syntax-sequence (cdr clause)) - (syntax-error "ELSE not last clause" rest))) - ((null? (cdr clause)) - (make-disjunction (syntax-expression (car clause)) - (if (null? rest) - undefined-conditional-branch - (process-cond-clauses (car rest) - (cdr rest))))) - ((and (pair? (cdr clause)) - (eq? (cadr clause) '=>)) - (syntax-expression - `((ACCESS COND-=>-HELPER SYNTAXER-PACKAGE '()) - ,(car clause) - (LAMBDA () ,@(cddr clause)) - (LAMBDA () - ,(if (null? rest) - undefined-conditional-branch - `(COND ,@rest)))))) - (else - (make-conditional (syntax-expression (car clause)) - (syntax-sequence (cdr clause)) - (if (null? rest) - undefined-conditional-branch - (process-cond-clauses (car rest) - (cdr rest))))))) - (spread-arguments - (lambda (clause . rest) - (process-cond-clauses clause rest))))) - -(define (cond-=>-helper form1-result thunk2 thunk3) - (if form1-result - ((thunk2) form1-result) - (thunk3))) +(define (syntax/if predicate consequent . rest) + (make-conditional (syntax-expression predicate) + (syntax-expression consequent) + (cond ((null? rest) undefined-conditional-branch) + ((null? (cdr rest)) + (syntax-expression (car rest))) + (else + (syntax-error "Too many forms" (cdr rest)))))) + +(define (syntax/or . expressions) + (expand-disjunction expressions)) + +(define (syntax/cond clause . rest) + (let loop ((clause clause) (rest rest)) + (cond ((eq? (car clause) 'ELSE) + (if (null? rest) + (syntax-sequence (cdr clause)) + (syntax-error "ELSE not last clause" rest))) + ((null? (cdr clause)) + (make-disjunction (syntax-expression (car clause)) + (if (null? rest) + undefined-conditional-branch + (loop (car rest) (cdr rest))))) + ((and (pair? (cdr clause)) + (eq? (cadr clause) '=>)) + (syntax-expression + `((ACCESS SYNTAXER/COND-=>-HELPER '()) + ,(car clause) + (LAMBDA () ,@(cddr clause)) + (LAMBDA () + ,(if (null? rest) + undefined-conditional-branch + `(COND ,@rest)))))) + (else + (make-conditional (syntax-expression (car clause)) + (syntax-sequence (cdr clause)) + (if (null? rest) + undefined-conditional-branch + (loop (car rest) (cdr rest)))))))) ;;;; Procedures -(define syntax-LAMBDA-form - (spread-arguments - (lambda (pattern . body) - (make-lambda pattern (syntax-lambda-body body))))) - -(define syntax-NAMED-LAMBDA-form - (spread-arguments - (lambda (pattern . body) - (expand-lambda pattern body - (lambda (pattern body) - (if (pair? pattern) - (make-named-lambda (car pattern) (cdr pattern) body) - (syntax-error "Illegal named-lambda list" pattern))))))) - -(define syntax-LET-form - (spread-arguments - (lambda (name-or-pattern pattern-or-first . rest) - (if (symbol? name-or-pattern) - (syntax-bindings pattern-or-first - (lambda (names values) - (make-letrec (list name-or-pattern) - (list (make-named-lambda name-or-pattern names - (syntax-sequence rest))) - (make-combination (make-variable name-or-pattern) - values)))) - (syntax-bindings name-or-pattern - (lambda (names values) - (make-closed-block - lambda-tag:let names values - (syntax-sequence (cons pattern-or-first rest))))))))) - -(define syntax-MAKE-ENVIRONMENT-form - (spread-arguments - (lambda body - (make-closed-block - lambda-tag:make-environment '() '() - (if (null? body) - the-environment-object - (make-sequence* (syntax-sequence body) the-environment-object)))))) +(define (syntax/lambda pattern . body) + (make-simple-lambda pattern (syntax-lambda-body body))) + +(define (syntax/named-lambda pattern . body) + (expand-lambda pattern body + (lambda (pattern body) + (if (pair? pattern) + (make-named-lambda (car pattern) (cdr pattern) body) + (syntax-error "Illegal named-lambda list" pattern))))) + +(define (syntax/let name-or-pattern pattern-or-first . rest) + (if (symbol? name-or-pattern) + (syntax-bindings pattern-or-first + (lambda (names values) + (make-letrec (list name-or-pattern) + (list (make-named-lambda name-or-pattern names + (syntax-sequence rest))) + (make-combination (make-variable name-or-pattern) + values)))) + (syntax-bindings name-or-pattern + (lambda (names values) + (make-closed-block + lambda-tag:let names values + (syntax-sequence (cons pattern-or-first rest))))))) ;;;; Syntax Extensions -(define syntax-LET-SYNTAX-form - (spread-arguments - (lambda (bindings . body) - (syntax-bindings bindings - (lambda (names values) - (fluid-let ((syntax-table - (extend-syntax-table - (map (lambda (name value) - (cons name (syntax-eval value))) - names - values) - syntax-table))) - (syntax-sequence body))))))) - -(define syntax-USING-SYNTAX-form - (spread-arguments - (lambda (table . body) - (let ((table* (syntax-eval (syntax-expression table)))) - (if (not (syntax-table? table*)) - (syntax-error "Not a syntax table" table)) - (fluid-let ((syntax-table table*)) - (syntax-sequence body)))))) - -(define syntax-DEFINE-SYNTAX-form - (spread-arguments - (lambda (name value) - (cond ((symbol? name) - (syntax-table-define syntax-table name - (syntax-eval (syntax-expression value))) - name) - ((and (pair? name) (symbol? (car name))) - (syntax-table-define syntax-table (car name) - (let ((transformer - (syntax-eval (syntax-NAMED-LAMBDA-form - `(NAMED-LAMBDA ,name ,value))))) - (lambda (expression) - (apply transformer (cdr expression))))) - (car name)) - (else (syntax-error "Bad syntax description" name)))))) - -(define (syntax-MACRO-form expression) - (make-combination* (make-absolute-reference 'MACRO-SPREADER) - (syntax-LAMBDA-form expression))) - -(define (syntax-DEFINE-MACRO-form expression) - (syntax-table-define syntax-table (caadr expression) - (macro-spreader (syntax-eval (syntax-NAMED-LAMBDA-form expression)))) - (caadr expression)) - -(set! macro-spreader - (named-lambda ((macro-spreader transformer) expression) - (syntax-expression (apply transformer (cdr expression))))) - -;;;; Grab Bag - -(define (syntax-ERROR-LIKE-form procedure-name) - (spread-arguments - (lambda (message . rest) - (make-combination* (make-absolute-reference procedure-name) - (syntax-expression message) - (cond ((null? rest) - (make-absolute-reference - '*THE-NON-PRINTING-OBJECT*)) - ((null? (cdr rest)) - (syntax-expression (car rest))) - (else - (make-combination - (make-absolute-reference 'LIST) - (syntax-expressions rest)))) - (make-the-environment))))) - -(define syntax-ERROR-form - (syntax-ERROR-LIKE-form 'ERROR-PROCEDURE)) - -(define syntax-BKPT-form - (syntax-ERROR-LIKE-form 'BREAKPOINT-PROCEDURE)) - -(define syntax-QUASIQUOTE-form - (spread-arguments expand-quasiquote)) +(define (syntax/let-syntax bindings . body) + (syntax-bindings bindings + (lambda (names values) + (fluid-let ((*syntax-table* + (syntax-table/extend + *syntax-table* + (map (lambda (name value) + (cons name (syntax-eval value))) + names + values)))) + (syntax-sequence body))))) + +(define (syntax/using-syntax table . body) + (let ((table* (syntax-eval (syntax-expression table)))) + (if (not (syntax-table? table*)) + (syntax-error "Not a syntax table" table)) + (fluid-let ((*syntax-table* table*)) + (syntax-sequence body)))) + +(define (syntax/define-syntax name value) + (if (not (symbol? name)) + (syntax-error "Illegal name" name)) + (syntax-table-define *syntax-table* name + (syntax-eval (syntax-expression value))) + name) + +(define (syntax/define-macro pattern . body) + (let ((keyword (car pattern))) + (syntax-table-define *syntax-table* keyword + (syntax-eval (apply syntax/named-lambda pattern body))) + keyword)) + +(define-integrable (syntax-eval scode) + (scode-eval scode syntaxer/default-environment)) ;;;; FLUID-LET -(define syntax-FLUID-LET-form-shallow - (let () - - (define (syntax-fluid-bindings bindings receiver) - (if (null? bindings) - (receiver '() '() '() '()) - (syntax-fluid-bindings (cdr bindings) - (lambda (names values transfers-in transfers-out) - (let ((binding (car bindings))) - (if (pair? binding) - (let ((transfer - (let ((reference (syntax-expression (car binding)))) - (let ((assignment (invert-expression reference))) - (lambda (target source) - (make-assignment - target - (assignment - (make-assignment source - unassigned-object))))))) - (value (expand-binding-value (cdr binding))) - (inside-name - (string->uninterned-symbol "INSIDE-PLACEHOLDER")) - (outside-name - (string->uninterned-symbol "OUTSIDE-PLACEHOLDER"))) - (receiver (cons* inside-name outside-name names) - (cons* value unassigned-object values) - (cons (transfer outside-name inside-name) - transfers-in) - (cons (transfer inside-name outside-name) - transfers-out))) - (syntax-error "Binding not a pair" binding))))))) - - (spread-arguments - (lambda (bindings . body) - (if (null? bindings) - (syntax-sequence body) - (syntax-fluid-bindings bindings - (lambda (names values transfers-in transfers-out) - (make-closed-block - lambda-tag:shallow-fluid-let names values - (make-combination* - (make-variable 'DYNAMIC-WIND) - (make-thunk (make-sequence transfers-in)) - (make-thunk (syntax-sequence body)) - (make-thunk (make-sequence transfers-out))))))))))) - -(define syntax-FLUID-LET-form-deep) -(define syntax-FLUID-LET-form-common-lisp) -(let () - -(define (make-fluid-let primitive procedure-tag) - ;; (FLUID-LET (( ) ...) . ) => - ;; (WITH-SAVED-FLUID-BINDINGS - ;; (LAMBDA () - ;; (ADD-FLUID! (THE-ENVIRONMENT) ) - ;; ... - ;; )) - (let ((with-saved-fluid-bindings - (make-primitive-procedure 'WITH-SAVED-FLUID-BINDINGS 1))) - (spread-arguments - (lambda (bindings . body) - (syntax-fluid-bindings bindings - (lambda (names values) - (make-combination - (internal-make-lambda procedure-tag '() '() '() - (make-combination - with-saved-fluid-bindings - (list - (make-thunk - (make-sequence - (map* - (list (syntax-sequence body)) - (lambda (name-or-access value) - (cond ((variable? name-or-access) - (make-combination - primitive - (list the-environment-object - (make-quotation name-or-access) - value))) - ((access? name-or-access) - (access-components name-or-access - (lambda (env name) - (make-combination primitive - (list env name value))))) - (else - (syntax-error - "Target of FLUID-LET not a symbol or ACCESS form" - name-or-access)))) - names values)))))) - '()))))))) +(define (syntax/fluid-let bindings . body) + (syntax/fluid-let/current bindings body)) + +(define syntax/fluid-let/current) + +(define (set-fluid-let-type! type) + (set! syntax/fluid-let/current + (case type + ((SHALLOW) syntax/fluid-let/shallow) + ((DEEP) syntax/fluid-let/deep) + ((COMMON-LISP) syntax/fluid-let/common-lisp) + (else (error "SET-FLUID-LET-TYPE!: unknown type" type))))) + +(define (syntax/fluid-let/shallow bindings body) + (if (null? bindings) + (syntax-sequence body) + (syntax-fluid-bindings/shallow bindings + (lambda (names values transfers-in transfers-out) + (make-closed-block lambda-tag:fluid-let names values + (make-combination* + (make-absolute-reference 'DYNAMIC-WIND) + (make-thunk (make-scode-sequence transfers-in)) + (make-thunk (syntax-sequence body)) + (make-thunk (make-scode-sequence transfers-out)))))))) + +(define (syntax/fluid-let/deep bindings body) + (syntax/fluid-let/deep* (ucode-primitive add-fluid-binding! 3) + bindings + body)) + +(define (syntax/fluid-let/common-lisp bindings body) + (syntax/fluid-let/deep* (ucode-primitive make-fluid-binding! 3) + bindings + body)) + +(define (syntax/fluid-let/deep* add-fluid-binding! bindings body) + (make-closed-block lambda-tag:fluid-let '() '() + (make-combination* + (ucode-primitive with-saved-fluid-bindings 1) + (make-thunk + (make-scode-sequence* + (make-scode-sequence + (syntax-fluid-bindings/deep add-fluid-binding! bindings)) + (syntax-sequence body)))))) -(define (syntax-fluid-bindings bindings receiver) +(define (syntax-fluid-bindings/shallow bindings receiver) (if (null? bindings) - (receiver '() '()) - (syntax-fluid-bindings - (cdr bindings) - (lambda (names values) - (let ((binding (car bindings))) - (if (pair? binding) - (receiver (cons (let ((name (syntax-expression (car binding)))) - (if (or (variable? name) - (access? name)) - name - (syntax-error "Binding name illegal" - (car binding)))) - names) - (cons (expand-binding-value (cdr binding)) values)) - (syntax-error "Binding not a pair" binding))))))) - -(set! syntax-FLUID-LET-form-deep - (make-fluid-let (make-primitive-procedure 'ADD-FLUID-BINDING! 3) - lambda-tag:deep-fluid-let)) - -(set! syntax-FLUID-LET-form-common-lisp - ;; This -- groan -- is for Common Lisp support - (make-fluid-let (make-primitive-procedure 'MAKE-FLUID-BINDING! 3) - lambda-tag:common-lisp-fluid-let)) - -;;; end special FLUID-LETs. -) + (receiver '() '() '() '()) + (syntax-fluid-bindings/shallow (cdr bindings) + (lambda (names values transfers-in transfers-out) + (let ((binding (car bindings))) + (if (pair? binding) + (let ((transfer + (let ((reference (syntax-expression (car binding)))) + (let ((assignment (invert-expression reference))) + (lambda (target source) + (make-assignment + target + (assignment (make-assignment source))))))) + (value (expand-binding-value (cdr binding))) + (inside-name + (string->uninterned-symbol "INSIDE-PLACEHOLDER")) + (outside-name + (string->uninterned-symbol "OUTSIDE-PLACEHOLDER"))) + (receiver (cons* inside-name outside-name names) + (cons* value (make-unassigned-reference-trap) + values) + (cons (transfer outside-name inside-name) + transfers-in) + (cons (transfer inside-name outside-name) + transfers-out))) + (syntax-error "Binding not a pair" binding))))))) + +(define (syntax-fluid-bindings/deep add-fluid-binding! bindings) + (map (lambda (binding) + (syntax-fluid-binding/deep add-fluid-binding! binding)) + bindings)) + +(define (syntax-fluid-binding/deep add-fluid-binding! binding) + (if (pair? binding) + (let ((name (syntax-expression (car binding))) + (finish + (lambda (environment name) + (make-combination* add-fluid-binding! + environment + name + (expand-binding-value (cdr binding)))))) + (cond ((variable? name) + (finish (make-the-environment) (make-quotation name))) + ((access? name) + (access-components name finish)) + (else + (syntax-error "Binding name illegal" (car binding))))) + (syntax-error "Binding not a pair" binding))) ;;;; Extended Assignment Syntax @@ -697,19 +531,15 @@ ;;; DECLARATION objects all contain lists of standard declarations. ;;; Each standard declaration is a proper list with symbolic keyword. -(define syntax-LOCAL-DECLARE-form - (spread-arguments - (lambda (declarations . body) - (make-declaration (process-declarations declarations) - (syntax-sequence body))))) +(define (syntax/declare . declarations) + (make-block-declaration (map process-declaration declarations))) -(define syntax-DECLARE-form - (spread-arguments - (lambda declarations - (make-block-declaration (map process-declaration declarations))))) +(define (syntax/local-declare declarations . body) + (make-declaration (process-declarations declarations) + (syntax-sequence body))) ;;; These two procedures use `error' instead of `syntax-error' because -;;; they are called when the syntaxer is not running. +;;; they are also called when the syntaxer is not running. (define (process-declarations declarations) (if (list? declarations) @@ -728,34 +558,25 @@ ;;;; SCODE Constructors -(define unassigned-object - (make-unassigned-object)) - -(define the-environment-object - (make-the-environment)) - (define (make-conjunction first second) (make-conditional first second false)) (define (make-combination* operator . operands) (make-combination operator operands)) -(define (make-sequence* . operands) - (make-sequence operands)) - -(define (make-sequence operands) - (internal-make-sequence operands)) +(define (make-scode-sequence* . operands) + (make-scode-sequence operands)) (define (make-absolute-reference name . rest) - (let loop ((reference (make-access (make-null) name)) (rest rest)) + (let loop ((reference (make-access false name)) (rest rest)) (if (null? rest) reference (loop (make-access reference (car rest)) (cdr rest))))) (define (make-thunk body) - (make-lambda '() body)) + (make-simple-lambda '() body)) -(define (make-lambda pattern body) +(define (make-simple-lambda pattern body) (make-named-lambda lambda-tag:unnamed pattern body)) (define (make-named-lambda name pattern body) @@ -771,20 +592,21 @@ (define (make-letrec names values body) (make-closed-block lambda-tag:let '() '() - (make-sequence (append! (map make-definition names values) - (list body))))) + (make-scode-sequence + (append! (map make-definition names values) + (list body))))) ;;;; Lambda List Parser (define (parse-lambda-list lambda-list receiver) (let ((required (list '())) (optional (list '()))) - (define (parse-parameters cell) - (define (loop pattern) + (define (parse-parameters cell pattern) + (let loop ((pattern pattern)) (cond ((null? pattern) (finish false)) ((symbol? pattern) (finish pattern)) ((not (pair? pattern)) (bad-lambda-list pattern)) - ((eq? (car pattern) (access lambda-rest-tag lambda-package)) + ((eq? (car pattern) lambda-rest-tag) (if (and (pair? (cdr pattern)) (null? (cddr pattern))) (cond ((symbol? (cadr pattern)) (finish (cadr pattern))) ((and (pair? (cadr pattern)) @@ -792,9 +614,9 @@ (finish (caadr pattern))) (else (bad-lambda-list (cdr pattern)))) (bad-lambda-list (cdr pattern)))) - ((eq? (car pattern) (access lambda-optional-tag lambda-package)) + ((eq? (car pattern) lambda-optional-tag) (if (eq? cell required) - ((parse-parameters optional) (cdr pattern)) + (parse-parameters optional (cdr pattern)) (bad-lambda-list pattern))) ((symbol? (car pattern)) (set-car! cell (cons (car pattern) (car cell))) @@ -802,8 +624,7 @@ ((and (pair? (car pattern)) (symbol? (caar pattern))) (set-car! cell (cons (caar pattern) (car cell))) (loop (cdr pattern))) - (else (bad-lambda-list pattern)))) - loop) + (else (bad-lambda-list pattern))))) (define (finish rest) (receiver (reverse! (car required)) @@ -813,208 +634,27 @@ (define (bad-lambda-list pattern) (syntax-error "Illegally-formed lambda-list" pattern)) - ((parse-parameters required) lambda-list))) + (parse-parameters required lambda-list))) ;;;; Scan Defines -(define no-scan-make-sequence - external-make-sequence) - -(define (scanning-make-sequence actions) - (scan-defines (external-make-sequence actions) +(define (make-sequence/scan actions) + (scan-defines (make-sequence actions) make-open-block)) -(define (no-scan-make-lambda name required optional rest body) - (external-make-lambda name required optional rest '() '() body)) +(define (make-lambda/no-scan name required optional rest body) + (make-lambda name required optional rest '() '() body)) -(define scanning-make-lambda - make-lambda*) +(define (make-lambda/scan name required optional rest body) + (make-lambda* name required optional rest body)) -(define internal-make-sequence) +(define make-scode-sequence) (define internal-make-lambda) -(set! enable-scan-defines! - (named-lambda (enable-scan-defines!) - (set! internal-make-sequence scanning-make-sequence) - (set! internal-make-lambda scanning-make-lambda))) - -(set! with-scan-defines-enabled - (named-lambda (with-scan-defines-enabled thunk) - (fluid-let ((internal-make-sequence scanning-make-sequence) - (internal-make-lambda scanning-make-lambda)) - (thunk)))) - -(set! disable-scan-defines! - (named-lambda (disable-scan-defines!) - (set! internal-make-sequence no-scan-make-sequence) - (set! internal-make-lambda no-scan-make-lambda))) - -(set! with-scan-defines-disabled - (named-lambda (with-scan-defines-disabled thunk) - (fluid-let ((internal-make-sequence no-scan-make-sequence) - (internal-make-lambda no-scan-make-lambda)) - (thunk)))) - -(define ((fluid-let-maker marker which-kind) #!optional name) - (if (unassigned? name) (set! name 'FLUID-LET)) - (if (eq? name 'FLUID-LET) (set! *fluid-let-type* marker)) - (syntax-table-define system-global-syntax-table name which-kind)) - -(set! shallow-fluid-let! - (fluid-let-maker 'SHALLOW syntax-fluid-let-form-shallow)) - -(set! deep-fluid-let! - (fluid-let-maker 'DEEP syntax-fluid-let-form-deep)) - -(set! common-lisp-fluid-let! - (fluid-let-maker 'COMMON-LISP syntax-fluid-let-form-common-lisp)) - -;;;; Top Level Syntaxers - -(define syntax-table) +(define (enable-scan-defines!) + (set! make-scode-sequence make-sequence/scan) + (set! internal-make-lambda make-lambda/scan)) -(define syntax-environment - (in-package system-global-environment - (make-environment))) - -;;; The top level procedures, when not given an argument, use whatever -;;; the current syntax table is. This is reasonable only while inside -;;; a syntaxer quantum, since at other times there is current table. - -(define ((make-syntax-top-level syntaxer) expression #!optional table) - (if (unassigned? table) - (syntaxer expression) - (begin (check-syntax-table table 'SYNTAX) - (fluid-let ((syntax-table table)) - (syntaxer expression))))) - -(set! syntax - (make-syntax-top-level syntax-expression)) - -(set! syntax* - (make-syntax-top-level syntax-sequence)) - -(define (syntax-eval scode) - (scode-eval scode syntax-environment)) - -;;;; Syntax Table - -(define syntax-table-tag - '(SYNTAX-TABLE)) - -(set! syntax-table? - (named-lambda (syntax-table? object) - (and (pair? object) - (eq? (car object) syntax-table-tag)))) - -(define (check-syntax-table table name) - (if (not (syntax-table? table)) - (error "Not a syntax table" name table))) - -(set! make-syntax-table - (named-lambda (make-syntax-table #!optional parent) - (cons syntax-table-tag - (cons '() - (if (unassigned? parent) - '() - (cdr parent)))))) - -(set! extend-syntax-table - (named-lambda (extend-syntax-table alist #!optional table) - (if (unassigned? table) (set! table (current-syntax-table))) - (check-syntax-table table 'EXTEND-SYNTAX-TABLE) - (cons syntax-table-tag (cons alist (cdr table))))) - -(set! copy-syntax-table - (named-lambda (copy-syntax-table #!optional table) - (if (unassigned? table) (set! table (current-syntax-table))) - (check-syntax-table table 'COPY-SYNTAX-TABLE) - (cons syntax-table-tag - (map (lambda (alist) - (map (lambda (pair) - (cons (car pair) (cdr pair))) - alist)) - (cdr table))))) - -(set! syntax-table-ref - (named-lambda (syntax-table-ref table name) - (define (loop frames) - (and (not (null? frames)) - (let ((entry (assq name (car frames)))) - (if entry - (cdr entry) - (loop (cdr frames)))))) - (check-syntax-table table 'SYNTAX-TABLE-REF) - (loop (cdr table)))) - -(set! syntax-table-define - (named-lambda (syntax-table-define table name quantum) - (check-syntax-table table 'SYNTAX-TABLE-DEFINE) - (let ((entry (assq name (cadr table)))) - (if entry - (set-cdr! entry quantum) - (set-car! (cdr table) - (cons (cons name quantum) - (cadr table))))))) - -(set! syntax-table-shadow - (named-lambda (syntax-table-shadow table name) - (check-syntax-table table 'SYNTAX-TABLE-SHADOW) - (let ((entry (assq name (cadr table)))) - (if entry - (set-cdr! entry false) - (set-car! (cdr table) - (cons (cons name false) - (cadr table))))))) - -(set! syntax-table-undefine - (named-lambda (syntax-table-undefine table name) - (check-syntax-table table 'SYNTAX-TABLE-UNDEFINE) - (if (assq name (cadr table)) - (set-car! (cdr table) - (del-assq! name (cadr table)))))) - -;;;; Default Syntax - -(enable-scan-defines!) - -(set! system-global-syntax-table - (cons syntax-table-tag - `(((ACCESS . ,syntax-ACCESS-form) - (AND . ,syntax-CONJUNCTION-form) - (BEGIN . ,syntax-SEQUENCE-form) - (BKPT . ,syntax-BKPT-form) - (COND . ,syntax-COND-form) - (CONS-STREAM . ,syntax-CONS-STREAM-form) - (DECLARE . ,syntax-DECLARE-form) - (DEFINE . ,syntax-DEFINE-form) - (DEFINE-SYNTAX . ,syntax-DEFINE-SYNTAX-form) - (DEFINE-MACRO . ,syntax-DEFINE-MACRO-form) - (DELAY . ,syntax-DELAY-form) - (ERROR . ,syntax-ERROR-form) - (FLUID-LET . ,syntax-FLUID-LET-form-shallow) - (IF . ,syntax-IF-form) - (IN-PACKAGE . ,syntax-IN-PACKAGE-form) - (LAMBDA . ,syntax-LAMBDA-form) - (LET . ,syntax-LET-form) - (LET-SYNTAX . ,syntax-LET-SYNTAX-form) - (LOCAL-DECLARE . ,syntax-LOCAL-DECLARE-form) - (MACRO . ,syntax-MACRO-form) - (MAKE-ENVIRONMENT . ,syntax-MAKE-ENVIRONMENT-form) - (NAMED-LAMBDA . ,syntax-NAMED-LAMBDA-form) - (OR . ,syntax-DISJUNCTION-form) - ;; The funniness here prevents QUASIQUOTE from being - ;; seen as a nested backquote. - (,'QUASIQUOTE . ,syntax-QUASIQUOTE-form) - (QUOTE . ,syntax-QUOTE-form) - (SCODE-QUOTE . ,syntax-SCODE-QUOTE-form) - (SEQUENCE . ,syntax-SEQUENCE-form) - (SET! . ,syntax-SET!-form) - (THE-ENVIRONMENT . ,syntax-THE-ENVIRONMENT-form) - (UNASSIGNED? . ,syntax-UNASSIGNED?-form) - (UNBOUND? . ,syntax-UNBOUND?-form) - (USING-SYNTAX . ,syntax-USING-SYNTAX-form) - )))) - -;;; end SYNTAXER-PACKAGE -) \ No newline at end of file +(define (disable-scan-defines!) + (set! make-scode-sequence make-sequence) + (set! internal-make-lambda make-lambda/no-scan)) \ No newline at end of file diff --git a/v7/src/runtime/sysclk.scm b/v7/src/runtime/sysclk.scm index 58b5c542f..f4632de24 100644 --- a/v7/src/runtime/sysclk.scm +++ b/v7/src/runtime/sysclk.scm @@ -1,97 +1,81 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sysclk.scm,v 13.42 1987/12/14 00:15:38 cph Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- -;;;; System Clock +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sysclk.scm,v 14.1 1988/06/13 11:57:59 cph Rel $ -(declare (usual-integrations)) - -(define process-time-clock - (make-primitive-procedure 'SYSTEM-CLOCK 0)) +Copyright (c) 1988 Massachusetts Institute of Technology -(define real-time-clock - (make-primitive-procedure 'REAL-TIME-CLOCK 0)) +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. -(define system-clock) -(define runtime) -(define measure-interval) -(define wait-interval) -(let ((offset-time) (non-runtime)) +1. Any copy made of this software must include this copyright notice +in full. -(define (clock) - (- (process-time-clock) offset-time)) +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. -(define (ticks->seconds ticks) - (/ ticks 1000)) +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. -(define (seconds->ticks seconds) - (* seconds 1000)) +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; System Clock +;;; package: (runtime system-clock) + +(declare (usual-integrations)) + +(define (initialize-package!) + (reset-system-clock!) + (add-event-receiver! event:after-restore reset-system-clock!)) (define (reset-system-clock!) (set! offset-time (process-time-clock)) (set! non-runtime 0)) -(reset-system-clock!) -(add-event-receiver! event:after-restore reset-system-clock!) - -(set! system-clock - (named-lambda (system-clock) - (ticks->seconds (clock)))) - -(set! runtime - (named-lambda (runtime) - (ticks->seconds (- (clock) non-runtime)))) - -(set! measure-interval - (named-lambda (measure-interval runtime? thunk) - (let ((start (clock))) - (let ((receiver (thunk (ticks->seconds start)))) - (let ((end (clock))) - (if (not runtime?) - (set! non-runtime (+ (- end start) non-runtime))) - (receiver (ticks->seconds end))))))) - -(set! wait-interval - (named-lambda (wait-interval number-of-seconds) - (let ((end (+ (clock) (seconds->ticks number-of-seconds)))) - (let wait-loop () - (if (< (clock) end) - (wait-loop)))))) - -;;; end LET. -) \ No newline at end of file +(define offset-time) +(define non-runtime) + +(define-integrable process-time-clock + (ucode-primitive system-clock 0)) + +(define-integrable real-time-clock + (ucode-primitive real-time-clock 0)) + +(define (system-clock) + (process->system-time (process-time-clock))) + +(define (runtime) + (process->system-time (- (process-time-clock) non-runtime))) + +(define (increment-non-runtime! ticks) + (set! non-runtime (+ non-runtime ticks))) + +(define (measure-interval runtime? thunk) + (let ((start (process-time-clock))) + (let ((receiver (thunk (process->system-time start)))) + (let ((end (process-time-clock))) + (if (not runtime?) + (increment-non-runtime! (- end start))) + (receiver (process->system-time end)))))) + +(define-integrable (process->system-time ticks) + (internal-time/ticks->seconds (- ticks offset-time))) + +(define-integrable (internal-time/ticks->seconds ticks) + (/ ticks 1000)) + +(define-integrable (internal-time/seconds->ticks seconds) + (* seconds 1000)) \ No newline at end of file diff --git a/v7/src/runtime/sysmac.scm b/v7/src/runtime/sysmac.scm index 2b9aad691..c71be220c 100644 --- a/v7/src/runtime/sysmac.scm +++ b/v7/src/runtime/sysmac.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sysmac.scm,v 14.1 1988/05/20 01:03:06 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sysmac.scm,v 14.2 1988/06/13 11:58:05 cph Rel $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,7 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; System Internal Syntax -;;; package: system-macros-package +;;; package: (runtime system-macros) (declare (usual-integrations)) @@ -46,8 +46,7 @@ MIT in each case. |# (let ((table (make-syntax-table system-global-syntax-table))) (for-each (lambda (entry) (syntax-table-define table (car entry) (cadr entry))) - `((DEFINE-INTEGRABLE ,transform/define-integrable) - (DEFINE-PRIMITIVES ,transform/define-primitives) + `((DEFINE-PRIMITIVES ,transform/define-primitives) (UCODE-PRIMITIVE ,transform/ucode-primitive) (UCODE-RETURN-ADDRESS ,transform/ucode-return-address) (UCODE-TYPE ,transform/ucode-type))) @@ -78,52 +77,4 @@ MIT in each case. |# (define transform/ucode-return-address (macro arguments - (make-return-address (apply microcode-return arguments)))) - -(define transform/define-integrable - (macro (pattern . body) - (parse-define-syntax pattern body - (lambda (name body) - `(BEGIN (DECLARE (INTEGRATE ,pattern)) - (DEFINE ,name ,@body))) - (lambda (pattern body) - `(BEGIN (DECLARE (INTEGRATE-OPERATOR ,(car pattern))) - (DEFINE ,pattern - ,@(if (list? (cdr pattern)) - `((DECLARE - (INTEGRATE - ,@(lambda-list->bound-names (cdr pattern))))) - '()) - ,@body)))))) - -(define (parse-define-syntax pattern body if-variable if-lambda) - (cond ((pair? pattern) - (let loop ((pattern pattern) (body body)) - (cond ((pair? (car pattern)) - (loop (car pattern) `((LAMBDA ,(cdr pattern) ,@body)))) - ((symbol? (car pattern)) - (if-lambda pattern body)) - (else - (error "Illegal name" (car pattern)))))) - ((symbol? pattern) - (if-variable pattern body)) - (else - (error "Illegal name" pattern)))) - -(define (lambda-list->bound-names lambda-list) - (cond ((null? lambda-list) - '()) - ((pair? lambda-list) - (let ((lambda-list - (if (eq? (car lambda-list) lambda-optional-tag) - (begin (if (not (pair? (cdr lambda-list))) - (error "Missing optional variable" lambda-list)) - (cdr lambda-list)) - lambda-list))) - (cons (let ((parameter (car lambda-list))) - (if (pair? parameter) (car parameter) parameter)) - (lambda-list->bound-names (cdr lambda-list))))) - (else - (if (not (symbol? lambda-list)) - (error "Illegal rest variable" lambda-list)) - (list lambda-list)))) \ No newline at end of file + (make-return-address (apply microcode-return arguments)))) \ No newline at end of file diff --git a/v7/src/runtime/system.scm b/v7/src/runtime/system.scm index 67bfa0534..6f0271a71 100644 --- a/v7/src/runtime/system.scm +++ b/v7/src/runtime/system.scm @@ -1,227 +1,109 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/system.scm,v 13.52 1988/02/21 18:13:33 jinx Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- -;;;; Systems +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/system.scm,v 14.1 1988/06/13 11:58:10 cph Exp $ -(declare (usual-integrations)) - -;;; (DISK-SAVE filename #!optional identify) -;;; (DUMP-WORLD filename #!optional identify) -;;; Saves a world image in FILENAME. IDENTIFY has the following meaning: -;;; -;;; [] Not supplied => ^G on restore (normal for saving band). -;;; [] String => New world ID message, and ^G on restore. -;;; [] Otherwise => Returns normally (very useful for saving bugs!). -;;; -;;; The image saved by DISK-SAVE does not include the "microcode", the -;;; one saved by DUMP-WORLD does, and is an executable file. +Copyright (c) 1988 Massachusetts Institute of Technology -(define disk-save) -(define dump-world) -(define event:after-restore) -(define event:after-restart) -(define full-quit) -(define identify-world) -(define identify-system) -(define add-system!) -(define add-secondary-gc-daemon!) -(let () +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. -(define world-identification "Scheme") -(define known-systems '()) -(define secondary-gc-daemons '()) -(define date-world-saved) -(define time-world-saved) +1. Any copy made of this software must include this copyright notice +in full. -(define (restart-world) - (screen-clear) - (abort->top-level - (lambda () - (identify-world) - (event:after-restart)))) - -(define (setup-image save-image) - (lambda (filename #!optional identify) - (let ((d (date)) (t (time))) - (gc-flip) - ((access trigger-daemons garbage-collector-package) secondary-gc-daemons) - (save-image filename - (lambda (ie) - (set-interrupt-enables! ie) - (set! date-world-saved d) - (set! time-world-saved t) - false) - (lambda (ie) - (set-interrupt-enables! ie) - (set! date-world-saved d) - (set! time-world-saved t) - (event:after-restore) - (cond ((unassigned? identify) - (restart-world)) - ((string? identify) - (set! world-identification identify) - (restart-world)) - (else - true))))))) +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. -(set! disk-save - (setup-image save-world)) +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. -(set! dump-world - (setup-image - (let ((primitive (make-primitive-procedure 'DUMP-WORLD 1))) - (lambda (filename after-dumping after-restoring) - (let ((ie (set-interrupt-enables! interrupt-mask-none))) - ((if (primitive filename) - (lambda (ie) - ((access reset! primitive-io)) - ((access reset! working-directory-package)) - (after-restoring ie)) - after-dumping) - ie)))))) - -(set! event:after-restore (make-event-distributor)) -(set! event:after-restart (make-event-distributor)) +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. -(add-event-receiver! event:after-restart - (lambda () - (if (not (unassigned? init-file-pathname)) - (let ((file - (or (pathname->input-truename - (merge-pathnames init-file-pathname - (working-directory-pathname))) - (pathname->input-truename - (merge-pathnames init-file-pathname - (home-directory-pathname)))))) - (if (not (null? file)) - (load file user-initial-environment)))))) +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. |# -;; This is not the right place for this, but I don't know what is. +;;;; Systems +;;; package: (runtime system) -(add-event-receiver! - event:after-restore - (lambda () - ((access reset! continuation-package)))) +(declare (usual-integrations)) -(set! full-quit - (named-lambda (full-quit) - (quit) - (restart-world))) - -(set! identify-world - (named-lambda (identify-world) - (newline) - (write-string world-identification) - (write-string " saved on ") - (write-string (apply date->string date-world-saved)) - (write-string " at ") - (write-string (apply time->string time-world-saved)) - (newline) - (write-string " Release ") - (write-string (access :release microcode-system)) - (for-each identify-system known-systems))) +(define-structure (system + (constructor make-system + (name version modification files-lists)) + (conc-name system/)) + (name false read-only true) + (version false read-only true) + (modification false read-only true) + (files-lists false read-only true) + (files false)) -(set! identify-system - (named-lambda (identify-system system) - (newline) - (write-string " ") - (write-string (access :name system)) - (write-string " ") - (write (access :version system)) - (let ((mod (access :modification system))) - (if mod - (begin (write-string ".") - (write mod)))))) - -(set! add-system! - (named-lambda (add-system! system) - (set! known-systems (append! known-systems (list system))))) - -(set! add-secondary-gc-daemon! - (named-lambda (add-secondary-gc-daemon! daemon) - (if (not (memq daemon secondary-gc-daemons)) - (set! secondary-gc-daemons (cons daemon secondary-gc-daemons))))) +(define known-systems '()) -) +(define (add-system! system) + (set! known-systems (append! known-systems (list system))) + *the-non-printing-object*) + +(define (for-each-system! procedure) + (for-each procedure known-systems)) + +(define (system/identification-string system) + (string-append (system/name system) + " " + (number->string (system/version system)) + (let ((modification (system/modification system))) + (if modification + (string-append "." (number->string modification)) + "")))) -;;; Load the given system, which must have the following variables -;;; defined: -;;; -;;; :FILES which will be assigned the list of filenames actually +;;; Load the given system. + +;;; SYSTEM/FILES will be assigned the list of filenames actually ;;; loaded. -;;; -;;; :FILES-LISTS which should contain a list of pairs, the car of each + +;;; SYSTEM/FILES-LISTS should contain a list of pairs, the car of each ;;; pair being an environment, and the cdr a list of filenames. The ;;; files are loaded in the order specified, into the environments ;;; specified. COMPILED?, if false, means change all of the file ;;; types to "BIN". -(define load-system!) -(let () +(define (load-system! system #!optional compiled?) + (let ((files + (format-files-list (system/files-lists system) + (if (default-object? compiled?) + (prompt-for-confirmation "Load compiled? ") compiled?)))) + (set-system/files! system + (map (lambda (file) (pathname->string (car file))) + files)) + (for-each (lambda (file scode) + (newline) (write-string "Eval ") + (write (pathname->string (car file))) + (scode-eval scode (cdr file))) + files + (let loop ((files (map car files))) + (if (null? files) + '() + (split-list files 20 + (lambda (head tail) + (let ((expressions (map fasload head))) + (newline) + (write-string "Purify") + (purify (list->vector expressions) true) + (append! expressions (loop tail)))))))) + (newline) + (write-string "Done")) + (add-system! system) + *the-non-printing-object*) -(set! load-system! - (named-lambda (load-system! system #!optional compiled?) - (if (unassigned? compiled?) (set! compiled? (query "Load compiled"))) - (define (loop files) - (if (null? files) - '() - (split-list files 20 - (lambda (head tail) - (let ((expressions (map fasload head))) - (newline) - (write-string "Purify") - (purify (list->vector expressions) true) - (append! expressions (loop tail))))))) - (let ((files (format-files-list (access :files-lists system) compiled?))) - (set! (access :files system) - (map (lambda (file) (pathname->string (car file))) files)) - (for-each (lambda (file scode) - (newline) (write-string "Eval ") - (write (pathname->string (car file))) - (scode-eval scode (cdr file))) - files - (loop (map car files))) - (newline) - (write-string "Done")) - (add-system! system) - *the-non-printing-object*)) - (define (split-list list n receiver) (if (or (not (pair? list)) (zero? n)) (receiver '() list) @@ -233,24 +115,10 @@ (mapcan (lambda (files-list) (map (lambda (filename) (let ((pathname (->pathname filename))) - (cons (if compiled? - pathname - (pathname-new-type pathname "bin")) + (cons (if (and (not compiled?) + (equal? "com" (pathname-type pathname))) + (pathname-new-type pathname "bin") + pathname) (car files-list)))) (cdr files-list))) - files-lists)) - -(define (query prompt) - (newline) - (write-string prompt) - (write-string " (Y or N)? ") - (let ((char (char-upcase (read-char)))) - (cond ((char=? #\Y char) - (write-string "Yes") - true) - ((char=? #\N char) - (write-string "No") - false) - (else (beep) (query prompt))))) - -) \ No newline at end of file + files-lists)) \ No newline at end of file diff --git a/v7/src/runtime/udata.scm b/v7/src/runtime/udata.scm index ae11be816..dbb74013e 100644 --- a/v7/src/runtime/udata.scm +++ b/v7/src/runtime/udata.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/udata.scm,v 14.1 1988/05/20 01:04:01 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/udata.scm,v 14.2 1988/06/13 11:58:26 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Simple Microcode Data Structures +;;; package: () (declare (usual-integrations)) @@ -237,6 +238,11 @@ to the correct value before these operations are used. (define-integrable (primitive-procedure? object) (object-type? (ucode-type primitive) object)) +(define (guarantee-primitive-procedure object) + (if (not (primitive-procedure? object)) + (error "Not a primitive procedure" object)) + object) + (define (make-primitive-procedure name #!optional arity) (let ((arity (if (default-object? arity) false arity))) (let ((result ((ucode-primitive get-primitive-address) name arity))) @@ -244,8 +250,9 @@ to the correct value before these operations are used. (eq? arity true))) (if (false? result) (error "MAKE-PRIMITIVE-PROCEDURE: unknown name" name) - (error "MAKE-PRIMITIVE-PROCEDURE: inconsistent arity" - name 'NEW: arity 'OLD: result))) + (error "MAKE-PRIMITIVE-PROCEDURE: inconsistent arity" name + (error-irritant/noise "new:") arity + (error-irritant/noise "old:") result))) result))) (define (implemented-primitive-procedure? object) @@ -253,14 +260,18 @@ to the correct value before these operations are used. false)) (define (primitive-procedure-name primitive) - (if (not (primitive-procedure? primitive)) - (error "PRIMITIVE-PROCEDURE-NAME: Not a primitive procedure" primitive)) - ((ucode-primitive get-primitive-name) (object-datum primitive))) + ((ucode-primitive get-primitive-name) + (object-datum (guarantee-primitive-procedure primitive)))) (define (compound-procedure? object) (or (object-type? (ucode-type procedure) object) (object-type? (ucode-type extended-procedure) object))) +(define (guarantee-compound-procedure object) + (if (not (compound-procedure? object)) + (error "Not a compound procedure" object)) + object) + (define-integrable (compound-procedure-lambda procedure) (system-pair-car procedure)) @@ -272,15 +283,16 @@ to the correct value before these operations are used. (primitive-procedure? object) (compiled-procedure? object))) -(define (procedure-lambda procedure) - (if (not (compound-procedure? procedure)) - (error "PROCEDURE-LAMBDA: Not a compound procedure" procedure)) - (compound-procedure-lambda procedure)) +(define-integrable (procedure-lambda procedure) + (compound-procedure-lambda (guarantee-compound-procedure procedure))) + +(define-integrable (procedure-environment procedure) + (compound-procedure-environment (guarantee-compound-procedure procedure))) -(define (procedure-environment procedure) - (if (not (compound-procedure? procedure)) - (error "PROCEDURE-ENVIRONMENT: Not a compound procedure" procedure)) - (compound-procedure-environment procedure)) +(define (procedure-components procedure receiver) + (guarantee-compound-procedure procedure) + (receiver (compound-procedure-lambda procedure) + (compound-procedure-environment procedure))) (define (procedure-arity procedure) (cond ((primitive-procedure? procedure) diff --git a/v7/src/runtime/uenvir.scm b/v7/src/runtime/uenvir.scm index 9d6394c17..0fae1fe3d 100644 --- a/v7/src/runtime/uenvir.scm +++ b/v7/src/runtime/uenvir.scm @@ -1,43 +1,39 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uenvir.scm,v 14.1 1988/05/20 01:04:16 cph Exp $ -;;; -;;; Copyright (c) 1988 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions and -;;; understandings. -;;; -;;; 1. Any copy made of this software must include this copyright -;;; notice in full. -;;; -;;; 2. Users of this software agree to make their best efforts (a) -;;; to return to the MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. All materials developed as a consequence of the use of this -;;; software shall duly acknowledge such use, in accordance with -;;; the usual standards of acknowledging credit in academic -;;; research. -;;; -;;; 4. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uenvir.scm,v 14.2 1988/06/13 11:58:33 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; Microcode Environments +;;; package: (runtime environment) (declare (usual-integrations)) diff --git a/v7/src/runtime/uerror.scm b/v7/src/runtime/uerror.scm index f6c9c7c60..e526e3bcb 100644 --- a/v7/src/runtime/uerror.scm +++ b/v7/src/runtime/uerror.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uerror.scm,v 14.1 1988/05/20 01:04:37 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uerror.scm,v 14.2 1988/06/13 11:58:37 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,7 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Microcode Errors -;;; package: microcode-errors +;;; package: (runtime microcode-errors) (declare (usual-integrations)) @@ -72,10 +72,11 @@ MIT in each case. |# (define (make-error-translator alist error-type) (lambda (error-code interrupt-enables) + error-code (set-interrupt-enables! interrupt-enables) (with-proceed-point proceed-value-filter (lambda () - (signal-condition + (signal-error (let ((frame (continuation/first-subproblem (current-proceed-continuation)))) @@ -98,7 +99,7 @@ MIT in each case. |# (set-interrupt-enables! interrupt-enables) (with-proceed-point proceed-value-filter (lambda () - (signal-condition + (signal-error (make-error-condition error-type:anomalous (list (or (microcode-error/code->name error-code) error-code)) @@ -191,7 +192,7 @@ MIT in each case. |# (set-interrupt-enables! interrupt-enables) (with-proceed-point proceed-value-filter (lambda () - (signal-condition + (signal-error (make-error-condition error-type:bad-error-code (list error-code) repl-environment))))) @@ -247,7 +248,7 @@ MIT in each case. |# " argument position"))) (define (make-wrong-type-type n) - (make-condition-type (list error-type:bad-range-argument) + (make-condition-type (list error-type:wrong-type-argument) (string-append "Illegal datum in " (vector-ref nth-string n) " argument position"))) @@ -452,6 +453,12 @@ MIT in each case. |# internal-apply-frame/add-fluid-binding-name (ucode-primitive add-fluid-binding! 3)) + (define-internal-apply-handler 'UNBOUND-VARIABLE 0 2 + (ucode-primitive environment-link-name)) + + (define-internal-apply-handler 'BAD-ASSIGNMENT 0 2 + (ucode-primitive environment-link-name)) + (define-standard-frame-handler 'UNASSIGNED-VARIABLE 'EVAL-ERROR standard-frame/variable? variable-name) diff --git a/v7/src/runtime/unpars.scm b/v7/src/runtime/unpars.scm index a9205a223..004a4f05e 100644 --- a/v7/src/runtime/unpars.scm +++ b/v7/src/runtime/unpars.scm @@ -1,239 +1,373 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unpars.scm,v 13.54 1988/03/14 16:36:38 jinx Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unpars.scm,v 14.1 1988/06/13 11:58:58 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; Unparser +;;; package: (runtime unparser) (declare (usual-integrations)) -;;; Control Variables +(define (initialize-package!) + (set! string-delimiters (char-set #\" #\\ #\Tab #\Newline #\Page)) + (set! hook/interned-symbol unparse-symbol) + (set! *unparser-radix* 10) + (set! *unparser-list-breadth-limit* false) + (set! *unparser-list-depth-limit* false) + (set! system-global-unparser-table (make-system-global-unparser-table)) + (set-current-unparser-table! system-global-unparser-table)) + +(define *unparser-radix*) +(define *unparser-list-breadth-limit*) +(define *unparser-list-depth-limit*) +(define system-global-unparser-table) +(define *current-unparser-table*) + +(define (current-unparser-table) + *current-unparser-table*) + +(define (set-current-unparser-table! table) + (guarantee-unparser-table table) + (set! *current-unparser-table* table)) + +(define (make-system-global-unparser-table) + (let ((table (make-unparser-table unparse/default))) + (for-each (lambda (entry) + (unparser-table/set-entry! table (car entry) (cadr entry))) + `((BIGNUM ,unparse/number) + (CHARACTER ,unparse/character) + (COMPILED-ENTRY ,unparse/compiled-entry) + (COMPLEX ,unparse/number) + (ENTITY ,unparse/entity) + (ENVIRONMENT ,unparse/environment) + (EXTENDED-PROCEDURE ,unparse/compound-procedure) + (FIXNUM ,unparse/number) + (FLONUM ,unparse/number) + (FUTURE ,unparse/future) + (INTERNED-SYMBOL ,unparse/interned-symbol) + (LIST ,unparse/pair) + (NULL ,unparse/null) + (PRIMITIVE ,unparse/primitive-procedure) + (PROCEDURE ,unparse/compound-procedure) + (RETURN-ADDRESS ,unparse/return-address) + (STRING ,unparse/string) + (TRUE ,unparse/true) + (UNINTERNED-SYMBOL ,unparse/uninterned-symbol) + (VARIABLE ,unparse/variable) + (VECTOR ,unparse/vector) + (VECTOR-1B ,unparse/bit-string))) + table)) + +;;;; Unparser Table/State -(define *unparser-radix* #d10) -(define *unparser-list-breadth-limit* false) -(define *unparser-list-depth-limit* false) +(define-structure (unparser-table (constructor %make-unparser-table) + (conc-name unparser-table/)) + (dispatch-vector false read-only true)) -(define unparser-package - (make-environment +(define (guarantee-unparser-table table) + (if (not (unparser-table? table)) (error "Bad unparser table" table)) + table) -(define *unparse-char) -(define *unparse-string) -(define *unparse-symbol) -(define *unparser-list-depth*) -(define *slashify*) +(define (make-unparser-table default-method) + (%make-unparser-table + (make-vector (microcode-type/code-limit) default-method))) -(define (unparse-with-brackets thunk) - (*unparse-string "#[") - (thunk) - (*unparse-char #\])) +(define (unparser-table/copy table) + (%make-unparser-table (unparser-table/dispatch-vector table))) -(define (unparse-object object port slashify) - (fluid-let ((*unparse-char (access :write-char port)) - (*unparse-string (access :write-string port)) - (*unparser-list-depth* 0) - (*slashify* slashify) - (*unparse-symbol (if (unassigned? *unparse-symbol) - unparse-symbol - *unparse-symbol))) - (*unparse-object-or-future object))) - -(define (*unparse-object-or-future object) - (if (future? object) - (unparse-with-brackets - (lambda () - (*unparse-string "FUTURE ") - (unparse-datum object))) - (*unparse-object object))) +(define (unparser-table/entry table type-name) + (vector-ref (unparser-table/dispatch-vector table) + (microcode-type type-name))) + +(define (unparser-table/set-entry! table type-name method) + (vector-set! (unparser-table/dispatch-vector table) + (microcode-type type-name) + method)) + +(define-structure (unparser-state (conc-name unparser-state/)) + (port false read-only true) + (list-depth false read-only true) + (slashify? false read-only true) + (unparser-table false read-only true)) + +(define (guarantee-unparser-state state) + (if (not (unparser-state? state)) (error "Bad unparser state" state)) + state) + +;;;; Top Level + +(define (unparse-char state char) + (guarantee-unparser-state state) + (write-char char (unparser-state/port state))) + +(define (unparse-string state string) + (guarantee-unparser-state state) + (write-string string (unparser-state/port state))) + +(define (unparse-object state object) + (guarantee-unparser-state state) + (unparse-object/internal object + (unparser-state/port state) + (unparser-state/list-depth state) + (unparser-state/slashify? state) + (unparser-state/unparser-table state))) + +(define (unparse-object/internal object port list-depth slashify? table) + (fluid-let + ((*output-port* port) + (*unparse-char-operation* (output-port/operation/write-char port)) + (*unparse-string-operation* (output-port/operation/write-string port)) + (*list-depth* list-depth) + (*slashify?* slashify?) + (*unparser-table* table) + (*dispatch-vector* (unparser-table/dispatch-vector table))) + (*unparse-object object))) + +(define-integrable (invoke-user-method method object) + (method (make-unparser-state *output-port* + *list-depth* + *slashify?* + *unparser-table*) + object)) + +(define *list-depth*) +(define *slashify?*) +(define *unparser-table*) +(define *dispatch-vector*) (define (*unparse-object object) - ((vector-ref dispatch-vector (primitive-type object)) object)) + ((vector-ref *dispatch-vector* + ((ucode-primitive primitive-object-type 1) object)) + object)) + +;;;; Low Level Operations + +(define *output-port*) +(define *unparse-char-operation*) +(define *unparse-string-operation*) + +(define-integrable (*unparse-char char) + (*unparse-char-operation* *output-port* char)) + +(define-integrable (*unparse-string string) + (*unparse-string-operation* *output-port* string)) -(define (*unparse-substring string start end) +(define-integrable (*unparse-substring string start end) (*unparse-string (substring string start end))) -(define (unparse-default object) - (unparse-with-brackets - (lambda () - (*unparse-object (or (object-type object) - `(UNDEFINED-TYPE-CODE ,(primitive-type object)))) - (*unparse-char #\Space) - (unparse-datum object)))) +(define-integrable (*unparse-datum object) + (*unparse-string (number->string (object-datum object) 16))) -(define dispatch-vector - (vector-cons number-of-microcode-types unparse-default)) +(define-integrable (*unparse-hash object) + (*unparse-string (number->string (hash object)))) -(define (define-type type dispatcher) - (vector-set! dispatch-vector (microcode-type type) dispatcher)) +(define (*unparse-with-brackets name object thunk) + (*unparse-string "#[") + (if (string? name) + (*unparse-string name) + (*unparse-object name)) + (if object + (begin (*unparse-char #\Space) + (*unparse-hash object))) + (if thunk + (begin (*unparse-char #\Space) + (thunk))) + (*unparse-char #\])) -(define-type 'NULL - (lambda (x) - (if (eq? x '()) - (*unparse-string "()") - (unparse-default x)))) - -(define-type 'TRUE - (lambda (x) - (if (eq? x true) - (*unparse-string "#T") - (unparse-default x)))) - -(define-type 'RETURN-ADDRESS - (lambda (return-address) - (unparse-with-brackets - (lambda () - (*unparse-string "RETURN-ADDRESS ") - (*unparse-object (return-address-name return-address)))))) +;;;; Unparser Methods + +(define (unparse/default object) + (let ((type (user-object-type object))) + (if (zero? (object-gc-type object)) + (*unparse-with-brackets type false + (lambda () + (*unparse-datum object))) + (*unparse-with-brackets type object false)))) + +(define (user-object-type object) + (let ((type-code (object-type object))) + (let ((type-name (microcode-type/code->name type-code))) + (if type-name + (let ((entry (assq type-name renamed-user-object-types))) + (if entry (cdr entry) type-name)) + (intern + (string-append "undefined-type:" (number->string type-code))))))) + +(define renamed-user-object-types + '((FIXNUM . NUMBER) + (BIGNUM . NUMBER) + (FLONUM . NUMBER) + (COMPLEX . NUMBER) + (INTERNED-SYMBOL . SYMBOL) + (UNINTERNED-SYMBOL . SYMBOL) + (EXTENDED-PROCEDURE . PROCEDURE) + (PRIMITIVE . PRIMITIVE-PROCEDURE) + (LEXPR . LAMBDA) + (EXTENDED-LAMBDA . LAMBDA) + (COMBINATION-1 . COMBINATION) + (COMBINATION-2 . COMBINATION) + (PRIMITIVE-COMBINATION-0 . COMBINATION) + (PRIMITIVE-COMBINATION-1 . COMBINATION) + (PRIMITIVE-COMBINATION-2 . COMBINATION) + (PRIMITIVE-COMBINATION-3 . COMBINATION) + (SEQUENCE-2 . SEQUENCE) + (SEQUENCE-3 . SEQUENCE))) + +(define (unparse/null object) + (cond ((eq? object '()) (*unparse-string "()")) + ((eq? object #F) (*unparse-string "#F")) + (else (unparse/default object)))) + +(define (unparse/true object) + (cond ((eq? object true) (*unparse-string "#T")) + ((undefined-value? object) (*unparse-string "#[undefined-value]")) + (else (unparse/default object)))) + +(define (unparse/return-address return-address) + (*unparse-with-brackets 'RETURN-ADDRESS return-address + (lambda () + (*unparse-object (return-address/name return-address))))) + +(define (unparse/interned-symbol symbol) + (hook/interned-symbol symbol)) + +(define hook/interned-symbol) + +(define (unparse/uninterned-symbol symbol) + (*unparse-with-brackets 'UNINTERNED-SYMBOL + symbol + (lambda () (unparse-symbol symbol)))) (define (unparse-symbol symbol) (*unparse-string (symbol->string symbol))) -(define-type 'INTERNED-SYMBOL - (lambda (symbol) - (*unparse-symbol symbol))) - -(define-type 'UNINTERNED-SYMBOL - (lambda (symbol) - (unparse-with-brackets - (lambda () - (*unparse-string "UNINTERNED ") - (unparse-symbol symbol) - (*unparse-char #\Space) - (*unparse-object (object-hash symbol)))))) - -(define-type 'CHARACTER - (lambda (character) - (if *slashify* - (begin (*unparse-string "#\\") - (*unparse-string (char->name character true))) - (*unparse-char character)))) +(define (unparse/character character) + (if *slashify?* + (begin (*unparse-string "#\\") + (*unparse-string (char->name character true))) + (*unparse-char character))) -(define-type 'STRING - (let ((delimiters (char-set #\" #\\ #\Tab char:newline #\Page))) - (lambda (string) - (if *slashify* - (begin (*unparse-char #\") - (let ((end (string-length string))) - (define (loop start) - (let ((index (substring-find-next-char-in-set - string start end delimiters))) - (if index - (begin (*unparse-substring string start index) - (*unparse-char #\\) - (*unparse-char - (let ((char (string-ref string index))) - (cond ((char=? char #\Tab) #\t) - ((char=? char char:newline) #\n) - ((char=? char #\Page) #\f) - (else char)))) - (loop (1+ index))) - (*unparse-substring string start end)))) - (if (substring-find-next-char-in-set string 0 end - delimiters) - (loop 0) - (*unparse-string string))) - (*unparse-char #\")) - (*unparse-string string))))) +(define (unparse/string string) + (if *slashify?* + (begin (*unparse-char #\") + (let ((end (string-length string))) + (define (loop start) + (let ((index + (substring-find-next-char-in-set string start end + string-delimiters))) + (if index + (begin (*unparse-substring string start index) + (*unparse-char #\\) + (*unparse-char + (let ((char (string-ref string index))) + (cond ((char=? char #\Tab) #\t) + ((char=? char char:newline) #\n) + ((char=? char #\Page) #\f) + (else char)))) + (loop (1+ index))) + (*unparse-substring string start end)))) + (if (substring-find-next-char-in-set string 0 end + string-delimiters) + (loop 0) + (*unparse-string string))) + (*unparse-char #\")) + (*unparse-string string))) + +(define string-delimiters) + +(define (unparse/bit-string bit-string) + (*unparse-string "#*") + (let loop ((index (-1+ (bit-string-length bit-string)))) + (if (not (negative? index)) + (begin (*unparse-char (if (bit-string-ref bit-string index) #\1 #\0)) + (loop (-1+ index)))))) -(define-type 'VECTOR - (let ((nmv-type (microcode-type 'manifest-nm-vector)) - (snmv-type (microcode-type 'manifest-special-nm-vector))) - (lambda (vector) - (limit-unparse-depth +(define (unparse/vector vector) + ((or (unparse-vector/unparser vector) unparse-vector/normal) vector)) + +(define (unparse-vector/unparser vector) + (and (not (zero? (vector-length vector))) + (let ((tag (safe-vector-ref vector 0))) + (and (not (future? tag)) + (let ((method (unparser/tagged-vector-method tag))) + (and method + (lambda (object) + (invoke-user-method method object)))))))) + +(define (unparse-vector/normal vector) + (limit-unparse-depth + (lambda () + (let ((length (vector-length vector))) + (if (zero? length) + (*unparse-string "#()") + (begin + (*unparse-string "#(") + (*unparse-object (safe-vector-ref vector 0)) + (let loop ((index 1)) + (cond ((= index length) + (*unparse-char #\))) + ((and *unparser-list-breadth-limit* + (>= index *unparser-list-breadth-limit*)) + (*unparse-string " ...)")) + (else + (*unparse-char #\Space) + (*unparse-object (safe-vector-ref vector index)) + (loop (1+ index))))))))))) + +(define (safe-vector-ref vector index) + (if (with-absolutely-no-interrupts (lambda () - (let ((length (vector-length vector)) - (element - (lambda (index) - (if (with-interrupt-mask interrupt-mask-none - (lambda (ie) - (or (primitive-type? nmv-type - (vector-ref vector index)) - (primitive-type? snmv-type - (vector-ref vector index))))) - (error "Attempt to unparse partially marked vector" 0) - (vector-ref vector index))))) - (let ((normal - (lambda () - (*unparse-string "#(") - (*unparse-object-or-future (element 0)) - (let loop ((index 1)) - (cond ((= index length) - (*unparse-char #\))) - ((and *unparser-list-breadth-limit* - (>= index *unparser-list-breadth-limit*)) - (*unparse-string " ...)")) - (else - (*unparse-char #\Space) - (*unparse-object-or-future (element index)) - (loop (1+ index)))))))) - (cond ((zero? length) - (*unparse-string "#()")) - ((future? vector) - (normal)) - (else - (let ((entry - (assq (element 0) *unparser-special-objects*))) - (if entry - ((cdr entry) vector) - (normal)))))))))))) - -(define *unparser-special-objects* '()) - -(define (add-unparser-special-object! key unparser) - (set! *unparser-special-objects* - (cons (cons key unparser) - *unparser-special-objects*)) - *the-non-printing-object*) + (or (object-type? (ucode-type manifest-nm-vector) + (vector-ref vector index)) + (object-type? (ucode-type manifest-special-nm-vector) + (vector-ref vector index))))) + (error "Attempt to unparse partially marked vector" 0)) + (vector-ref vector index)) -(define-type 'LIST - (lambda (object) - ((or (unparse-list/unparser object) unparse-list) object))) +(define (unparse/pair pair) + ((or (unparse-list/unparser pair) unparse-list) pair)) (define (unparse-list list) (limit-unparse-depth (lambda () (*unparse-char #\() - (*unparse-object-or-future (car list)) + (*unparse-object (car list)) (unparse-tail (cdr list) 2) (*unparse-char #\))))) (define (limit-unparse-depth kernel) (if *unparser-list-depth-limit* - (fluid-let ((*unparser-list-depth* (1+ *unparser-list-depth*))) - (if (> *unparser-list-depth* *unparser-list-depth-limit*) + (fluid-let ((*list-depth* (1+ *list-depth*))) + (if (> *list-depth* *unparser-list-depth-limit*) (*unparse-string "...") (kernel))) (kernel))) @@ -245,7 +379,7 @@ (begin (*unparse-string " . ") (unparser l)) (begin (*unparse-char #\Space) - (*unparse-object-or-future (car l)) + (*unparse-object (car l)) (if (and *unparser-list-breadth-limit* (>= n *unparser-list-breadth-limit*) (not (null? (cdr l)))) @@ -253,105 +387,62 @@ (unparse-tail (cdr l) (1+ n))))))) ((not (null? l)) (*unparse-string " . ") - (*unparse-object-or-future l)))) + (*unparse-object l)))) (define (unparse-list/unparser object) - (cond ((future? (car object)) false) - ((unassigned-object? object) unparse-unassigned) - ((unbound-object? object) unparse-unbound) - ((reference-trap? object) unparse-reference-trap) - ((eq? (car object) 'QUOTE) - (and (pair? (cdr object)) - (null? (cddr object)) - unparse-quote-form)) - (else - (let ((entry (assq (car object) *unparser-special-pairs*))) - (and entry - (cdr entry)))))) - -(define *unparser-special-pairs* '()) - -(define (add-unparser-special-pair! key unparser) - (set! *unparser-special-pairs* - (cons (cons key unparser) - *unparser-special-pairs*)) - *the-non-printing-object*) + (and (not (future? (car object))) + (if (eq? (car object) 'QUOTE) + (and (pair? (cdr object)) + (null? (cddr object)) + unparse-quote-form) + (let ((method (unparser/tagged-pair-method (car object)))) + (and method + (lambda (object) + (invoke-user-method method object))))))) (define (unparse-quote-form pair) (*unparse-char #\') - (*unparse-object-or-future (cadr pair))) - -(define (unparse-unassigned x) - (unparse-with-brackets - (lambda () - (*unparse-string "UNASSIGNED")))) - -(define (unparse-unbound x) - (unparse-with-brackets - (lambda () - (*unparse-string "UNBOUND")))) - -(define (unparse-reference-trap x) - (unparse-with-brackets - (lambda () - (*unparse-string "REFERENCE-TRAP ") - (*unparse-object (reference-trap-kind x))))) + (*unparse-object (cadr pair))) ;;;; Procedures and Environments -(define (unparse-compound-procedure procedure) - (unparse-with-brackets - (lambda () - (*unparse-string "COMPOUND-PROCEDURE ") - (lambda-components* (procedure-lambda procedure) - (lambda (name required optional rest body) - (if (eq? name lambda-tag:unnamed) - (unparse-datum procedure) - (*unparse-object name))))))) - -(define-type 'PROCEDURE unparse-compound-procedure) -(define-type 'EXTENDED-PROCEDURE unparse-compound-procedure) - -(define (unparse-primitive-procedure proc) - (unparse-with-brackets - (lambda () - (*unparse-string "PRIMITIVE-PROCEDURE ") - (*unparse-object (primitive-procedure-name proc))))) - -(define-type 'PRIMITIVE unparse-primitive-procedure) - -(define (unparse-compiled-entry entry) - (unparse-with-brackets - (lambda () - (*unparse-string (symbol->string (compiled-entry-type entry))) - (*unparse-char #\Space) - (unparse-datum entry)))) - -(define-type 'COMPILED-ENTRY unparse-compiled-entry) - -(define-type 'ENVIRONMENT - (lambda (environment) - (if (lexical-unreferenceable? environment ':PRINT-SELF) - (unparse-default environment) - ((access :print-self environment))))) - -(define-type 'VARIABLE - (lambda (variable) - (unparse-with-brackets - (lambda () - (*unparse-string "VARIABLE ") - (*unparse-object (variable-name variable)))))) - -(define (unparse-datum object) - (*unparse-string (number->string (primitive-datum object) 16))) - -(define (unparse-number object) +(define (unparse/compound-procedure procedure) + (*unparse-with-brackets 'COMPOUND-PROCEDURE procedure + (lambda-components* (procedure-lambda procedure) + (lambda (name required optional rest body) + required optional rest body + (and (not (eq? name lambda-tag:unnamed)) + (lambda () (*unparse-object name))))))) + +(define (unparse/primitive-procedure procedure) + (*unparse-with-brackets 'PRIMITIVE-PROCEDURE false + (lambda () + (*unparse-object (primitive-procedure-name procedure))))) + +(define (unparse/compiled-entry entry) + (*unparse-with-brackets (compiled-entry-type entry) + false + (lambda () (*unparse-datum entry)))) + +(define (unparse/environment environment) + (if (lexical-unreferenceable? environment ':PRINT-SELF) + (unparse/default environment) + ((lexical-reference environment ':PRINT-SELF)))) + +(define (unparse/variable variable) + (*unparse-with-brackets 'VARIABLE variable + (lambda () (*unparse-object (variable-name variable))))) + +(define (unparse/number object) (*unparse-string (number->string object *unparser-radix*))) - -(define-type 'FIXNUM unparse-number) -(define-type 'BIGNUM unparse-number) -(define-type 'FLONUM unparse-number) -(define-type 'COMPLEX unparse-number) - -;;; end UNPARSER-PACKAGE. -)) \ No newline at end of file +(define (unparse/future future) + (*unparse-with-brackets 'FUTURE false + (lambda () + (*unparse-string + (number->string ((ucode-primitive primitive-object-datum 1) future) + 16))))) + +(define (unparse/entity entity) + (*unparse-with-brackets (if (continuation? entity) 'CONTINUATION 'ENTITY) + entity + false)) \ No newline at end of file diff --git a/v7/src/runtime/unsyn.scm b/v7/src/runtime/unsyn.scm index b9435176f..85e5087b6 100644 --- a/v7/src/runtime/unsyn.scm +++ b/v7/src/runtime/unsyn.scm @@ -1,70 +1,73 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unsyn.scm,v 13.49 1988/02/18 16:46:02 jrm Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; - -;;;; UNSYNTAX: SCODE -> S-Expressions +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unsyn.scm,v 14.1 1988/06/13 11:59:14 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; UNSYNTAX: SCode -> S-Expression +;;; package: (runtime unsyntaxer) (declare (usual-integrations)) -(define unsyntax) -(define unsyntax-lambda-list) -(define make-unsyntax-table) -(define unsyntax-table?) -(define current-unsyntax-table) -(define set-current-unsyntax-table!) -(define with-unsyntax-table) - -(define unsyntaxer-package - (make-environment - -(set! unsyntax - (named-lambda (unsyntax scode #!optional unsyntax-table) - (let ((object (if (compound-procedure? scode) - (procedure-lambda scode) - scode))) - (if (unassigned? unsyntax-table) - (unsyntax-object object) - (with-unsyntax-table unsyntax-table - (lambda () - (unsyntax-object object))))))) +(define (initialize-package!) + (set! unsyntaxer/scode-walker + (make-scode-walker unsyntax-constant + `((ACCESS ,unsyntax-ACCESS-object) + (ASSIGNMENT ,unsyntax-ASSIGNMENT-object) + (COMBINATION ,unsyntax-COMBINATION-object) + (COMMENT ,unsyntax-COMMENT-object) + (CONDITIONAL ,unsyntax-CONDITIONAL-object) + (DECLARATION ,unsyntax-DECLARATION-object) + (DEFINITION ,unsyntax-DEFINITION-object) + (DELAY ,unsyntax-DELAY-object) + (DISJUNCTION ,unsyntax-DISJUNCTION-object) + (ERROR-COMBINATION + ,unsyntax-ERROR-COMBINATION-object) + (IN-PACKAGE ,unsyntax-IN-PACKAGE-object) + (LAMBDA ,unsyntax-LAMBDA-object) + (OPEN-BLOCK ,unsyntax-OPEN-BLOCK-object) + (QUOTATION ,unsyntax-QUOTATION) + (SEQUENCE ,unsyntax-SEQUENCE-object) + (THE-ENVIRONMENT ,unsyntax-THE-ENVIRONMENT-object) + (UNASSIGNED? ,unsyntax-UNASSIGNED?-object) + (VARIABLE ,unsyntax-VARIABLE-object))))) + +(define (unsyntax scode) + (unsyntax-object + (if (compound-procedure? scode) (procedure-lambda scode) scode))) (define (unsyntax-object object) - ((unsyntax-dispatcher object) object)) + ((scode-walk unsyntaxer/scode-walker object) object)) + +(define unsyntaxer/scode-walker) (define (unsyntax-objects objects) (if (null? objects) @@ -72,25 +75,25 @@ (cons (unsyntax-object (car objects)) (unsyntax-objects (cdr objects))))) -(define (absolute-reference? object) - (and (access? object) - (eq? (access-environment object) system-global-environment))) - -(define (absolute-reference-name reference) - (access-name reference)) - -(define (absolute-reference-to? object name) - (and (absolute-reference? object) - (eq? (absolute-reference-name object) name))) +(define (unsyntax-error keyword message . irritants) + (error (string-append "UNSYNTAX: " + (symbol->string keyword) + ": " + message) + (cond ((null? irritants) *the-non-printing-object*) + ((null? (cdr irritants)) (car irritants)) + (else irritants)))) ;;;; Unsyntax Quanta +(define (unsyntax-constant object) + (if (or (pair? object) (symbol? object)) + `(QUOTE ,object) + object)) + (define (unsyntax-QUOTATION quotation) `(SCODE-QUOTE ,(unsyntax-object (quotation-expression quotation)))) -(define (unsyntax-constant object) - `(QUOTE ,object)) - (define (unsyntax-VARIABLE-object object) (variable-name object)) @@ -111,31 +114,25 @@ (assignment-components assignment (lambda (name value) `(SET! ,name - ,@(if (unassigned-object? value) + ,@(if (unassigned-reference-trap? value) '() `(,(unsyntax-object value))))))) -(define ((definition-unexpander key lambda-key) name value) +(define (unexpand-definition name value) (if (lambda? value) (lambda-components** value (lambda (lambda-name required optional rest body) (if (eq? lambda-name name) - `(,lambda-key (,name . ,(lambda-list required optional rest)) + `(DEFINE (,name . ,(lambda-list required optional rest)) ,@(unsyntax-sequence body)) - `(,key ,name ,@(unexpand-binding-value value))))) - `(,key ,name ,@(unexpand-binding-value value)))) + `(DEFINE ,name ,@(unexpand-binding-value value))))) + `(DEFINE ,name ,@(unexpand-binding-value value)))) (define (unexpand-binding-value value) - (if (unassigned-object? value) + (if (unassigned-reference-trap? value) '() `(,(unsyntax-object value)))) - -(define unexpand-definition - (definition-unexpander 'DEFINE 'DEFINE)) -(define (unsyntax-UNBOUND?-object unbound?) - `(UNBOUND? ,(unbound?-name unbound?))) - (define (unsyntax-UNASSIGNED?-object unassigned?) `(UNASSIGNED? ,(unassigned?-name unassigned?))) @@ -171,8 +168,13 @@ ,@(unsyntax-sequence expression))))) (define (unsyntax-THE-ENVIRONMENT-object object) + object `(THE-ENVIRONMENT)) +(define (unsyntax-MAKE-ENVIRONMENT names values body) + names values + `(MAKE-ENVIRONMENT ,@(except-last-pair (unsyntax-sequence body)))) + (define (unsyntax-DISJUNCTION-object object) `(OR ,@(disjunction-components object unexpand-disjunction))) @@ -233,8 +235,8 @@ ;;;; Lambdas -(define (unsyntax-LAMBDA-object lambda) - (lambda-components** lambda +(define (unsyntax-LAMBDA-object expression) + (lambda-components** expression (lambda (name required optional rest body) (let ((bvl (lambda-list required optional rest)) (body (unsyntax-sequence body))) @@ -242,28 +244,26 @@ `(LAMBDA ,bvl ,@body) `(NAMED-LAMBDA (,name . ,bvl) ,@body)))))) -(set! unsyntax-lambda-list - (named-lambda (unsyntax-lambda-list lambda) - (if (not (lambda? lambda)) - (error "Must be a lambda expression" lambda)) - (lambda-components** lambda - (lambda (name required optional rest body) - (lambda-list required optional rest))))) +(define (unsyntax-lambda-list expression) + (if (not (lambda? expression)) + (error "Must be a lambda expression" expression)) + (lambda-components** expression + (lambda (name required optional rest body) + name body + (lambda-list required optional rest)))) (define (lambda-list required optional rest) (cond ((null? rest) (if (null? optional) required - `(,@required ,(access lambda-optional-tag lambda-package) - ,@optional))) + `(,@required ,lambda-optional-tag ,@optional))) ((null? optional) `(,@required . ,rest)) (else - `(,@required ,(access lambda-optional-tag lambda-package) - ,@optional . ,rest)))) + `(,@required ,lambda-optional-tag ,@optional . ,rest)))) -(define (lambda-components** lambda receiver) - (lambda-components lambda +(define (lambda-components** expression receiver) + (lambda-components expression (lambda (name required optional rest auxiliary declarations body) (receiver name required optional rest (unscan-defines auxiliary declarations body))))) @@ -273,58 +273,50 @@ (define (unsyntax-COMBINATION-object combination) (combination-components combination (lambda (operator operands) + (let ((ordinary-combination + (lambda () + (cons (unsyntax-object operator) + (unsyntax-objects operands))))) + (cond ((and (or (eq? operator cons) + (absolute-reference-to? operator 'CONS)) + (= (length operands) 2) + (delay? (cadr operands))) + `(CONS-STREAM ,(unsyntax-object (car operands)) + ,(unsyntax-object + (delay-expression (cadr operands))))) + ((absolute-reference-to? operator 'BREAKPOINT-PROCEDURE) + (unsyntax-error-like-form operands 'BKPT)) + ((lambda? operator) + (lambda-components** operator + (lambda (name required optional rest body) + (if (and (null? optional) + (null? rest)) + (cond ((or (eq? name lambda-tag:unnamed) + (eq? name lambda-tag:let)) + `(LET ,(unsyntax-let-bindings required operands) + ,@(unsyntax-sequence body))) + ((eq? name lambda-tag:fluid-let) + (unsyntax/fluid-let required + operands + body + ordinary-combination)) + ((eq? name lambda-tag:make-environment) + (unsyntax-make-environment required + operands + body)) + (else (ordinary-combination))) + (ordinary-combination))))) + (else + (ordinary-combination))))))) - (define (unsyntax-default) - (cons (unsyntax-object operator) - (unsyntax-objects operands))) - - (cond ((and (or (eq? operator cons) - (and (variable? operator) - (eq? (variable-name operator) 'CONS))) - (= (length operands) 2) - (delay? (cadr operands))) - `(CONS-STREAM ,(unsyntax-object (car operands)) - ,(unsyntax-object - (delay-expression (cadr operands))))) - ((eq? operator error-procedure) - (unsyntax-error-like-form operands 'ERROR)) - ((absolute-reference? operator) - (case (absolute-reference-name operator) - ((ERROR-PROCEDURE) - (unsyntax-error-like-form operands 'ERROR)) - ((BREAKPOINT-PROCEDURE) - (unsyntax-error-like-form operands 'BKPT)) - (else (unsyntax-default)))) - ((lambda? operator) - (lambda-components** operator - (lambda (name required optional rest body) - (if (and (null? optional) - (null? rest)) - (cond ((or (eq? name lambda-tag:unnamed) - (eq? name lambda-tag:let)) - `(LET ,(unsyntax-let-bindings required operands) - ,@(unsyntax-sequence body))) - ((eq? name lambda-tag:deep-fluid-let) - (unsyntax-deep-fluid-let required operands body)) - ((eq? name lambda-tag:shallow-fluid-let) - (unsyntax-shallow-fluid-let required operands - body)) - ((eq? name lambda-tag:common-lisp-fluid-let) - (unsyntax-common-lisp-fluid-let required operands - body)) - ((eq? name lambda-tag:make-environment) - (unsyntax-make-environment required operands body)) - #| - Old way when named-lambda was a letrec - `(LET ,name - ,(unsyntax-let-bindings required operands) - ,@(unsyntax-sequence body)))) - |# - (else (unsyntax-default))) - (unsyntax-default))))) - (else (unsyntax-default)))))) +(define (unsyntax-let-bindings names values) + (map unsyntax-let-binding names values)) + +(define (unsyntax-let-binding name value) + `(,name ,@(unexpand-binding-value value))) +(define (unsyntax-ERROR-COMBINATION-object combination) + (unsyntax-error-like-form (combination-operands combination) 'ERROR)) - (define (unsyntax-error-like-form operands name) (cons* name (unsyntax-object (first operands)) @@ -339,26 +331,43 @@ `(,(unsyntax-object operand)))))) (else `(,(unsyntax-object operand))))))) - -(define (unsyntax-shallow-FLUID-LET names values body) + +(define (unsyntax/fluid-let names values body if-malformed) (combination-components body (lambda (operator operands) - `(FLUID-LET ,(unsyntax-let-bindings - (map extract-transfer-var - (sequence-actions (lambda-body (car operands)))) - (let every-other ((values values)) - (if (null? values) - '() - (cons (car values) (every-other (cddr values)))))) - ,@(lambda-components** (cadr operands) - (lambda (name required optional rest body) - (unsyntax-sequence body))))))) + (cond ((or (absolute-reference-to? operator 'DYNAMIC-WIND) + (and (variable? operator) + (eq? (variable-name operator) 'DYNAMIC-WIND))) + (unsyntax/fluid-let/shallow names values operands)) + ((and (eq? operator (ucode-primitive with-saved-fluid-bindings 1)) + (null? names) + (null? values) + (not (null? operands)) + (null? (cdr operands))) + (unsyntax/fluid-let/deep (car operands))) + (else + (if-malformed)))))) + +(define (unsyntax/fluid-let/shallow names values operands) + names + `(FLUID-LET ,(unsyntax-let-bindings + (map extract-transfer-var + (sequence-actions (lambda-body (car operands)))) + (let every-other ((values values)) + (if (null? values) + '() + (cons (car values) (every-other (cddr values)))))) + ,@(lambda-components** (cadr operands) + (lambda (name required optional rest body) + name required optional rest + (unsyntax-sequence body))))) (define (extract-transfer-var assignment) (assignment-components assignment (lambda (name value) + name (cond ((assignment? value) - (assignment-components value (lambda (name value) name))) + (assignment-components value (lambda (name value) value name))) ((combination? value) (combination-components value (lambda (operator operands) @@ -366,131 +375,43 @@ `(ACCESS ,(cadr operands) ,@(unexpand-access (car operands)))) (else - (error "FLUID-LET: Unknown SCODE form" assignment)))))) + (unsyntax-error 'FLUID-LET + "Unknown SCODE form" + assignment)))))) (else - (error "FLUID-LET: Unknown SCODE form" assignment)))))) - -(define ((unsyntax-deep-or-common-FLUID-LET name prim) - ignored-required ignored-operands body) - (define (sequence->list seq) - (if (sequence? seq) - (sequence-actions seq) - (list seq))) - (define (unsyntax-fluid-bindings l) - (define (unsyntax-fluid-assignment combi) - (let ((operands (combination-operands combi))) - (let ((env (first operands)) - (name (second operands)) - (val (third operands))) - (cond ((symbol? name) - `((ACCESS ,name ,(unsyntax-object env)) - ,(unsyntax-object val))) - ((quotation? name) - (let ((var (quotation-expression name))) - (if (variable? var) - `(,(variable-name var) ,(unsyntax-object val)) - (error "FLUID-LET unsyntax: unexpected name" name)))) - (else - (error "FLUID-LET unsyntax: unexpected name" name)))))) - (let ((first (car l))) - (if (and (combination? first) - (eq? (combination-operator first) prim)) - (let ((remainder (unsyntax-fluid-bindings (cdr l)))) - (cons - (cons (unsyntax-fluid-assignment first) (car remainder)) - (cdr remainder))) - (cons '() (unsyntax-objects l))))) - - (let* ((thunk (car (combination-operands body))) - (real-body (lambda-body thunk)) - (seq-list (sequence->list real-body)) - (fluid-binding-list (unsyntax-fluid-bindings seq-list))) - `(,name ,(car fluid-binding-list) ,@(cdr fluid-binding-list)))) - -(define unsyntax-deep-FLUID-LET - (unsyntax-deep-or-common-FLUID-LET - 'FLUID-LET (make-primitive-procedure 'add-fluid-binding! 3))) - -(define unsyntax-common-lisp-FLUID-LET - (unsyntax-deep-or-common-FLUID-LET - 'FLUID-BIND (make-primitive-procedure 'make-fluid-binding! 3))) - -(define (unsyntax-MAKE-ENVIRONMENT names values body) - `(MAKE-ENVIRONMENT ,@(except-last-pair (unsyntax-sequence body)))) - -(define (unsyntax-let-bindings names values) - (map unsyntax-let-binding names values)) - -(define (unsyntax-let-binding name value) - `(,name ,@(unexpand-binding-value value))) + (unsyntax-error 'FLUID-LET "Unknown SCODE form" assignment)))))) -;;;; Unsyntax Tables - -(define unsyntax-table-tag - '(UNSYNTAX-TABLE)) - -(set! make-unsyntax-table - (named-lambda (make-unsyntax-table alist) - (cons unsyntax-table-tag - (make-type-dispatcher alist identity-procedure)))) - -(set! unsyntax-table? - (named-lambda (unsyntax-table? object) - (and (pair? object) - (eq? (car object) unsyntax-table-tag)))) - -(set! current-unsyntax-table - (named-lambda (current-unsyntax-table) - *unsyntax-table)) - -(set! set-current-unsyntax-table! - (named-lambda (set-current-unsyntax-table! table) - (if (not (unsyntax-table? table)) - (error "Not an unsyntax table" 'SET-CURRENT-UNSYNTAX-TABLE! table)) - (set-table! table))) - -(set! with-unsyntax-table - (named-lambda (with-unsyntax-table table thunk) - (define old-table) - (if (not (unsyntax-table? table)) - (error "Not an unsyntax table" 'WITH-UNSYNTAX-TABLE table)) - (dynamic-wind (lambda () - (set! old-table (set-table! table))) - thunk - (lambda () - (set! table (set-table! old-table)))))) - -(define unsyntax-dispatcher) -(define *unsyntax-table) - -(define (set-table! table) - (set! unsyntax-dispatcher (cdr table)) - (set! *unsyntax-table table)) - -;;;; Default Unsyntax Table - -(set-table! - (make-unsyntax-table - `((,(microcode-type-object 'LIST) ,unsyntax-constant) - (,symbol-type ,unsyntax-constant) - (,variable-type ,unsyntax-VARIABLE-object) - (,unbound?-type ,unsyntax-UNBOUND?-object) - (,unassigned?-type ,unsyntax-UNASSIGNED?-object) - (,combination-type ,unsyntax-COMBINATION-object) - (,quotation-type ,unsyntax-QUOTATION) - (,access-type ,unsyntax-ACCESS-object) - (,definition-type ,unsyntax-DEFINITION-object) - (,assignment-type ,unsyntax-ASSIGNMENT-object) - (,conditional-type ,unsyntax-CONDITIONAL-object) - (,disjunction-type ,unsyntax-DISJUNCTION-object) - (,comment-type ,unsyntax-COMMENT-object) - (,declaration-type ,unsyntax-DECLARATION-object) - (,sequence-type ,unsyntax-SEQUENCE-object) - (,open-block-type ,unsyntax-OPEN-BLOCK-object) - (,delay-type ,unsyntax-DELAY-object) - (,in-package-type ,unsyntax-IN-PACKAGE-object) - (,the-environment-type ,unsyntax-THE-ENVIRONMENT-object) - (,lambda-type ,unsyntax-LAMBDA-object)))) - -;;; end UNSYNTAXER-PACKAGE -)) \ No newline at end of file +(define (unsyntax/fluid-let/deep expression) + (let ((body (lambda-body expression))) + (let loop + ((actions (sequence-actions body)) + (receiver + (lambda (bindings body) + `(FLUID-LET ,bindings ,@body)))) + (let ((action (car actions))) + (if (and (combination? action) + (or (eq? (combination-operator action) + (ucode-primitive add-fluid-binding! 3)) + (eq? (combination-operator action) + (ucode-primitive make-fluid-binding! 3)))) + (loop (cdr actions) + (lambda (bindings body) + (receiver (cons (unsyntax-fluid-assignment action) bindings) + body))) + (receiver '() (unsyntax-objects actions))))))) + +(define (unsyntax-fluid-assignment combination) + (let ((operands (combination-operands combination))) + (let ((environment (car operands)) + (name (cadr operands)) + (value (caddr operands))) + (cond ((symbol? name) + `((ACCESS ,name ,(unsyntax-object environment)) + ,(unsyntax-object value))) + ((quotation? name) + (let ((variable (quotation-expression name))) + (if (variable? variable) + `(,(variable-name variable) ,(unsyntax-object value)) + (unsyntax-error 'FLUID-LET "unexpected name" name)))) + (else + (unsyntax-error 'FLUID-LET "unexpected name" name)))))) \ No newline at end of file diff --git a/v7/src/runtime/unxdir.scm b/v7/src/runtime/unxdir.scm index 5f1aaed66..1e1ce6cf4 100644 --- a/v7/src/runtime/unxdir.scm +++ b/v7/src/runtime/unxdir.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxdir.scm,v 14.1 1988/06/13 10:49:56 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxdir.scm,v 14.2 1988/06/13 11:59:36 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,7 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Directory Operations -- unix -;;; package: (directory) +;;; package: (runtime directory) (declare (usual-integrations)) diff --git a/v7/src/runtime/unxpth.scm b/v7/src/runtime/unxpth.scm index d767d09cb..65c2f9637 100644 --- a/v7/src/runtime/unxpth.scm +++ b/v7/src/runtime/unxpth.scm @@ -1,341 +1,78 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxpth.scm,v 1.8 1987/11/24 22:27:04 jrm Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- -;;;; Unix pathname parsing and unparsing. +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxpth.scm,v 14.1 1988/06/13 11:59:45 cph Exp $ -(declare (usual-integrations)) - -;;; A note about parsing of filename strings: the standard syntax for -;;; a filename string is "..". Since the Unix -;;; file system treats "." just like any other character, it is -;;; possible to give files strange names like "foo.bar.baz.mum". In -;;; this case, the resulting name would be "foo.bar.baz", and the -;;; resulting type would be "mum". In general, degenerate filenames -;;; (including names with non-numeric versions) are parsed such that -;;; the characters following the final "." become the type, while the -;;; characters preceding the final "." become the name. - -;;;; Parse - -(define (symbol->pathname symbol) - (string->pathname (string-downcase (symbol->string symbol)))) - -(define parse-pathname) -(define pathname-as-directory) -(define home-directory-pathname) -(let () +Copyright (c) 1988 Massachusetts Institute of Technology -(set! parse-pathname - (named-lambda (parse-pathname string receiver) - (let ((end (string-length string))) - (parse-device string 0 end - (lambda (device start) - (let ((components - (let ((components - (substring-components string start end #\/))) - (append (expand-directory-prefixes (car components)) - (cdr components))))) - (parse-name (car (last-pair components)) - (lambda (name type version) - (receiver device - (parse-directory-components - (except-last-pair components)) - name type version))))))))) +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. -(define (parse-directory-components components) - (if (null? components) - '() - (cons (if (string-null? (car components)) - 'ROOT - (parse-directory-component (car components))) - (map parse-directory-component (cdr components))))) +1. Any copy made of this software must include this copyright notice +in full. -(set! pathname-as-directory - (named-lambda (pathname-as-directory pathname) - (make-pathname - (pathname-device pathname) - (let ((directory (pathname-directory pathname))) - (let ((file (pathname-unparse-name (pathname-name pathname) - (pathname-type pathname) - (pathname-version pathname)))) - (if (string-null? file) - directory - (let ((file-components (list (parse-directory-component file)))) - (cond ((or (null? directory) (eq? directory 'UNSPECIFIC)) - file-components) - ((pair? directory) - (append directory file-components)) - (else (error "Illegal pathname directory" directory))))))) - false false false))) - -(define (parse-device string start end receiver) - (let ((index (substring-find-next-char string start end #\:))) - (if index - (receiver (substring string start index) (1+ index)) - (receiver false start)))) +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. -(define (parse-directory-component component) - (cond ((string=? "*" component) 'WILD) - ((string=? "." component) 'SELF) - ((string=? ".." component) 'UP) - (else component))) +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. -(define (expand-directory-prefixes string) - (if (string-null? string) - (list string) - (case (string-ref string 0) - ((#\$) - (string-components - (get-environment-variable - (substring string 1 (string-length string))) - #\/)) - ((#\~) - (let ((user-name (substring string 1 (string-length string)))) - (string-components - (if (string-null? user-name) - (get-environment-variable "HOME") - (get-user-home-directory user-name)) - #\/))) - (else (list string))))) +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. -(set! home-directory-pathname - (lambda () - (pathname-as-directory - (string->pathname (get-environment-variable "HOME"))))) +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. |# -(define get-environment-variable - (let ((primitive (make-primitive-procedure 'GET-ENVIRONMENT-VARIABLE))) - (lambda (name) - (or (primitive name) - (error "GET-ENVIRONMENT-VARIABLE: Unbound name" name))))) - -(define get-user-home-directory - (let ((primitive (make-primitive-procedure 'GET-USER-HOME-DIRECTORY))) - (lambda (user-name) - (or (primitive user-name) - (error "User has no home directory" user-name))))) - -(define (parse-name string receiver) - (let ((start 0) - (end (string-length string))) - (define (find-next-dot start) - (substring-find-next-char string start end #\.)) - - (define (find-previous-dot start) - (substring-find-previous-char string start end #\.)) - - (define (parse-version start) - (cond ((= start end) "") - ((substring=? string start end "*" 0 1) 'WILD) - ((substring-find-next-char string start end #\*) - (substring string start end)) - (else - (let ((n (digits->number (reverse! (substring->list string start - end)) - 1 0))) - (if (and n (>= n 0)) - (if (= n 0) 'NEWEST n) - (substring string start end)))))) - - (if (= start end) - (receiver false false false) - (let ((index (find-next-dot start))) - (if index - (let ((start* (1+ index)) - (name (wildify string start index))) - (if (= start* end) - (receiver name "" false) - (or (let ((index (find-next-dot start*))) - (and index - (let ((version (parse-version (1+ index)))) - (and (not (string? version)) - (receiver name - (wildify string start* index) - version))))) - (let ((index (find-previous-dot start))) - (receiver (wildify string start index) - (wildify string (1+ index) end) - false))))) - (receiver (wildify string start end) false false)))))) - -(define (wildify string start end) - (if (substring=? string start end "*" 0 1) - 'WILD - (substring string start end))) - -(define (string-components string delimiter) - (substring-components string 0 (string-length string) delimiter)) - -(define (substring-components string start end delimiter) - (define (loop start) - (let ((index (substring-find-next-char string start end delimiter))) - (if index - (cons (substring string start index) - (loop (1+ index))) - (list (substring string start end))))) - (loop start)) - -(define (digits->number digits weight accumulator) - (if (null? digits) - accumulator - (let ((value (char->digit (car digits) 10))) - (and value - (digits->number (cdr digits) - (* weight 10) - (+ (* weight value) accumulator)))))) - -;;; end LET. -) - -;;;; Unparse +;;;; Miscellaneous Pathnames -- Unix +;;; package: () -(define pathname-unparse) -(define pathname-unparse-name) -(let () - -(set! pathname-unparse - (named-lambda (pathname-unparse device directory name type version) - (string-append (let ((device-string (unparse-component device))) - (if device-string - (string-append device-string ":") - "")) - (unparse-directory directory) - (pathname-unparse-name name type version)))) - -(define (unparse-directory directory) - (define (loop directory) - (if (null? directory) - "" - (string-append (unparse-directory-component (car directory)) - "/" - (loop (cdr directory))))) - (cond ((null? directory) "") - ((pair? directory) - (string-append (if (eq? (car directory) 'ROOT) - "" - (unparse-directory-component (car directory))) - "/" - (loop (cdr directory)))) - (else (error "Illegal pathname directory" directory)))) - -(define (unparse-directory-component component) - (cond ((eq? component 'WILD) "*") - ((eq? component 'SELF) ".") - ((eq? component 'UP) "..") - ((string? component) component) - (else (error "Illegal pathname directory component" component)))) - -(set! pathname-unparse-name - (named-lambda (pathname-unparse-name name type version) - (let ((name (unparse-component name)) - (type (unparse-component type)) - (version (unparse-version version))) - (cond ((not name) "") - ((not type) name) - ((not version) (string-append name "." type)) - (else (string-append name "." type "." version)))))) - -(define (unparse-component component) - (cond ((or (not component) (string? component)) component) - ((eq? component 'UNSPECIFIC) false) - ((eq? component 'WILD) "*") - (else (error "Illegal pathname component" component)))) - -(define (unparse-version version) - (cond ((or (not version) (string? version)) version) - ((eq? version 'UNSPECIFIC) false) - ((eq? version 'WILD) "*") - ((eq? version 'NEWEST) "0") - ((and (integer? version) (> version 0)) - (list->string (number->digits version '()))) - (else (error "Illegal pathname version" version)))) - -(define (number->digits number accumulator) - (if (zero? number) - accumulator - (let ((qr (integer-divide number 10))) - (number->digits (integer-divide-quotient qr) - (cons (digit->char (integer-divide-remainder qr)) - accumulator))))) - -;;; end LET. -) +(declare (usual-integrations)) -;;;; Working Directory - -(define working-directory-pathname) -(define set-working-directory-pathname!) - -(define working-directory-package - (make-environment - -(define primitive - (make-primitive-procedure 'WORKING-DIRECTORY-PATHNAME)) - -(define pathname) - -(define (reset!) - (set! pathname - (string->pathname - (let ((string (primitive))) - (let ((length (string-length string))) - (if (or (zero? length) - (not (char=? #\/ (string-ref string (-1+ length))))) - (string-append string "/") - string)))))) - -(set! working-directory-pathname - (named-lambda (working-directory-pathname) - pathname)) - -(set! set-working-directory-pathname! - (named-lambda (set-working-directory-pathname! name) - (set! pathname - (pathname-as-directory - (pathname->absolute-pathname (->pathname name)))) - pathname)) +(define (symbol->pathname symbol) + (string->pathname (string-downcase (symbol->string symbol)))) -;;; end WORKING-DIRECTORY-PACKAGE -)) +(define (home-directory-pathname) + (pathname-as-directory (string->pathname (get-environment-variable "HOME")))) -(define init-file-pathname +(define (init-file-pathname) (string->pathname ".scheme.init")) (define pathname-newest - false) \ No newline at end of file + false) + +(define (file-directory? filename) + (let ((truename (pathname->input-truename (->pathname filename)))) + (and truename + ((ucode-primitive file-directory?) (pathname->string truename))))) + +(define (file-symbolic-link? filename) + (let ((truename (pathname->input-truename (->pathname filename)))) + (and truename + ((ucode-primitive file-symlink?) (pathname->string truename))))) + +(define (file-attributes filename) + (let ((truename (pathname->input-truename (->pathname filename)))) + (and truename + ((ucode-primitive file-attributes) (pathname->string truename))))) + +(define (file-modification-time filename) + (let ((attributes (file-attributes filename))) + (and attributes + (vector-ref attributes 5)))) + +(define (get-environment-variable name) + (or ((ucode-primitive get-environment-variable) name) + (error "GET-ENVIRONMENT-VARIABLE: Unbound name" name))) + +(define (get-user-home-directory user-name) + (or ((ucode-primitive get-user-home-directory) user-name) + (error "User has no home directory" user-name))) \ No newline at end of file diff --git a/v7/src/runtime/urtrap.scm b/v7/src/runtime/urtrap.scm index be3e3fc1f..f54b87174 100644 --- a/v7/src/runtime/urtrap.scm +++ b/v7/src/runtime/urtrap.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/urtrap.scm,v 14.1 1988/05/20 01:06:12 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/urtrap.scm,v 14.2 1988/06/13 11:59:56 cph Rel $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,7 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Reference Traps -;;; package: reference-trap-package +;;; package: (runtime reference-trap) (declare (usual-integrations)) diff --git a/v7/src/runtime/utabs.scm b/v7/src/runtime/utabs.scm index 6cb36f0a4..d733a7029 100644 --- a/v7/src/runtime/utabs.scm +++ b/v7/src/runtime/utabs.scm @@ -1,109 +1,119 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/utabs.scm,v 13.48 1988/03/14 16:37:15 jinx Rel $ -;;; -;;; Copyright (c) 1987 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions and -;;; understandings. -;;; -;;; 1. Any copy made of this software must include this copyright -;;; notice in full. -;;; -;;; 2. Users of this software agree to make their best efforts (a) -;;; to return to the MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. All materials developed as a consequence of the use of this -;;; software shall duly acknowledge such use, in accordance with -;;; the usual standards of acknowledging credit in academic -;;; research. -;;; -;;; 4. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; - -;;;; Microcode Table Interface +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/utabs.scm,v 14.1 1988/06/13 12:00:01 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Microcode Name <-> Code Maps +;;; package: (runtime microcode-tables) (declare (usual-integrations)) -(define fixed-objects-vector-slot) - -(define number-of-microcode-types) -(define microcode-type-name) -(define microcode-type) -(define microcode-type-predicate) -(define object-type) - -(define number-of-microcode-returns) -(define microcode-return) -(define make-return-address) -(define return-address?) -(define return-address-code) -(define return-address-name) - -(define number-of-microcode-errors) -(define microcode-error) - -(define number-of-microcode-terminations) -(define microcode-termination) -(define microcode-termination-name) - -(define make-primitive-procedure) -(define primitive-procedure?) -(define primitive-procedure-name) -(define implemented-primitive-procedure?) - -(define microcode-identification-item) - -(define future?) - -(define microcode-system - (make-environment - -(define :name "Microcode") -(define :version) -(define :modification) -(define :identification) -(define :release) - -(let-syntax ((define-primitive - (macro (name arity) - `(DEFINE ,name ,(make-primitive-procedure name arity))))) - (define-primitive binary-fasload 1) - (define-primitive microcode-identify 0) - (define-primitive microcode-tables-filename 0) - (define-primitive map-machine-address-to-code 2) - (define-primitive map-code-to-machine-address 2) - (define-primitive get-primitive-address 2) - (define-primitive get-primitive-name 1) - (define-primitive get-primitive-counts 0)) +(define (initialize-package!) + (read-microcode-tables!) + (add-event-receiver! event:after-restore read-microcode-tables!)) + +(define (read-microcode-tables!) + (set! microcode-tables-identification + (scode-eval ((ucode-primitive binary-fasload) + ((ucode-primitive microcode-tables-filename))) + system-global-environment)) + (set! identification-vector ((ucode-primitive microcode-identify))) + (set! errors-slot (fixed-object/name->code 'MICROCODE-ERRORS-VECTOR)) + (set! identifications-slot + (fixed-object/name->code 'MICROCODE-IDENTIFICATION-VECTOR)) + (set! returns-slot (fixed-object/name->code 'MICROCODE-RETURNS-VECTOR)) + (set! terminations-slot + (fixed-object/name->code 'MICROCODE-TERMINATIONS-VECTOR)) + (set! types-slot (fixed-object/name->code 'MICROCODE-TYPES-VECTOR)) + (set! non-object-slot (fixed-object/name->code 'NON-OBJECT)) + (set! microcode-id/version + (microcode-identification-item 'MICROCODE-VERSION)) + (set! microcode-id/modification + (microcode-identification-item 'MICROCODE-MODIFICATION)) + (set! microcode-id/release-string + (microcode-identification-item 'SYSTEM-RELEASE-STRING)) + (set! char:newline (microcode-identification-item 'NEWLINE-CHAR)) + (set! microcode-id/tty-x-size (microcode-identification-item 'CONSOLE-WIDTH)) + (set! microcode-id/tty-y-size + (microcode-identification-item 'CONSOLE-HEIGHT)) + (set! microcode-id/floating-mantissa-bits + (microcode-identification-item 'FLONUM-MANTISSA-LENGTH)) + (set! microcode-id/floating-exponent-bits + (microcode-identification-item 'FLONUM-EXPONENT-LENGTH)) (set! microcode-id/operating-system-name + (microcode-identification-item 'OS-NAME-STRING)) + (set! microcode-id/operating-system-variant + (microcode-identification-item 'OS-VARIANT-STRING)) + (set! microcode-id/stack-type + (let ((string (microcode-identification-item 'STACK-TYPE-STRING))) + (cond ((string? string) (intern string)) + ((not string) 'STANDARD) + (else (error "illegal stack type" string)))))) + +(define microcode-tables-identification) +(define microcode-id/version) +(define microcode-id/modification) +(define microcode-id/release-string) +(define char:newline) +(define microcode-id/tty-x-size) +(define microcode-id/tty-y-size) +(define microcode-id/floating-mantissa-bits) +(define microcode-id/floating-exponent-bits)(define microcode-id/operating-system-name) +(define microcode-id/operating-system-variant) +(define microcode-id/stack-type) -;;;; Fixed Objects Vector +(define-integrable fixed-objects-slot 15) +(define non-object-slot) + +(define (fixed-object/name->code name) + (microcode-table-search fixed-objects-slot name)) -(set! fixed-objects-vector-slot -(named-lambda (fixed-objects-vector-slot name) - (or (microcode-table-search 15 name) - (error "FIXED-OBJECTS-VECTOR-SLOT: Unknown name" name)))) +(define (fixed-object/code->name code) + (microcode-table-ref fixed-objects-slot code)) -(define fixed-objects) +(define (fixed-object/code-limit) + (vector-length (vector-ref (get-fixed-objects-vector) fixed-objects-slot))) + +(define (fixed-objects-vector-slot name) + (or (fixed-object/name->code name) + (error "FIXED-OBJECTS-VECTOR-SLOT: Unknown name" name))) + +(define (fixed-objects-item name) + (vector-ref (get-fixed-objects-vector) (fixed-objects-vector-slot name))) + +(define (microcode-object/unassigned) + (vector-ref (get-fixed-objects-vector) non-object-slot)) (define (microcode-table-search slot name) - (let ((vector (vector-ref fixed-objects slot))) + (let ((vector (vector-ref (get-fixed-objects-vector) slot))) (let ((end (vector-length vector))) (define (loop i) (and (not (= i end)) @@ -116,230 +126,64 @@ (loop 0)))) (define (microcode-table-ref slot index) - (let ((vector (vector-ref fixed-objects slot))) + (let ((vector (vector-ref (get-fixed-objects-vector) slot))) (and (< index (vector-length vector)) (let ((entry (vector-ref vector index))) (if (pair? entry) (car entry) entry))))) -;;;; Microcode Type Codes - -(define types-slot) - -(define renamed-user-object-types - '((FIXNUM . NUMBER) - (BIGNUM . NUMBER) - (FLONUM . NUMBER) - (COMPLEX . NUMBER) - (INTERNED-SYMBOL . SYMBOL) - (UNINTERNED-SYMBOL . SYMBOL) - (EXTENDED-PROCEDURE . PROCEDURE) - (PRIMITIVE . PRIMITIVE-PROCEDURE) - (LEXPR . LAMBDA) - (EXTENDED-LAMBDA . LAMBDA) - (COMBINATION-1 . COMBINATION) - (COMBINATION-2 . COMBINATION) - (PRIMITIVE-COMBINATION-0 . COMBINATION) - (PRIMITIVE-COMBINATION-1 . COMBINATION) - (PRIMITIVE-COMBINATION-2 . COMBINATION) - (PRIMITIVE-COMBINATION-3 . COMBINATION) - (SEQUENCE-2 . SEQUENCE) - (SEQUENCE-3 . SEQUENCE))) - -(set! microcode-type-name -(named-lambda (microcode-type-name type) - (microcode-table-ref types-slot type))) - -(set! microcode-type -(named-lambda (microcode-type name) - (or (microcode-table-search types-slot name) - (error "MICROCODE-TYPE: Unknown name" name)))) - -(set! microcode-type-predicate -(named-lambda (microcode-type-predicate name) - (type-predicate (microcode-type name)))) - -(define ((type-predicate type) object) - (primitive-type? type object)) - -(set! object-type -(named-lambda (object-type object) - (let ((type (microcode-type-name (primitive-type object)))) - (let ((entry (assq type renamed-user-object-types))) - (if (not (null? entry)) - (cdr entry) - type))))) - -;;;; Microcode Return Codes - (define returns-slot) -(define return-address-type) - -(set! microcode-return -(named-lambda (microcode-return name) - (microcode-table-search returns-slot name))) - -(set! make-return-address -(named-lambda (make-return-address code) - (map-code-to-machine-address return-address-type code))) -(set! return-address? -(named-lambda (return-address? object) - (primitive-type? return-address-type object))) +(define (microcode-return/name->code name) + (microcode-table-search returns-slot name)) -(set! return-address-code -(named-lambda (return-address-code return-address) - (map-machine-address-to-code return-address-type return-address))) +(define (microcode-return/code->name code) + (microcode-table-ref returns-slot code)) -(set! return-address-name -(named-lambda (return-address-name return-address) - (microcode-table-ref returns-slot (return-address-code return-address)))) - -;;;; Microcode Error Codes +(define (microcode-return/code-limit) + (vector-length (vector-ref (get-fixed-objects-vector) returns-slot))) (define errors-slot) -(set! microcode-error -(named-lambda (microcode-error name) - (microcode-table-search errors-slot name))) +(define (microcode-error/name->code name) + (microcode-table-search errors-slot name)) -;;;; Microcode Termination Codes +(define (microcode-error/code->name code) + (microcode-table-ref errors-slot code)) -(define termination-vector-slot) +(define (microcode-error/code-limit) + (vector-length (vector-ref (get-fixed-objects-vector) errors-slot))) -(set! microcode-termination -(named-lambda (microcode-termination name) - (microcode-table-search termination-vector-slot name))) +(define terminations-slot) -(set! microcode-termination-name -(named-lambda (microcode-termination-name type) - (code->name termination-vector-slot type))) +(define (microcode-termination/name->code name) + (microcode-table-search terminations-slot name)) -(define identification-vector-slot) +(define (microcode-termination/code->name code) + (microcode-table-ref terminations-slot code)) -(set! microcode-identification-item - (lambda (name) - (vector-ref :identification - (or (microcode-table-search identification-vector-slot name) - (error "Unknown identification item" name))))) - -;;;; Microcode Primitives - -(define primitive-type-code) - -(define renamed-user-primitives - '((NOT . NULL?) - (FALSE? . NULL?) - (FIRST . CAR) - (FIRST-TAIL . CDR) - (SET-FIRST! . SET-CAR!) - (SET-FIRST-TAIL! . SET-CDR!) - (VECTOR-SIZE . VECTOR-LENGTH) - (STRING-SIZE . VECTOR-8B-SIZE) - (&OBJECT-REF . SYSTEM-MEMORY-REF) - (&OBJECT-SET! . SYSTEM-MEMORY-SET!))) - -(set! primitive-procedure? -(named-lambda (primitive-procedure? object) - (primitive-type? primitive-type-code object))) - -(set! make-primitive-procedure -(named-lambda (make-primitive-procedure name #!optional arity) - (if (unassigned? arity) - (set! arity false)) - (let* ((name (let ((place (assq name renamed-user-primitives))) - (if (not (null? place)) - (cdr place) - name))) - (result (get-primitive-address name arity))) - (cond ((or (primitive-type? primitive-type-code result) - (eq? arity true)) - result) - ((false? result) - (error "MAKE-PRIMITIVE-PROCEDURE: Unknown name" name)) - (else - (error "MAKE-PRIMITIVE-PROCEDURE: Inconsistent arity" - `(,name new: ,arity old: ,result))))))) - -(set! implemented-primitive-procedure? -(named-lambda (implemented-primitive-procedure? object) - (if (primitive-type? primitive-type-code object) - (get-primitive-address (get-primitive-name (primitive-datum object)) - false) - (error "Not a primitive procedure" implemented-primitive-procedure? - object)))) - -(set! primitive-procedure-name -(named-lambda (primitive-procedure-name primitive-procedure) - (if (primitive-type? primitive-type-code primitive-procedure) - (get-primitive-name (primitive-datum primitive-procedure)) - (error "Not a primitive procedure" primitive-procedure-name - primitive-procedure)))) - -(define (name->code slot type name) - (or (and (pair? name) - (eq? (car name) type) - (pair? (cdr name)) - (let ((x (cdr name))) - (and (integer? (car x)) - (not (negative? (car x))) - (null? (cdr x)) - (car x)))) - (microcode-table-search slot name))) - -(define (code->name slot type code) - (or (and (not (negative? code)) - (microcode-table-ref slot code)) - (list type code))) - -;;;; Initialization +(define (microcode-termination/code-limit) + (vector-length (vector-ref (get-fixed-objects-vector) terminations-slot))) -(define microcode-tables-identification) - -(define (snarf-version) - (set! :identification (microcode-identify)) - - (set! microcode-tables-identification - (scode-eval (binary-fasload (microcode-tables-filename)) - system-global-environment)) - - (set! fixed-objects (get-fixed-objects-vector)) - - (set! types-slot (fixed-objects-vector-slot 'MICROCODE-TYPES-VECTOR)) - (set! number-of-microcode-types - (vector-length (vector-ref fixed-objects types-slot))) - - (set! returns-slot (fixed-objects-vector-slot 'MICROCODE-RETURNS-VECTOR)) - (set! return-address-type (microcode-type 'RETURN-ADDRESS)) - (set! number-of-microcode-returns - (vector-length (vector-ref fixed-objects returns-slot))) - - (set! errors-slot (fixed-objects-vector-slot 'MICROCODE-ERRORS-VECTOR)) - (set! number-of-microcode-errors - (vector-length (vector-ref fixed-objects errors-slot))) +(define types-slot) - (set! primitive-type-code (microcode-type 'PRIMITIVE)) +(define (microcode-type/name->code name) + (microcode-table-search types-slot name)) - (set! termination-vector-slot - (fixed-objects-vector-slot 'MICROCODE-TERMINATIONS-VECTOR)) - (set! number-of-microcode-terminations - (vector-length (vector-ref fixed-objects termination-vector-slot))) +(define (microcode-type/code->name code) + (microcode-table-ref types-slot code)) - (set! identification-vector-slot - (fixed-objects-vector-slot 'MICROCODE-IDENTIFICATION-VECTOR)) - (set! :release (microcode-identification-item 'SYSTEM-RELEASE-STRING)) - (set! :version (microcode-identification-item 'MICROCODE-VERSION)) - (set! :modification (microcode-identification-item 'MICROCODE-MODIFICATION)) +(define (microcode-type/code-limit) + (vector-length (vector-ref (get-fixed-objects-vector) types-slot))) - ;; Predicate to test if object is a future without touching it. - (set! future? - (let ((primitive (make-primitive-procedure 'FUTURE? 1))) - (if (implemented-primitive-procedure? primitive) - primitive - (lambda (object) false))))) +(define identifications-slot) +(define identification-vector) -(snarf-version) +(define (microcode-identification-vector-slot name) + (or (microcode-table-search identifications-slot name) + (error "Unknown microcode identification item" name))) -;;; end MICROCODE-SYSTEM. -)) \ No newline at end of file +(define (microcode-identification-item name) + (vector-ref identification-vector + (microcode-identification-vector-slot name))) \ No newline at end of file diff --git a/v7/src/runtime/vector.scm b/v7/src/runtime/vector.scm index 5dcff36ad..31e758e1d 100644 --- a/v7/src/runtime/vector.scm +++ b/v7/src/runtime/vector.scm @@ -1,82 +1,79 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/vector.scm,v 13.45 1987/12/23 04:17:16 cph Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/vector.scm,v 14.1 1988/06/13 12:00:13 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; Operations on Vectors +;;; package: () (declare (usual-integrations)) ;;; Standard Procedures -(let-syntax () - (define-macro (define-primitives . names) - `(BEGIN ,@(map (lambda (name) - `(LOCAL-ASSIGNMENT - system-global-environment - ',name ,(make-primitive-procedure name))) - names))) - (define-primitives - vector-length vector-ref vector-set! - list->vector vector vector-cons subvector->list - subvector-move-right! subvector-move-left! subvector-fill!)) - -(let-syntax () - (define-macro (define-type-predicate name type-name) - `(DEFINE (,name OBJECT) - (PRIMITIVE-TYPE? ,(microcode-type type-name) OBJECT))) - (define-type-predicate vector? vector)) +(define-primitives + vector-length vector-ref vector-set! + list->vector vector subvector->list + subvector-move-right! subvector-move-left! subvector-fill!) + +(define-integrable (vector? object) + (object-type? (ucode-type vector) object)) (define (make-vector size #!optional fill) - (if (unassigned? fill) (set! fill false)) - (vector-cons size fill)) + (if (default-object? fill) (set! fill false)) + ((ucode-primitive vector-cons) size fill)) (define (vector->list vector) (subvector->list vector 0 (vector-length vector))) (define (vector-fill! vector value) (subvector-fill! vector 0 (vector-length vector) value)) + +(define (subvector vector start end) + (let ((result (make-vector (- end start)))) + (subvector-move-right! vector start end result 0) + result)) + +(define-integrable (vector-head vector end) + (subvector vector 0 end)) + +(define (vector-tail vector start) + (subvector vector start (vector-length vector))) #| ;;; Nonstandard Primitives (let-syntax ((check-type (let ((type (microcode-type 'VECTOR))) (macro (object) - `(IF (NOT (PRIMITIVE-TYPE? ,type ,object)) + `(IF (NOT (OBJECT-TYPE? ,type ,object)) (ERROR "Wrong type argument" ,object))))) (check-target (macro (object index) @@ -154,11 +151,11 @@ (subvector-move-right! vector 0 (vector-length vector) new-vector 0) new-vector)) -(define (vector-first vector) (vector-ref vector 0)) -(define (vector-second vector) (vector-ref vector 1)) -(define (vector-third vector) (vector-ref vector 2)) -(define (vector-fourth vector) (vector-ref vector 3)) -(define (vector-fifth vector) (vector-ref vector 4)) -(define (vector-sixth vector) (vector-ref vector 5)) -(define (vector-seventh vector) (vector-ref vector 6)) -(define (vector-eighth vector) (vector-ref vector 7)) \ No newline at end of file +(define-integrable (vector-first vector) (vector-ref vector 0)) +(define-integrable (vector-second vector) (vector-ref vector 1)) +(define-integrable (vector-third vector) (vector-ref vector 2)) +(define-integrable (vector-fourth vector) (vector-ref vector 3)) +(define-integrable (vector-fifth vector) (vector-ref vector 4)) +(define-integrable (vector-sixth vector) (vector-ref vector 5)) +(define-integrable (vector-seventh vector) (vector-ref vector 6)) +(define-integrable (vector-eighth vector) (vector-ref vector 7)) \ No newline at end of file diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm index 515b9b25d..8e785a5ce 100644 --- a/v7/src/runtime/version.scm +++ b/v7/src/runtime/version.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.1 1988/06/13 10:47:01 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.2 1988/06/13 12:00:18 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Runtime System Version Information +;;; package: (runtime) (declare (usual-integrations)) @@ -40,4 +41,4 @@ MIT in each case. |# microcode-id/version microcode-id/modification '())) -(add-system! (make-system "Runtime" 14 1 '())) \ No newline at end of file +(add-system! (make-system "Runtime" 14 2 '())) \ No newline at end of file diff --git a/v7/src/runtime/where.scm b/v7/src/runtime/where.scm index 485f2b6b0..88a2bb2f9 100644 --- a/v7/src/runtime/where.scm +++ b/v7/src/runtime/where.scm @@ -1,85 +1,85 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/where.scm,v 13.44 1988/01/02 14:21:45 cph Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- -;;;; Environment Inspector +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/where.scm,v 14.1 1988/06/13 12:00:44 cph Exp $ -(in-package debugger-package +Copyright (c) 1988 Massachusetts Institute of Technology -(declare (usual-integrations)) +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. -(define env-package - (let ((env) - (current-frame) - (current-frame-depth) - (env-commands (make-command-set 'WHERE-COMMANDS))) - -(define (define-where-command letter function help-text) - (define-letter-command env-commands letter function help-text)) +1. Any copy made of this software must include this copyright notice +in full. -;;; Basic Commands +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. -(define-where-command #\? (standard-help-command env-commands) - "Help, list command letters") +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. -(define-where-command #\Q standard-exit-command - "Quit (exit from Where)") +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. -;;; Lexpr since it can take one or no arguments +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. |# -(define (where #!optional env-spec) - (if (unassigned? env-spec) (set! env-spec (rep-environment))) +;;;; Environment Inspector +;;; package: (runtime environment-inspector) + +(declare (usual-integrations)) + +(define (initialize-package!) + (set! command-set + (make-command-set + 'WHERE-COMMANDS + `((#\? ,standard-help-command + "Help, list command letters") + (#\Q ,standard-exit-command + "Quit (exit from Where)") + (#\C ,show + "Display the bindings in the current frame") + (#\A ,show-all + "Display the bindings of all the frames in the current chain") + (#\P ,parent + "Find the parent frame of the current one") + (#\S ,son + "Find the son of the current environment in the current chain") + (#\W ,recursive-where + "Eval an expression in the current frame and do WHERE on it") + (#\V ,show-object + "Eval expression in current frame") + (#\E ,enter + "Create a read-eval-print loop in the current environment") + (#\N ,name + "Name of procedure which created current environment") + )))) + +(define command-set) + +(define env) +(define current-frame) +(define current-frame-depth) + +(define (where #!optional environment) (let ((environment - (cond ((or (eq? env-spec system-global-environment) - (environment? env-spec)) - env-spec) - ((compound-procedure? env-spec) - (procedure-environment env-spec)) - ((promise? env-spec) - (promise-environment env-spec)) - (else - (error "WHERE: Not a legal environment object" env-spec))))) - (environment-warning-hook environment) + (if (default-object? environment) + (standard-repl-environment) + (->environment environment)))) + (hook/repl-environment (nearest-repl) environment) (fluid-let ((env environment) (current-frame environment) (current-frame-depth 0)) - (letter-commands env-commands - (standard-rep-message "Environment Inspector") + (letter-commands command-set + (cmdl-message/standard "Environment Inspector") "Where-->")))) ;;;; Display Commands @@ -96,71 +96,6 @@ (if (environment-has-parent? env) (s1 (environment-parent env) (1+ depth)) *the-non-printing-object*))))) - -(define (show-frame frame depth) - (if (eq? system-global-environment frame) - (begin (newline) - (write-string "This frame is the system global environment")) - (begin (newline) (write-string "Frame created by ") - (print-user-friendly-name frame) - (if (>= depth 0) - (begin (newline) - (write-string "Depth (relative to starting frame): ") - (write depth))) - (newline) - (let ((bindings (environment-bindings frame))) - (if (null? bindings) - (write-string "Has no bindings") - (begin (write-string "Has bindings:") - (newline) - (for-each print-binding bindings)))))) - (newline)) - -(define print-user-friendly-name - (let ((rename-list - `((,lambda-tag:unnamed . LAMBDA) - (,(access internal-lambda-tag lambda-package) . LAMBDA) - (,(access internal-lexpr-tag lambda-package) . LAMBDA) - (,lambda-tag:let . LET) - (,lambda-tag:shallow-fluid-let . FLUID-LET) - (,lambda-tag:deep-fluid-let . FLUID-LET) - (,lambda-tag:common-lisp-fluid-let . FLUID-BIND) - (,lambda-tag:make-environment . MAKE-ENVIRONMENT)))) - (lambda (frame) - (let ((name (environment-name frame))) - (let ((rename (assq name rename-list))) - (if rename - (begin (write-string "a ") - (write (cdr rename)) - (write-string " special form")) - (begin (write-string "the procedure ") - (write name)))))))) - -(define (print-binding binding) - (define line-width 79) - (define name-width 40) - (define (truncate str length) - (set-string-length! str (- length 4)) - (string-append str " ...")) - (newline) - (let ((s (write-to-string (car binding) name-width))) - (if (car s) ; Name was truncated - (set! s (truncate (cdr s) name-width)) - (set! s (cdr s))) - (if (null? (cdr binding)) - (set! s (string-append s " is unassigned")) - (let ((s1 (write-to-string (cadr binding) - (- line-width (string-length s))))) - (set! s (string-append s " = " (cdr s1))); - (if (car s1) ; Value truncated - (set! s (truncate s line-width))))) - (write-string s))) - -(define-where-command #\C show - "Display the bindings in the current frame") - -(define-where-command #\A show-all - "Display the bindings of all the frames in the current chain") ;;;; Motion Commands @@ -199,55 +134,20 @@ (let ((inp (prompt-for-expression "Object to eval and examine-> "))) (write-string "New where!") (debug/where (debug/eval inp current-frame)))) - -(define-where-command #\P parent - "Find the parent frame of the current one") - -(define-where-command #\S son - "Find the son of the current environment in the current chain") - -(define-where-command #\W recursive-where - "Eval an expression in the current frame and do WHERE on it") ;;;; Relative Evaluation Commands -(define (show-object) - (let ((inp (prompt-for-expression "Object to eval and print-> "))) - (newline) - (write (debug/eval inp current-frame)) - (newline))) - (define (enter) (debug/read-eval-print current-frame "You are now in the desired environment" "Eval-in-env-->")) -(define-where-command #\V show-object - "Eval an expression in the current frame and print the result") - -(define-where-command #\E enter - "Create a read-eval-print loop in the current environment") +(define (show-object) + (debug/read-eval-print-1 current-frame)) ;;;; Miscellaneous Commands (define (name) (newline) (write-string "This frame was created by ") - (print-user-friendly-name current-frame)) - -(define-where-command #\N name - "Name of procedure which created current environment") - -;;; end ENV-PACKAGE. -(the-environment))) - -(define print-user-friendly-name - (access print-user-friendly-name env-package)) - -;;; end IN-PACKAGE DEBUGGER-PACKAGE. -) - -;;;; Exports - -(define where - (access where env-package debugger-package)) \ No newline at end of file + (print-user-friendly-name current-frame)) \ No newline at end of file diff --git a/v7/src/runtime/wind.scm b/v7/src/runtime/wind.scm index ab5d64ce1..ba494f387 100644 --- a/v7/src/runtime/wind.scm +++ b/v7/src/runtime/wind.scm @@ -1,99 +1,83 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/wind.scm,v 13.42 1987/02/15 15:46:23 cph Rel $ -;;; -;;; Copyright (c) 1987 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. -;;; +#| -*-Scheme-*- -;;;; State Space Model +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/wind.scm,v 14.1 1988/06/13 12:00:51 cph Exp $ -(declare (usual-integrations) - (integrate-primitive-procedures set-fixed-objects-vector!)) - -(vector-set! (get-fixed-objects-vector) - (fixed-objects-vector-slot 'STATE-SPACE-TAG) - "State Space") +Copyright (c) 1988 Massachusetts Institute of Technology -(vector-set! (get-fixed-objects-vector) - (fixed-objects-vector-slot 'STATE-POINT-TAG) - "State Point") +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. -(set-fixed-objects-vector! (get-fixed-objects-vector)) +1. Any copy made of this software must include this copyright notice +in full. -(define make-state-space - (let ((prim (make-primitive-procedure 'MAKE-STATE-SPACE))) - (named-lambda (make-state-space #!optional mutable?) - (if (unassigned? mutable?) (set! mutable? #T)) - (prim mutable?)))) +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. -(define execute-at-new-state-point - (make-primitive-procedure 'EXECUTE-AT-NEW-STATE-POINT)) +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. -(define translate-to-state-point - (make-primitive-procedure 'TRANSLATE-TO-STATE-POINT)) +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. -;;; The following code implements the current model of DYNAMIC-WIND as -;;; a special case of the more general concept. +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. |# -(define system-state-space - (make-state-space #F)) +;;;; State Space Model +;;; package: (runtime state-space) -(define current-dynamic-state - (let ((prim (make-primitive-procedure 'current-dynamic-state))) - (named-lambda (current-dynamic-state #!optional state-space) - (prim (if (unassigned? state-space) - system-state-space - state-space))))) +(declare (usual-integrations)) + +(define (initialize-package!) + (let ((fixed-objects (get-fixed-objects-vector)) + (state-space-tag "State Space") + (state-point-tag "State Point")) + (unparser/set-tagged-vector-method! + state-space-tag + (unparser/standard-method 'STATE-SPACE)) + (unparser/set-tagged-vector-method! + state-point-tag + (unparser/standard-method 'STATE-POINT)) + (vector-set! fixed-objects + (fixed-objects-vector-slot 'STATE-SPACE-TAG) + state-space-tag) + (vector-set! fixed-objects + (fixed-objects-vector-slot 'STATE-POINT-TAG) + state-point-tag) + (set! system-state-space (make-state-space false)) + (vector-set! fixed-objects + (fixed-objects-vector-slot 'STATE-SPACE-ROOT) + (current-dynamic-state)) + ((ucode-primitive set-fixed-objects-vector!) fixed-objects))) -(define set-current-dynamic-state! - (make-primitive-procedure 'set-current-dynamic-state!)) +(define-primitives + execute-at-new-state-point + translate-to-state-point + set-current-dynamic-state! + (get-fluid-bindings 0) + (set-fluid-bindings! 1)) -;; NOTICE that the "before" thunk is executed IN THE NEW STATE, -;; the "after" thunk is executed IN THE OLD STATE. It is hard to -;; imagine why anyone would care about this. +(define (make-state-space #!optional mutable?) + ((ucode-primitive make-state-space) + (if (default-object? mutable?) true mutable?))) -(define (dynamic-wind before during after) - (execute-at-new-state-point system-state-space - before - during - after)) +(define system-state-space) -;; This is so the microcode can find the base state point. +(define (current-dynamic-state #!optional state-space) + ((ucode-primitive current-dynamic-state) + (if (default-object? state-space) system-state-space state-space))) -(let ((fov (get-fixed-objects-vector))) - (vector-set! fov - (fixed-objects-vector-slot 'STATE-SPACE-ROOT) - (current-dynamic-state)) - (set-fixed-objects-vector! fov)) \ No newline at end of file +;;; NOTE: the "before" thunk is executed IN THE NEW STATE, the "after" +;;; thunk is executed IN THE OLD STATE. Your programs should not +;;; depend on this if it can be avoided. +(define (dynamic-wind before during after) + (execute-at-new-state-point system-state-space before during after)) \ No newline at end of file diff --git a/v7/src/runtime/wrkdir.scm b/v7/src/runtime/wrkdir.scm index af756329c..89d34714f 100644 --- a/v7/src/runtime/wrkdir.scm +++ b/v7/src/runtime/wrkdir.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/wrkdir.scm,v 14.1 1988/06/13 10:50:01 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/wrkdir.scm,v 14.2 1988/06/13 12:00:56 cph Rel $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,7 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Working Directory -;;; package: (working-directory) +;;; package: (runtime working-directory) (declare (usual-integrations)) diff --git a/v8/src/runtime/conpar.scm b/v8/src/runtime/conpar.scm index f93fca50b..e60a2858b 100644 --- a/v8/src/runtime/conpar.scm +++ b/v8/src/runtime/conpar.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/conpar.scm,v 14.1 1988/05/20 00:54:26 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/conpar.scm,v 14.2 1988/06/13 11:41:24 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,7 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Continuation Parser -;;; package: continuation-parser-package +;;; package: (runtime continuation-parser) (declare (usual-integrations)) @@ -158,9 +158,7 @@ MIT in each case. |# (if (not (return-address? return-address)) (error "illegal return address" return-address)) (let ((code (return-address/code return-address))) - (if (>= code (vector-length stack-frame-types)) - (error "return-code too large" code)) - (let ((type (vector-ref stack-frame-types code))) + (let ((type (microcode-return/code->type code))) (if (not type) (error "return-code has no type" code)) type)))) @@ -379,6 +377,11 @@ MIT in each case. |# (parser false read-only true) (unparser false read-only true)) +(define (microcode-return/code->type code) + (if (not (< code (vector-length stack-frame-types))) + (error "return-code too large" code)) + (vector-ref stack-frame-types code)) + (define (initialize-package!) (set! stack-frame-types (make-stack-frame-types))) diff --git a/v8/src/runtime/dbgutl.scm b/v8/src/runtime/dbgutl.scm index 8781e9418..46fd1478a 100644 --- a/v8/src/runtime/dbgutl.scm +++ b/v8/src/runtime/dbgutl.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/dbgutl.scm,v 14.1 1988/05/20 00:55:52 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/dbgutl.scm,v 14.2 1988/06/13 11:43:10 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,7 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Debugger Utilities -;;; package: debugger-utilities-package +;;; package: (runtime debugger-utilities) (declare (usual-integrations)) @@ -110,4 +110,9 @@ MIT in each case. |# (string-append s (write->string (cadr binding) (max (- x-size (string-length s)) - 0))))))))) \ No newline at end of file + 0))))))))) + +(define (debug/read-eval-print-1 environment) + (let ((value (debug/eval (prompt-for-expression "Eval--> ") environment))) + (newline) + (write value))) \ No newline at end of file diff --git a/v8/src/runtime/framex.scm b/v8/src/runtime/framex.scm index 7b01140ed..19e35e9b7 100644 --- a/v8/src/runtime/framex.scm +++ b/v8/src/runtime/framex.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/framex.scm,v 14.1 1988/05/20 00:57:08 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/framex.scm,v 14.2 1988/06/13 11:44:55 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,7 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Debugging Info -;;; package: debugging-info-package +;;; package: (runtime debugging-info) (declare (usual-integrations)) @@ -143,8 +143,8 @@ MIT in each case. |# (for-each (lambda (entry) (for-each (lambda (name) (let ((type - (or (vector-ref stack-frame-types - (microcode-return name)) + (or (microcode-return/code->type + (microcode-return name)) (error "Missing return type" name)))) (1d-table/put! (stack-frame-type/properties type) method-tag diff --git a/v8/src/runtime/global.scm b/v8/src/runtime/global.scm index 4ac53b04c..76adce7ae 100644 --- a/v8/src/runtime/global.scm +++ b/v8/src/runtime/global.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/global.scm,v 14.1 1988/05/20 00:58:36 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/global.scm,v 14.2 1988/06/13 11:45:33 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Miscellaneous Global Definitions +;;; package: () (declare (usual-integrations)) @@ -55,6 +56,7 @@ MIT in each case. |# (object-datum 1) (object-type? 2) (object-new-type object-set-type 2) + make-non-pointer-object eq? ;; Cells @@ -256,7 +258,7 @@ MIT in each case. |# (not (object-non-pointer? object))) (define (impurify object) - (if (and (object-pointer? object) (pure? object)) + (if (and (object-pointer? object) (object-pure? object)) ((ucode-primitive primitive-impurify) object)) object) diff --git a/v8/src/runtime/load.scm b/v8/src/runtime/load.scm index deba015b1..26adf1235 100644 --- a/v8/src/runtime/load.scm +++ b/v8/src/runtime/load.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.1 1988/05/20 00:59:11 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.2 1988/06/13 11:47:32 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -33,7 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; Code Loader -;;; package: load-package +;;; package: (runtime load) (declare (usual-integrations)) @@ -48,10 +48,10 @@ MIT in each case. |# (define fasload/default-types) (define (read-file filename) - (stream->list - (call-with-input-file - (pathname-default-version (->pathname filename) 'NEWEST) - read-stream))) + (call-with-input-file + (pathname-default-version (->pathname filename) 'NEWEST) + (lambda (port) + (stream->list (read-stream port))))) (define (fasload filename) (fasload/internal @@ -66,10 +66,15 @@ MIT in each case. |# (write-string " -- done" port) value))) -(define (load-noisily filename #!optional environment) +(define (load-noisily filename #!optional environment syntax-table purify?) (fluid-let ((load-noisily? true)) (load filename - (if (default-object? environment) default-object environment)))) + ;; This defaulting is a kludge until we get the optional + ;; defaulting fixed. Right now it must match the defaulting + ;; of `load'. + (if (default-object? environment) default-object environment) + (if (default-object? syntax-table) default-object syntax-table) + (if (default-object? purify?) default-object purify?)))) (define (load-init-file) (let ((truename (init-file-truename))) @@ -80,10 +85,24 @@ MIT in each case. |# ;;; This is careful to do the minimum number of file existence probes ;;; before opening the input file. -(define (load filename/s #!optional environment) +(define (load filename/s #!optional environment syntax-table purify?) (let ((environment ;; Kludge until optional defaulting fixed. - (if (default-object? environment) default-object environment))) + (if (or (default-object? environment) + (eq? environment default-object)) + default-object + (->environment environment))) + (syntax-table + ;; Kludge until optional defaulting fixed. + (if (or (default-object? syntax-table) + (eq? syntax-table default-object)) + default-object + (guarantee-syntax-table syntax-table))) + (purify? + (if (or (default-object? purify?) + (eq? purify? default-object)) + false + purify?))) (let ((kernel (lambda (filename last-file?) (let ((value @@ -92,6 +111,8 @@ MIT in each case. |# (find-true-filename pathname load/default-types) environment + syntax-table + purify? load-noisily?)))) (cond (last-file? value) (load-noisily? (write-line value))))))) @@ -106,19 +127,22 @@ MIT in each case. |# (define default-object "default-object") -(define (load/internal pathname true-filename environment load-noisily?) +(define (load/internal pathname true-filename environment syntax-table + purify? load-noisily?) (let ((port (open-input-file/internal pathname true-filename))) (if (= 250 (char->ascii (peek-char port))) (begin (close-input-port port) - (scode-eval (fasload/internal true-filename) + (scode-eval (let ((scode (fasload/internal true-filename))) + (if purify? (purify scode)) + scode) (if (eq? environment default-object) (standard-repl-environment) environment))) - (write-stream (eval-stream (read-stream port) environment) + (write-stream (eval-stream (read-stream port) environment syntax-table) (if load-noisily? (lambda (value) (hook/repl-write (nearest-repl) value)) - (lambda (value) value false)))))) + (lambda (value) value false)))))) (define (find-true-filename pathname default-types) (pathname->string (or (let ((try @@ -133,7 +157,7 @@ MIT in each case. |# (or (try (pathname-new-type pathname (car types))) (loop (cdr types)))))))) (error "No such file" pathname)))) - + (define (read-stream port) (parse-objects port (current-parser-table) @@ -142,14 +166,18 @@ MIT in each case. |# (begin (close-input-port port) true))))) -(define (eval-stream stream environment) +(define (eval-stream stream environment syntax-table) (stream-map stream (lambda (s-expression) - (hook/repl-eval (nearest-repl) - s-expression - (if (eq? environment default-object) - (standard-repl-environment) - environment))))) + (let ((repl (nearest-repl))) + (hook/repl-eval repl + s-expression + (if (eq? environment default-object) + (repl/environment repl) + environment) + (if (eq? syntax-table default-object) + (repl/syntax-table repl) + syntax-table)))))) (define (write-stream stream write) (if (stream-pair? stream) diff --git a/v8/src/runtime/make.scm b/v8/src/runtime/make.scm index 52827a04b..f1ff9da47 100644 --- a/v8/src/runtime/make.scm +++ b/v8/src/runtime/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.1 1988/05/20 00:59:28 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.2 1988/06/13 11:47:44 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -38,9 +38,8 @@ MIT in each case. |# ((ucode-primitive set-interrupt-enables!) 0) (define system-global-environment (the-environment)) -(define system-packages (let () (the-environment))) -(let () +(let ((environment-for-package (let () (the-environment)))) (define-primitives (+ &+) @@ -49,6 +48,7 @@ MIT in each case. |# (file-exists? 1) garbage-collect get-fixed-objects-vector + get-next-constant get-primitive-address get-primitive-name lexical-reference @@ -63,7 +63,9 @@ MIT in each case. |# substring=? substring-move-right! substring-upcase! + tty-beep tty-flush-output + tty-read-char-immediate tty-write-char tty-write-string vector-ref @@ -85,10 +87,32 @@ MIT in each case. |# (tty-write-char newline-char) (tty-flush-output) (exit)) + +(define (prompt-for-confirmation prompt) + (let loop () + (tty-write-char newline-char) + (tty-write-string prompt) + (tty-write-string "(y or n) ") + (tty-flush-output) + (let ((char (tty-read-char-immediate))) + (cond ((or (eq? #\y char) + (eq? #\Y char)) + (tty-write-string "Yes") + (tty-flush-output) + true) + ((or (eq? #\n char) + (eq? #\N char)) + (tty-write-string "No") + (tty-flush-output) + false) + (else + (tty-beep) + (loop)))))) ;;;; GC, Interrupts, Errors (define safety-margin 4500) +(define constant-space/base (get-next-constant)) (let ((condition-handler/gc (lambda (interrupt-code interrupt-enables) @@ -142,7 +166,8 @@ MIT in each case. |# (get-primitive-address (get-primitive-name (object-datum primitive)) false)) (define map-filename - (if (implemented-primitive-procedure? file-exists?) + (if (and (implemented-primitive-procedure? file-exists?) + (not (prompt-for-confirmation "Load interpreted? "))) (lambda (filename) (let ((com-file (string-append filename ".com"))) (if (file-exists? com-file) @@ -172,22 +197,23 @@ MIT in each case. |# (define (package-initialize package-name procedure-name) (tty-write-char newline-char) - (tty-write-string "initialize:") + (tty-write-string "initialize: (") (let loop ((name package-name)) (if (not (null? name)) - (begin (tty-write-string " ") + (begin (if (not (eq? name package-name)) + (tty-write-string " ")) (tty-write-string (system-pair-car (car name))) (loop (cdr name))))) + (tty-write-string ")") + (if (not (eq? procedure-name 'INITIALIZE-PACKAGE!)) + (begin (tty-write-string " [") + (tty-write-string (system-pair-car procedure-name)) + (tty-write-string "]"))) (tty-flush-output) ((lexical-reference (package-reference package-name) procedure-name))) (define (package-reference name) - (if (null? name) - system-global-environment - (let loop ((name name) (environment system-packages)) - (if (null? name) - environment - (loop (cdr name) (lexical-reference environment (car name))))))) + (package/environment (find-package name))) (define (package-initialization-sequence packages) (let loop ((packages packages)) @@ -196,39 +222,66 @@ MIT in each case. |# (loop (cdr packages)))))) ;; Construct the package structure. +;; Lotta hair here to load the package code before its package is built. +(eval (cold-load/purify (fasload (map-filename "packag"))) + environment-for-package) +((access initialize-package! environment-for-package)) +(let loop ((names + '(FIND-PACKAGE + NAME->PACKAGE + PACKAGE/ADD-CHILD! + PACKAGE/CHILD + PACKAGE/CHILDREN + PACKAGE/ENVIRONMENT + PACKAGE/NAME + PACKAGE/PARENT + PACKAGE/REFERENCE + PACKAGE/SYSTEM-LOADER + PACKAGE? + SYSTEM-GLOBAL-PACKAGE))) + (if (not (null? names)) + (begin (environment-link-name system-global-environment + environment-for-package + (car names)) + (loop (cdr names))))) +(package/add-child! system-global-package 'PACKAGE environment-for-package) (eval (fasload "runtim.bcon") system-global-environment) ;; Global databases. Load, then initialize. - (let loop ((files - '(("gcdemn" . (GC-DAEMONS)) - ("poplat" . (POPULATION)) - ("prop1d" . (1D-PROPERTY)) - ("events" . (EVENT-DISTRIBUTOR)) - ("gdatab" . (GLOBAL-DATABASE)) + '(("gcdemn" . (RUNTIME GC-DAEMONS)) + ("poplat" . (RUNTIME POPULATION)) + ("prop1d" . (RUNTIME 1D-PROPERTY)) + ("events" . (RUNTIME EVENT-DISTRIBUTOR)) + ("gdatab" . (RUNTIME GLOBAL-DATABASE)) ("boot" . ()) ("queue" . ()) - ("gc" . (GARBAGE-COLLECTOR))))) + ("gc" . (RUNTIME GARBAGE-COLLECTOR))))) (if (not (null? files)) (begin (eval (cold-load/purify (fasload (map-filename (car (car files))))) (package-reference (cdr (car files)))) (loop (cdr files))))) -(package-initialize '(GC-DAEMONS) 'INITIALIZE-PACKAGE!) -(package-initialize '(POPULATION) 'INITIALIZE-PACKAGE!) -(package-initialize '(1D-PROPERTY) 'INITIALIZE-PACKAGE!) -(package-initialize '(EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE!) -(package-initialize '(GLOBAL-DATABASE) 'INITIALIZE-PACKAGE!) -(package-initialize '(POPULATION) 'INITIALIZE-UNPARSER!) -(package-initialize '(1D-PROPERTY) 'INITIALIZE-UNPARSER!) -(package-initialize '(EVENT-DISTRIBUTOR) 'INITIALIZE-UNPARSER!) -(package-initialize '(GARBAGE-COLLECTOR) 'INITIALIZE-PACKAGE!) +(package-initialize '(RUNTIME GC-DAEMONS) 'INITIALIZE-PACKAGE!) +(package-initialize '(RUNTIME POPULATION) 'INITIALIZE-PACKAGE!) +(package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-PACKAGE!) +(package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE!) +(package-initialize '(RUNTIME GLOBAL-DATABASE) 'INITIALIZE-PACKAGE!) +(package-initialize '(RUNTIME POPULATION) 'INITIALIZE-UNPARSER!) +(package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-UNPARSER!) +(package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-UNPARSER!) +(package-initialize '(PACKAGE) 'INITIALIZE-UNPARSER!) +(package-initialize '(RUNTIME GARBAGE-COLLECTOR) 'INITIALIZE-PACKAGE!) +(lexical-assignment (package-reference '(RUNTIME GARBAGE-COLLECTOR)) + 'CONSTANT-SPACE/BASE + constant-space/base) ;; Load everything else. ((eval (fasload "runtim.bldr") system-global-environment) (lambda (filename environment) - (if (not (or (string=? filename "gcdemn") + (if (not (or (string=? filename "packag") + (string=? filename "gcdemn") (string=? filename "poplat") (string=? filename "prop1d") (string=? filename "events") @@ -244,81 +297,75 @@ MIT in each case. |# (package-initialization-sequence '( ;; Microcode interface - (MICROCODE-TABLES) - (PRIMITIVE-IO) - (SAVE/RESTORE) - (STATE-SPACE) - (SYSTEM-CLOCK) + (RUNTIME MICROCODE-TABLES) + (RUNTIME PRIMITIVE-IO) + (RUNTIME SAVE/RESTORE) + (RUNTIME STATE-SPACE) + (RUNTIME SYSTEM-CLOCK) ;; Basic data structures - (NUMBER) - (LIST) - (CHARACTER) - (CHARACTER-SET) - (GENSYM) - (STREAM) - (2D-PROPERTY) - (HASH) - (RANDOM-NUMBER) + (RUNTIME NUMBER) + (RUNTIME LIST) + (RUNTIME CHARACTER) + (RUNTIME CHARACTER-SET) + (RUNTIME GENSYM) + (RUNTIME STREAM) + (RUNTIME 2D-PROPERTY) + (RUNTIME HASH) + (RUNTIME RANDOM-NUMBER) ;; Microcode data structures - (HISTORY) - (LAMBDA-ABSTRACTION) - (SCODE) - (SCODE-COMBINATOR) - (SCODE-SCAN) - (SCODE-WALKER) - (CONTINUATION-PARSER) - - ;; I/O ports - (CONSOLE-INPUT) - (CONSOLE-OUTPUT) - (FILE-INPUT) - (FILE-OUTPUT) - (STRING-INPUT) - (STRING-OUTPUT) - (TRUNCATED-STRING-OUTPUT) - (INPUT-PORT) - (OUTPUT-PORT) - (WORKING-DIRECTORY) - (LOAD) + (RUNTIME HISTORY) + (RUNTIME LAMBDA-ABSTRACTION) + (RUNTIME SCODE) + (RUNTIME SCODE-COMBINATOR) + (RUNTIME SCODE-SCAN) + (RUNTIME SCODE-WALKER) + (RUNTIME CONTINUATION-PARSER) + + ;; I/O + (RUNTIME CONSOLE-INPUT) + (RUNTIME CONSOLE-OUTPUT) + (RUNTIME FILE-INPUT) + (RUNTIME FILE-OUTPUT) + (RUNTIME STRING-INPUT) + (RUNTIME STRING-OUTPUT) + (RUNTIME TRUNCATED-STRING-OUTPUT) + (RUNTIME INPUT-PORT) + (RUNTIME OUTPUT-PORT) + (RUNTIME WORKING-DIRECTORY) + (RUNTIME DIRECTORY) + (RUNTIME LOAD) ;; Syntax - (PARSER) - (NUMBER-UNPARSER) - (UNPARSER) - (SYNTAXER) - (MACROS) - (SYSTEM-MACROS) - (DEFSTRUCT) - (UNSYNTAXER) - (PRETTY-PRINTER) - + (RUNTIME PARSER) + (RUNTIME NUMBER-UNPARSER) (RUNTIME UNPARSER) + (RUNTIME SYNTAXER) + (RUNTIME MACROS) + (RUNTIME SYSTEM-MACROS) + (RUNTIME DEFSTRUCT) + (RUNTIME UNSYNTAXER) + (RUNTIME PRETTY-PRINTER) ;; REP Loops - (ERROR-HANDLER) - (MICROCODE-ERRORS) - (INTERRUPT-HANDLER) - (GC-STATISTICS) - (REP) + (RUNTIME ERROR-HANDLER) + (RUNTIME MICROCODE-ERRORS) + (RUNTIME INTERRUPT-HANDLER) + (RUNTIME GC-STATISTICS) + (RUNTIME REP) ;; Debugging - (ADVICE) - (DEBUGGER-COMMAND-LOOP) - (DEBUGGER-UTILITIES) - (ENVIRONMENT-INSPECTOR) - (DEBUGGING-INFO) - (DEBUGGER) - + (RUNTIME ADVICE) + (RUNTIME DEBUGGER-COMMAND-LOOP) + (RUNTIME DEBUGGER-UTILITIES) + (RUNTIME ENVIRONMENT-INSPECTOR) + (RUNTIME DEBUGGING-INFO) + (RUNTIME DEBUGGER) + + (RUNTIME) ;; Emacs -- last because it grabs the kitchen sink. - (EMACS-INTERFACE) + (RUNTIME EMACS-INTERFACE) )) - + ) -(add-system! (make-system "Microcode" - microcode-id/version - microcode-id/modification - '())) -(add-system! (make-system "Runtime" 14 0 '())) -(remove-environment-parent! system-packages) (initial-top-level-repl) \ No newline at end of file diff --git a/v8/src/runtime/uenvir.scm b/v8/src/runtime/uenvir.scm index c208b416b..d7ff76c1a 100644 --- a/v8/src/runtime/uenvir.scm +++ b/v8/src/runtime/uenvir.scm @@ -1,43 +1,39 @@ -;;; -*-Scheme-*- -;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/uenvir.scm,v 14.1 1988/05/20 01:04:16 cph Exp $ -;;; -;;; Copyright (c) 1988 Massachusetts Institute of Technology -;;; -;;; This material was developed by the Scheme project at the -;;; Massachusetts Institute of Technology, Department of -;;; Electrical Engineering and Computer Science. Permission to -;;; copy this software, to redistribute it, and to use it for any -;;; purpose is granted, subject to the following restrictions and -;;; understandings. -;;; -;;; 1. Any copy made of this software must include this copyright -;;; notice in full. -;;; -;;; 2. Users of this software agree to make their best efforts (a) -;;; to return to the MIT Scheme project any improvements or -;;; extensions that they make, so that these may be included in -;;; future releases; and (b) to inform MIT of noteworthy uses of -;;; this software. -;;; -;;; 3. All materials developed as a consequence of the use of this -;;; software shall duly acknowledge such use, in accordance with -;;; the usual standards of acknowledging credit in academic -;;; research. -;;; -;;; 4. MIT has made no warrantee or representation that the -;;; operation of this software will be error-free, and MIT is -;;; under no obligation to provide any services, by way of -;;; maintenance, update, or otherwise. -;;; -;;; 5. In conjunction with products arising from the use of this -;;; material, there shall be no use of the name of the -;;; Massachusetts Institute of Technology nor of any adaptation -;;; thereof in any advertising, promotional, or sales literature -;;; without prior written consent from MIT in each case. -;;; +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/uenvir.scm,v 14.2 1988/06/13 11:58:33 cph Exp $ + +Copyright (c) 1988 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# ;;;; Microcode Environments +;;; package: (runtime environment) (declare (usual-integrations)) -- 2.25.1