--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sicp/compat.scm,v 1.1 1990/09/10 18:08:10 jinx Exp $
+
+Copyright (c) 1987, 1988, 1989, 1990 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. |#
+
+;;;; 6.001 Compatibility Definitions
+
+(declare (usual-integrations))
+\f
+;;; Make rationals print as flonums to create the illusion of not having
+;;; rationals at all, since the Chipmunks don't.
+
+(in-package (->environment '(runtime number))
+
+ (define (rat:->string q radix)
+ (if (ratnum? q)
+ (let ((divided (flo:/ (int:->flonum (ratnum-numerator q))
+ (int:->flonum (ratnum-denominator q)))))
+ (if (integer? divided)
+ (int:->string divided radix)
+ (flo:->string divided radix)))
+ (int:->string q radix))))
+\f
+(syntax-table-define system-global-syntax-table 'CONJUNCTION
+ (syntax-table-ref system-global-syntax-table 'AND))
+
+(syntax-table-define system-global-syntax-table 'DISJUNCTION
+ (syntax-table-ref system-global-syntax-table 'OR))
+
+(define (alphaless? symbol1 symbol2)
+ (string<? (symbol->string symbol1)
+ (symbol->string symbol2)))
+
+(define (and* . args)
+ (define (and-loop args)
+ (or (null? args)
+ (and (car args)
+ (and-loop (cdr args)))))
+ (and-loop args))
+
+(define (digit? object)
+ (and (integer? object)
+ (>= object 0)
+ (<= object 9)))
+
+(define (singleton-symbol? object)
+ (and (symbol? object)
+ (= (string-length (symbol->string object)) 1)))
+
+(define (ascii object)
+ (cond ((singleton-symbol? object)
+ (char->ascii
+ (char-upcase (string-ref (symbol->string object) 0))))
+ ((digit? object)
+ (char->ascii (string-ref (number->string object) 0)))
+ (error "Not a singleton symbol" object)))
+
+(define (atom? object)
+ (not (pair? object)))
+
+(define (or* . args)
+ (define (or-loop args)
+ (and (not (null? args))
+ (or (car args)
+ (or-loop (cdr args)))))
+ (or-loop args))
+
+(define (applicable? object)
+ (or (procedure? object)
+ (continuation? object)))
+
+(define (atom? object)
+ (not (pair? object)))
+
+(define char ascii->char)
+
+(define nil false)
+(define t true)
+
+(define (nth n l)
+ (list-ref l n))
+
+(define (nthcdr n l)
+ (list-tail l n))
+
+(define (explode string)
+ (map (lambda (character)
+ (let ((string (char->string character)))
+ (let ((number (string->number string)))
+ (or number
+ (string->symbol string)))))
+ (string->list string)))
+
+(define (implode list)
+ (list->string
+ (map (lambda (element)
+ (cond ((digit? element)
+ (string-ref (number->string element) 0))
+ ((singleton-symbol? element)
+ (string-ref (symbol->string element) 0))
+ (else (error "Element neither digit nor singleton symbol"
+ element))))
+ list)))
+\f
+(define (close-channel port)
+ (cond ((input-port? port) (close-input-port port))
+ ((output-port? port) (close-output-port port))
+ (else (error "CLOSE-CHANNEL: Wrong type argument" port))))
+
+(define (print object #!optional port)
+ (cond ((unassigned? port) (set! port (current-output-port)))
+ ((not (output-port? port)) (error "Bad output port" port)))
+ (if (not (eq? object *the-non-printing-object*))
+ (begin ((access :write-char port) char:newline)
+ ((access unparse-object unparser-package) object port true)
+ ((access :write-char port) #\Space)))
+ *the-non-printing-object*)
+
+(define (tyi #!optional port)
+ (if (unassigned? port) (set! port (current-input-port)))
+ (let ((char (read-char port)))
+ (if (eof-object? char)
+ char
+ (char->ascii char))))
+
+(define (tyipeek #!optional port)
+ (if (unassigned? port) (set! port (current-input-port)))
+ (let ((char (peek-char port)))
+ (if (eof-object? char)
+ char
+ (char->ascii char))))
+
+(define (tyo ascii #!optional port)
+ (if (unassigned? port) (set! port (current-output-port)))
+ (write-char (ascii->char ascii) port))
+
+(define (print-depth #!optional newval)
+ (if (unassigned? newval) (set! newval false))
+ (if (or (not newval)
+ (and (integer? newval)
+ (positive? newval)))
+ (set! *unparser-list-depth-limit* newval)
+ (error "PRINT-DEPTH: Wrong type argument" newval)))
+
+(define (print-breadth #!optional newval)
+ (if (unassigned? newval) (set! newval false))
+ (if (or (not newval)
+ (and (integer? newval)
+ (positive? newval)))
+ (set! *unparser-list-breadth-limit* newval)
+ (error "PRINT-BREADTH: Wrong type argument" newval)))
+
+(define (vector-cons size fill)
+ (make-vector size fill))
+
+(define (read-from-keyboard)
+ (let ((input (read)))
+ (if (eq? input 'abort)
+ ((access default/abort-nearest (->environment '(runtime rep))))
+ input)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sicp/genenv.scm,v 1.1 1990/09/10 18:09:30 jinx Exp $
+
+Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Environment hacking for 6.001
+
+(declare (usual-integrations))
+\f
+(define build-environment)
+
+(define make-unassigned-object
+ microcode-object/unassigned)
+
+(let ((list-type (microcode-type 'LIST)))
+ (define (get-values descriptors frame receiver)
+ (define (inner descriptors names values unref)
+ (define (do-next name-here name-there)
+ (if (or (not (symbol? name-there))
+ (lexical-unreferenceable? frame name-there))
+ (inner (cdr descriptors)
+ (cons name-here names)
+ (cons (make-unassigned-object)
+ values)
+ (if (not (symbol? name-there))
+ unref
+ (cons name-here unref)))
+ (inner (cdr descriptors)
+ (cons name-here names)
+ (cons (lexical-reference frame name-there)
+ values)
+ unref)))
+
+ (if (null? descriptors)
+ (receiver (reverse! names)
+ (reverse! values)
+ (reverse! unref))
+ (let ((this (car descriptors)))
+ (cond ((not (pair? this))
+ (do-next this this))
+ ((null? (cdr this))
+ (do-next (car this) (car this)))
+ (else
+ (do-next (car this) (cdr this)))))))
+ (inner descriptors '() '() '()))
+
+ (define (default-receiver frame unref)
+ frame)
+
+ ;; Kludge:
+ ;; This wants to be map-unassigned from sdata.scm
+
+ (define (default-process object)
+ (car ((access &typed-pair-cons (->environment '(runtime scode-data)))
+ list-type object '())))
+
+ (define (compose f g)
+ (lambda (x)
+ (f (g x))))
+
+ (set! build-environment
+ (named-lambda (build-environment names source-frame
+ #!optional parent-frame
+ process receiver)
+ (get-values
+ names
+ source-frame
+ (lambda (names values unreferenceable)
+ ((if (unassigned? receiver)
+ default-receiver
+ receiver)
+ (apply (scode-eval (make-lambda lambda-tag:make-environment
+ names
+ '()
+ '()
+ '()
+ '()
+ (make-the-environment))
+ (if (unassigned? parent-frame)
+ source-frame
+ parent-frame))
+ (map (if (unassigned? process)
+ default-process
+ (compose default-process process))
+ values))
+ unreferenceable)))))
+ 42)
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sicp/graphics.scm,v 1.1 1990/09/10 18:10:00 jinx Exp $
+
+Copyright (c) 1987, 1988, 1989, 1990 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. |#
+
+;;;; Student graphics Interface
+;;;; implemented for X Windows
+
+(declare (usual-integrations))
+\f
+(define clear-graphics)
+(define clear-point)
+(define draw-line-to)
+(define draw-point)
+(define graphics-available?)
+(define graphics-text) ;Accepts different parameters on Chipmunks
+(define init-graphics)
+(define position-pen)
+
+(define graphics-package
+ (make-environment
+
+ (define graphics-device)
+
+ (set! clear-graphics
+ (lambda ()
+ (if (unassigned? graphics-device)
+ (init-graphics))
+ (graphics-clear graphics-device)
+ (graphics-move-cursor graphics-device 0 0)))
+
+ (set! clear-point
+ (lambda (x y)
+ (graphics-erase-point graphics-device x y)))
+
+ (set! draw-line-to
+ (lambda (x y)
+ (graphics-drag-cursor graphics-device x y)))
+
+ (set! draw-point
+ (lambda (x y)
+ (graphics-draw-point graphics-device x y)))
+
+ (set! graphics-available?
+ (lambda ()
+ (graphics-type-available? x-graphics-device-type)))
+
+ (set! graphics-text
+ (lambda (text x y)
+ (graphics-draw-text graphics-device x y text)))
+
+ (set! init-graphics
+ (lambda ()
+ (let ((display (x-open-display #f)))
+ (set! graphics-device (make-graphics-device
+ x-graphics-device-type
+ display
+ "512x388"
+ #f)))
+ (graphics-set-coordinate-limits graphics-device
+ -256 -195
+ 255 194)
+ (graphics-move-cursor graphics-device 0 0)))
+
+ (set! position-pen
+ (lambda (x y)
+ (graphics-move-cursor graphics-device x y)))
+))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sicp/sbuild.scm,v 1.1 1990/09/10 18:10:26 jinx Exp $
+
+Copyright (c) 1987, 1988, 1989, 1990 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. |#
+
+;;;; 6.001 Student Environment
+
+(declare (usual-integrations))
+\f
+(define student-system
+ (make-system "Student (6.001)"
+ 14 1
+ `((,system-global-environment
+ "compat" "graphics" "strmac" "stream" "genenv" "studen"))))
+
+(load-system! student-system #f)
+
+"Student environment loaded."
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sicp/stream.scm,v 1.1 1990/09/10 18:12:21 jinx Exp $
+
+Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Stream Utilities
+
+(declare (usual-integrations))
+\f
+;;;; General Streams
+
+(define (nth-stream n s)
+ (cond ((empty-stream? s)
+ (error "Empty stream -- NTH-STREAM" n))
+ ((= n 0)
+ (head s))
+ (else
+ (nth-stream (- n 1) (tail s)))))
+
+(define (accumulate combiner initial-value stream)
+ (if (empty-stream? stream)
+ initial-value
+ (combiner (head stream)
+ (accumulate combiner
+ initial-value
+ (tail stream)))))
+
+(define (filter pred stream)
+ (cond ((empty-stream? stream)
+ the-empty-stream)
+ ((pred (head stream))
+ (cons-stream (head stream)
+ (filter pred (tail stream))))
+ (else
+ (filter pred (tail stream)))))
+
+(define (map-stream proc stream)
+ (if (empty-stream? stream)
+ the-empty-stream
+ (cons-stream (proc (head stream))
+ (map-stream proc (tail stream)))))
+
+(define (map-stream-2 proc s1 s2)
+ (if (or (empty-stream? s1)
+ (empty-stream? s2))
+ the-empty-stream
+ (cons-stream (proc (head s1) (head s2))
+ (map-stream-2 proc (tail s1) (tail s2)))))
+
+(define (append-streams s1 s2)
+ (if (empty-stream? s1)
+ s2
+ (cons-stream (head s1)
+ (append-streams (tail s1) s2))))
+
+(define (enumerate-fringe tree)
+ (if (pair? tree)
+ (append-streams (enumerate-fringe (car tree))
+ (enumerate-fringe (cdr tree)))
+ (cons-stream tree the-empty-stream)))
+\f
+;;;; Numeric Streams
+
+(define (add-streams s1 s2)
+ (cond ((empty-stream? s1) s2)
+ ((empty-stream? s2) s1)
+ (else
+ (cons-stream (+ (head s1) (head s2))
+ (add-streams (tail s1) (tail s2))))))
+
+(define (scale-stream c s)
+ (map-stream (lambda (x) (* c x)) s))
+
+(define (enumerate-interval n1 n2)
+ (if (> n1 n2)
+ the-empty-stream
+ (cons-stream n1 (enumerate-interval (1+ n1) n2))))
+
+(define (integers-from n)
+ (cons-stream n (integers-from (1+ n))))
+
+(define integers
+ (integers-from 1))
+\f
+;;;; Some Hairier Stuff
+
+(define (merge s1 s2)
+ (cond ((empty-stream? s1) s2)
+ ((empty-stream? s2) s1)
+ (else
+ (let ((h1 (head s1))
+ (h2 (head s2)))
+ (cond ((< h1 h2)
+ (cons-stream h1
+ (merge (tail s1)
+ s2)))
+ ((> h1 h2)
+ (cons-stream h2
+ (merge s1
+ (tail s2))))
+ (else
+ (cons-stream h1
+ (merge (tail s1)
+ (tail s2)))))))))
+\f
+;;;; Printing
+
+(define print-stream
+ (let ()
+ (define (iter s)
+ (if (empty-stream? s)
+ (write-string "}")
+ (begin (write-string " ")
+ (write (head s))
+ (iter (tail s)))))
+ (lambda (s)
+ (newline)
+ (write-string "{")
+ (if (empty-stream? s)
+ (write-string "}")
+ (begin (write (head s))
+ (iter (tail s)))))))
+\f
+;;;; Support for COLLECT
+
+(define (flatmap f s)
+ (flatten (map-stream f s)))
+
+(define (flatten stream)
+ (accumulate-delayed interleave-delayed
+ the-empty-stream
+ stream))
+
+(define (accumulate-delayed combiner initial-value stream)
+ (if (empty-stream? stream)
+ initial-value
+ (combiner (head stream)
+ (delay (accumulate-delayed combiner
+ initial-value
+ (tail stream))))))
+
+(define (interleave-delayed s1 delayed-s2)
+ (if (empty-stream? s1)
+ (force delayed-s2)
+ (cons-stream (head s1)
+ (interleave-delayed (force delayed-s2)
+ (delay (tail s1))))))
+
+(define ((spread-tuple procedure) tuple)
+ (apply procedure tuple))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sicp/strmac.scm,v 1.1 1990/09/10 18:12:49 jinx Exp $
+
+Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Stream Macros
+
+(declare (usual-integrations))
+\f
+(syntax-table-define system-global-syntax-table 'COLLECT
+ (let ()
+ (define (collect-macro-kernel result bindings filter)
+ (if (null? bindings)
+ (error "COLLECT: No bindings"))
+ (parse-bindings bindings
+ (lambda (names sets)
+ (define (make-tuple-generator names* sets)
+ (if (null? (cdr names*))
+ `(MAP-STREAM (LAMBDA (,(car names*))
+ (LIST ,@names))
+ ,(car sets))
+ `(FLATMAP (LAMBDA (,(car names*))
+ ,(make-tuple-generator (cdr names*)
+ (cdr sets)))
+ ,(car sets))))
+
+ `(MAP-STREAM (SPREAD-TUPLE (LAMBDA ,names ,result))
+ ,(let ((tuple-generator
+ (make-tuple-generator names sets)))
+ (if (null? filter)
+ tuple-generator
+ `(FILTER (SPREAD-TUPLE (LAMBDA ,names ,@filter))
+ ,tuple-generator)))))))
+
+ (define (parse-bindings bindings receiver)
+ (if (null? bindings)
+ (receiver '() '())
+ (begin
+ (if (not (pair? bindings))
+ (error "COLLECT: Bindings must be a list" bindings))
+ (parse-bindings (cdr bindings)
+ (lambda (names sets)
+ (if (not (and (list? (car bindings))
+ (= (length (car bindings)) 2)
+ (symbol? (caar bindings))))
+ (error "COLLECT: Badly formed binding" (car bindings)))
+ (receiver (cons (caar bindings) names)
+ (cons (cadar bindings) sets)))))))
+
+ (macro (result bindings . filter)
+ (collect-macro-kernel result bindings filter))))
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sicp/studen.scm,v 1.1 1990/09/10 18:13:21 jinx Exp $
+
+Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Environment, syntax and read table hacking for 6.001 students.
+
+(declare (usual-integrations))
+\f
+;;; Define the #/ syntax.
+
+(in-package (->environment '(runtime parser))
+ (define (parse-object/char-forward-quote)
+ (discard-char)
+ (if (char=? #\/ (peek-char))
+ (read-char)
+ (name->char
+ (let loop ()
+ (cond ((char=? #\/ (peek-char))
+ (discard-char)
+ (string (read-char)))
+ ((char-set-member? char-set/char-delimiters (peek-char))
+ (string (read-char)))
+ (else
+ (let ((string (read-string char-set/char-delimiters)))
+ (if (let ((char (peek-char/eof-ok)))
+ (and char
+ (char=? #\- char)))
+ (begin (discard-char)
+ (string-append string "-" (loop)))
+ string)))))))))
+
+(parser-table/set-entry! system-global-parser-table
+ "#\/"
+ (access parse-object/char-forward-quote
+ (->environment '(runtime parser))))
+
+(define environment-warning-hook)
+
+(define user-global-environment)
+
+(define student-package
+ (make-environment
+\f
+;;;; Syntax Restrictions
+
+(define sicp-parser-table
+ (parser-table/copy system-global-parser-table))
+
+(define *student-parser-table*)
+
+(define sicp-syntax-table
+ (make-syntax-table))
+
+(define *student-syntax-table*)
+
+(define (enable-system-syntax)
+ (set-current-parser-table! system-global-parser-table)
+ (set-repl/syntax-table! (nearest-repl) system-global-syntax-table))
+
+(define (disable-system-syntax)
+ (set-current-parser-table! *student-parser-table*)
+ (set-repl/syntax-table! (nearest-repl) *student-syntax-table*))
+
+(define (initialize-syntax!)
+ ;; First hack the parser (reader) table
+ ;; Remove backquote and comma
+ (let ((undefined-entry (access parse-object/undefined-atom-delimiter
+ (->environment '(runtime parser)))))
+ (parser-table/set-entry! sicp-parser-table "`" undefined-entry)
+ (parser-table/set-entry! sicp-parser-table "," undefined-entry))
+ ;; Add brackets as extended alphabetic since they are used in book (ugh!)
+ (parser-table/entry
+ system-global-parser-table
+ "/"
+ (lambda (parse-object collect-list)
+ (parser-table/set-entry! sicp-parser-table "[" parse-object collect-list)
+ (parser-table/set-entry! sicp-parser-table "]" parse-object collect-list)))
+ ;; Now, hack the syntax (special form) table.
+ (for-each (lambda (name)
+ (syntax-table-define
+ sicp-syntax-table
+ name
+ (or (syntax-table-ref system-global-syntax-table name)
+ (error "Missing syntactic keyword" name))))
+ '(ACCESS BEGIN BKPT COLLECT COND CONJUNCTION CONS-STREAM DEFINE
+ DELAY DISJUNCTION ERROR IF LAMBDA LET MAKE-ENVIRONMENT
+ QUOTE SEQUENCE SET! THE-ENVIRONMENT))
+ (set! *student-parser-table* (parser-table/copy sicp-parser-table))
+ (set! *student-syntax-table* (syntax-table/copy sicp-syntax-table))
+ #T)
+\f
+;;;; Global Environment
+
+(define (global-environment-enabled?)
+ (or (eq? user-global-environment system-global-environment)
+ (environment-has-parent? user-global-environment)))
+
+(define (in-user-environment-chain? environment)
+ (or (eq? environment user-global-environment)
+ (and (not (eq? environment system-global-environment))
+ (environment-has-parent? environment)
+ (in-user-environment-chain? (environment-parent environment)))))
+
+(define (enable-global-environment)
+ ((access ic-environment/set-parent! (->environment '(runtime environment)))
+ user-global-environment
+ system-global-environment)
+ 'ENABLED)
+
+(define (disable-global-environment)
+ ((access ic-environment/remove-parent! (->environment '(runtime environment)))
+ user-global-environment)
+ 'DISABLED)
+
+(define (student-environment-warning-hook environment)
+ (if (not (in-user-environment-chain? environment))
+ (begin
+ (newline)
+ (write-string "This environment is part of the Scheme system outside the student system.")
+ (newline)
+ (write-string
+ "Performing side-effects in it may damage to the system."))))
+\f
+;;;; Feature hackery
+
+(define (enable-language-features . prompt)
+ (without-interrupts
+ (lambda ()
+ (enable-global-environment)
+ (enable-system-syntax)
+ *the-non-printing-object*)))
+
+(define (disable-language-features . prompt)
+ (without-interrupts
+ (lambda ()
+ (disable-global-environment)
+ (disable-system-syntax)
+ *the-non-printing-object*)))
+
+(define (language-features-enabled?)
+ (global-environment-enabled?))
+\f
+;;;; Clean environment hackery
+
+(define user-global-names
+ '(
+ (%EXIT)
+ (%GE)
+ (%IN)
+ (%OUT)
+ (%VE)
+ (*)
+ (*ARGS*)
+ (*PROC*)
+ (*RESULT*)
+ (+)
+ (-)
+ (-1+)
+ (/)
+ (1+)
+ (<)
+ (<=)
+ (=)
+ (>)
+ (>=)
+ (ABS)
+ (ACCUMULATE)
+ (ACCUMULATE-DELAYED)
+ (ADD-STREAMS)
+ (ADVICE)
+ (ADVISE-ENTRY)
+ (ADVISE-EXIT)
+ (ALPHALESS?)
+ (AND . AND*)
+ (APPEND)
+ (APPEND-STREAMS)
+ (APPLICABLE?)
+ (APPLY)
+ (ASCII)
+ (ASSOC)
+ (ASSQ)
+ (ASSV)
+ (ATAN)
+ (ATOM?)
+ (BREAK . BREAK-ENTRY)
+ (BREAK-BOTH . BREAK)
+ (BREAK-ENTRY)
+ (BREAK-EXIT)
+ (BREAKPOINT-PROCEDURE)
+\f
+ (CAR)
+ (CAAAAR)
+ (CAAADR)
+ (CAAAR)
+ (CAADAR)
+ (CAADDR)
+ (CAADR)
+ (CAAR)
+ (CADAAR)
+ (CADADR)
+ (CADAR)
+ (CADDAR)
+ (CADDDR)
+ (CADDR)
+ (CADR)
+ (CD)
+ (CDR)
+ (CDAAAR)
+ (CDAADR)
+ (CDAAR)
+ (CDADAR)
+ (CDADDR)
+ (CDADR)
+ (CDAR)
+ (CDDAAR)
+ (CDDADR)
+ (CDDAR)
+ (CDDDAR)
+ (CDDDDR)
+ (CDDDR)
+ (CDDR)
+ (CEILING)
+ (CHAR)
+ (CLEAR-GRAPHICS)
+ (CLEAR-POINT)
+ (CLOSE-CHANNEL)
+ (CONS)
+ (CONS*)
+ (COPY-FILE)
+ (COS)
+ (DEBUG)
+ (DELETE-FILE)
+ (DRAW-LINE-TO)
+ (DRAW-POINT)
+\f
+ (EIGHTH)
+ (EMPTY-STREAM?)
+ (ENABLE-LANGUAGE-FEATURES)
+ (ENUMERATE-FRINGE)
+ (ENUMERATE-INTERVAL)
+ (ENVIRONMENT?)
+ (EQ?)
+ (EQUAL?)
+ (EQV?)
+ (ERROR-PROCEDURE)
+ (EVAL)
+ (EVEN?)
+ (EXP)
+ (EXPLODE)
+ (EXPT)
+ (FALSE)
+ (FIFTH)
+ (FILE-EXISTS?)
+ (FILTER)
+ (FIRST)
+ (FLATMAP)
+ (FLATTEN)
+ (FLOOR)
+ (FORCE)
+ (FOURTH)
+ (GCD)
+ (GENERATE-UNINTERNED-SYMBOL)
+ (GRAPHICS-AVAILABLE?)
+ (GRAPHICS-TEXT)
+ (HEAD)
+ (IMPLODE)
+ (INIT-GRAPHICS)
+ (INTEGER-DIVIDE)
+ (INTEGER?)
+ (INTEGERS-FROM)
+ (INTEGERS)
+ (INTERLEAVE-DELAYED)
+ (LAST . LAST-PAIR)
+ (LENGTH)
+ (LIST)
+ (LIST* . CONS*)
+ (LIST-REF)
+ (LIST-TAIL)
+ (LIST?)
+ (LOAD)
+ (LOAD-NOISILY)
+ (LOG)
+\f
+ (MAP-STREAM)
+ (MAP-STREAM-2)
+ (MAPC . FOR-EACH)
+ (MAPCAR . MAP)
+ (MAX)
+ (MEMBER)
+ (MEMQ)
+ (MEMV)
+ (MERGE)
+ (MIN)
+ (NEGATIVE?)
+ (NEWLINE)
+ (NIL)
+ (NOT)
+ (NTH)
+ (NTH-STREAM)
+ (NTHCDR)
+ (NULL?)
+ (NUMBER?)
+ (OBJECT-TYPE)
+ (ODD?)
+ (OPEN-READER-CHANNEL . OPEN-INPUT-FILE)
+ (OPEN-PRINTER-CHANNEL . OPEN-OUTPUT-FILE)
+ (OR . OR*)
+ (PAIR?)
+ (POSITION-PEN)
+ (POSITIVE?)
+ (PP)
+ (PRIN1 . WRITE)
+ (PRINC . DISPLAY)
+ (PRINT . WRITE-LINE)
+ (PRINT-STREAM)
+ (PROCEED)
+ (QUIT)
+ (QUOTIENT)
+ (RANDOM)
+ (READ)
+ (READ-FROM-KEYBOARD)
+ (REMAINDER)
+ (REVERSE)
+ (ROUND)
+ (RUNTIME)
+ (SCALE-STREAM)
+\f
+ (SECOND)
+ (SET-CAR!)
+ (SET-CDR!)
+ (SEVENTH)
+ (SIN)
+ (SIXTH)
+ (SPREAD-TUPLE)
+ (SQRT)
+ (STRING-LESS?. STRING<?)
+ (SYMBOL?)
+ (T)
+ (TAIL)
+ (TAN)
+ (THE-EMPTY-STREAM)
+ (THIRD)
+ (TRACE . TRACE-ENTRY)
+ (TRACE-BOTH . TRACE)
+ (TRACE-ENTRY)
+ (TRACE-EXIT)
+ (TRUE)
+ (TRUNCATE)
+ (UNADVISE)
+ (UNADVISE-ENTRY)
+ (UNADVISE-EXIT)
+ (UNBREAK)
+ (UNBREAK-ENTRY)
+ (UNBREAK-EXIT)
+ (UNTRACE)
+ (UNTRACE-ENTRY)
+ (UNTRACE-EXIT)
+ (USER-GLOBAL-ENVIRONMENT . #T)
+ (USER-INITIAL-ENVIRONMENT . #T)
+ (VECTOR)
+ (VECTOR-CONS)
+ (VECTOR-REF)
+ (VECTOR-SET!)
+ (VECTOR-SIZE . VECTOR-LENGTH)
+ (VECTOR?)
+ (WHERE)
+ (ZERO?)))
+\f
+;;; Environment setup code
+
+(define (warn-about-missing-objects missing)
+ (for-each
+ (lambda (name)
+ (newline)
+ (write-string "Warning -- missing name: ")
+ (write name))
+ missing))
+
+(define (setup-user-global-environment!)
+ (define (copy-if-proc object)
+ (if (compound-procedure? object)
+ (scode-eval (lambda-components (procedure-lambda object)
+ make-lambda)
+ (procedure-environment object))
+ object))
+
+ (build-environment
+ user-global-names
+ system-global-environment ; Where to look
+ system-global-environment ; Parent frame
+ copy-if-proc ; What to do to each value
+ (lambda (frame missing)
+ (scode-eval (scode-quote
+ (begin
+ (set! user-global-environment (the-environment))
+ (set! user-initial-environment (make-environment))))
+ frame)
+ (set! user-global-environment frame)
+ (set! user-initial-environment
+ (lexical-reference frame 'user-initial-environment))
+ (warn-about-missing-objects missing))))
+\f
+;;;; Saving and restoring the student system
+
+(define student-band-pathname)
+
+(define (initialize-system)
+ (let ((old-init-file-pathname (init-file-pathname)))
+ (set! init-file-pathname
+ (lambda ()
+ (merge-pathnames
+ (make-pathname #f #f #f "sicp" #f #f)
+ old-init-file-pathname))))
+ (set! student-band-pathname
+ (merge-pathnames
+ (make-pathname #f #f #f "sicp" "bin" #f)
+ (->pathname
+ (or ((make-primitive-procedure 'reload-band-name))
+ ((make-primitive-procedure 'microcode-tables-filename))))))
+ (add-event-receiver!
+ event:after-restart
+ (lambda ()
+ (if (language-features-enabled?)
+ (disable-language-features))
+ (if (not (graphics-available?))
+ (begin
+ (newline)
+ (display "*** Note: no graphics available in this system. ***")))))
+ #T)
+
+(define (reload #!optional filename)
+ (disk-restore
+ (if (unassigned? filename)
+ student-band-pathname
+ (merge-pathnames (->pathname filename)
+ student-band-pathname))))
+
+(define (student-band #!optional filename)
+ (if (not (unassigned? filename))
+ (set! student-band-pathname
+ (merge-pathnames (->pathname filename)
+ student-band-pathname)))
+ (disk-save student-band-pathname))
+
+(define (student-dump filename)
+ (dump-world filename))
+
+;;; End STUDENT-PACKAGE.
+))
+\f
+;;;; Exports
+
+(define enable-language-features
+ (access enable-language-features student-package))
+
+(define disable-language-features
+ (access disable-language-features student-package))
+
+(define reload
+ (access reload student-package))
+
+(define student-band
+ (access student-band student-package))
+
+(define student-dump
+ (access student-dump student-package))
+
+;;; Install the student package
+
+((access initialize-syntax! student-package))
+((access setup-user-global-environment! student-package))
+((access initialize-system student-package))
+(set! environment-warning-hook
+ (access student-environment-warning-hook student-package))
+(set-repl/environment! (nearest-repl) user-initial-environment)
+(disable-language-features)
\ No newline at end of file
projects / mit-scheme.git / commitdiff