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