--- /dev/null
+;;; -*-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))
+\f
+(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))
+\f
+ (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)))
+
+ ))
+ ))
+\f
+;;;; 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!)))
+\f
+;;;; 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!)))
+\f
+;;;; 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!)))
+\f
+(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)))))))
+\f
+(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))
+\f
+;;;; 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
--- /dev/null
+;;; -*-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))
+\f
+;;; 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)))
+\f
+;;;; 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))
+\f
+;;;; 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 '()))
+\f
+;;;; 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))))
+
+)
+\f
+(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)
+\f
+;;;; 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)
+\f
+;;; 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))
+\f
+;;;; 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?))
+\f
+;;;; 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))
+\f
+;;;; 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
--- /dev/null
+;;; -*-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))
+\f
+;; 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))
--- /dev/null
+;;; -*-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))
+\f
+(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))))))
+\f
+(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))))))))))))
+\f
+(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))))
+\f
+(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)))
+\f
+(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))
+\f
+(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
--- /dev/null
+;;; -*-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))
+\f
+;;;; 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)))
+\f
+;;;; 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)
+\f
+;;; 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))
+
+)
+\f
+;;;; 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))
+\f
+(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.
+)))
+\f
+;;;; 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
--- /dev/null
+;;; -*-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))
+\f
+(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))))
+\f
+;;;; 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))
+\f
+;;; 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*)))
+\f
+(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))
+\f
+(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)
+ '()))
+\f
+(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))
+
+)
+\f
+(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 #\# #\|))
+
+)
+\f
+(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)))))
+\f
+(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.
+))
+\f
+;;;; 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)))))
+
+)
--- /dev/null
+;;; -*-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))
+\f
+;;; 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 "<name>.<version>.<type>". 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.
+\f
+;;;; 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)))))
+\f
+(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))))
+\f
+;;;; 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)))
+\f
+(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)))))
+\f
+(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.
+)
+\f
+;;;; 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))))
+\f
+(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.
+)
+\f
+(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))
--- /dev/null
+;;; -*-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))
+\f
+(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))
+\f
+;;;; 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))))
+\f
+(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))
+\f
+;;;; 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))))
+\f
+;;; 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)))
+\f
+;;;; 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)))
+\f
+;;;; 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))
+\f
+;;;; 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))
+\f
+;;; 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
--- /dev/null
+;;; -*-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))
+\f
+(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)
--- /dev/null
+;;; -*-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))
+\f
+;;;; 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))))
+\f
+(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))))))
+\f
+(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
+\f
+;;;; 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*)
+\f
+(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)
+\f
+;;; 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
--- /dev/null
+;;; -*-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))
+\f
+;;; 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)))
+\f
+;;;; 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))))
+\f
+(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))))
+\f
+;;;; 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
--- /dev/null
+;;; -*-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))
+\f
+;;;; 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)
+\f
+;;;; 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 "]")))
+\f
+;;;; 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)))
+\f
+;;;; 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!)
+\f
+;;;; 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)
+\f
+;;;; 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
--- /dev/null
+;;; -*-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))
+\f
+;;;; 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)))
+\f
+;;;; 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)
+\f
+;;;; 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)
+\f
+;;;; 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))))
+\f
+(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)))))
+\f
+(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)))))
+\f
+(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)))))
+
+)
+\f
+;;;; 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
--- /dev/null
+;;; -*-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))
+\f
+(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)
+\f
+(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))))
+\f
+(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))))
+\f
+(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
--- /dev/null
+;;; -*-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))
+\f
+(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?
--- /dev/null
+;;; -*-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))
+\f
+;;;; 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)))
+\f
+;;;; 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))
+\f
+;;;; 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)))))))))
+\f
+;;;; 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)))))))
+\f
+;;;; 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)
--- /dev/null
+;;; -*-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))
+\f
+;;;; 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=? substring<?
+ substring-move-right! substring-move-left!
+ substring-find-next-char-in-set
+ substring-find-previous-char-in-set
+ substring-match-forward substring-match-backward
+ substring-match-forward-ci substring-match-backward-ci
+ substring-upcase! substring-downcase! string-hash
+
+ vector-8b-ref vector-8b-set! vector-8b-fill!
+ vector-8b-find-next-char vector-8b-find-previous-char
+ vector-8b-find-next-char-ci vector-8b-find-previous-char-ci)))
+
+;;; Character Covers
+
+(define (substring-fill! string start end char)
+ (vector-8b-fill! string start end (char->ascii 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 start1 end1 string2 start2 end2)
+ (let ((match (substring-match-forward-ci string1 start1 end1
+ string2 start2 end2))
+ (len1 (- end1 start1))
+ (len2 (- end2 start2)))
+ (and (not (= match len2))
+ (or (= match len1)
+ (char-ci<? (string-ref string1 (+ match start1))
+ (string-ref string2 (+ match start2)))))))
+\f
+;;; Substring Covers
+
+(define (string=? string1 string2)
+ (substring=? string1 0 (string-length string1)
+ string2 0 (string-length string2)))
+
+(define (string-ci=? string1 string2)
+ (substring-ci=? string1 0 (string-length string1)
+ string2 0 (string-length string2)))
+
+(define (string<? string1 string2)
+ (substring<? string1 0 (string-length string1)
+ string2 0 (string-length string2)))
+
+(define (string-ci<? string1 string2)
+ (substring-ci<? string1 0 (string-length string1)
+ string2 0 (string-length string2)))
+
+(define (string>? string1 string2)
+ (substring<? string2 0 (string-length string2)
+ string1 0 (string-length string1)))
+
+(define (string-ci>? string1 string2)
+ (substring-ci<? string2 0 (string-length string2)
+ string1 0 (string-length string1)))
+
+(define (string>=? string1 string2)
+ (not (substring<? string1 0 (string-length string1)
+ string2 0 (string-length string2))))
+
+(define (string-ci>=? string1 string2)
+ (not (substring-ci<? string1 0 (string-length string1)
+ string2 0 (string-length string2))))
+
+(define (string<=? string1 string2)
+ (not (substring<? string2 0 (string-length string2)
+ string1 0 (string-length string1))))
+
+(define (string-ci<=? string1 string2)
+ (not (substring-ci<? string2 0 (string-length string2)
+ string1 0 (string-length string1))))
+\f
+(define (string-fill! string char)
+ (substring-fill! string 0 (string-length string) char))
+
+(define (string-find-next-char string char)
+ (substring-find-next-char string 0 (string-length string) char))
+
+(define (string-find-previous-char string char)
+ (substring-find-previous-char string 0 (string-length string) char))
+
+(define (string-find-next-char-ci string char)
+ (substring-find-next-char-ci string 0 (string-length string) char))
+
+(define (string-find-previous-char-ci string char)
+ (substring-find-previous-char-ci string 0 (string-length string) char))
+
+(define (string-find-next-char-in-set string char-set)
+ (substring-find-next-char-in-set string 0 (string-length string) char-set))
+
+(define (string-find-previous-char-in-set string char-set)
+ (substring-find-previous-char-in-set string 0 (string-length string)
+ char-set))
+
+(define (string-match-forward string1 string2)
+ (substring-match-forward string1 0 (string-length string1)
+ string2 0 (string-length string2)))
+
+(define (string-match-backward string1 string2)
+ (substring-match-backward string1 0 (string-length string1)
+ string2 0 (string-length string2)))
+
+(define (string-match-forward-ci string1 string2)
+ (substring-match-forward-ci string1 0 (string-length string1)
+ string2 0 (string-length string2)))
+
+(define (string-match-backward-ci string1 string2)
+ (substring-match-backward-ci string1 0 (string-length string1)
+ string2 0 (string-length string2)))
+\f
+;;;; Basic Operations
+
+(define (make-string length #!optional char)
+ (if (unassigned? char)
+ (string-allocate length)
+ (let ((result (string-allocate length)))
+ (substring-fill! result 0 length char)
+ result)))
+
+(define (string-null? string)
+ (zero? (string-length string)))
+
+(define (substring string start end)
+ (let ((result (string-allocate (- end start))))
+ (substring-move-right! string start end result 0)
+ result))
+
+(define (list->string 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)))
+\f
+;;;; 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)))
+\f
+(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)))
+\f
+;;;; 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))
+\f
+;;;; 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<? (string-ref string1 match)
+ (string-ref string2 match))
+ if< if>)))))))
+
+(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<? (string-ref string1 match)
+ (string-ref string2 match))
+ if< if>)))))))
+
+(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)))
+\f
+;;;; 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)))
--- /dev/null
+;;; -*-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))
+\f
+(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))
+\f
+;;;; 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))))
+\f
+(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)))))
+\f
+;;;; 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)))
+\f
+;;;; 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))))
+\f
+(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))))
+
+)
+\f
+;;;; 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))))
+\f
+(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))))))
+\f
+;;;; 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))
+\f
+(define syntax-CONJUNCTION-form
+ (spread-arguments
+ (lambda forms
+ (expand-conjunction forms))))
+
+(define syntax-DISJUNCTION-form
+ (spread-arguments
+ (lambda forms
+ (expand-disjunction forms))))
+\f
+;;;; 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))))))
+\f
+;;;; 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)))))
+\f
+;;;; 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))
+\f
+;;;; 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))))))))))
+\f
+(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 <bvl> . <body>) =>
+ ;; (WITH-SAVED-FLUID-BINDINGS
+ ;; (lambda ()
+ ;; (ADD-FLUID! (the-environment) <access-or-symbol> <value>)
+ ;; ...
+ ;; <fluid-let-body>))
+ (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 <bvl> . <body>) =>
+ ;; (WITH-SAVED-FLUID-BINDINGS
+ ;; (lambda ()
+ ;; (ADD-FLUID! (the-environment) <access-or-symbol> <value>)
+ ;; ...
+ ;; <fluid-let-body>))
+ (let ((make-fluid-binding!
+ (make-primitive-procedure 'make-fluid-binding!)))
+ (make-fluid-let-like make-fluid-binding! lambda-tag:common-lisp-fluid-let)))
+\f
+;;;; 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))
+\f
+;;;; 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))))
+\f
+;;;; 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))
+\f
+;;;; 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)))
+\f
+;;;; 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))
+\f
+;;;; 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))
+\f
+;;;; 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)))))
+\f
+(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))))))
+\f
+;;;; 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
--- /dev/null
+;;; -*-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))
+\f
+(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.
--- /dev/null
+;;; -*-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))
+\f
+;;; (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))
+\f
+(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))
+\f
+(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)))))
+
+)
+\f
+;;; 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)))))
+\f
+(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
--- /dev/null
+;;; -*-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))
+\f
+;;; 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))
+\f
+(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))))
+\f
+(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*)
+\f
+(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))))
+\f
+;;;; 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
--- /dev/null
+;;; -*-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))
+\f
+(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)))))
+\f
+;;;; 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))
+\f
+(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)))))
+\f
+;;;; 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)))))
+\f
+;;;; 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)))))))
+\f
+(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))))))
+\f
+(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)))
+\f
+(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)))
+\f
+;;;; 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))
+\f
+;;;; 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
--- /dev/null
+;;; -*-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))
+\f
+(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))
+\f
+;;;; 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)))))
+\f
+;;;; 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)))))
+\f
+;;;; 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)))
+\f
+;;;; 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)))))
+\f
+;;;; 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
--- /dev/null
+;;; -*-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))
+\f
+;;; 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))
+\f
+;;; 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))
+
+)
+\f
+;;; 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
--- /dev/null
+;;; -*-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)))
+\f
+(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-->")))))
+\f
+;;;; 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")
+\f
+;;;; 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")
+\f
+;;;; 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
--- /dev/null
+;;; -*-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!))
+\f
+(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
projects / mit-scheme.git / commitdiff