From: Guillermo J. Rozas <edu/mit/csail/zurich/gjr>
Date: Mon, 10 Sep 1990 18:13:21 +0000 (+0000)
Subject: Initial revision
X-Git-Tag: 20090517-FFI~11214
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=fd2d9b5a91deb700625d3e4adb18e744538ea1e3;p=mit-scheme.git

Initial revision
---

diff --git a/v7/src/sicp/compat.scm b/v7/src/sicp/compat.scm
new file mode 100644
index 000000000..d929eb44b
--- /dev/null
+++ b/v7/src/sicp/compat.scm
@@ -0,0 +1,189 @@
+#| -*-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))
+
+;;; 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))))
+
+(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)))
+
+(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
diff --git a/v7/src/sicp/genenv.scm b/v7/src/sicp/genenv.scm
new file mode 100644
index 000000000..9718ed37a
--- /dev/null
+++ b/v7/src/sicp/genenv.scm
@@ -0,0 +1,116 @@
+#| -*-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))
+
+(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)
diff --git a/v7/src/sicp/graphics.scm b/v7/src/sicp/graphics.scm
new file mode 100644
index 000000000..ecf61c325
--- /dev/null
+++ b/v7/src/sicp/graphics.scm
@@ -0,0 +1,97 @@
+#| -*-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))
+
+(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
diff --git a/v7/src/sicp/sbuild.scm b/v7/src/sicp/sbuild.scm
new file mode 100644
index 000000000..4f0fc5ebb
--- /dev/null
+++ b/v7/src/sicp/sbuild.scm
@@ -0,0 +1,47 @@
+#| -*-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))
+
+(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
diff --git a/v7/src/sicp/stream.scm b/v7/src/sicp/stream.scm
new file mode 100644
index 000000000..47258cbc0
--- /dev/null
+++ b/v7/src/sicp/stream.scm
@@ -0,0 +1,179 @@
+#| -*-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))
+
+;;;; General Streams
+
+(define (nth-stream n s)
+  (cond ((empty-stream? s)
+	 (error "Empty stream -- NTH-STREAM" n))
+	((= n 0)
+	 (head s))
+	(else
+	 (nth-stream (- n 1) (tail s)))))
+
+(define (accumulate combiner initial-value stream)
+  (if (empty-stream? stream)
+      initial-value
+      (combiner (head stream)
+		(accumulate combiner
+			    initial-value
+			    (tail stream)))))
+
+(define (filter pred stream)
+  (cond ((empty-stream? stream)
+	 the-empty-stream)
+	((pred (head stream))
+	 (cons-stream (head stream)
+		      (filter pred (tail stream))))
+	(else
+	 (filter pred (tail stream)))))
+
+(define (map-stream proc stream)
+  (if (empty-stream? stream)
+      the-empty-stream
+      (cons-stream (proc (head stream))
+		   (map-stream proc (tail stream)))))
+
+(define (map-stream-2 proc s1 s2)
+  (if (or (empty-stream? s1)
+	  (empty-stream? s2))
+      the-empty-stream
+      (cons-stream (proc (head s1) (head s2))
+		   (map-stream-2 proc (tail s1) (tail s2)))))
+
+(define (append-streams s1 s2)
+  (if (empty-stream? s1)
+      s2
+      (cons-stream (head s1)
+		   (append-streams (tail s1) s2))))
+
+(define (enumerate-fringe tree)
+  (if (pair? tree)
+      (append-streams (enumerate-fringe (car tree))
+		      (enumerate-fringe (cdr tree)))
+      (cons-stream tree the-empty-stream)))
+
+;;;; Numeric Streams
+
+(define (add-streams s1 s2)
+  (cond ((empty-stream? s1) s2)
+	((empty-stream? s2) s1)
+	(else
+	 (cons-stream (+ (head s1) (head s2))
+		      (add-streams (tail s1) (tail s2))))))
+
+(define (scale-stream c s)
+  (map-stream (lambda (x) (* c x)) s))
+
+(define (enumerate-interval n1 n2)
+  (if (> n1 n2)
+      the-empty-stream
+      (cons-stream n1 (enumerate-interval (1+ n1) n2))))
+
+(define (integers-from n)
+  (cons-stream n (integers-from (1+ n))))
+
+(define integers
+  (integers-from 1))
+
+;;;; Some Hairier Stuff
+
+(define (merge s1 s2)
+  (cond ((empty-stream? s1) s2)
+	((empty-stream? s2) s1)
+	(else
+	 (let ((h1 (head s1))
+	       (h2 (head s2)))
+	   (cond ((< h1 h2)
+		  (cons-stream h1
+			       (merge (tail s1)
+				      s2)))
+		 ((> h1 h2)
+		  (cons-stream h2
+			       (merge s1
+				      (tail s2))))
+		 (else
+		  (cons-stream h1
+			       (merge (tail s1)
+				      (tail s2)))))))))
+
+;;;; Printing
+
+(define print-stream
+  (let ()
+    (define (iter s)
+      (if (empty-stream? s)
+	  (write-string "}")
+	  (begin (write-string " ")
+		 (write (head s))
+		 (iter (tail s)))))
+    (lambda (s)
+      (newline)
+      (write-string "{")
+      (if (empty-stream? s)
+	  (write-string "}")
+	  (begin (write (head s))
+		 (iter (tail s)))))))
+
+;;;; Support for COLLECT
+
+(define (flatmap f s)
+  (flatten (map-stream f s)))
+
+(define (flatten stream)
+  (accumulate-delayed interleave-delayed
+		      the-empty-stream
+		      stream))
+
+(define (accumulate-delayed combiner initial-value stream)
+  (if (empty-stream? stream)
+      initial-value
+      (combiner (head stream)
+		(delay (accumulate-delayed combiner
+					   initial-value
+					   (tail stream))))))
+
+(define (interleave-delayed s1 delayed-s2)
+  (if (empty-stream? s1)
+      (force delayed-s2)
+      (cons-stream (head s1)
+		   (interleave-delayed (force delayed-s2)
+				       (delay (tail s1))))))
+
+(define ((spread-tuple procedure) tuple)
+  (apply procedure tuple))
\ No newline at end of file
diff --git a/v7/src/sicp/strmac.scm b/v7/src/sicp/strmac.scm
new file mode 100644
index 000000000..21fa0a308
--- /dev/null
+++ b/v7/src/sicp/strmac.scm
@@ -0,0 +1,80 @@
+#| -*-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))
+
+(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))))
diff --git a/v7/src/sicp/studen.scm b/v7/src/sicp/studen.scm
new file mode 100644
index 000000000..4528482fe
--- /dev/null
+++ b/v7/src/sicp/studen.scm
@@ -0,0 +1,506 @@
+#| -*-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))
+
+;;; 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
+
+;;;; 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)
+
+;;;; 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."))))
+
+;;;; 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?))
+
+;;;; 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)
+
+    (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)
+
+    (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)
+
+    (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)
+
+    (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?)))
+
+;;; 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))))
+
+;;;; 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.
+))
+
+;;;; 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