From 14123570b7877d696bcf312a5ffa0fc2dabbfde9 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 16 Dec 1986 03:01:38 +0000 Subject: [PATCH] initial revision --- v7/src/runtime/lambda.scm | 504 ++++++++++++++++++ v7/src/runtime/list.scm | 424 ++++++++++++++++ v7/src/runtime/msort.scm | 99 ++++ v7/src/runtime/numpar.scm | 278 ++++++++++ v7/src/runtime/output.scm | 323 ++++++++++++ v7/src/runtime/parse.scm | 476 +++++++++++++++++ v7/src/runtime/pathnm.scm | 443 ++++++++++++++++ v7/src/runtime/pp.scm | 465 +++++++++++++++++ v7/src/runtime/qsort.scm | 92 ++++ v7/src/runtime/rep.scm | 326 ++++++++++++ v7/src/runtime/scan.scm | 210 ++++++++ v7/src/runtime/scode.scm | 350 +++++++++++++ v7/src/runtime/scomb.scm | 367 ++++++++++++++ v7/src/runtime/sdata.scm | 226 +++++++++ v7/src/runtime/sfile.scm | 65 +++ v7/src/runtime/stream.scm | 181 +++++++ v7/src/runtime/string.scm | 421 +++++++++++++++ v7/src/runtime/syntax.scm | 1013 +++++++++++++++++++++++++++++++++++++ v7/src/runtime/sysclk.scm | 91 ++++ v7/src/runtime/system.scm | 255 ++++++++++ v7/src/runtime/unpars.scm | 289 +++++++++++ v7/src/runtime/unsyn.scm | 495 ++++++++++++++++++ v7/src/runtime/utabs.scm | 323 ++++++++++++ v7/src/runtime/vector.scm | 163 ++++++ v7/src/runtime/where.scm | 259 ++++++++++ v7/src/runtime/wind.scm | 100 ++++ 26 files changed, 8238 insertions(+) create mode 100644 v7/src/runtime/lambda.scm create mode 100644 v7/src/runtime/list.scm create mode 100644 v7/src/runtime/msort.scm create mode 100644 v7/src/runtime/numpar.scm create mode 100644 v7/src/runtime/output.scm create mode 100644 v7/src/runtime/parse.scm create mode 100644 v7/src/runtime/pathnm.scm create mode 100644 v7/src/runtime/pp.scm create mode 100644 v7/src/runtime/qsort.scm create mode 100644 v7/src/runtime/rep.scm create mode 100644 v7/src/runtime/scan.scm create mode 100644 v7/src/runtime/scode.scm create mode 100644 v7/src/runtime/scomb.scm create mode 100644 v7/src/runtime/sdata.scm create mode 100644 v7/src/runtime/sfile.scm create mode 100644 v7/src/runtime/stream.scm create mode 100644 v7/src/runtime/string.scm create mode 100644 v7/src/runtime/syntax.scm create mode 100644 v7/src/runtime/sysclk.scm create mode 100644 v7/src/runtime/system.scm create mode 100644 v7/src/runtime/unpars.scm create mode 100644 v7/src/runtime/unsyn.scm create mode 100644 v7/src/runtime/utabs.scm create mode 100644 v7/src/runtime/vector.scm create mode 100644 v7/src/runtime/where.scm create mode 100644 v7/src/runtime/wind.scm diff --git a/v7/src/runtime/lambda.scm b/v7/src/runtime/lambda.scm new file mode 100644 index 000000000..1afc10fa6 --- /dev/null +++ b/v7/src/runtime/lambda.scm @@ -0,0 +1,504 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of +;;; this software shall duly acknowledge such use, in accordance +;;; with the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; + +;;;; 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 + (make-package lambda-package + ((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)) + +;;;; Hairy Advice Wrappers + +;;; The body of a LAMBDA object can be modified by transformation. +;;; This has the advantage that the body can be transformed many times, +;;; 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)) + + (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))) + + )) + )) + +;;;; Compound Lambda + +(define (make-clambda name required auxiliary body) + (make-slambda name + required + (if (null? auxiliary) + body + (make-combination (make-slambda internal-lambda-tag + auxiliary + body) + (map (lambda (auxiliary) + (make-unassigned-object)) + 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)))))) + +(define (clambda-bound clambda) + (slambda-components clambda + (lambda (name required body) + (cons name + (if (combination? body) + (let ((operator (combination-operator body))) + (if (is-internal-lambda? operator) + (slambda-components operator + (lambda (tag auxiliary body) + (append required auxiliary))) + required)) + required))))) + +(define (clambda-has-internal-lambda? clambda) + (let ((body (slambda-body clambda))) + (and (combination? body) + (let ((operator (combination-operator body))) + (and (is-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!))) + +;;;; 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))))) + +(define (clexpr-components clexpr receiver) + (slexpr-components clexpr + (lambda (name required body) + (slambda-components (combination-operator body) + (lambda (tag auxiliary body) + (receiver name + required + '() + (car auxiliary) + (cdr auxiliary) + (clexpr-unwrapped-body clexpr))))))) + +(define (clexpr-bound clexpr) + (slexpr-components clexpr + (lambda (name required body) + (slambda-components (combination-operator body) + (lambda (tag auxiliary body) + (cons name (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!))) + +;;;; 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)))) + (make-non-pointer-object + (+ (length optional) + (* 256 + (+ (length required) + (if (null? rest) 0 256))))))) + +(define (xlambda-components xlambda receiver) + (let ((qr1 (integer-divide (primitive-datum (&triple-third xlambda)) 256))) + (let ((qr2 (integer-divide (car qr1) 256))) + (let ((ostart (1+ (cdr qr2)))) + (let ((rstart (+ ostart (cdr qr1)))) + (let ((astart (+ rstart (car qr2))) + (bound (&triple-second xlambda))) + (receiver (vector-ref bound 0) + (subvector->list bound 1 ostart) + (subvector->list bound ostart rstart) + (if (zero? (car qr2)) + '() + (vector-ref bound rstart)) + (subvector->list bound + astart + (vector-length bound)) + (xlambda-unwrapped-body xlambda)))))))) + +(define (xlambda-bound xlambda) + (vector->list (&triple-second xlambda))) + +(define (xlambda-has-internal-lambda? 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!))) + +(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))) + +(set! make-lambda +(named-lambda (make-lambda name required optional rest auxiliary + declarations body) + (let ((body* (if (null? declarations) + body + (make-sequence (list (make-block-declaration declarations) + body))))) + (cond ((and (< (length required) 256) + (< (length optional) 256) + (or (not (null? optional)) + (not (null? rest)) + (not (null? auxiliary)))) + (make-xlambda name required optional rest auxiliary body*)) + ((not (null? optional)) + (error "Optionals not implemented" 'MAKE-LAMBDA)) + ((null? rest) + (make-clambda name required auxiliary body*)) + (else + (make-clexpr name required rest auxiliary body*)))))) + +(set! lambda-components +(named-lambda (lambda-components lambda receiver) + (&lambda-components lambda + (lambda (name required optional rest auxiliary body) + (let ((actions (and (sequence? body) + (sequence-actions body)))) + (if (and actions + (block-declaration? (car actions))) + (receiver name required optional rest auxiliary + (block-declaration-text (car actions)) + (make-sequence (cdr actions))) + (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) + (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) + (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)) + +;;;; Simple Lambda/Lexpr + +(define (make-slambda name required body) + (&typed-pair-cons slambda-type body (list->vector (cons name required)))) + +(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) + (vector-ref (&pair-cdr slambda) 0)) + +(define slambda-body &pair-car) +(define set-slambda-body! &pair-set-car!) + +(define (make-slexpr name required body) + (&typed-pair-cons slexpr-type body (list->vector (cons name required)))) + +(define slexpr-components slambda-components) +(define slexpr-body slambda-body) + +;;; end LAMBDA-PACKAGE. +)) + +(define (make-lambda* name required optional rest body) + (scan-defines body + (lambda (auxiliary declarations body*) + (make-lambda name required optional rest auxiliary declarations body*)))) + +(define (lambda-components* lambda receiver) + (lambda-components lambda + (lambda (name required optional rest auxiliary declarations body) + (receiver name required optional rest + (make-open-block auxiliary declarations body))))) + +(define (lambda-components** lambda receiver) + (lambda-components* lambda + (lambda (name required optional rest body) + (let ((rest-list (if (null? rest) '() (list rest)))) + (receiver (list required optional rest-list) + `(,name ,@required ,@optional ,@rest-list) + body))))) + +(define (make-lambda** pattern bound body) + (define (split pattern bound receiver) + (cond ((null? pattern) + (receiver '() bound)) + (else + (split (cdr pattern) (cdr bound) + (lambda (copy tail) + (receiver (cons (car bound) copy) + tail)))))) + (split (first pattern) (cdr bound) + (lambda (required tail) + (split (second pattern) tail + (lambda (optional rest) + (make-lambda* (car bound) + required + optional + (if (null? rest) rest (car rest)) + body)))))) \ No newline at end of file diff --git a/v7/src/runtime/list.scm b/v7/src/runtime/list.scm new file mode 100644 index 000000000..4941e9cd8 --- /dev/null +++ b/v7/src/runtime/list.scm @@ -0,0 +1,424 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of +;;; this software shall duly acknowledge such use, in accordance +;;; with the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; + +;;;; List Operations + +(declare (usual-integrations)) + +;;; This IN-PACKAGE is just a kludge to prevent the definitions of the +;;; primitives from shadowing the USUAL-INTEGRATIONS declaration. +(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) + (or (null? frob) + (and (pair? frob) + (list? (cdr frob))))) + +(define (cons* first-element . rest-elements) + (define (loop this-element rest-elements) + (if (null? rest-elements) + this-element + (cons this-element + (loop (car rest-elements) + (cdr rest-elements))))) + (loop first-element rest-elements)) + +(define (make-list size #!optional value) + (subvector->list (vector-cons size (if (unassigned? value) '() value)) + 0 + size)) + +(define (list-copy elements) + (apply list elements)) + +(define (list-ref l n) + (car (list-tail l n))) + +(define (list-tail l n) + (cond ((zero? n) l) + ((pair? l) (list-tail (cdr l) (-1+ n))) + (else (error "LIST-TAIL: Argument not a list" l)))) + +(define the-empty-stream + '()) + +(define empty-stream? + null?) + +(define head + car) + +(define (tail stream) + (force (cdr stream))) + +;;;; 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)) + +;;;; 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)))) + +(define (append! . lists) + (define (loop head tail) + (cond ((null? tail) head) + ((null? head) (loop (car tail) (cdr tail))) + ((pair? head) + (set-cdr! (last-pair head) (loop (car tail) (cdr tail))) + head) + (else (error "APPEND!: Argument not a list" head)))) + (if (null? lists) + '() + (loop (car lists) (cdr lists)))) + +(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 '())) + +(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 '())) + +;;;; Mapping Procedures + +(define map) +(define map*) +(let () + +(define (inner-map f lists initial-value) + (define (loop lists) + (define (scan lists c) + (if (null? lists) + (c '() '()) + (let ((list (car lists))) + (cond ((null? list) initial-value) + ((pair? list) + (scan (cdr lists) + (lambda (cars cdrs) + (c (cons (car list) cars) + (cons (cdr list) cdrs))))) + (else (error "MAP: Argument not a list" list)))))) + (scan lists + (lambda (cars cdrs) + (cons (apply f cars) (loop cdrs))))) + (loop lists)) + +(set! map +(named-lambda (map f . lists) + (if (null? lists) + (error "MAP: Too few arguments" f) + (inner-map f lists '())))) + +(set! map* +(named-lambda (map* initial-value f . lists) + (if (null? lists) + (error "MAP*: Too few arguments" initial-value f) + (inner-map f lists initial-value)))) + +) + +(define (for-each f . lists) + (define (loop lists) + (define (scan lists c) + (if (null? lists) + (c '() '()) + (let ((list (car lists))) + (cond ((null? list) '()) + ((pair? list) + (scan (cdr lists) + (lambda (cars cdrs) + (c (cons (car list) cars) + (cons (cdr list) cdrs))))) + (else (error "FOR-EACH: Argument not a list" list)))))) + (scan lists + (lambda (cars cdrs) + (apply f cars) + (loop cdrs)))) + (if (null? lists) + (error "FOR-EACH: Too few arguments" f) + (loop lists)) + *the-non-printing-object*) + +(define mapcar map) +(define mapcar* map*) +(define mapc for-each) + +(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) + (or (not (pair? objects)) + (and (predicate (car objects)) + (loop (cdr objects))))) + loop) + +;;;; Generalized List Operations + +(define (positive-list-searcher pred if-win if-lose) + (define (list-searcher-loop list) + (if (pair? list) + (if (pred list) + (if-win list) + (list-searcher-loop (cdr list))) + (and if-lose (if-lose)))) + list-searcher-loop) + +(define (negative-list-searcher pred if-win if-lose) + (define (list-searcher-loop list) + (if (pair? list) + (if (pred 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) + +;;; Not so general, but useful. + +(define (list-deletor pred) + (negative-list-transformer pred '())) + +(define (list-deletor! pred) + (define (trim-initial-segment list) + (if (pair? list) + (if (pred (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 (pred (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) + ((positive-list-transformer predicate '()) list)) + +(define (list-transform-negative list predicate) + ((negative-list-transformer predicate '()) list)) + +(define (list-search-positive list predicate) + ((positive-list-searcher (lambda (items) + (predicate (car items))) + car + #!FALSE) + list)) + +(define (list-search-negative list predicate) + ((negative-list-searcher (lambda (items) + (predicate (car items))) + car + #!FALSE) + list)) + +;;;; Membership Lists + +(define ((member-procedure pred) element list) + ((positive-list-searcher (lambda (sub-list) + (pred (car sub-list) element)) + identity-procedure + #!FALSE) + list)) + +;(define memq (member-procedure eq?)) +(define memv (member-procedure eqv?)) +(define member (member-procedure equal?)) + +(define ((delete-member-procedure deletor pred) element list) + ((deletor (lambda (match) + (pred match element))) + list)) + +(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 delq! (delete-member-procedure list-deletor! eq?)) +(define delv! (delete-member-procedure list-deletor! eqv?)) +(define delete! (delete-member-procedure list-deletor! equal?)) + +;;;; Association Lists + +(define ((association-procedure pred selector) key alist) + ((positive-list-searcher (lambda (sub-alist) + (pred (selector (car sub-alist)) key)) + car + #!FALSE) + alist)) + +;(define assq (association-procedure eq? car)) +(define assv (association-procedure eqv? car)) +(define assoc (association-procedure equal? car)) + +(define ((delete-association-procedure deletor pred selector) key alist) + ((deletor (lambda (association) + (pred (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)) + +(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)) + +;;;; Lastness + +(define (last-pair l) + (define (loop l) + (if (pair? (cdr l)) + (loop (cdr l)) + l)) + (if (pair? l) + (loop l) + (error "LAST-PAIR: Argument not a list" l))) + +(define (except-last-pair l) + (define (loop l) + (if (pair? (cdr l)) + (cons (car l) + (loop (cdr l))) + '())) + (if (pair? l) + (loop l) + (error "EXCEPT-LAST-PAIR: Argument not a list" l))) + +(define (except-last-pair! l) + (define (loop l) + (if (pair? (cddr l)) + (loop (cdr l)) + (set-cdr! l '()))) + (if (pair? l) + (if (pair? (cdr l)) + (begin (loop l) + l) + '()) + (error "EXCEPT-LAST-PAIR!: Argument not a list" l))) \ No newline at end of file diff --git a/v7/src/runtime/msort.scm b/v7/src/runtime/msort.scm new file mode 100644 index 000000000..01c1523ee --- /dev/null +++ b/v7/src/runtime/msort.scm @@ -0,0 +1,99 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1985 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of +;;; this software shall duly acknowledge such use, in accordance +;;; with the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; + +;;;; Merge Sort + +(declare (usual-integrations)) + +;; Functional and unstable but fairly fast + +(define (sort the-list p) + (define (loop l) + (if (and (pair? l) (pair? (cdr l))) + (split l '() '()) + l)) + + (define (split l one two) + (if (pair? l) + (split (cdr l) two (cons (car l) one)) + (merge (loop one) (loop two)))) + + (define (merge one two) + (cond ((null? one) two) + ((p (car two) (car one)) + (cons (car two) + (merge (cdr two) one))) + (else + (cons (car one) + (merge (cdr one) two))))) + + (loop the-list)) + +;; In-place and stable, fairly slow + +#| + +(define (sort! vector p) + (define (merge! source target low1 high1 low2 high2 point) + (define (loop low1 high1 low2 high2 point) + (cond ((= low1 high1) (transfer! source target low2 high2 point)) + ((p (vector-ref source low2) (vector-ref source low1)) + (vector-set! target point (vector-ref source low2)) + (loop (1+ low2) high2 low1 high1 (1+ point))) + (else + (vector-set! target point (vector-ref source low1)) + (loop (1+ low1) high1 low2 high2 (1+ point))))) + (loop low1 high1 low2 high2 point)) + (define (transfer! from to low high where) + (if (= low high) + 'DONE + (begin (vector-set! to where (vector-ref from low)) + (transfer! from to (1+ low) high (1+ where))))) + (define (split! source target low high) + (let ((bound (ceiling (/ (+ low high) 2)))) + (transfer! source target low bound low) + (transfer! source target bound high bound) + (do! target source low bound) + (do! target source bound high) + (merge! target source low bound bound high low))) + (define (do! source target low high) + (if (< high (+ low 2)) + 'DONE + (split! source target low high))) + (let ((size (vector-length vector))) + (do! vector (vector-cons size '()) 0 size) + vector)) diff --git a/v7/src/runtime/numpar.scm b/v7/src/runtime/numpar.scm new file mode 100644 index 000000000..48f0d40d5 --- /dev/null +++ b/v7/src/runtime/numpar.scm @@ -0,0 +1,278 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of this +;;; software shall duly acknowledge such use, in accordance with +;;; the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; + +;;;; 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 *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 (parse-number chars) + (parse-real chars + (lambda (chars real) + (if (null? chars) + real + (case (car chars) + ((#\+ #\-) + (parse-real chars + (lambda (chars real*) + (and (not (null? chars)) + (char-ci=? (car chars) #\i) + (null? (cdr chars)) + (make-rectangular real + (if (char=? (car chars) #\+) + real* + (- real*))))))) + ((#\@) + (parse-real chars + (lambda (chars real*) + (and (null? chars) + (make-polar real real*))))) + (else false)))))) + +(define (parse-real chars receiver) + (and (not (null? chars)) + (case (car chars) + ((#\+) + (parse-unsigned-real (cdr chars) + receiver)) + ((#\-) + (parse-unsigned-real (cdr chars) + (lambda (chars real) + (receiver chars (- real))))) + (else + (parse-unsigned-real chars + receiver))))) + +(define (parse-unsigned-real chars receiver) + (parse-prefix chars false false false + (lambda (chars radix exactness precision) + (fluid-let ((*radix* + (cdr (assv radix + '((#F . 10) + (#\b . 2) + (#\o . 8) + (#\d . 10) + (#\x . 16)))))) + (parse-body chars + (lambda (chars real) + (parse-suffix chars + (lambda (chars exponent) + (receiver chars + ((case exactness + ((#F) identity-procedure) + ((#\e) ->exact) + ((#\i) ->inexact)) + ((case precision + ((#F) identity-procedure) + ((#\s) ->short-flonum) + ((#\l) ->long-flonum)) + (if exponent + (* real (expt 10 exponent)) + real)))))))))))) + +(define (parse-prefix chars radix exactness precision receiver) + (and (not (null? chars)) + (if (char=? (car chars) #\#) + (and (pair? (cdr chars)) + (let ((type (char-downcase (cadr chars))) + (rest (cddr chars))) + (let ((specify-prefix-type + (lambda (old) + (if old + (error "Respecification of prefix type" type) + type)))) + (case type + ((#\b #\o #\d #\x) + (parse-prefix rest + (specify-prefix-type radix) + exactness + precision + receiver)) + ((#\i #\e) + (parse-prefix rest + radix + (specify-prefix-type exactness) + precision + receiver)) + ((#\s #\l) + (parse-prefix rest + radix + exactness + (specify-prefix-type precision) + receiver)) + (else (error "Unknown prefix type" type)))))) + (receiver chars radix exactness precision)))) + +(define (parse-suffix chars receiver) + (if (and (not (null? chars)) + (char-ci=? (car chars) #\e)) + (parse-signed-suffix (cdr chars) receiver) + (receiver chars false))) + +(define (parse-signed-suffix chars receiver) + (and (not (null? chars)) + (case (car chars) + ((#\+) + (parse-unsigned-suffix (cdr chars) + receiver)) + ((#\-) + (parse-unsigned-suffix (cdr chars) + (lambda (chars exponent) + (receiver chars (- exponent))))) + (else + (parse-unsigned-suffix chars + receiver))))) + +(define (parse-unsigned-suffix chars receiver) + (define (parse-digit chars value if-digit) + (let ((digit (char->digit (car chars) 10))) + (if digit + (if-digit (cdr chars) digit) + (receiver chars value)))) + + (define (loop chars value) + (if (null? chars) + (receiver chars value) + (parse-digit chars value + (lambda (chars digit) + (loop chars (+ digit (* value 10))))))) + + (and (not (null? chars)) + (parse-digit chars false + loop))) + +(define (parse-body chars receiver) + (and (not (null? chars)) + (if (char=? (car chars) #\.) + (require-digit (cdr chars) + (lambda (chars digit) + (parse-fraction chars digit 1 + receiver))) + (parse-integer chars + (lambda (chars integer) + (if (null? chars) + (receiver chars integer) + (case (car chars) + ((#\/) + (parse-integer (cdr chars) + (lambda (chars denominator) + (receiver chars (/ integer denominator))))) + ((#\.) + (parse-fraction (cdr chars) 0 0 + (lambda (chars fraction) + (receiver chars (+ integer fraction))))) + (else + (receiver chars integer))))))))) + +(define (parse-integer chars receiver) + (define (loop chars integer) + (parse-digit/sharp chars + (lambda (chars count) + (receiver chars (->inexact (* integer (expt *radix* count))))) + (lambda (chars digit) + (loop chars (+ digit (* integer *radix*)))) + (lambda (chars) + (receiver chars integer)))) + (require-digit chars loop)) + +(define (parse-fraction chars integer place-value receiver) + (define (loop chars integer place-value) + (parse-digit/sharp chars + (lambda (chars count) + (finish chars (->inexact integer) place-value)) + (lambda (chars digit) + (loop chars + (+ digit (* integer *radix*)) + (1+ place-value))) + (lambda (chars) + (finish chars integer place-value)))) + + (define (finish chars integer place-value) + (receiver chars (/ integer (expt *radix* place-value)))) + + (loop chars integer place-value)) + +(define (require-digit chars receiver) + (and (not (null? chars)) + (let ((digit (char->digit (car chars) *radix*))) + (and digit + (receiver (cdr chars) digit))))) + +(define (parse-digit/sharp chars if-sharp if-digit otherwise) + (cond ((null? chars) (otherwise chars)) + ((char=? (car chars) #\#) + (let count-sharps ((chars (cdr chars)) (count 1)) + (if (and (not (null? chars)) + (char=? (car chars) #\#)) + (count-sharps (cdr chars) (1+ count)) + (if-sharp chars count)))) + (else + (let ((digit (char->digit (car chars) *radix*))) + (if digit + (if-digit (cdr chars) digit) + (otherwise chars)))))) + +;;; end NUMBER-PARSER-PACKAGE diff --git a/v7/src/runtime/output.scm b/v7/src/runtime/output.scm new file mode 100644 index 000000000..f86e73abb --- /dev/null +++ b/v7/src/runtime/output.scm @@ -0,0 +1,323 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of this +;;; software shall duly acknowledge such use, in accordance with +;;; the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; + +;;;; Output + +(declare (usual-integrations)) + +;;;; Output Ports + +(define output-port-tag + "Output Port") + +(define (output-port? object) + (and (environment? object) + (not (lexical-unreferenceable? object ':TYPE)) + (eq? (access :type object) output-port-tag))) + +(define *current-output-port*) + +(define (current-output-port) + *current-output-port*) + +(define (with-output-to-port port thunk) + (if (not (output-port? port)) (error "Bad output port" port)) + (fluid-let ((*current-output-port* port)) + (thunk))) + +(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)))))) + +(define (call-with-output-file output-specifier receiver) + (let ((port (open-output-file output-specifier))) + (let ((value (receiver port))) + (close-output-port port) + value))) + +(define (close-output-port port) + ((access :close port))) + +;;;; Console Output Port + +(define beep + (make-primitive-procedure 'TTY-BEEP)) + +(define (screen-clear) + ((access :clear-screen 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) + +(define (:print-self) + (unparse-with-brackets + (lambda () + (write-string "Console output port")))) + +(define (:close) 'DONE) +(define :write-char tty-write-char) +(define :write-string tty-write-string) +(define (:flush-output) 'DONE) +(define :clear-screen tty-clear) + +(define (:x-size) + (access printer-width implementation-dependencies)) + +(define (:y-size) + (access printer-length implementation-dependencies)) + +;;; end CONSOLE-OUTPUT-PORT. +)) + +) + +(set! *current-output-port* console-output-port) + +;;; File Output Ports + +(define open-output-file) +(let () +#| +(declare (compilable-primitive-functions 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)) + +) + +;;;; 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 (:write-char char) + (set! accumulator (cons (char->string char) accumulator))) + +(define (:write-string string) + (set! accumulator (cons string accumulator))) + +(define (:close) 'DONE) +(define (:flush-output) 'DONE) +(define (:x-size) false) +(define (:y-size) 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. +))) + +;;;; Output Procedures + +(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)) + *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)) + *the-non-printing-object*) + +(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)) + *the-non-printing-object*) + +(define (display object #!optional port) + (cond ((unassigned? port) (set! port *current-output-port*)) + ((not (output-port? port)) (error "Bad output port" port))) + (if (not (non-printing-object? object)) + (begin (if (and (not (future? object)) (string? object)) + ((access :write-string port) object) + ((access unparse-object unparser-package) object port false)) + ((access :flush-output port)))) + *the-non-printing-object*) + +(define (write object #!optional port) + (cond ((unassigned? port) (set! port *current-output-port*)) + ((not (output-port? port)) (error "Bad output port" port))) + (if (not (non-printing-object? object)) + (begin ((access unparse-object unparser-package) object port) + ((access :flush-output port)))) + *the-non-printing-object*) + +(define (write-line object #!optional port) + (cond ((unassigned? port) (set! port *current-output-port*)) + ((not (output-port? port)) (error "Bad output port" port))) + (if (not (non-printing-object? object)) + (begin ((access :write-char port) char:newline) + ((access unparse-object unparser-package) object port) + ((access :flush-output port)))) + *the-non-printing-object*) + +(define (non-printing-object? object) + (and (not (future? object)) + ((access :flush-output port)))))) \ No newline at end of file diff --git a/v7/src/runtime/parse.scm b/v7/src/runtime/parse.scm new file mode 100644 index 000000000..a1754ab7f --- /dev/null +++ b/v7/src/runtime/parse.scm @@ -0,0 +1,476 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of this +;;; software shall duly acknowledge such use, in accordance with +;;; the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; + +;;;; Scheme Parser + +(declare (usual-integrations)) + +(define *parser-radix* #d10) +(define *parser-table*) + +(define parser-package + (make-environment + +(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-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) + '() + (cons object (loop (parse-object))))) + (loop (parse-object)))) + +;;;; Character Operations + +(declare (integrate peek-char read-char discard-char + read-string discard-chars)) + +(define (peek-char) + (or (*parser-peek-char*) + (error "End of file within READ"))) + +(define (read-char) + (or (*parser-read-char*) + (error "End of file within READ"))) + +(define (discard-char) + (*parser-discard-char*)) + +(define (read-string delimiters) + (declare (integrate delimiters)) + (*parser-read-string* delimiters)) + +(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. + +;;; 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 (parse-object:atom) + (build-atom (read-atom))) + +(define ((collect-list-wrapper object-parser)) + (let ((value (object-parser))) ;forces order. + (cons value (collect-list)))) + +(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*))) + +(declare (integrate peek-ascii parse-object collect-list)) + +(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 (parse-object) + (let ((char (*parser-peek-char*))) + (if char + ((vector-ref *parser-parse-object-table* + (or (char-ascii? char) + (non-ascii-error)))) + eof-object))) + +(define (collect-list) + ((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 undefined-atom-delimiters + (char-set #\[ #\] #\{ #\} #\|)) + +(define atom-delimiters + (char-set-union char-set:whitespace + (char-set-union undefined-atom-delimiters + (char-set #\( #\) #\; #\" #\' #\`)))) + +(define atom-constituents + (char-set-invert atom-delimiters)) + +(declare (integrate read-atom)) + +(define (read-atom) + (read-string atom-delimiters)) + +(define (build-atom string) + (or (parse-number string) + (intern-string! string))) + +(declare (integrate parse-number)) + +(define (parse-number string) + (declare (integrate string)) + (string->number string false *parser-radix*)) + +(define (intern-string! string) + (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))) + +(define-char-special #\( + (lambda () + (discard-char) + (list->vector (collect-list)))) + +(define-char #\) + (lambda () + (if (not (eq? console-input-port *parser-input-port*)) + (error "PARSE-OBJECT: Unmatched close paren" (read-char)) + (read-char)) + (parse-object)) + (lambda () + (discard-char) + '())) + +(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 () + +(vector-set! (cdar *parser-table*) + (char->ascii #\.) + (lambda () + (discard-char) + ;; atom with initial dot? + (if (char-set-member? atom-constituents (peek-char)) + (let ((first (build-atom (string-append "." (read-atom))))) + (cons first (collect-list))) + + ;; (A . B) -- get B and ignore whitespace following it. + (let ((tail (parse-object))) + (discard-whitespace) + (if (not (char=? (peek-char) #\))) + (error "Illegal character in ignored stream" (peek-char))) + (discard-char) + tail)))) + +(define-char char-set:whitespace + (lambda () + (discard-whitespace) + (parse-object)) + (lambda () + (discard-whitespace) + (collect-list))) + +(define (discard-whitespace) + (discard-chars non-whitespace)) + +(define non-whitespace + (char-set-invert char-set:whitespace)) + +) + +(let () + +(define-char #\; + (lambda () + (discard-comment) + (parse-object)) + (lambda () + (discard-comment) + (collect-list))) + +(define (discard-comment) + (discard-char) + (discard-chars comment-delimiters) + (discard-char)) + +(define comment-delimiters + (char-set char:newline)) + +) + +(let () + +(define-char-special #\| + (lambda () + (discard-char) + (discard-special-comment) + (parse-object)) + (lambda () + (discard-char) + (discard-special-comment) + (collect-list))) + +(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 (access quasiquote-keyword syntaxer-package) + (parse-object)))) + +(define-char #\, + (lambda () + (discard-char) + (if (char=? #\@ (peek-char)) + (begin (discard-char) + (list (access unquote-splicing-keyword syntaxer-package) + (parse-object))) + (list (access unquote-keyword syntaxer-package) + (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))))) + +(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 (char=? #\- (peek-char)) + (begin (discard-char) + (string-append string "-" (loop))) + string))))) + (discard-char) + (if (char=? #\\ (peek-char)) + (read-char) + (name->char (loop)))))) + +(define ((fixed-object-parser object)) + (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)))) + +(define (ptable-ref table index) + (cons (vector-ref (car table) index) + (vector-ref (cdr table) index))) + +(define (ptable-set! table index value) + (vector-set! (car table) index (car value)) + (vector-set! (cdr table) index (cdr value))) + +(set! parser-table-entry +(named-lambda (parser-table-entry table char) + (decode-parser-char table char ptable-ref))) + +(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))))) + +) diff --git a/v7/src/runtime/pathnm.scm b/v7/src/runtime/pathnm.scm new file mode 100644 index 000000000..20f000b48 --- /dev/null +++ b/v7/src/runtime/pathnm.scm @@ -0,0 +1,443 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of this +;;; software shall duly acknowledge such use, in accordance with +;;; the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; + +;;;; Pathnames + +(declare (usual-integrations)) + +;;; A pathname component is normally one of: + +;;; * A string, which is the literal component. + +;;; * 'WILD, meaning that the component is wildcarded. Such +;;; components may have special meaning to certain directory +;;; operations. + +;;; * 'UNSPECIFIC, meaning that the component was supplied, but null. +;;; This means about the same thing as "". (maybe it should be +;;; eliminated in favor of that?) + +;;; * #F, meaning that the component was not supplied. This has +;;; special meaning to `merge-pathnames', in which such components are +;;; substituted. + +;;; A pathname consists of 5 components, as follows: + +;;; * The DEVICE is usually a physical device, as in the Twenex `ps:'. +;;; Unix does not use this field. + +;;; * The DIRECTORY is a list of components. If the first component +;;; is the null string, then the directory path is absolute. +;;; Otherwise it is relative. + +;;; * The NAME is the proper name part of the filename. + +;;; * The TYPE usually indicates something about the contents of the +;;; file. Certain system procedures will default the type to standard +;;; type strings. + +;;; * The VERSION is special. Unlike an ordinary component, it is +;;; never a string, but may be either a positive integer, 'NEWEST, +;;; 'WILD, 'UNSPECIFIC, or #F. Many system procedures will default +;;; the version to 'NEWEST, which means to search the directory for +;;; the highest version numbered file. + +;;; 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. + +;;;; Basic Pathnames + +(define (pathname? object) + (and (environment? object) + (eq? (environment-procedure object) make-pathname))) + +(define (make-pathname device directory name type version) + (define string #F) + + (define (:print-self) + (unparse-with-brackets + (lambda () + (write-string "PATHNAME ") + (write (pathname->string (the-environment)))))) + + (the-environment)) + +(define (pathname-components pathname receiver) + (receiver (access device pathname) + (access directory pathname) + (access name pathname) + (access type pathname) + (access version pathname))) + +(define (pathname-device pathname) + (access device pathname)) + +(define (pathname-directory pathname) + (access directory pathname)) + +(define (pathname-name pathname) + (access name pathname)) + +(define (pathname-type pathname) + (access type pathname)) + +(define (pathname-version pathname) + (access version pathname)) + +(define (pathname-extract pathname . fields) + (pathname-components pathname + (lambda (device directory name type version) + (make-pathname (and (memq 'DEVICE fields) device) + (and (memq 'DIRECTORY fields) directory) + (and (memq 'NAME fields) name) + (and (memq 'TYPE fields) type) + (and (memq 'VERSION fields) version))))) + +(define (pathname-absolute? pathname) + (let ((directory (pathname-directory pathname))) + (and (not (null? directory)) + (string-null? (car directory))))) + +(define (pathname-new-device pathname device) + (pathname-components pathname + (lambda (old-device directory name type version) + (make-pathname device directory name type version)))) + +(define (pathname-new-directory pathname directory) + (pathname-components pathname + (lambda (device old-directory name type version) + (make-pathname device directory name type version)))) + +(define (pathname-new-name pathname name) + (pathname-components pathname + (lambda (device directory old-name type version) + (make-pathname device directory name type version)))) + +(define (pathname-new-type pathname type) + (pathname-components pathname + (lambda (device directory name old-type version) + (make-pathname device directory name type version)))) + +(define (pathname-new-version pathname version) + (pathname-components pathname + (lambda (device directory name type old-version) + (make-pathname device directory name type version)))) + +(define (pathname-directory-path pathname) + (pathname-components pathname + (lambda (device directory name type version) + (make-pathname device directory #F #F #F)))) + +(define (pathname-directory-string pathname) + (pathname-components pathname + (lambda (device directory name type version) + (pathname-unparse device directory #F #F #F)))) + +(define (pathname-name-path pathname) + (pathname-components pathname + (lambda (device directory name type version) + (make-pathname #F #F name type version)))) + +(define (pathname-name-string pathname) + (pathname-components pathname + (lambda (device directory name type version) + (pathname-unparse #F #F name type version)))) + +;;;; Parse + +(define (->pathname object) + (cond ((pathname? object) object) + ((string? object) (string->pathname object)) + ((symbol? object) + (string->pathname (string-downcase (symbol->string object)))) + (else (error "Unable to coerce into pathname" object)))) + +(define string->pathname) +(let () + +(set! string->pathname +(named-lambda (string->pathname string) + (parse-pathname (canonicalize-filename-string string) + make-pathname))) + +(define (parse-pathname string receiver) + (let ((components (divide-into-components (string-trim string)))) + (if (null? components) + (receiver #F #F #F #F #F) + (let ((components + (append (expand-directory-prefixes (car components)) + (cdr components)))) + (parse-name (car (last-pair components)) + (lambda (name type version) + (receiver #F + (map (lambda (component) + (if (string=? "*" component) + 'WILD + component)) + (except-last-pair components)) + name type version))))))) + +(define (divide-into-components string) + (let ((end (string-length string))) + (define (loop start) + (let ((index (substring-find-next-char string start end #\/))) + (if index + (cons (substring string start index) + (loop (1+ index))) + (list (substring string start end))))) + (loop 0))) + +(define (expand-directory-prefixes string) + (if (string-null? string) + (list string) + (case (string-ref string 0) + ((#\$) + (divide-into-components + (get-environment-variable + (substring string 1 (string-length string))))) + ((#\~) + (let ((user-name (substring string 1 (string-length string)))) + (divide-into-components + (if (string-null? user-name) + (get-environment-variable "HOME") + (get-user-home-directory user-name))))) + (else (list string))))) + +(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) 'UNSPECIFIC) + ((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 #F #F #F) + (let ((index (find-next-dot start))) + (if index + (let ((start* (1+ index)) + (name (wildify string start index))) + (if (= start* end) + (receiver name 'UNSPECIFIC 'UNSPECIFIC) + (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) + #F))))) + (receiver (wildify string start end) #F #F)))))) + +(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)))))) + +(define (wildify string start end) + (if (substring=? string start end "*" 0 1) + 'WILD + (substring string start end))) + +;;; end LET. +) + +;;;; Unparse + +(define (pathname->string pathname) + (or (access string pathname) + (let ((string (pathname-components pathname pathname-unparse))) + (set! (access string pathname) string) + string))) + +(define (pathname-extract-string pathname . fields) + (pathname-components pathname + (lambda (device directory name type version) + (pathname-unparse (and (memq 'DEVICE fields) device) + (and (memq 'DIRECTORY fields) directory) + (and (memq 'NAME fields) name) + (and (memq 'TYPE fields) type) + (and (memq 'VERSION fields) version))))) + +(define pathname-unparse) +(define pathname-unparse-name) +(let () + +(set! pathname-unparse +(named-lambda (pathname-unparse device directory name type version) + (unparse-device + device + (unparse-directory directory + (pathname-unparse-name name type version))))) + +(define (unparse-device device rest) + (let ((device-string (unparse-component device))) + (if device-string + (string-append device-string ":" rest) + rest))) + +(define (unparse-directory directory rest) + (cond ((null? directory) rest) + ((pair? directory) + (let loop ((directory directory)) + (let ((directory-string (unparse-component (car directory))) + (rest (if (null? (cdr directory)) + rest + (loop (cdr directory))))) + (if directory-string + (string-append directory-string "/" rest) + rest)))) + (else + (error "Unrecognizable directory" directory)))) + +(set! pathname-unparse-name +(named-lambda (pathname-unparse-name name type version) + (let ((name-string (unparse-component name)) + (type-string (unparse-component type)) + (version-string (unparse-version version))) + (cond ((not name-string) "") + ((not type-string) name-string) + ((eq? type-string 'UNSPECIFIC) (string-append name-string ".")) + ((not version-string) (string-append name-string "." type-string)) + ((eq? version-string 'UNSPECIFIC) + (string-append name-string "." type-string ".")) + (else + (string-append name-string "." type-string "." version-string)))))) + +(define (unparse-version version) + (if (eq? version 'NEWEST) + "0" + (unparse-component version))) + +(define (unparse-component component) + (cond ((not component) #F) + ((eq? component 'UNSPECIFIC) component) + ((eq? component 'WILD) "*") + ((string? component) component) + ((and (integer? component) (> component 0)) + (list->string (number->digits component '()))) + (else (error "Unknown component" component)))) + +(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. +) + +(define merge-pathnames) +(let () + +(set! merge-pathnames +(named-lambda (merge-pathnames pathname default) + (make-pathname (or (pathname-device pathname) (pathname-device default)) + (simplify-directory + (let ((directory (pathname-directory pathname))) + (cond ((null? directory) (pathname-directory default)) + ((string-null? (car directory)) directory) + (else + (append (pathname-directory default) directory))))) + (or (pathname-name pathname) (pathname-name default)) + (or (pathname-type pathname) (pathname-type default)) + (or (pathname-version pathname) (pathname-version default))))) + +(define (simplify-directory directory) + (cond ((null? directory) directory) + ((string=? (car directory) ".") + (simplify-directory (cdr directory))) + ((null? (cdr directory)) directory) + ((string=? (cadr directory) "..") + (simplify-directory (cddr directory))) + (else + (cons (car directory) + (simplify-directory (cdr directory)))))) + +) + +(define (pathname-as-directory pathname) + (let ((file (pathname-unparse-name (pathname-name pathname) + (pathname-type pathname) + (pathname-version pathname)))) + (if (string-null? file) + pathname + (make-pathname (pathname-device pathname) + (append (pathname-directory pathname) + (list file)) diff --git a/v7/src/runtime/pp.scm b/v7/src/runtime/pp.scm new file mode 100644 index 000000000..178f9270d --- /dev/null +++ b/v7/src/runtime/pp.scm @@ -0,0 +1,465 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of this +;;; software shall duly acknowledge such use, in accordance with +;;; the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; + +;;;; Pretty Printer + +(declare (usual-integrations)) + +(define scheme-pretty-printer + (make-environment + +(define *pp-primitives-by-name* true) +(define *forced-x-size* false) +(define *default-x-size* 80) + +(define x-size) +(define next-coords) +(define add-sc-entry!) +(define sc-relink!) + +(declare (integrate *unparse-string *unparse-char)) + +(define (*unparse-string string) + (declare (integrate string)) + ((access :write-string *current-output-port*) string)) + +(define (*unparse-char char) + (declare (integrate char)) + ((access :write-char *current-output-port*) char)) + +(define (*unparse-open) + (*unparse-char #\()) + +(define (*unparse-close) + (*unparse-char #\))) + +(define (*unparse-space) + (*unparse-char #\Space)) + +(define (*unparse-newline) + (*unparse-char char:newline)) + +;;;; Top Level + +(define (pp expression as-code?) + (fluid-let ((x-size (get-x-size))) + (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*))))) + +(define (stepper-pp expression port p-wrapper table nc relink! sc! offset) + (fluid-let ((x-size (get-x-size)) + (walk-dispatcher table) + (next-coords nc) + (sc-relink! relink!) + (add-sc-entry! sc!) + (print-combination (p-wrapper print-combination)) + (forced-indentation (p-wrapper forced-indentation)) + (pressured-indentation (p-wrapper pressured-indentation)) + (print-procedure (p-wrapper print-procedure)) + (print-let-expression (p-wrapper print-let-expression)) + (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*))))))) + +(define (get-x-size) + (or *forced-x-size* + ((access :x-size *current-output-port*)) + *default-x-size*)) + +(define (print-non-code-node node column depth) + (fluid-let ((dispatch-list '())) + (print-node node column depth))) + +(define (print-node node column depth) + (cond ((list-node? node) (print-list-node node column depth)) + ((symbol? node) (*unparse-symbol node)) + ((prefix-node? node) (*unparse-string (node-prefix node)) + (print-node (node-subnode node) + (+ (string-length (node-prefix node)) column) + depth)) + (else (*unparse-string node)))) + +(define (print-list-node node column depth) + (if (fits-within? node column depth) + (print-guaranteed-list-node node) + (let ((subnodes (node-subnodes node))) + ((or (let ((association (assq (car subnodes) dispatch-list))) + (and association (cdr association))) + print-combination) + subnodes column depth)))) + +(define (print-guaranteed-node node) + (cond ((list-node? node) (print-guaranteed-list-node node)) + ((symbol? node) (*unparse-symbol node)) + ((prefix-node? node) + (*unparse-string (node-prefix node)) + (print-guaranteed-node (node-subnode node))) + (else (*unparse-string node)))) + +(define (print-guaranteed-list-node node) + (define (loop nodes) + (print-guaranteed-node (car nodes)) + (if (not (null? (cdr nodes))) + (begin (*unparse-space) + (loop (cdr nodes))))) + (*unparse-open) + (loop (node-subnodes node)) + (*unparse-close)) + +(define (print-column nodes column depth) + (define (loop nodes) + (if (null? (cdr nodes)) + (print-node (car nodes) column depth) + (begin (print-node (car nodes) column 0) + (tab-to column) + (loop (cdr nodes))))) + (loop nodes)) + +(define (print-guaranteed-column nodes column) + (define (loop nodes) + (print-guaranteed-node (car nodes)) + (if (not (null? (cdr nodes))) + (begin (tab-to column) + (loop (cdr nodes))))) + (loop nodes)) + +;;;; Printers + +(define (print-combination nodes column depth) + (*unparse-open) + (let ((column (1+ column)) (depth (1+ depth))) + (cond ((null? (cdr nodes)) + (print-node (car nodes) column depth)) + ((two-on-first-line? nodes column depth) + (print-guaranteed-node (car nodes)) + (*unparse-space) + (print-guaranteed-column (cdr nodes) + (1+ (+ column (node-size (car nodes)))))) + (else + (print-column nodes column depth)))) + (*unparse-close)) + +(define ((special-printer procedure) nodes column depth) + (*unparse-open) + (*unparse-symbol (car nodes)) + (*unparse-space) + (if (not (null? (cdr nodes))) + (procedure (cdr nodes) + (+ 2 (+ column (symbol-length (car nodes)))) + (+ 2 column) + (1+ depth))) + (*unparse-close)) + +;;; Force the indentation to be an optimistic column. + +(define forced-indentation + (special-printer + (lambda (nodes optimistic pessimistic depth) + (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)))))) + +;;; 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)))) + +;;; 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 +;;; binder. But most important is the code that handles the name when +;;; we encounter a named LET; it must go on the same line as the +;;; keyword. In that case, the bindings try to fit on that line or +;;; 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 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)) + (> (- x-size depth) + (+ column (node-size node)))) + +;;; Fits if each node fits when stacked vertically at the given column. + +(define (fits-as-column? nodes column depth) + (define (loop nodes) + (if (null? (cdr nodes)) + (fits-within? (car nodes) column depth) + (and (> x-size + (+ column (node-size (car nodes)))) + (loop (cdr nodes))))) + (loop nodes)) + +;;; Fits if first two nodes fit on same line, and rest fit under the +;;; second node. Assumes at least two nodes are given. + +(define (two-on-first-line? nodes column depth) + (let ((column (1+ (+ column (node-size (car nodes)))))) + (and (> x-size column) + (fits-as-column? (cdr nodes) column depth)))) + +;;; Starts a new line with the specified indentation. + +(define (tab-to column) + (*unparse-newline) + (*unparse-string (make-string column #\Space))) + +;;;; Numerical Walk + +(define (numerical-walk object) + ((walk-dispatcher object) object)) + +(define (walk-general object) + (write-to-string object)) + +(define (walk-primitive primitive) + (if *pp-primitives-by-name* + (primitive-procedure-name primitive) + (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) + (if (null? (cdr pair)) + (make-singleton-list-node (numerical-walk (car pair))) + (make-list-node + (numerical-walk (car pair)) + (if (pair? (cdr pair)) + (walk-unquoted-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)) + +;;;; Node Model +;;; Carefully crafted to use the least amount of memory, while at the +;;; same time being as fast as possible. The only concession to +;;; space was in the implementation of atomic nodes, in which it was +;;; decided that the extra space needed to cache the size of a string +;;; or the print-name of a symbol wasn't worth the speed that would +;;; be gained by keeping it around. + +(declare (integrate symbol-length *unparse-symbol)) + +(define (symbol-length symbol) + (declare (integrate symbol)) + (string-length (symbol->string symbol))) + +(define (*unparse-symbol symbol) + (declare (integrate symbol)) + (*unparse-string (symbol->string symbol))) + +(define (make-prefix-node prefix subnode) + (cond ((or (list-node? subnode) + (symbol? subnode)) + (vector (+ (string-length prefix) + (node-size subnode)) + prefix + subnode)) + ((prefix-node? subnode) + (make-prefix-node (string-append prefix (node-prefix subnode)) + (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 (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)))) + +(define (make-singleton-list-node car-node) + (cons (+ 2 (node-size car-node)) ;+1 each parenthesis. + (list car-node))) + +(declare (integrate list-node? list-node-size node-subnodes)) + +(define list-node? pair?) +(define list-node-size car) +(define node-subnodes cdr) + +(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 diff --git a/v7/src/runtime/qsort.scm b/v7/src/runtime/qsort.scm new file mode 100644 index 000000000..2035caf04 --- /dev/null +++ b/v7/src/runtime/qsort.scm @@ -0,0 +1,92 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1985 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of +;;; this software shall duly acknowledge such use, in accordance +;;; with the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; + +;;;; Quick Sort + +(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) diff --git a/v7/src/runtime/rep.scm b/v7/src/runtime/rep.scm new file mode 100644 index 000000000..78d6506df --- /dev/null +++ b/v7/src/runtime/rep.scm @@ -0,0 +1,326 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of +;;; this software shall duly acknowledge such use, in accordance +;;; with the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; + +;;;; Read-Eval-Print Loop + +(declare (usual-integrations)) + +;;;; 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)) + + (push-command-hook startup-hook driver initial-state + (lambda (startup-hook driver initial-state each-time) + (fluid-let ((current-level (1+ current-level)) + (previous-driver-hook nearest-driver-hook) + (nearest-driver-hook) + (current-state initial-state)) + (restart startup-hook each-time)))))) + +(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)))) + +(set! abort->nearest +(named-lambda (abort->nearest message) + (nearest-driver-hook message))) + +(set! abort->previous +(named-lambda (abort->previous message) + ((if (null? previous-driver-hook) + nearest-driver-hook + previous-driver-hook) + message))) + +(set! abort->top-level +(named-lambda (abort->top-level message) + (top-level-driver-hook message))) + +(set! rep-continuation +(named-lambda (rep-continuation) + current-continuation)) + +(set! rep-state +(named-lambda (rep-state) + current-state)) + +(set! rep-level +(named-lambda (rep-level) + current-level)) + +) ; 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 (rep-prompt) + *rep-current-prompt*) + +(define (set-rep-prompt! prompt) + (set! *rep-current-prompt* prompt)) + +(define (rep-base-prompt) + *rep-base-prompt*) + +(define (set-rep-base-prompt! prompt) + (set! *rep-base-prompt* prompt) + (set! *rep-current-prompt* prompt)) + +(define (rep-input-port) + *rep-current-input-port*) + +(define (rep-output-port) + *rep-current-output-port*) + +(define environment-warning-hook + identity-procedure) + +(define rep-value-hook + write-line) + +(define make-rep) +(define push-rep) +(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*) + (let ((object + (let ((scode + (let ((s-expression (read))) + (record-in-history! (rep-state-reader-history state) + s-expression) + (syntax s-expression *rep-current-syntax-table*)))) + (with-new-history + (lambda () + (scode-eval scode *rep-current-environment*)))))) + (record-in-history! (rep-state-printer-history state) object) + (rep-value-hook object)) + state) + +;;; History Manipulation + +(define (make-history size) + (let ((list (make-list size '()))) + (append! list list) + (vector history-tag size list))) + +(define history-tag + '(REP-HISTORY)) + +(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 (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 ((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 rep-state-tag + "REP State") + +(define (make-rep-state reader-history printer-history) + (vector rep-state-tag reader-history printer-history)) + +(define (rep-state? object) + (and (vector? object) + (not (zero? (vector-length object))) + (eq? (vector-ref object 0) rep-state-tag))) + +(define rep-state-reader-history vector-second) +(define rep-state-printer-history vector-third) + +(set! reader-history + (history-reader rep-state-reader-history 'READER-HISTORY)) + +(set! printer-history + (history-reader rep-state-printer-history 'PRINTER-HISTORY)) + +) \ No newline at end of file diff --git a/v7/src/runtime/scan.scm b/v7/src/runtime/scan.scm new file mode 100644 index 000000000..fced825d9 --- /dev/null +++ b/v7/src/runtime/scan.scm @@ -0,0 +1,210 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1985 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of +;;; this software shall duly acknowledge such use, in accordance +;;; with the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; + +;;;; Definition Scanner + +(declare (usual-integrations)) + +;;; Scanning of internal definitions is necessary to reduce the number +;;; of "real auxiliary" variables in the system. These bindings are +;;; maintained in alists by the microcode, and cannot be compiled as +;;; ordinary formals can. + +;;; The following support is provided. SCAN-DEFINES will find the +;;; top-level definitions in a sequence, and returns an ordered list +;;; of those names, and a new sequence in which those definitions are +;;; replaced by assignments. UNSCAN-DEFINES will invert that. + +;;; The Open Block abstraction can be used to store scanned +;;; definitions in code, which is extremely useful for code analysis +;;; and transformation. The supplied procedures, MAKE-OPEN-BLOCK and +;;; 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) + +(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))) + +;;;; Scanning + +;;; This depends on the fact that the lambda abstraction will preserve +;;; the order of the auxiliaries. That is, giving MAKE-LAMBDA a list +;;; 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-loop expression receiver) + (cond ((primitive-type? sequence-2-type expression) + (scan-loop (&pair-cdr expression) + (scan-loop (&pair-car expression) + receiver))) + ((primitive-type? sequence-3-type expression) + (let ((first (&triple-first expression))) + (if (and (vector? first) + (not (zero? (vector-length first))) + (eq? (vector-ref first 0) open-block-tag)) + (lambda (names declarations body) + (receiver (append (vector-ref first 1) names) + (append (vector-ref first 2) declarations) + (cons-sequence (&triple-third expression) + body))) + (scan-loop (&triple-third expression) + (scan-loop (&triple-second expression) + (scan-loop first + receiver)))))) + ((definition? expression) + (definition-components expression + (lambda (name value) + (lambda (names declarations body) + (receiver (cons name names) + declarations + (cons-sequence (make-assignment name value) + body)))))) + ((block-declaration? expression) + (lambda (names declarations body) + (receiver names + (append (block-declaration-text expression) + declarations) + body))) + (else + (lambda (names declarations body) + (receiver names + 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) + (unscan-loop names body + (lambda (names* body*) + (if (not (null? names*)) + (error "Extraneous auxiliaries -- get a wizard" + 'UNSCAN-DEFINES + names*)) + (if (null? declarations) + body* + (&typed-pair-cons sequence-2-type + (make-block-declaration declarations) + body*)))))) + +(define (unscan-loop names body receiver) + (cond ((null? names) (receiver '() body)) + ((assignment? body) + (assignment-components body + (lambda (name value) + (if (eq? name (car names)) + (receiver (cdr names) + (make-definition name value)) + (receiver names + body))))) + ((primitive-type? sequence-2-type body) + (unscan-loop names (&pair-car body) + (lambda (names* body*) + (unscan-loop names* (&pair-cdr body) + (lambda (names** body**) + (receiver names** + (&typed-pair-cons sequence-2-type + body* + body**))))))) + ((primitive-type? sequence-3-type body) + (unscan-loop names (&triple-first body) + (lambda (names* body*) + (unscan-loop names* (&triple-second body) + (lambda (names** body**) + (unscan-loop names** (&triple-third body) + (lambda (names*** body***) + (receiver names*** + (&typed-triple-cons sequence-3-type + body* + body** + body***))))))))) + (else + (receiver names + body)))) + +;;;; Open Block + +(set! make-open-block +(named-lambda (make-open-block names declarations body) + (if (and (null? names) + (null? declarations)) + body + (&typed-triple-cons + sequence-3-type + (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) + (vector? (&triple-first object)) + (eq? (vector-ref (&triple-first object) 0) open-block-tag)))) + +(set! open-block-components +(named-lambda (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 diff --git a/v7/src/runtime/scode.scm b/v7/src/runtime/scode.scm new file mode 100644 index 000000000..fa67d39cb --- /dev/null +++ b/v7/src/runtime/scode.scm @@ -0,0 +1,350 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1985 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of +;;; this software shall duly acknowledge such use, in accordance +;;; with the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; + +;;;; SCODE Grab Bag + +(declare (usual-integrations)) + +;;;; Constants + +(define scode-constant? + (let ((type-vector (make-vector number-of-microcode-types #!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))) + +;;;; 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) + +;;;; SYMBOL + +(define symbol?) +(define string->uninterned-symbol) +(let () + +(define utype + (microcode-type 'UNINTERNED-SYMBOL)) + +(define itype + (microcode-type 'INTERNED-SYMBOL)) + +(set! symbol? +(named-lambda (symbol? object) + (or (primitive-type? itype object) + (primitive-type? utype object)))) + +(set! string->uninterned-symbol +(named-lambda (string->uninterned-symbol string) + (&typed-pair-cons utype + string + (make-unbound-object)))) + +) + +(define string->symbol + (make-primitive-procedure 'STRING->SYMBOL)) + +(define (symbol->string symbol) + (make-object-safe (&pair-car symbol))) + +(define make-symbol string->uninterned-symbol) +(define make-interned-symbol string->symbol) +(define symbol-print-name symbol->string) + +(define (symbol-global-value symbol) + (make-object-safe (&pair-cdr symbol))) + +(define (set-symbol-global-value! symbol value) + (&pair-set-cdr! symbol + ((if (object-dangerous? (&pair-cdr symbol)) + make-object-dangerous + make-object-safe) + value))) + +(define (make-named-tag name) + (string->symbol (string-append "#[" name "]"))) + +;;;; VARIABLE + +(define variable?) +(define make-variable) + +(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))))) + +(define variable-name system-hunk3-cxr0) + +(define (variable-components variable receiver) + (receiver (variable-name variable))) + +;;;; DEFINITION + +(define definition?) +(define make-definition) + +(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 (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 assignment?) +(define make-assignment-from-variable) + +(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 (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 value) + (make-assignment-from-variable (make-variable name) value)) + +(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))) + +;;;; COMMENT + +(define comment?) +(define make-comment) + +(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 (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)))) + +(define (declaration-text tagged-comment) + (cdr (comment-text tagged-comment))) + +(define (set-declaration-text! tagged-comment new-text) + (set-cdr! (comment-text tagged-comment) new-text)) + +(define declaration-expression + comment-expression) + +(define set-declaration-expression! + set-comment-expression!) + +(define make-block-declaration) +(define block-declaration?) +(let () + +(define tag + (make-named-tag "Block Declaration")) + +(set! make-block-declaration +(named-lambda (make-block-declaration text) + (cons tag text))) + +(set! block-declaration? +(named-lambda (block-declaration? object) + (and (pair? object) (eq? (car object) tag)))) + +) + +(define block-declaration-text + cdr) + +;;;; THE-ENVIRONMENT + +(define the-environment?) +(define make-the-environment) + +(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)))) + +;;;; ACCESS + +(define access?) +(define make-access) + +(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 (access-components access receiver) + (receiver (access-environment access) + (access-name access))) + +(define access-environment &pair-car) +(define access-name system-pair-cdr) + +;;;; IN-PACKAGE + +(define in-package?) +(define make-in-package) + +(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 (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 + +(define delay?) +(define make-delay) + +(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 delay-expression &singleton-element) + +(define (delay-components delay receiver) + (receiver (delay-expression delay))) + (receiver (delay-expression delay))) \ No newline at end of file diff --git a/v7/src/runtime/scomb.scm b/v7/src/runtime/scomb.scm new file mode 100644 index 000000000..bc1ec8f9c --- /dev/null +++ b/v7/src/runtime/scomb.scm @@ -0,0 +1,367 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1985 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of +;;; this software shall duly acknowledge such use, in accordance +;;; with the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; + +;;;; SCODE Combinator Abstractions + +(declare (usual-integrations)) + +;;;; SEQUENCE + +(define sequence?) +(define make-sequence) +(define sequence-actions) +(let () + +(define type-2 + (microcode-type 'SEQUENCE-2)) + +(define type-3 + (microcode-type 'SEQUENCE-3)) + +(set! sequence? +(named-lambda (sequence? object) + (or (primitive-type? type-2 object) + (primitive-type? type-3 object)))) + +(set! make-sequence +(lambda (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 + (car actions) + (cadr actions) + (actions->sequence (cddr actions)))))) + +(set! sequence-actions +(named-lambda (sequence-actions sequence) + (cond ((primitive-type? type-2 sequence) + (append! (sequence-actions (&pair-car sequence)) + (sequence-actions (&pair-cdr sequence)))) + ((primitive-type? type-3 sequence) + (append! (sequence-actions (&triple-first sequence)) + (sequence-actions (&triple-second sequence)) + (sequence-actions (&triple-third sequence)))) + (else + (list sequence))))) + +) + +(define (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)))) + +) + +(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 () + +(define type + (microcode-type 'DISJUNCTION)) + +(set! disjunction? +(named-lambda (disjunction? object) + (primitive-type? type 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 (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)) + (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 '())))) + ((null? (cdr operands)) + (&typed-pair-cons + (if (and (primitive-procedure? operator) + (= (primitive-procedure-arity operator) 1)) + p-type-1 + type-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) + operator + (car operands) + (cadr operands))) + (else + (&typed-vector-cons + (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 + CAR CDR VECTOR-LENGTH VECTOR-REF + &+ &- &* &/ 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))))) + +(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))))) + +) + +;;;; 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 + (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?-components unassigned? receiver) + (receiver (unassigned?-name unassigned?))) + +(define unbound?-name unassigned?-name) +(define unbound?-components unassigned?-components) +(define unbound?-components unassigned?-components) \ No newline at end of file diff --git a/v7/src/runtime/sdata.scm b/v7/src/runtime/sdata.scm new file mode 100644 index 000000000..4a4da77d9 --- /dev/null +++ b/v7/src/runtime/sdata.scm @@ -0,0 +1,226 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1984 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of +;;; this software shall duly acknowledge such use, in accordance +;;; with the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; + +;;;; Abstract Data Field + +(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)) + (&unassigned-object '(&UNASSIGNED-OBJECT)) + (&unassigned-type (microcode-type 'UNASSIGNED)) + (hunk3-cons (make-primitive-procedure 'HUNK3-CONS))) + + (define (map-unassigned object) + (if (eq? object &unbound-object) + (primitive-set-type &unassigned-type 1) + (if (eq? object &unassigned-object) + (primitive-set-type &unassigned-type 0) + object))) + + (define (map-from-unassigned datum) + (if (eq? datum 0) ;**** 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) + #!NULL))) + +(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)))) + +(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 diff --git a/v7/src/runtime/sfile.scm b/v7/src/runtime/sfile.scm new file mode 100644 index 000000000..ddee383ca --- /dev/null +++ b/v7/src/runtime/sfile.scm @@ -0,0 +1,65 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1985 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of +;;; this software shall duly acknowledge such use, in accordance +;;; with the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; + +;;;; Simple File Operations + +(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))))) + +(define file-exists? + (let ((p-file-exists? (make-primitive-procedure 'FILE-EXISTS?))) + (named-lambda (file-exists? name) + (let ((pathname (->pathname name))) + (if (eq? 'NEWEST (pathname-version pathname)) + (pathname-newest pathname) + (p-file-exists? diff --git a/v7/src/runtime/stream.scm b/v7/src/runtime/stream.scm new file mode 100644 index 000000000..1b32c1d2d --- /dev/null +++ b/v7/src/runtime/stream.scm @@ -0,0 +1,181 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1985 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of +;;; this software shall duly acknowledge such use, in accordance +;;; with the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; + +;;;; Stream Utilities + +(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 + +(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)))))) + +(define (scale-stream c s) + (map-stream (lambda (x) (* c x)) s)) + +(define (enumerate-interval n1 n2) + (if (> n1 n2) + the-empty-stream + (cons-stream n1 (enumerate-interval (1+ n1) n2)))) + +(define (integers-from n) + (cons-stream n (integers-from (1+ n)))) + +(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))))))))) + +;;;; 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))))))) + +;;;; 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) diff --git a/v7/src/runtime/string.scm b/v7/src/runtime/string.scm new file mode 100644 index 000000000..aa4d8cc6e --- /dev/null +++ b/v7/src/runtime/string.scm @@ -0,0 +1,421 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of +;;; this software shall duly acknowledge such use, in accordance +;;; with the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; + +;;;; Character String Operations + +(declare (usual-integrations)) + +;;;; Primitives + +(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 + 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) + (vector-8b-find-next-char string start end (char->ascii char))) + +(define (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) + (vector-8b-find-next-char-ci string start end (char->ascii char))) + +(define (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. + +(define (substring-ci? string1 string2) + (substring? string1 string2) + (substring-ci=? string1 string2) + (not (substring=? string1 string2) + (not (substring-cistring chars) + (let ((result (string-allocate (length chars)))) + (define (loop index chars) + (if (null? chars) + result + (begin (string-set! result index (car chars)) + (loop (1+ index) (cdr chars))))) + (loop 0 chars))) + +(define (char->string . chars) + (list->string chars)) + +(define (string->list string) + (substring->list string 0 (string-length string))) + +(define (substring->list string start end) + (define (loop index) + (if (= index end) + '() + (cons (string-ref string index) + (loop (1+ index))))) + (loop start)) + +(define (string-copy string) + (let ((size (string-length string))) + (let ((result (string-allocate size))) + (substring-move-right! string 0 size result 0) + result))) + +(define (string-append . strings) + (define (count strings) + (if (null? strings) + 0 + (+ (string-length (car strings)) + (count (cdr strings))))) + + (let ((result (string-allocate (count strings)))) + (define (move strings index) + (if (null? strings) + result + (let ((size (string-length (car strings)))) + (substring-move-right! (car strings) 0 size result index) + (move (cdr strings) (+ index size))))) + + (move strings 0))) + +;;;; Case + +(define (string-upper-case? string) + (substring-upper-case? string 0 (string-length string))) + +(define (substring-upper-case? string start end) + (define (find-upper start) + (and (not (= start end)) + ((if (char-upper-case? (string-ref string start)) + search-rest + find-upper) + (1+ start)))) + (define (search-rest start) + (or (= start end) + (and (not (char-lower-case? (string-ref string start))) + (search-rest (1+ start))))) + (find-upper start)) + +(define (string-upcase string) + (let ((string (string-copy string))) + (string-upcase! string) + string)) + +(define (string-upcase! string) + (substring-upcase! string 0 (string-length string))) + +(define (string-lower-case? string) + (substring-lower-case? string 0 (string-length string))) + +(define (substring-lower-case? string start end) + (define (find-lower start) + (and (not (= start end)) + ((if (char-lower-case? (string-ref string start)) + search-rest + find-lower) + (1+ start)))) + (define (search-rest start) + (or (= start end) + (and (not (char-upper-case? (string-ref string start))) + (search-rest (1+ start))))) + (find-lower start)) + +(define (string-downcase string) + (let ((string (string-copy string))) + (string-downcase! string) + string)) + +(define (string-downcase! string) + (substring-downcase! string 0 (string-length string))) + +(define (string-capitalized? string) + (substring-capitalized? string 0 (string-length string))) + +(define (substring-capitalized? string start end) + (and (not (= start end)) + (char-upper-case? (string-ref string 0)) + (substring-lower-case? string (1+ start) end))) + +(define (string-capitalize string) + (let ((string (string-copy string))) + (string-capitalize! string) + string)) + +(define (string-capitalize! string) + (let ((length (string-length string))) + (if (zero? length) (error "String must have non-zero length" string)) + (substring-upcase! string 0 1) + (substring-downcase! string 1 length))) + +;;;; Replace + +(define (string-replace string char1 char2) + (let ((string (string-copy string))) + (string-replace! string char1 char2) + string)) + +(define (substring-replace string start end char1 char2) + (let ((string (string-copy string))) + (substring-replace! string start end char1 char2) + string)) + +(define (string-replace! string char1 char2) + (substring-replace! string 0 (string-length string) char1 char2)) + +(define (substring-replace! string start end char1 char2) + (define (loop start) + (let ((index (substring-find-next-char string start end char1))) + (if index + (begin (string-set! string index char2) + (loop (1+ index)))))) + (loop start)) + +;;;; Compare + +(define (string-compare string1 string2 if= if< if>) + (let ((size1 (string-length string1)) + (size2 (string-length string2))) + (let ((match (substring-match-forward string1 0 size1 string2 0 size2))) + ((if (= match size1) + (if (= match size2) if= if<) + (if (= match size2) if> + (if (char))))))) + +(define (string-prefix? string1 string2) + (substring-prefix? string1 0 (string-length string1) + 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))) + +(define (string-compare-ci string1 string2 if= if< if>) + (let ((size1 (string-length string1)) + (size2 (string-length string2))) + (let ((match (substring-match-forward-ci string1 0 size1 string2 0 size2))) + ((if (= match size1) + (if (= match size2) if= if<) + (if (= match size2) if> + (if (char-ci))))))) + +(define (string-prefix-ci? string1 string2) + (substring-prefix-ci? string1 0 (string-length string1) + 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))) + +;;;; Trim/Pad + +(define (string-trim-left string #!optional char-set) + (if (unassigned? 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) + "" + (substring string index length)))) + +(define (string-trim-right string #!optional char-set) + (if (unassigned? 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)) + (let ((index (string-find-next-char-in-set string char-set))) + (if (not index) + "" + (substring string index + (1+ (string-find-previous-char-in-set string char-set)))))) + +(define (string-pad-right string n #!optional char) + (if (unassigned? char) (set! char #\Space)) + (let ((length (string-length string))) + (if (= length n) + string + (let ((result (string-allocate n))) + (if (> length n) + (substring-move-right! string 0 n result 0) + (begin (substring-move-right! string 0 length result 0) + (substring-fill! result length n char))) + result)))) + +(define (string-pad-left string n #!optional char) + (if (unassigned? char) (set! char #\Space)) + (let ((length (string-length string))) + (if (= length n) + string + (let ((result (string-allocate n)) + (i (- n length))) + (if (negative? i) + (substring-move-right! string 0 n result 0) + (begin (substring-fill! result 0 i char) + (substring-move-right! string 0 length result i))) diff --git a/v7/src/runtime/syntax.scm b/v7/src/runtime/syntax.scm new file mode 100644 index 000000000..433575b9e --- /dev/null +++ b/v7/src/runtime/syntax.scm @@ -0,0 +1,1013 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of +;;; this software shall duly acknowledge such use, in accordance +;;; with the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; + +;;;; SYNTAX: S-Expressions -> SCODE + +(declare (usual-integrations)) + +(define lambda-tag:unnamed + (make-named-tag "UNNAMED-PROCEDURE")) + +(define *fluid-let-type* 'shallow) + +(define lambda-tag:shallow-fluid-let + (make-named-tag "SHALLOW-FLUID-LET-PROCEDURE")) + +(define lambda-tag:deep-fluid-let + (make-named-tag "DEEP-FLUID-LET-PROCEDURE")) + +(define lambda-tag:common-lisp-fluid-let + (make-named-tag "COMMON-LISP-FLUID-LET-PROCEDURE")) + +(define lambda-tag:let + (make-named-tag "LET-PROCEDURE")) + +(define lambda-tag:make-environment + (make-named-tag "MAKE-ENVIRONMENT-PROCEDURE")) + +(define lambda-tag:make-package + (make-named-tag "MAKE-PACKAGE-PROCEDURE")) + +(define syntax) +(define syntax*) +(define macro-spreader) + +(define enable-scan-defines!) +(define with-scan-defines-enabled) +(define disable-scan-defines!) +(define with-scan-defines-disabled) + +;; Enable shallow vs fluid binding for FLUID-LET +(define shallow-fluid-let!) +(define deep-fluid-let!) +(define common-lisp-fluid-let!) + +(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)) + +;;;; Dispatch Point + +(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)) + (make-combination (syntax-expression (car expression)) + (syntax-expressions (cdr expression)))))) + ((symbol? expression) + (make-variable expression)) + (else + expression))) + +(define (syntax-expressions expressions) + (if (null? expressions) + '() + (cons (syntax-expression (car expressions)) + (syntax-expressions (cdr expressions))))) + +(define ((spread-arguments kernel) expression) + (apply kernel (cdr expression))) + +(define saved-keyword + (make-interned-symbol "")) + +(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 (syntax-sequence subexpressions) + (if (null? subexpressions) + (syntax-error "No subforms in sequence") + (make-sequence (syntax-sequentially subexpressions)))) + +(define (syntax-sequentially expressions) + (if (null? expressions) + '() + ;; force eval order. + (let ((first (syntax-expression (car expressions)))) + (cons first + (syntax-sequentially (cdr expressions)))))) + +(define (syntax-bindings bindings receiver) + (cond ((null? bindings) + (receiver '() '())) + ((and (pair? (car bindings)) + (symbol? (caar bindings))) + (syntax-bindings (cdr bindings) + (lambda (names values) + (receiver (cons (caar bindings) names) + (cons (expand-binding-value (cdar bindings)) values))))) + (else + (syntax-error "Badly-formed binding" (car bindings))))) + +;;;; Expanders + +(define (expand-access chain cont) + (if (symbol? (car chain)) + (cont (if (null? (cddr chain)) + (syntax-expression (cadr chain)) + (expand-access (cdr chain) make-access)) + (car chain)) + (syntax-error "Non-symbolic variable" (car chain)))) + +(define (expand-binding-value rest) + (cond ((null? rest) unassigned-object) + ((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-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))) + +(define (syntax-lambda-body body) + (syntax-sequence + (if (and (not (null? body)) + (not (null? (cdr body))) + (string? (car body))) + (cdr body) ;discard documentation string. + body))) + +;;;; Quasiquote + +(define quasiquote-keyword 'QUASIQUOTE) +(define unquote-keyword 'UNQUOTE) +(define unquote-splicing-keyword 'UNQUOTE-SPLICING) + +(define expand-quasiquote) +(let () + +(define (expand expression) + (if (pair? expression) + (cond ((eq? (car expression) unquote-keyword) + (cadr expression)) + ((eq? (car expression) quasiquote-keyword) + (expand (expand (cadr expression)))) + ((eq? (car expression) unquote-splicing-keyword) + (error "EXPAND-QUASIQUOTE: Misplaced ,@" expression)) + ((and (pair? (car expression)) + (eq? (caar expression) unquote-splicing-keyword)) + (expand-spread (cadr (car expression)) + (expand (cdr expression)))) + (else + (expand-pair (expand (car expression)) + (expand (cdr expression))))) + (list 'QUOTE expression))) + +(define (expand-pair a d) + (cond ((pair? d) + (cond ((eq? (car d) 'QUOTE) + (cond ((and (pair? a) (eq? (car a) 'QUOTE)) + (list 'QUOTE (cons (cadr a) (cadr d)))) + ((list? (cadr d)) + (cons* 'LIST + a + (map (lambda (element) + (list 'QUOTE element)) + (cadr d)))) + (else + (list 'CONS a d)))) + ((eq? (car d) 'CONS) + (cons* 'CONS* a (cdr d))) + ((memq (car d) '(LIST CONS*)) + (cons* (car d) a (cdr d))) + (else + (list 'CONS a d)))) + (else + (list 'CONS a d)))) + +(define (expand-spread a d) + (cond ((pair? d) + (cond ((eq? (car d) 'QUOTE) + (cond ((and (pair? a) (eq? (car a) 'QUOTE)) + (list 'QUOTE (append (cadr a) (cadr d)))) + ((null? (cadr d)) + a) + (else + (list 'APPEND a d)))) + ((eq? (car d) 'APPEND) + (cons* (car d) a (cdr d))) + (else + (list 'APPEND a d)))) + (else + (list 'APPEND a d)))) + +(set! expand-quasiquote +(named-lambda (expand-quasiquote expression) + (syntax-expression (expand expression)))) + +) + +;;;; 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) + ((syntax-extended-assignment 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)))))) + +;;;; Conditionals + +(define syntax-IF-form + (spread-arguments + (lambda (predicate consequent . rest) + (make-conditional (syntax-expression predicate) + (syntax-expression consequent) + (cond ((null? rest) + false) + ((null? (cdr rest)) + (syntax-expression (car rest))) + (else + (syntax-error "Too many forms" (cdr rest)))))))) + +(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? rest) + (if (cdr clause) + (make-conjunction (syntax-expression (car clause)) + (syntax-sequence (cdr clause))) + (syntax-expression (car clause)))) + ((null? (cdr clause)) + (make-disjunction (syntax-expression (car clause)) + (process-cond-clauses (car rest) + (cdr rest)))) + ((and (pair? (cdr clause)) + (eq? (cadr clause) '=>)) + (syntax-expression + `((ACCESS COND-=>-HELPER SYNTAXER-PACKAGE '()) + ,(car clause) + (DELAY ,@(cddr clause)) + (DELAY (COND ,@rest))))) + (else + (make-conditional (syntax-expression (car clause)) + (syntax-sequence (cdr clause)) + (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 + ((force thunk2) form1-result) + (force thunk3))) + +(define (make-funcall name . args) + (make-combination (make-variable name) args)) + +(define syntax-CONJUNCTION-form + (spread-arguments + (lambda forms + (expand-conjunction forms)))) + +(define syntax-DISJUNCTION-form + (spread-arguments + (lambda forms + (expand-disjunction forms)))) + +;;;; 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) + (make-named-lambda (car pattern) (cdr pattern) body)))))) + +(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-combination (make-named-lambda name-or-pattern names + (syntax-sequence rest)) + 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-PACKAGE-form + (spread-arguments + (lambda (name bindings . body) + (if (symbol? name) + (syntax-bindings bindings + (lambda (names values) + (make-closed-block + lambda-tag:make-package + (cons name names) + (cons unassigned-object values) + (make-sequence* (make-assignment name the-environment-object) + (if (null? body) + the-environment-object + (make-sequence* (syntax-sequence body) + the-environment-object)))))) + (syntax-error "Bad package name" name))))) + +(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)))))) + +;;;; 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* (expand-access '(MACRO-SPREADER '()) make-access) + (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-variable procedure-name) + (syntax-expression message) + (cond ((null? rest) + ;; Slightly crockish, but prevents + ;; hidden variable reference. + (make-access (make-null) + '*THE-NON-PRINTING-OBJECT*)) + ((null? (cdr rest)) + (syntax-expression (car rest))) + (else + (make-combination + (make-access (make-null) '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)) + +;;;; FLUID-LET + +(define syntax-FLUID-LET-form-shallow + (spread-arguments + (lambda (bindings . body) + (define (syntax-fluid-bindings bindings receiver) + (if (null? bindings) + (receiver '() '() '() '()) + (syntax-fluid-bindings + (cdr bindings) + (syntax-fluid-binding (car bindings) receiver)))) + + (define (syntax-fluid-binding binding receiver) + (if (pair? binding) + (let ((transfer + (let ((assignment (syntax-extended-assignment (car binding)))) + (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"))) + (lambda (names values transfers-in transfers-out) + (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 list" binding))) + + (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 (make-fluid-let-like prim procedure-tag) + (define (syntax-fluid-bindings bindings receiver) + (if (null? bindings) + (receiver '() '()) + (syntax-fluid-bindings + (cdr bindings) + (syntax-fluid-binding (car bindings) receiver)))) + + (define (syntax-fluid-binding binding receiver) + (if (pair? binding) + (let ((value (expand-binding-value (cdr binding))) + (var-or-access (syntax-fluid-let-name (car binding)))) + (lambda (names values) + (receiver (cons var-or-access names) + (cons value values)))) + (syntax-error "Binding not a list" binding))) + + (define (syntax-fluid-let-name name) + (let ((syntaxed (syntax-expression name))) + (if (or (variable? syntaxed) (access? syntaxed)) + syntaxed + (syntax-error "binding name illegal")))) + + (let ((with-saved-fluid-bindings + (make-primitive-procedure 'with-saved-fluid-bindings))) + (spread-arguments + (lambda (bindings . body) + (syntax-fluid-bindings bindings + (lambda (names values) + (define (accum-assignments names values) + (mapcar make-fluid-assign names values)) + (define (make-fluid-assign name-or-access value) + (cond ((variable? name-or-access) + (make-combination + prim + `(,the-environment-object + ,(make-quotation name-or-access) + ,value))) + ((access? name-or-access) + (access-components + name-or-access + (lambda (env name) + (make-combination + prim + `(,env ,name ,value))))) + (else + (syntax-error + "Target of FLUID-LET not a symbol or ACCESS form" + name-or-access)))) + (make-combination + (internal-make-lambda procedure-tag '() '() '() + (make-combination + with-saved-fluid-bindings + (list + (make-thunk + (make-sequence + (append (accum-assignments names values) + (list (syntax-sequence body)))))))) + '()))))))) + +(define syntax-FLUID-LET-form-deep + ;; (FLUID-LET . ) => + ;; (WITH-SAVED-FLUID-BINDINGS + ;; (lambda () + ;; (ADD-FLUID! (the-environment) ) + ;; ... + ;; )) + (let ((add-fluid-binding! + (make-primitive-procedure 'add-fluid-binding!))) + (make-fluid-let-like add-fluid-binding! lambda-tag:deep-fluid-let))) + +(define syntax-FLUID-LET-form-common-lisp + ;; This -- groan -- is for Common Lisp support + ;; (FLUID-BIND . ) => + ;; (WITH-SAVED-FLUID-BINDINGS + ;; (lambda () + ;; (ADD-FLUID! (the-environment) ) + ;; ... + ;; )) + (let ((make-fluid-binding! + (make-primitive-procedure 'make-fluid-binding!))) + (make-fluid-let-like make-fluid-binding! lambda-tag:common-lisp-fluid-let))) + +;;;; Extended Assignment Syntax + +(define (syntax-extended-assignment expression) + (invert-expression (syntax-expression expression))) + +(define (invert-expression target) + (cond ((variable? target) + (invert-variable (variable-name target))) + ((access? target) + (access-components target invert-access)) + (else + (syntax-error "Bad target" target)))) + +(define ((invert-variable name) value) + (make-assignment name value)) + +(define ((invert-access environment name) value) + (make-combination* lexical-assignment environment name value)) + +;;;; Declarations + +;;; All declarations are syntactically checked; the resulting +;;; 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-form + (spread-arguments + (lambda declarations + (make-block-declaration (map process-declaration declarations))))) + +(define (process-declarations declarations) + (if (list? declarations) + (map process-declaration declarations) + (syntax-error "Illegal declaration list" declarations))) + +(define (process-declaration declaration) + (cond ((symbol? declaration) + (list declaration)) + ((and (list? declaration) + (not (null? declaration)) + (symbol? (car declaration))) + declaration) + (else + (syntax-error "Illegal declaration" declaration)))) + +;;;; 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-thunk body) + (make-lambda '() body)) + +(define (make-lambda pattern body) + (make-named-lambda lambda-tag:unnamed pattern body)) + +(define (make-named-lambda name pattern body) + (if (not (symbol? name)) + (syntax-error "Name of lambda expression must be a symbol" name)) + (parse-lambda-list pattern + (lambda (required optional rest) + (internal-make-lambda name required optional rest body)))) + +(define (make-closed-block tag names values body) + (make-combination (internal-make-lambda tag names '() '() body) + values)) + +;;;; Lambda List Parser + +(define (parse-lambda-list lambda-list receiver) + (let ((required (list '())) + (optional (list '()))) + (define (parse-parameters cell) + (define (loop 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)) + (if (and (pair? (cdr pattern)) (null? (cddr pattern))) + (cond ((symbol? (cadr pattern)) (finish (cadr pattern))) + ((and (pair? (cadr pattern)) + (symbol? (caadr pattern))) + (finish (caadr pattern))) + (else (bad-lambda-list (cdr pattern)))) + (bad-lambda-list (cdr pattern)))) + ((eq? (car pattern) (access lambda-optional-tag lambda-package)) + (if (eq? cell required) + ((parse-parameters optional) (cdr pattern)) + (bad-lambda-list pattern))) + ((symbol? (car pattern)) + (set-car! cell (cons (car pattern) (car cell))) + (loop (cdr pattern))) + ((and (pair? (car pattern)) (symbol? (caar pattern))) + (set-car! cell (cons (caar pattern) (car cell))) + (loop (cdr pattern))) + (else (bad-lambda-list pattern)))) + loop) + + (define (finish rest) + (receiver (reverse! (car required)) + (reverse! (car optional)) + rest)) + + (define (bad-lambda-list pattern) + (syntax-error "Illegally-formed lambda-list" pattern)) + + ((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) + make-open-block)) + +(define (no-scan-make-lambda name required optional rest body) + (external-make-lambda name required optional rest '() '() body)) + +(define scanning-make-lambda + make-lambda*) + +(define internal-make-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)) + (add-syntax! 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 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) + (MAKE-PACKAGE . ,syntax-MAKE-PACKAGE-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 +) + +;;; Edwin Variables: +;;; Scheme Environment: syntaxer-package +;;; End: +) \ No newline at end of file diff --git a/v7/src/runtime/sysclk.scm b/v7/src/runtime/sysclk.scm new file mode 100644 index 000000000..1e6f8901a --- /dev/null +++ b/v7/src/runtime/sysclk.scm @@ -0,0 +1,91 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1984 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of +;;; this software shall duly acknowledge such use, in accordance +;;; with the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; + +;;;; System Clock + +(declare (usual-integrations)) + +(define system-clock) +(define runtime) +(define measure-interval) +(define wait-interval) + +(let ((primitive-clock (make-primitive-procedure 'SYSTEM-CLOCK)) + (offset-time) + (non-runtime)) + +(define (clock) + (- (primitive-clock) offset-time)) + +(define (ticks->seconds ticks) + (/ ticks 100)) + +(define (seconds->ticks seconds) + (* seconds 100)) + +(define (reset-system-clock!) + (set! offset-time (primitive-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. diff --git a/v7/src/runtime/system.scm b/v7/src/runtime/system.scm new file mode 100644 index 000000000..bb5df299e --- /dev/null +++ b/v7/src/runtime/system.scm @@ -0,0 +1,255 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of +;;; this software shall duly acknowledge such use, in accordance +;;; with the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; + +;;;; Systems + +(declare (usual-integrations)) + +;;; (DISK-SAVE filename #!optional identify) +;;; (DUMP-WORLD filename #!optional identify) +;;; Saves a world image in FILENAME. IDENTIFY has the following meaning: +;;; +;;; [] Not supplied => ^G on restore (normal for saving band). +;;; [] String => New world ID message, and ^G on restore. +;;; [] Otherwise => Returns normally (very useful for saving bugs!). +;;; +;;; The image saved by DISK-SAVE does not include the "microcode", the +;;; one saved by DUMP-WORLD does, and is an executable file. + +(define disk-save) +(define dump-world) +(define event:after-restore) +(define full-quit) +(define identify-world) +(define identify-system) +(define add-system!) +(define add-secondary-gc-daemon!) +(let () + +(define world-identification "Scheme") +(define known-systems '()) +(define secondary-gc-daemons '()) +(define date-world-saved) +(define time-world-saved) + +(define (restart-world) + (screen-clear) + (abort->top-level identify-world)) + +(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) + *the-non-printing-object*) + (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 + *the-non-printing-object*))))))) + +(set! disk-save + (setup-image save-world)) + +(set! dump-world + (setup-image + (let ((primitive (make-primitive-procedure 'DUMP-WORLD #T))) + (lambda (filename after-dumping after-restoring) + (let ((ie (set-interrupt-enables! INTERRUPT-MASK-NONE))) + ((if (primitive filename) + after-restoring + after-dumping) + ie)))))) + +(set! event:after-restore + (make-event-distributor)) + +(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))) + +(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))))) + +) + +;;; Load the given system, which must have the following variables +;;; defined: +;;; +;;; :FILES which will be assigned the list of filenames actually +;;; loaded. +;;; +;;; :FILES-LISTS which 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 () + +(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) + (fasload-files head + (lambda (eval-list pure-list constant-list) + (if (not (null? pure-list)) + (begin (newline) (write-string "Purify") + (purify (list->vector pure-list) #!TRUE))) + (if (not (null? constant-list)) + (begin (newline) (write-string "Constantify") + (purify (list->vector constant-list) #!FALSE))) + (append! eval-list (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) + (split-list (cdr list) (-1+ n) + (lambda (head tail) + (receiver (cons (car list) head) tail))))) + +(define (fasload-files pathnames receiver) + (if (null? pathnames) + (receiver '() '() '()) + (fasload-file (car pathnames) + (lambda (scode) + (fasload-files (cdr pathnames) + (lambda (eval-list pure-list constant-list) + (receiver (cons scode eval-list) + (cons scode pure-list) + constant-list)))) + (lambda (scode) + (fasload-files (cdr pathnames) + (lambda (eval-list pure-list constant-list) + (receiver (cons scode eval-list) + pure-list + (cons scode constant-list)))))))) + +(define (fasload-file pathname if-pure if-not-pure) + (let ((type (pathname-type pathname))) + (cond ((string-ci=? "bin" type) (if-pure (fasload pathname))) + ((string-ci=? "com" type) (if-not-pure (fasload pathname))) + (else (error "Unknown file type" type))))) + +(define (format-files-list files-lists compiled?) + (mapcan (lambda (files-list) + (map (lambda (filename) + (let ((pathname (->pathname filename))) + (cons (if compiled? + pathname + (pathname-new-type pathname "bin")) + (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 diff --git a/v7/src/runtime/unpars.scm b/v7/src/runtime/unpars.scm new file mode 100644 index 000000000..784f47edd --- /dev/null +++ b/v7/src/runtime/unpars.scm @@ -0,0 +1,289 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of this +;;; software shall duly acknowledge such use, in accordance with +;;; the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; + +;;;; Unparser + +(declare (usual-integrations)) + +;;; Control Variables +(define *unparser-radix* #d10) +(define *unparser-list-breadth-limit* false) +(define *unparser-list-depth-limit* false) + +(define (unparse-with-brackets thunk) + (write-string "#[") + (thunk) + (write-char #\])) + +(define unparser-package + (make-environment + +(define *unparse-char) +(define *unparse-string) +(define *unparser-list-depth*) +(define *slashify*) + +(define (unparse-object object port #!optional slashify) + (if (unassigned? slashify) (set! slashify true)) + (fluid-let ((*unparse-char (access :write-char port)) + (*unparse-string (access :write-string port)) + (*unparser-list-depth* 0) + (*slashify* slashify)) + (*unparse-object object))) + +(define (*unparse-object-or-future object) + (if (future? object) + (unparse-with-brackets + (lambda () + (*unparse-string "FUTURE ") + (unparse-datum object))) + (*unparse-object object))) + +(define (*unparse-object object) + ((vector-ref dispatch-vector (primitive-type object)) object)) + +(define (*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 dispatch-vector + (vector-cons number-of-microcode-types unparse-default)) + +(define (define-type type dispatcher) + (vector-set! dispatch-vector (microcode-type type) dispatcher)) + +(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)))))) + +(define (unparse-unassigned x) + (unparse-with-brackets + (lambda () + (*unparse-string "UNASSIGNED")))) + +(define (unparse-unbound x) + (unparse-with-brackets + (lambda () + (*unparse-string "UNBOUND")))) + +(define (unparse-symbol symbol) + (*unparse-string (symbol->string symbol))) + +(define-type 'INTERNED-SYMBOL + unparse-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-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-type 'VECTOR + (lambda (vector) + (define (normal) + (*unparse-char #\#) + (unparse-list-internal (vector->list vector))) + (cond ((zero? (vector-length vector)) (*unparse-string "#()")) + ((future? vector) (normal)) + (else + (let ((entry + (assq (vector-ref vector 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*) + +(define-type 'LIST + (lambda (object) + ((cond ((future? (car object)) unparse-list) + ((unassigned-object? object) unparse-unassigned) + ((unbound-object? object) unparse-unbound) + (else unparse-list)) + object))) + +(define (unparse-list list) + (cond ((and (not (future? (car list))) + (eq? (car list) 'QUOTE) + (pair? (cdr list)) + (null? (cddr list))) + (*unparse-char #\') + (*unparse-object-or-future (cadr list))) + (else + (unparse-list-internal list)))) + +(define (unparse-list-internal list) + (if *unparser-list-depth-limit* + (fluid-let ((*unparser-list-depth* (1+ *unparser-list-depth*))) + (if (> *unparser-list-depth* *unparser-list-depth-limit*) + (*unparse-string "...") + (begin (*unparse-char #\() + (*unparse-object-or-future (car list)) + (unparse-tail (cdr list) 2) + (*unparse-char #\))))) + (begin (*unparse-char #\() + (*unparse-object-or-future (car list)) + (unparse-tail (cdr list) 2) + (*unparse-char #\))))) + +(define (unparse-tail l n) + (cond ((pair? l) + (*unparse-char #\Space) + (*unparse-object-or-future (car l)) + (if (and *unparser-list-breadth-limit* + (>= n *unparser-list-breadth-limit*) + (not (null? (cdr l)))) + (*unparse-string " ...") + (unparse-tail (cdr l) (1+ n)))) + ((not (null? l)) + (*unparse-string " . ") + (*unparse-object-or-future l)))) + +;;;; 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-type 'PRIMITIVE-EXTERNAL unparse-primitive-procedure) + +(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-symbol (variable-name variable)))))) + +(define (unparse-datum object) + (*unparse-string (number->string (primitive-datum object) 16))) + +(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) + +;;; end UNPARSER-PACKAGE. +)) \ No newline at end of file diff --git a/v7/src/runtime/unsyn.scm b/v7/src/runtime/unsyn.scm new file mode 100644 index 000000000..7fd20ea4e --- /dev/null +++ b/v7/src/runtime/unsyn.scm @@ -0,0 +1,495 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1985 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of +;;; this software shall duly acknowledge such use, in accordance +;;; with the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; + +;;;; UNSYNTAX: SCODE -> S-Expressions + +(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 (unsyntax-object object) + ((unsyntax-dispatcher object) object)) + +(define (unsyntax-objects objects) + (if (null? objects) + '() + (cons (unsyntax-object (car objects)) + (unsyntax-objects (cdr objects))))) + +;;;; Unsyntax Quanta + +(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)) + +(define (unsyntax-ACCESS-object object) + `(ACCESS ,@(unexpand-access object))) + +(define (unexpand-access object) + (if (access? object) + (access-components object + (lambda (environment name) + `(,name ,@(unexpand-access environment)))) + `(,(unsyntax-object object)))) + +(define (unsyntax-UNBOUND?-object unbound?) + `(UNBOUND? ,(unbound?-name unbound?))) + +(define (unsyntax-UNASSIGNED?-object unassigned?) + `(UNASSIGNED? ,(unassigned?-name unassigned?))) + +(define (unsyntax-DEFINITION-object definition) + (definition-components definition unexpand-definition)) + +(define (unsyntax-ASSIGNMENT-object assignment) + (assignment-components assignment + (lambda (name value) + `(SET! ,name ,(unsyntax-object value))))) + +(define ((definition-unexpander key lambda-key) 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)) + ,@(unsyntax-sequence body)) + `(,key ,name ,@(unexpand-binding-value value))))) + `(,key ,name ,@(unexpand-binding-value value)))) + +(define (unexpand-binding-value value) + (if (unassigned-object? value) + '() + `(,(unsyntax-object value)))) + +(define unexpand-definition + (definition-unexpander 'DEFINE 'DEFINE)) + +(define (unsyntax-COMMENT-object comment) + (comment-components comment + (lambda (text expression) + `(COMMENT ,text ,(unsyntax-object expression))))) +(define (unsyntax-DECLARATION-object declaration) + (declaration-components declaration + (lambda (text expression) + `(LOCAL-DECLARE ,text ,(unsyntax-object expression))))) + +(define (unsyntax-SEQUENCE-object sequence) + `(BEGIN ,@(unsyntax-sequence sequence))) + +(define (unsyntax-sequence sequence) + (unsyntax-objects (sequence-actions sequence))) + +(define (unsyntax-OPEN-BLOCK-object open-block) + (open-block-components open-block + (lambda (auxiliary declarations expression) + `(OPEN-BLOCK ,auxiliary + ,declarations + ,@(unsyntax-sequence expression))))) + +(define (unsyntax-DELAY-object object) + `(DELAY ,(unsyntax-object (delay-expression object)))) + +(define (unsyntax-IN-PACKAGE-object in-package) + (in-package-components in-package + (lambda (environment expression) + `(IN-PACKAGE ,(unsyntax-object environment) + ,@(unsyntax-sequence expression))))) + +(define (unsyntax-THE-ENVIRONMENT-object object) + `(THE-ENVIRONMENT)) + +(define (unsyntax-CONDITIONAL-object conditional) + (conditional-components conditional unsyntax-conditional)) + +(define (unsyntax-conditional predicate consequent alternative) + (cond ((false? alternative) + (if (conditional? consequent) + `(AND ,@(unexpand-conjunction predicate consequent)) + `(IF ,(unsyntax-object predicate) + ,(unsyntax-object consequent)))) + ((conditional? alternative) + `(COND ,@(unsyntax-cond-conditional predicate + consequent + alternative))) + (else + `(IF ,(unsyntax-object predicate) + ,(unsyntax-object consequent) + ,(unsyntax-object alternative))))) + +(define (unsyntax-cond-conditional predicate consequent alternative) + `((,(unsyntax-object predicate) ,@(unsyntax-sequence consequent)) + ,@(unsyntax-cond-alternative alternative))) + +(define (unsyntax-cond-disjunction predicate alternative) + `((,(unsyntax-object predicate)) + ,@(unsyntax-cond-alternative alternative))) + +(define (unsyntax-cond-alternative alternative) + (cond ((false? alternative) + '()) + ((disjunction? alternative) + (disjunction-components alternative unsyntax-cond-disjunction)) + ((conditional? alternative) + (conditional-components alternative unsyntax-cond-conditional)) + (else + `((ELSE ,@(unsyntax-sequence alternative)))))) + +(define (unexpand-conjunction predicate consequent) + (if (conditional? consequent) + `(,(unsyntax-object predicate) + ,@(conditional-components consequent + (lambda (predicate consequent alternative) + (if (false? alternative) + (unexpand-conjunction predicate consequent) + `(,(unsyntax-conditional predicate + consequent + alternative)))))) + `(,(unsyntax-object predicate) + ,(unsyntax-object consequent)))) + +(define (unsyntax-DISJUNCTION-object object) + `(OR ,@(disjunction-components object unexpand-disjunction))) + +(define (unexpand-disjunction predicate alternative) + `(,(unsyntax-object predicate) + ,@(if (disjunction? alternative) + (disjunction-components alternative unexpand-disjunction) + `(,(unsyntax-object alternative))))) + +;;;; Lambdas + +(define (unsyntax-LAMBDA-object lambda) + (lambda-components** lambda + (lambda (name required optional rest body) + (let ((bvl (lambda-list required optional rest)) + (body (unsyntax-sequence body))) + (if (eq? name lambda-tag:unnamed) + `(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 (lambda-list required optional rest) + (cond ((null? rest) + (if (null? optional) + required + `(,@required ,(access lambda-optional-tag lambda-package) + ,@optional))) + ((null? optional) + `(,@required . ,rest)) + (else + `(,@required ,(access lambda-optional-tag lambda-package) + ,@optional . ,rest)))) + +(define (lambda-components** lambda receiver) + (lambda-components lambda + (lambda (name required optional rest auxiliary declarations body) + (receiver name required optional rest + (unscan-defines auxiliary declarations body))))) + +;;;; Combinations + +(define (unsyntax-COMBINATION-object combination) + (combination-components combination + (lambda (operator 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)) + ((variable? operator) + (let ((name (variable-name operator))) + (cond ((eq? name 'ERROR-PROCEDURE) + (unsyntax-error-like-form operands 'ERROR)) + ((eq? name 'BREAKPOINT-PROCEDURE) + (unsyntax-error-like-form operands 'BKPT)) + (else + (cons (unsyntax-object operator) + (unsyntax-objects operands)))))) + ((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)) + ((eq? name lambda-tag:make-package) + (unsyntax-make-package required operands body)) + (else + `(LET ,name + ,(unsyntax-let-bindings required operands) + ,@(unsyntax-sequence body)))) + (cons (unsyntax-object operator) + (unsyntax-objects operands)))))) + (else + (cons (unsyntax-object operator) + (unsyntax-objects operands))))))) + +(define (unsyntax-error-like-form operands name) + (cons* name + (unsyntax-object (first operands)) + (let ((operand (second operands))) + (cond ((and (access? operand) + (null? (access-environment operand)) + (eq? (access-name operand) '*THE-NON-PRINTING-OBJECT*)) + '()) + ((combination? operand) + (combination-components operand + (lambda (operator operands) + (if (and (access? operator) + (access-components operator + (lambda (environment name) + (and (eq? name 'LIST) + (null? environment))))) + (unsyntax-objects operands) + `(,(unsyntax-object operand)))))) + (else + `(,(unsyntax-object operand))))))) + +(define (unsyntax-shallow-FLUID-LET names values body) + (combination-components body + (lambda (operator operands) + `(FLUID-LET ,(unsyntax-let-bindings + (map extract-transfer-var + (lambda-components** (car operands) + (lambda (name req opt rest body) + (sequence-actions body)))) + (every-other values)) + ,@(lambda-components** (cadr operands) + (lambda (name required optional rest body) + (unsyntax-sequence body))))))) + +(define (every-other list) + (if (null? list) + '() + (cons (car list) + (every-other (cddr list))))) + +(define (extract-transfer-var assignment) + (assignment-components assignment + (lambda (name value) + (cond ((assignment? value) + (assignment-components value + (lambda (name value) + name))) + ((combination? value) + (combination-components value + (lambda (operator operands) + (cond ((eq? operator lexical-assignment) + `(ACCESS ,(cadr operands) + ,@(unexpand-access (car operands)))) + (else + (error "Unknown SCODE form" 'FLUID-LET + assignment)))))) + (else + (error "Unknown SCODE form" 'FLUID-LET 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! #!true))) + +(define unsyntax-common-lisp-FLUID-LET + (unsyntax-deep-or-common-FLUID-LET + 'FLUID-BIND (make-primitive-procedure 'make-fluid-binding! #!true))) + +(define (unsyntax-MAKE-ENVIRONMENT names values body) + `(MAKE-ENVIRONMENT ,@(except-last-pair (unsyntax-sequence body)))) + +(define (unsyntax-MAKE-PACKAGE names values body) + `(MAKE-PACKAGE ,(car names) + ,(unsyntax-let-bindings (cdr names) + (cdr values)) + ,@(except-last-pair (cdr (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 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 diff --git a/v7/src/runtime/utabs.scm b/v7/src/runtime/utabs.scm new file mode 100644 index 000000000..1c3bcf478 --- /dev/null +++ b/v7/src/runtime/utabs.scm @@ -0,0 +1,323 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of this +;;; software shall duly acknowledge such use, in accordance with +;;; the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; + +;;;; Microcode Table Interface + +(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 future?) + +(define microcode-system + (make-environment + +(define :name "Microcode") +(define :version) +(define :modification) +(define :identification) +(define :release) + +(let-syntax ((define-primitive + (macro (name) + `(DEFINE ,name ,(make-primitive-procedure name))))) + (define-primitive binary-fasload) + (define-primitive microcode-identify) + (define-primitive microcode-tables-filename) + (define-primitive map-machine-address-to-code) + (define-primitive map-code-to-machine-address) + (define-primitive get-external-counts) + (define-primitive get-external-number) + (define-primitive get-external-name)) + +;;;; Fixed Objects Vector + +(set! fixed-objects-vector-slot +(named-lambda (fixed-objects-vector-slot name) + (or (microcode-table-search 15 name) + (error "Unknown name" fixed-objects-vector-slot name)))) + +(define fixed-objects) + +(define (microcode-table-search slot name) + (let ((vector (vector-ref fixed-objects slot))) + (let ((end (vector-length vector))) + (define (loop i) + (and (not (= i end)) + (let ((entry (vector-ref vector i))) + (if (if (pair? entry) + (memq name entry) + (eq? name entry)) + i + (loop (1+ i)))))) + (loop 0)))) + +(define (microcode-table-ref slot index) + (let ((vector (vector-ref fixed-objects 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) (BIG-FIXNUM . NUMBER) (BIG-FLONUM . NUMBER) + (EXTENDED-FIXNUM . NUMBER) + (EXTENDED-PROCEDURE . 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) + (INTERN-SYMBOL . SYMBOL) + (PRIMITIVE . PRIMITIVE-PROCEDURE))) + +(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 "Unknown name" microcode-type 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))) + +(set! return-address-code +(named-lambda (return-address-code return-address) + (map-machine-address-to-code return-address-type return-address))) + +(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 errors-slot) + +(set! microcode-error +(named-lambda (microcode-error name) + (microcode-table-search errors-slot name))) + +;;;; Microcode Termination Codes + +(define termination-vector-slot) + +(set! microcode-termination +(named-lambda (microcode-termination name) + (microcode-table-search termination-vector-slot name))) + +(set! microcode-termination-name +(named-lambda (microcode-termination-name type) + (code->name termination-vector-slot type))) + +;;;; Microcode Primitives + +(define primitives-slot) +(define primitive-type-code) +(define external-type-code) + +(set! primitive-procedure? +(named-lambda (primitive-procedure? object) + (or (primitive-type? primitive-type-code object) + (primitive-type? external-type-code object)))) + +(set! make-primitive-procedure +(named-lambda (make-primitive-procedure name #!optional force?) + (let ((code (name->code primitives-slot 'PRIMITIVE name))) + (if code + (map-code-to-machine-address primitive-type-code code) + (or (get-external-number name force?) + (error "Unknown name" make-primitive-procedure name)))))) + +(set! implemented-primitive-procedure? +(named-lambda (implemented-primitive-procedure? object) + (cond ((primitive-type? primitive-type-code object) true) + ((primitive-type? external-type-code object) + (get-external-number (external-code->name (primitive-datum object)) + false)) + (else + (error "Not a primitive procedure" implemented-primitive-procedure? + object))))) + +(set! primitive-procedure-name +(named-lambda (primitive-procedure-name primitive-procedure) + (cond ((primitive-type? primitive-type-code primitive-procedure) + (code->name primitives-slot + 'PRIMITIVE + (map-machine-address-to-code primitive-type-code + primitive-procedure))) + ((primitive-type? external-type-code primitive-procedure) + (external-code->name (primitive-datum primitive-procedure))) + (else + (error "Not a primitive procedure" primitive-procedure-name + primitive-procedure))))) + +(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))) + +(define (external-code->name code) + (let ((current-counts (get-external-counts))) + (cond ((< code (car current-counts)) (get-external-name code)) + ((< code (+ (car current-counts) (cdr current-counts))) + (get-external-name code)) ;Maybe should warn about undefined + (else + (error "Not an external procedure name" external-code->name + code))))) + +;;;; Initialization + +(define (snarf-version) + (set! :identification (microcode-identify)) + (set! :release (vector-ref :identification 0)) + (set! :version (vector-ref :identification 1)) + (set! :modification (vector-ref :identification 2)) + + (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))) + + (set! primitives-slot + (fixed-objects-vector-slot 'MICROCODE-PRIMITIVES-VECTOR)) + (set! primitive-type-code (microcode-type 'PRIMITIVE)) + + (set! external-type-code (microcode-type 'PRIMITIVE-EXTERNAL)) + + (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))) + + ;; Predicate to test if object is a future without touching it. + (set! future? + (let ((primitive (make-primitive-procedure 'FUTURE? true))) + (if (implemented-primitive-procedure? primitive) + primitive + (lambda (object) false))))) + +(snarf-version) + +;;; end MICROCODE-SYSTEM. +)) \ No newline at end of file diff --git a/v7/src/runtime/vector.scm b/v7/src/runtime/vector.scm new file mode 100644 index 000000000..06852d963 --- /dev/null +++ b/v7/src/runtime/vector.scm @@ -0,0 +1,163 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of +;;; this software shall duly acknowledge such use, in accordance +;;; with the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; + +;;;; Operations on Vectors + +(declare (usual-integrations)) + +;;; Standard Procedures + +(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 + vector-length vector-ref vector-set! + list->vector vector-cons subvector->list))) + +(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 (make-vector size #!optional fill) + (if (unassigned? fill) (set! fill #!FALSE)) + (vector-cons size fill)) + +(define (vector . elements) + (list->vector elements)) + +(define (vector->list vector) + (subvector->list vector 0 (vector-length vector))) + +(define (vector-fill! vector value) + (subvector-fill! vector 0 (vector-length vector) value)) + +;;; Nonstandard Primitives + +(let-syntax ((check-type + (let ((type (microcode-type 'VECTOR))) + (macro (object) + `(IF (NOT (PRIMITIVE-TYPE? ,type ,object)) + (ERROR "Wrong type argument" ,object))))) + (check-target + (macro (object index) + `(BEGIN (CHECK-TYPE ,object) + (IF (NOT (AND (NOT (NEGATIVE? ,index)) + (<= ,index (VECTOR-LENGTH ,object)))) + (ERROR "Index out of range" ,index))))) + (check-subvector + (macro (object start end) + `(BEGIN (CHECK-TYPE ,object) + (IF (NOT (AND (NOT (NEGATIVE? ,start)) + (<= ,start ,end) + (<= ,end (VECTOR-LENGTH ,object)))) + (ERROR "Indices out of range" ,start ,end)))))) + +(define (subvector-move-right! vector1 start1 end1 vector2 start2) + (define (loop index1 index2) + (if (<= start1 index1) + (begin (vector-set! vector2 index2 (vector-ref vector1 index1)) + (loop (-1+ index1) (-1+ index2))))) + (check-subvector vector1 start1 end1) + (check-target vector2 start2) + (loop (-1+ end1) (-1+ (+ start2 (- end1 start1))))) + +(define (subvector-move-left! vector1 start1 end1 vector2 start2) + (define (loop index1 index2) + (if (< index1 end1) + (begin (vector-set! vector2 index2 (vector-ref vector1 index1)) + (loop (1+ index1) (1+ index2))))) + (check-subvector vector1 start1 end1) + (check-target vector2 start2) + (loop start1 start2)) + +(define (subvector-fill! vector start end value) + (define (loop index) + (if (< index end) + (begin (vector-set! vector index value) + (loop (1+ index))))) + (check-subvector vector start end) + (loop start)) + +) + +;;; Nonstandard Procedures + +(define (vector-copy vector) + (let ((length (vector-length vector))) + (let ((new-vector (make-vector length))) + (subvector-move-right! vector 0 length new-vector 0) + new-vector))) + +(define (make-initialized-vector length initialization) + (let ((vector (make-vector length))) + (define (loop n) + (if (= n length) + vector + (begin (vector-set! vector n (initialization n)) + (loop (1+ n))))) + (loop 0))) + +(define (vector-map vector procedure) + (let ((length (vector-length vector))) + (if (zero? length) + vector + (let ((result (make-vector length))) + (define (loop i) + (vector-set! result i (procedure (vector-ref vector i))) + (if (zero? i) + result + (loop (-1+ i)))) + (loop (-1+ length)))))) + +(define (vector-grow vector length) + (let ((new-vector (make-vector length))) + (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 diff --git a/v7/src/runtime/where.scm b/v7/src/runtime/where.scm new file mode 100644 index 000000000..325c05596 --- /dev/null +++ b/v7/src/runtime/where.scm @@ -0,0 +1,259 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1985 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of +;;; this software shall duly acknowledge such use, in accordance +;;; with the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; + +;;;; Environment Inspector + +(in-package debugger-package + +(declare (usual-integrations)) + +(define env-package + (make-package env-package + ((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)) + +;;; Basic Commands + +(define-where-command #\? (standard-help-command env-commands) + "Help, list command letters") + +(define-where-command #\Q standard-exit-command + "Quit (exit from Where)") + +;;; Lexpr since it can take one or no arguments + +(define (where #!optional env-spec) + (if (unassigned? env-spec) (set! env-spec (rep-environment))) + (let ((environment + (cond ((or (eq? env-spec system-global-environment) + (environment? env-spec)) + env-spec) + ((compound-procedure? env-spec) + (procedure-environment env-spec)) + ((delayed? env-spec) + (if (delayed-evaluation-forced? env-spec) + (error "Not a valid environment, already forced" + (list where env-spec)) + (delayed-evaluation-environment env-spec))) + (else + (error "Not a legal environment object" 'WHERE + env-spec))))) + (environment-warning-hook environment) + (fluid-let ((env environment) + (current-frame environment) + (current-frame-depth 0)) + (letter-commands env-commands + (standard-rep-message "Environment Inspector") + (standard-rep-prompt "Where-->"))))) + +;;;; Display Commands + +(define (show) + (show-frame current-frame current-frame-depth)) + +(define (show-all) + (let s1 ((env env) + (depth 0)) + (if (eq? system-global-environment env) + *the-non-printing-object* + (begin (show-frame env depth) + (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 (del-assq (environment-name frame) + (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-package . MAKE-PACKAGE) + (,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 + +(define (parent) + (cond ((eq? system-global-environment current-frame) + (newline) + (write-string +"The current frame is the system global environment, it has no parent.")) + ((environment-has-parent? current-frame) + (set! current-frame (environment-parent current-frame)) + (set! current-frame-depth (1+ current-frame-depth)) + (show)) + (else + (newline) + (write-string "The current frame has no parent.")))) + + +(define (son) + (cond ((eq? current-frame env) + (newline) + (write-string "This is the original frame. Its children cannot be found.")) + (else + (let son-1 ((prev env) + (prev-depth 0) + (next (environment-parent env))) + (if (eq? next current-frame) + (begin (set! current-frame prev) + (set! current-frame-depth prev-depth)) + (son-1 next + (1+ prev-depth) + (environment-parent next)))) + (show)))) + +(define (recursive-where) + (write-string "; Object to eval and examine-> ") + (let ((inp (read))) + (write-string "New where!") + (where (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) + (write-string "; Object to eval and print-> ") + (let ((inp (read))) + (newline) + (write (eval inp current-frame)) + (newline))) + +(define (enter) + (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") + +;;;; 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. +)) + +(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 diff --git a/v7/src/runtime/wind.scm b/v7/src/runtime/wind.scm new file mode 100644 index 000000000..86dcda803 --- /dev/null +++ b/v7/src/runtime/wind.scm @@ -0,0 +1,100 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of +;;; this software shall duly acknowledge such use, in accordance +;;; with the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; + +;;;; State Space Model + +(declare (usual-integrations) + (compilable-primitive-functions + set-fixed-objects-vector!)) + +(vector-set! (get-fixed-objects-vector) + (fixed-objects-vector-slot 'STATE-SPACE-TAG) + "State Space") + +(vector-set! (get-fixed-objects-vector) + (fixed-objects-vector-slot 'STATE-POINT-TAG) + "State Point") + +(set-fixed-objects-vector! (get-fixed-objects-vector)) + +(define make-state-space + (let ((prim (make-primitive-procedure 'MAKE-STATE-SPACE))) + (named-lambda (make-state-space #!optional mutable?) + (if (unassigned? mutable?) (set! mutable? #!true)) + (prim mutable?)))) + +(define execute-at-new-state-point + (make-primitive-procedure 'EXECUTE-AT-NEW-STATE-POINT)) + +(define translate-to-state-point + (make-primitive-procedure 'TRANSLATE-TO-STATE-POINT)) + +;;; The following code implements the current model of DYNAMIC-WIND as +;;; a special case of the more general concept. + +(define system-state-space + (make-state-space #!false)) + +(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))))) + +(define set-current-dynamic-state! + (make-primitive-procedure 'set-current-dynamic-state!)) + +;; 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 (dynamic-wind before during after) + (execute-at-new-state-point system-state-space + before + during + after)) + +;; This is so the microcode can find the base state point. + +(let ((fov (get-fixed-objects-vector))) + (vector-set! fov + (fixed-objects-vector-slot 'STATE-SPACE-ROOT) + (current-dynamic-state)) + (set-fixed-objects-vector! fov)) + + (set-fixed-objects-vector! fov)) \ No newline at end of file -- 2.25.1