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