diff --git a/build/build-external-modules b/build/build-external-modules
deleted file mode 100755
index aad9f2f..0000000
--- a/build/build-external-modules
+++ /dev/null
@@ -1,28 +0,0 @@
-#!/bin/sh
-# Build external-modules.c.
-
-target="$1"
-shift
-
-(
-	cat <<!
-
-!
-	for i in "s48_initialize_external" "$@"; do
-		cat <<!
-extern void	$i(void);
-!
-	done
-	cat <<!
-
-void s48_initialize_external_modules (void) {
-!
-	for i in "s48_initialize_external" "$@"; do
-		cat <<!
-			$i();
-!
-	done
-	cat <<!
-		};
-!
-) >"$target"
diff --git a/build/load-linker.exec b/build/load-linker.exec
deleted file mode 100644
index 953ea60..0000000
--- a/build/load-linker.exec
+++ /dev/null
@@ -1,90 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Load the linker.    -*- Mode: Scheme; -*-
-
-; Run this script with  ,exec ,load l.exec.
-; After the script is loaded, you can, in principle, do whatever
-; you might do in the usual linker image.  For example, you might do
-; (this is from the Makefile)
-;
-;         ,in link-config
-;         (load-configuration "interfaces.scm") 
-;         (load-configuration "packages.scm") 
-;         (flatload initial-structures) 
-;         (load "initial.scm")  
-;         (link-initial-system)
-;
-; This is intended to be used to debug new versions of the compiler or
-; static linker.
-
-(config '(run (define :arguments :values)))  ;temporary hack
-
-(translate "=scheme48/" "./")
-
-(load-package 'flatloading)
-(open 'flatloading)
-
-(define (r x) (config `(run ,x)))
-
-(r '(define-structure source-file-names (export (%file-name% :syntax))
-      (open scheme-level-1
-	    syntactic
-	    fluids)
-      (begin (define-syntax %file-name%
-	       (syntax-rules ()
-		 ((%file-name%) (fluid $source-file-name)))))))
-
-(r '(define-structure enumerated enumerated-interface
-      (open scheme-level-1 signals)
-      (files (rts defenum scm))))
-
-(r '(define-structure architecture architecture-interface
-      (open scheme-level-1 signals enumerated)
-      (files (rts arch))))
-
-(config '(structure reflective-tower-maker
-		    (export-reflective-tower-maker)))
-
-; Make the new linker obtain its table, record, etc. structures from
-; the currently running Scheme.
-
-(config '(load "packages.scm"))
-(config '(structure %run-time-structures run-time-structures-interface))
-(config '(structure %features-structures features-structures-interface))
-
-(r
- '(define-structure %linker-structures
-    (make-linker-structures %run-time-structures
-			    %features-structures
-			    (make-compiler-structures %run-time-structures
-						      %features-structures))))
-
-; Load the linker's interface and structure definitions.
-(config '(load "interfaces.scm" "more-interfaces.scm"))
-(let ((z (config '(run %linker-structures)))
-      (env (config interaction-environment)))
-  (config (lambda () (flatload z env))))
-
-; Load the linker.
-(load-package 'link-config)
-
-; Initialize
-(in 'link-config
-    '(open scheme packages packages-internal
-	   reflective-tower-maker))
-
-(in 'linker '(run (set! *debug-linker?* #t)))
-(in 'link-config '(open flatloading))    ; A different one.
-
-; ,open debuginfo packages-internal compiler scan syntactic meta-types
-
-; (in 'link-config '(dump "l.image"))
-
-; ,exec (usual-stuff)
-
-(define (usual-stuff)
-  (in 'link-config)
-  (run '(begin (load-configuration "interfaces.scm")
-	       (load-configuration "packages.scm")
-	       (flatload initial-structures)))
-  (load "initial.scm"))
diff --git a/build/lucid-script.lisp b/build/lucid-script.lisp
deleted file mode 100644
index 0f142cf..0000000
--- a/build/lucid-script.lisp
+++ /dev/null
@@ -1,82 +0,0 @@
-
-; Script to load the Scheme 48 linker into Common Lisp.
-; Requires Pseudoscheme 2.11.
-
-(defvar pseudoscheme-directory "../pseudo/")
-(load (concatenate 'string pseudoscheme-directory "loadit.lisp"))
-; or perhaps (load (merge-pathnames "loadit.lisp" pseudoscheme-directory))
-(load-pseudoscheme pseudoscheme-directory)
-
-(progn (revised^4-scheme::define-sharp-macro #\.
-	 #'(lambda (c port)
-	     (read-char port)
-	     (eval (let ((*readtable* ps::scheme-readtable))
-		     (read port)))))
-       (values))
-
-(ps:scheme)
-;--------------------
-; Scheme forms
-
-(benchmark-mode)
-
-(define config-env     ; (interaction-environment) would also work here.
-  (#.'scheme-translator:make-program-env
-     '%config
-     (list #.'scheme-translator:revised^4-scheme-structure)))
-
-(load "bcomp/module-language" config-env)
-(load "alt/config" config-env)
-(load "env/flatload" config-env)
-(eval '(set! *load-file-type* #f) config-env)
-
-(define load-config
-  (let ((load-config (eval 'load-configuration config-env)))
-    (lambda (filename)
-      (load-config filename config-env))))
-
-(load-config "packages")
-
-(define flatload-package (eval 'flatload config-env))
-
-(flatload-package (eval 'linker-structures config-env) config-env)
-
-(let ((#.'clever-load:*compile-if-necessary-p* #t))
-  (let ((#.'ps:*scheme-read* #.'#'ps::scheme-read-using-commonlisp-reader))
-    (load "alt/pseudoscheme-record")
-    (load "alt/pseudoscheme-features")))
-
-(let ((#.'clever-load:*compile-if-necessary-p* #t))
-  (flatload-package (eval 'link-config config-env)))
-
-(load "alt/init-defpackage.scm")
-
-(define-syntax struct-list    ;not in link.sbin
-  (syntax-rules ()
-    ((struct-list ?name ...) (list (cons '?name ?name) ...))))
-
-;--------------------
-(quit)
-
-#+Lucid
-(defun disksave-restart-function ()
-  (format t "~&Scheme 48 linker.~2%")
-  ;; (hax:init-interrupt-delivery)   - for threads
-  (ps:scheme)
-  (terpri))
-#+Lucid
-(defun dump-linker ()
-  (lcl:disksave "link/linker-in-lucid" :gc t :full-gc t :verbose t
-		:restart-function #'disksave-restart-function))
-;(dump-linker)
-;(lcl:quit)
-
-
-; Debugging hacks
-;(defun enable-lisp-packages ()
-;  (setq *readtable* ps:scheme-readtable)
-;  (values))
-;(defun disable-lisp-packages ()
-;  (setq *readtable* ps::roadblock-readtable)
-;  (values))
-
diff --git a/c/extension.c b/c/extension.c
deleted file mode 100644
index ba54548..0000000
--- a/c/extension.c
+++ /dev/null
@@ -1,236 +0,0 @@
-/* Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees.
-   See file COPYING. */
-
-/* Implementation of the vm-extension opcode.  This is completely
-   optional; nothing in the standard system uses these features.
-   If you have ANSI C but not POSIX support, try compiling with -DPOSIX=0.
-
-   The vm-extension opcode is being phased out.  New code should use the
-   external-call opcode to call C procedures.
-
-   floating point: POSIX.1, ANSI C (should we be linking with -lM or -lm?)
-   sprintf: POSIX.1, ANSI C
-   atof: POSIX.1, ANSI C
-
- */
-
-#ifndef POSIX
-#  define POSIX 2
-#endif
-
-#include <stdio.h>
-#include "sysdep.h"
-#include "scheme48.h"
-
-#include <string.h>
-#include <stdlib.h>
-#include <math.h>
-#include <signal.h>
-#include <unistd.h>		/* setuid & setgid */
-#include <errno.h>
-#include <netdb.h>		/* gethostbyname */  /* Kali code */
-
-#include <sys/types.h>
-#include <sys/wait.h>
-
-
-#define GREATEST_FIXNUM_VALUE ((1 << 29) - 1)
-#define LEAST_FIXNUM_VALUE (-1 << 29)
-#define CHANNEL_INDEX(x) EXTRACT_FIXNUM(STOB_REF(x, 1))
-#define FOR_INPUT 1
-#define FOR_OUTPUT 2
-
-typedef struct {
-  char b[sizeof(double)];
-} unaligned_double;
-
-typedef union {
-  double f;
-  unaligned_double b;
-} float_or_bytes;
-
-extern long s48_Sextension_valueS;  /* how values are returned */
-
-/* return status values */
-#define EXT_ST_OKAY 0
-#define EXT_ST_EXCEPTION 1
-
-#define EXT_RETURN(value) {s48_Sextension_valueS = (value); return EXT_ST_OKAY; }
-#define EXT_EXCEPTION     return EXT_ST_EXCEPTION
-
-/******************************************/
-
-s48_value
-s48_extended_vm (long key, s48_value value)
-{
-  double x, y;
-
-  switch (key) {
-
-    /* Cases 0 through 19 are reserved for the mobot system. */
-
-  case 0:			/* read jumpers on 68000 board */
-    EXT_RETURN(S48_UNSAFE_ENTER_FIXNUM(0));
-
-  /* Floating point */
-
-#define FLOP 100
-#define FLOP2(i) case FLOP+(i): \
-		   if (!S48_STOB_P(value) || S48_STOB_DESCRIPTOR_LENGTH(value) != 2) \
-		     EXT_EXCEPTION;
-#define FLOP3(i) case FLOP+(i): \
-		   if (!S48_STOB_P(value) || S48_STOB_DESCRIPTOR_LENGTH(value) != 3) \
-		     EXT_EXCEPTION;
-
-#define get_arg(args,i) S48_STOB_REF(args,(i))
-#define get_string_arg(args,i) (S48_UNSAFE_EXTRACT_STRING(get_arg(args,i)))
-
-#define get_float_arg(args, i, var) EXTRACT_FLOAT(get_arg(args, i), var)
-#define set_float_arg(args, i, val) SET_FLOAT(get_arg(args, i), val)
-
-#define EXTRACT_FLOAT(stob, var) \
-  { s48_value temp_ = (stob); \
-    float_or_bytes loser_; \
-    if (!S48_STOB_P(temp_)) EXT_EXCEPTION; \
-    loser_.b = *(unaligned_double*)(&S48_STOB_REF(temp_, 0)); \
-    (var) = loser_.f; }
-
-#define SET_FLOAT(stob, val) \
-  { s48_value temp_ = (stob); \
-    float_or_bytes loser_; \
-    if (!S48_STOB_P(temp_)) EXT_EXCEPTION; \
-    loser_.f = (double)(val); \
-    *(unaligned_double*)(&S48_STOB_REF(temp_, 0)) = loser_.b; }
-
-  FLOP3(0) {
-    get_float_arg(value, 0, x);
-    get_float_arg(value, 1, y);
-    set_float_arg(value, 2, x + y);
-    EXT_RETURN(S48_UNSPECIFIC);}
-  FLOP3(1) {
-    get_float_arg(value, 0, x);
-    get_float_arg(value, 1, y);
-    set_float_arg(value, 2, x - y);
-    EXT_RETURN(S48_UNSPECIFIC);}
-  FLOP3(2) {
-    get_float_arg(value, 0, x);
-    get_float_arg(value, 1, y);
-    set_float_arg(value, 2, x * y);
-    EXT_RETURN(S48_UNSPECIFIC);}
-  FLOP3(3) {
-    get_float_arg(value, 0, x);
-    get_float_arg(value, 1, y);
-    if (y == 0.0) EXT_EXCEPTION;
-    set_float_arg(value, 2, x / y);
-    EXT_RETURN(S48_UNSPECIFIC);}
-  FLOP2(4) {
-    get_float_arg(value, 0, x);
-    get_float_arg(value, 1, y);
-    EXT_RETURN(S48_ENTER_BOOLEAN(x == y));}
-  FLOP2(5) {
-    get_float_arg(value, 0, x);
-    get_float_arg(value, 1, y);
-    EXT_RETURN(S48_ENTER_BOOLEAN(x < y));}
-  FLOP2(6) {			/* fixnum->float */
-    s48_value arg = get_arg(value, 0);
-    if (!S48_FIXNUM_P(arg)) EXT_RETURN(S48_FALSE);
-    set_float_arg(value, 1, S48_UNSAFE_EXTRACT_FIXNUM(arg));
-    EXT_RETURN(S48_TRUE);}
-  FLOP2(7) {			/* string->float */
-    char *str = get_string_arg(value, 0);
-    set_float_arg(value, 1, atof(str));
-    EXT_RETURN(S48_UNSPECIFIC);}
-  FLOP2(8) {			/* float->string */
-    size_t len;
-    char *str = get_string_arg(value,1);
-    get_float_arg(value, 0, x);
-    sprintf(str, "%g", x);
-    len = strlen(str);
-    if (len > S48_UNSAFE_STRING_LENGTH(get_arg(value,1)))
-      /* unlikely but catastrophic */
-      fprintf(stderr, "printing float: output too long: %s\n",
-	      str);
-    EXT_RETURN(S48_UNSAFE_ENTER_FIXNUM(len));}
-
-    /* exp log sin cos tan asin acos atan sqrt */
-
-  FLOP2(9) {
-    get_float_arg(value, 0, x);
-    set_float_arg(value, 1, exp(x));
-    EXT_RETURN(S48_UNSPECIFIC);}
-  FLOP2(10) {
-    get_float_arg(value, 0, x);
-    set_float_arg(value, 1, log(x));
-    EXT_RETURN(S48_UNSPECIFIC);}
-  FLOP2(11) {
-    get_float_arg(value, 0, x);
-    set_float_arg(value, 1, sin(x));
-    EXT_RETURN(S48_UNSPECIFIC);}
-  FLOP2(12) {
-    get_float_arg(value, 0, x);
-    set_float_arg(value, 1, cos(x));
-    EXT_RETURN(S48_UNSPECIFIC);}
-  FLOP2(13) {
-    get_float_arg(value, 0, x);
-    set_float_arg(value, 1, tan(x));
-    EXT_RETURN(S48_UNSPECIFIC);}
-  FLOP2(14) {
-    get_float_arg(value, 0, x);
-    set_float_arg(value, 1, asin(x));
-    EXT_RETURN(S48_UNSPECIFIC);}
-  FLOP2(15) {
-    get_float_arg(value, 0, x);
-    set_float_arg(value, 1, acos(x));
-    EXT_RETURN(S48_UNSPECIFIC);}
-  FLOP3(16) {			/* atan */
-    get_float_arg(value, 0, y);
-    get_float_arg(value, 1, x);
-    set_float_arg(value, 2, atan2(y, x));
-    EXT_RETURN(S48_UNSPECIFIC);}
-  FLOP2(17) {
-    get_float_arg(value, 0, x);
-    set_float_arg(value, 1, sqrt(x));
-    EXT_RETURN(S48_UNSPECIFIC);}
-
-  FLOP2(18) {			/* floor */
-    get_float_arg(value, 0, x);
-    set_float_arg(value, 1, floor(x));
-    EXT_RETURN(S48_UNSPECIFIC);}
-  case FLOP+19: {		/* integer? */
-    EXTRACT_FLOAT(value, x);
-    EXT_RETURN(S48_ENTER_BOOLEAN(fmod(x, 1.0) == 0.0)); }
-  case FLOP+20: {		/* float->fixnum */
-    EXTRACT_FLOAT(value, x);
-    if (x <= (double)GREATEST_FIXNUM_VALUE
-	&& x >= (double)LEAST_FIXNUM_VALUE)
-      {
-      EXT_RETURN(S48_UNSAFE_ENTER_FIXNUM((long)x)); }
-    else
-      EXT_RETURN(S48_FALSE);}
-  FLOP3(21) {			/* quotient */
-    double z;
-    get_float_arg(value, 0, x);
-    get_float_arg(value, 1, y);
-    if (fmod(x, 1.0) != 0.0 || fmod(y, 1.0) != 0.0) EXT_EXCEPTION;
-    if (y == 0.0) EXT_EXCEPTION;
-    z = x / y;
-    set_float_arg(value, 2, z < 0.0 ? ceil(z) : floor(z));
-    EXT_RETURN(S48_UNSPECIFIC);}
-  FLOP3(22) {			/* remainder */
-    get_float_arg(value, 0, x);
-    get_float_arg(value, 1, y);
-    if (fmod(x, 1.0) != 0.0 || fmod(y, 1.0) != 0.0) EXT_EXCEPTION;
-    if (y == 0.0) EXT_EXCEPTION;
-
-    /* "fmod(double x, double y) returns the floating-point remainder
-       (f) of the division of x by y, where f has the same sign as x,
-       such that x=iy+f for some integer i, and |f| < |y|." */
-
-    set_float_arg(value, 2, fmod(x, y));
-    EXT_RETURN(S48_UNSPECIFIC);}
-
-  default:
-    EXT_EXCEPTION;
-  }
-}
-
diff --git a/c/fake/libdl2.c b/c/fake/libdl2.c
deleted file mode 100644
index 376ea24..0000000
--- a/c/fake/libdl2.c
+++ /dev/null
@@ -1,43 +0,0 @@
-/*
- * This is a fake version of the dynamic loading library for machines
- * which don't have it, and don't even have an nlist.
- * We fake it so that everything fails.
- */
-#include "sysdep.h"
-
-
-static char	*lasterror;
-
-
-char	*
-dlerror(void)
-{
-	char	*res;
-
-	res = lasterror;
-	lasterror = NULL;
-	return (res);
-}
-
-
-void	*
-dlopen(char *name, int flags)
-{
-	lasterror = "Dynamic loading not supported on this machine";
-	return (NULL);
-}
-
-
-int
-dlclose(void *lib)
-{
-	return (0);
-}
-
-
-void	*
-dlsym(void *lib, char *name)
-{
-	lasterror = "Dynamic loading not supported on this machine";
-	return (NULL);
-}
diff --git a/c/fake/sigact.h b/c/fake/sigact.h
deleted file mode 100644
index e12edcb..0000000
--- a/c/fake/sigact.h
+++ /dev/null
@@ -1,15 +0,0 @@
-/*
- * If we don't have sigaction, we fake it using signal.
- */
-#if	! defined(HAVE_SIGACTION)
-
-struct	sigaction {
-	void	(*sa_handler)();
-	int	sa_mask;
-	int	sa_flags;
-};
-
-#define	sigaction(sig, act, oact)	signal((sig), (act)->sa_handler)
-#define	sigemptyset(ign)		0
-
-#endif
diff --git a/c/fake/strerror.c b/c/fake/strerror.c
deleted file mode 100644
index fe1ec7e..0000000
--- a/c/fake/strerror.c
+++ /dev/null
@@ -1,22 +0,0 @@
-/*
- * If the system doesn't have a strerror procedure, we provide our own.
- * Note, this depends on sys_nerr and sys_errlist being provided.
- * If your system doesn't provide that either, you can replace this
- * procedure with one that always returns "Unknown error".
- */
-#include "sysdep.h"
-
-
-extern int	sys_nerr;
-extern char	*sys_errlist[];
-
-
-char	*
-strerror(int errnum)
-{
-	if ((0 <= errnum)
-	&&  (errnum < sys_nerr))
-		return (sys_errlist[errnum]);
-	else
-		return ("Unknown error");
-}
diff --git a/c/fake/strerror.h b/c/fake/strerror.h
deleted file mode 100644
index 670e683..0000000
--- a/c/fake/strerror.h
+++ /dev/null
@@ -1,8 +0,0 @@
-/*
- * If we don't have strerror(), we fake it using sys_nerr and sys_errlist.
- */
-#if	! defined(HAVE_STRERROR)
-
-extern char	*strerror(int errnum);
-
-#endif
diff --git a/c/fake/sys-select.h b/c/fake/sys-select.h
deleted file mode 100644
index d5dc08c..0000000
--- a/c/fake/sys-select.h
+++ /dev/null
@@ -1,9 +0,0 @@
-/*
- * If we have a sys/select.h, then include it.
- */
-#if	defined(HAVE_SYS_SELECT_H)
-
-#include <sys/types.h>
-#include <sys/select.h>
-
-#endif
diff --git a/c/io.h b/c/io.h
deleted file mode 100644
index 8357210..0000000
--- a/c/io.h
+++ /dev/null
@@ -1,12 +0,0 @@
-extern FILE	*ps_open_input_file(char *, long *);
-extern FILE	*ps_open_output_file(char *, long *);
-extern long	ps_close(FILE *);
-extern char	ps_read_char(FILE *, char *, long *, char);
-extern long	ps_read_integer(FILE *, char *, long *);
-extern long	ps_write_char(char, FILE *);
-extern long	ps_write_integer(long, FILE *);
-extern long	ps_write_string(char *, FILE *);
-extern long	ps_read_block(FILE *, char *, long, char *, long *);
-extern long	ps_write_block(FILE *, char *, long);
-extern char	*ps_error_string(long);
-extern void	ps_error(char *, long count, ...);
diff --git a/c/old-scheme48.h b/c/old-scheme48.h
deleted file mode 100644
index 03f5d10..0000000
--- a/c/old-scheme48.h
+++ /dev/null
@@ -1,110 +0,0 @@
-typedef long scheme_value;
-
-#define FIXNUM_TAG 0
-#define FIXNUMP(x) (((long)(x) & 3L) == FIXNUM_TAG)
-#define IMMEDIATE_TAG 1
-#define IMMEDIATEP(x) (((long)(x) & 3L) == IMMEDIATE_TAG)
-#define HEADER_TAG 2
-#define HEADERP(x) (((long)(x) & 3L) == HEADER_TAG)
-#define STOB_TAG 3
-#define STOBP(x) (((long)(x) & 3L) == STOB_TAG)
-
-#define ENTER_FIXNUM(n)   ((scheme_value)((n) << 2))
-#define EXTRACT_FIXNUM(x) ((long)(x) >> 2)
-
-#define MISC_IMMEDIATE(n) (scheme_value)(IMMEDIATE_TAG | ((n) << 2))
-#define SCHFALSE    MISC_IMMEDIATE(0)
-#define SCHTRUE    MISC_IMMEDIATE(1)
-#define SCHCHAR    MISC_IMMEDIATE(2)
-#define SCHUNSPECIFIC    MISC_IMMEDIATE(3)
-#define SCHUNDEFINED    MISC_IMMEDIATE(4)
-#define SCHEOF    MISC_IMMEDIATE(5)
-#define SCHNULL    MISC_IMMEDIATE(6)
-#define UNDEFINED SCHUNDEFINED
-#define UNSPECIFIC SCHUNSPECIFIC
-
-#define ENTER_BOOLEAN(n) ((n) ? SCHTRUE : SCHFALSE)
-#define EXTRACT_BOOLEAN(x) ((x) != SCHFALSE)
-
-#define ENTER_CHAR(c) (SCHCHAR | ((c) << 8))
-#define EXTRACT_CHAR(x) ((x) >> 8)
-#define CHARP(x) ((((long) (x)) & 0xff) == SCHCHAR)
-
-#define ADDRESS_AFTER_HEADER(x, type) ((type *)((x) - STOB_TAG))
-#define STOB_REF(x, i) ((ADDRESS_AFTER_HEADER(x, long))[i])
-#define STOB_TYPE(x)   ((STOB_HEADER(x)>>2)&31)
-#define STOB_HEADER(x) (STOB_REF((x),-1))
-#define STOB_BLENGTH(x) (STOB_HEADER(x) >> 8)
-#define STOB_LLENGTH(x) (STOB_HEADER(x) >> 10)
-
-#define STOBTYPE_PAIR 0
-#define PAIRP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_PAIR))
-#define STOBTYPE_SYMBOL 1
-#define SYMBOLP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_SYMBOL))
-#define STOBTYPE_VECTOR 2
-#define VECTORP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_VECTOR))
-#define STOBTYPE_CLOSURE 3
-#define CLOSUREP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_CLOSURE))
-#define STOBTYPE_LOCATION 4
-#define LOCATIONP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_LOCATION))
-#define STOBTYPE_CHANNEL 5
-#define CHANNELP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_CHANNEL))
-#define STOBTYPE_PORT 6
-#define PORTP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_PORT))
-#define STOBTYPE_RATNUM 7
-#define RATNUMP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_RATNUM))
-#define STOBTYPE_RECORD 8
-#define RECORDP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_RECORD))
-#define STOBTYPE_CONTINUATION 9
-#define CONTINUATIONP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_CONTINUATION))
-#define STOBTYPE_EXTENDED_NUMBER 10
-#define EXTENDED_NUMBERP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_EXTENDED_NUMBER))
-#define STOBTYPE_TEMPLATE 11
-#define TEMPLATEP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_TEMPLATE))
-#define STOBTYPE_WEAK_POINTER 12
-#define WEAK_POINTERP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_WEAK_POINTER))
-#define STOBTYPE_SHARED_BINDING 13
-#define SHARED_BINDINGP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_SHARED_BINDING))
-#define STOBTYPE_UNUSED_D_HEADER1 14
-#define UNUSED_D_HEADER1P(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_UNUSED_D_HEADER1))
-#define STOBTYPE_UNUSED_D_HEADER2 15
-#define UNUSED_D_HEADER2P(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_UNUSED_D_HEADER2))
-#define STOBTYPE_STRING 16
-#define STRINGP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_STRING))
-#define STOBTYPE_CODE_VECTOR 17
-#define CODE_VECTORP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_CODE_VECTOR))
-#define STOBTYPE_DOUBLE 18
-#define DOUBLEP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_DOUBLE))
-#define STOBTYPE_BIGNUM 19
-#define BIGNUMP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_BIGNUM))
-
-#define CAR(x) STOB_REF(x, 0)
-#define CDR(x) STOB_REF(x, 1)
-#define SYMBOL_TO_STRING(x) STOB_REF(x, 0)
-#define LOCATION_ID(x) STOB_REF(x, 0)
-#define CONTENTS(x) STOB_REF(x, 1)
-#define CLOSURE_TEMPLATE(x) STOB_REF(x, 0)
-#define CLOSURE_ENV(x) STOB_REF(x, 1)
-#define WEAK_POINTER_REF(x) STOB_REF(x, 0)
-#define SHARED_BINDING_NAME(x) STOB_REF(x, 0)
-#define SHARED_BINDING_IS_IMPORTP(x) STOB_REF(x, 1)
-#define SHARED_BINDING_REF(x) STOB_REF(x, 2)
-#define PORT_HANDLER(x) STOB_REF(x, 0)
-#define PORT_STATUS(x) STOB_REF(x, 1)
-#define PORT_LOCK(x) STOB_REF(x, 2)
-#define PORT_LOCKEDP(x) STOB_REF(x, 3)
-#define PORT_DATA(x) STOB_REF(x, 4)
-#define PORT_BUFFER(x) STOB_REF(x, 5)
-#define PORT_INDEX(x) STOB_REF(x, 6)
-#define PORT_LIMIT(x) STOB_REF(x, 7)
-#define PORT_PENDING_EOFP(x) STOB_REF(x, 8)
-#define CHANNEL_STATUS(x) STOB_REF(x, 0)
-#define CHANNEL_ID(x) STOB_REF(x, 1)
-#define CHANNEL_OS_INDEX(x) STOB_REF(x, 2)
-
-#define VECTOR_LENGTH(x) STOB_LLENGTH(x)
-#define VECTOR_REF(x, i) STOB_REF(x, i)
-#define CODE_VECTOR_LENGTH(x)  STOB_BLENGTH(x)
-#define CODE_VECTOR_REF(x, i)  (ADDRESS_AFTER_HEADER(x, unsigned char)[i])
-#define STRING_LENGTH(x)  (STOB_BLENGTH(x)-1)
-#define STRING_REF(x, i)  (ADDRESS_AFTER_HEADER(x, char)[i])
diff --git a/c/prescheme.h b/c/prescheme.h
deleted file mode 100644
index b95d022..0000000
--- a/c/prescheme.h
+++ /dev/null
@@ -1,59 +0,0 @@
-#include <errno.h>
-#include "io.h"
-
-#define PS_READ_CHAR(PORT,RESULT,EOFP,STATUS)		\
-{							\
-  FILE * TTport = PORT;					\
-  int TTchar;						\
-  if (EOF == (TTchar = getc(TTport)))			\
-    RESULT = ps_read_char(TTport, &EOFP, &STATUS, 0==1);\
-  else {						\
-    RESULT = TTchar; 					\
-    EOFP = 0;						\
-    STATUS = 0; }					\
-}
-
-#define PS_PEEK_CHAR(PORT,RESULT,EOFP,STATUS)		\
-{							\
-  FILE * TTport = PORT;					\
-  int TTchar;						\
-  if (EOF == (TTchar = getc(TTport)))			\
-    RESULT = ps_read_char(TTport, &EOFP, &STATUS, 0==0);\
-  else {						\
-    RESULT = TTchar; 					\
-    ungetc(RESULT, TTport);				\
-    EOFP = 0;						\
-    STATUS = 0; }					\
-}
-
-#define PS_READ_INTEGER(PORT,RESULT,EOFP,STATUS)	\
-RESULT = ps_read_integer(PORT,&EOFP,&STATUS);
-
-#define PS_WRITE_CHAR(CHAR,PORT,STATUS)			\
-{							\
-  FILE * TTport = PORT;					\
-  char TTchar = CHAR;					\
-  if (EOF == putc(TTchar,TTport))			\
-    STATUS = ps_write_char(TTchar,TTport);		\
-  else {						\
-    STATUS = 0; }					\
-}
-
-
-/* C shifts may not work if the amount is greater than the machine word size */
-/* Patched by JAR 6/6/93 */
-
-#define PS_SHIFT_RIGHT(X,Y,RESULT)   \
-{                                    \
-  long TTx = X,  TTy = Y;            \
-  RESULT = TTy >= 32 ? (TTx < 0 ? -1 : 0) : TTx >> TTy; \
-}  
-
-#define PS_SHIFT_LEFT(X,Y,RESULT)    \
-{                                    \
-  long TTy = Y;                      \
-  RESULT = TTy >= 32 ? 0 : X << TTy; \
-}  
-
-extern long s48_return_value, s48_run_machine();
-
diff --git a/c/scheme48heap.h b/c/scheme48heap.h
deleted file mode 100644
index 7072653..0000000
--- a/c/scheme48heap.h
+++ /dev/null
@@ -1,53 +0,0 @@
-/*
- * Externally visible objects defined in scheme48heap.c.
- */
-
-/* initialize top-level variables */
-extern void	s48_heap_init(void);
-
-/* heap-init interface */
-extern void	s48_initialize_heap(long, long);
-extern void	s48_register_static_areas(unsigned char, long *, long *,
-					  unsigned char, long *, long *);
-
-/* heap interface */
-extern long	s48_available(void);
-extern long	s48_heap_size(void);
-extern long	s48_find_all(long);
-extern long	s48_find_all_records(long);
-extern char	*s48_ShpS;
-extern char	*s48_SlimitS;
-
-/* gc interface */
-extern void	s48_begin_collection(void);
-extern long	s48_trace_value(long);
-extern long	s48_trace_locationsB(char *, char *);
-extern long	s48_trace_stob_contentsB(long);
-extern void	s48_do_gc(void);
-extern void	s48_end_collection(void);
-extern char	s48_extantP(long);
-extern long	s48_gc_count(void);
-
-/* allocation interface */
-extern char	s48_availableP(long);
-extern long	s48_preallocate_space(long);
-extern char	*s48_allocate_space(long, long, long);
-extern void	s48_write_barrier(long, char *, long);
-
-/* images interface */
-extern char	s48_image_writing_okayP(void);
-extern long	s48_write_image(long, FILE *);
-extern long	s48_check_image_header(unsigned char *);
-extern long	s48_read_image();
-
-extern long	s48_startup_procedure(void);
-extern long	s48_initial_symbols(void);
-extern long	s48_initial_imported_bindings(void);
-extern long	s48_initial_exported_bindings(void);
-extern long	s48_resumer_records(void);
-extern long	s48_undumpable_records(long *);
-
-extern void	s48_initialization_completeB(void);
-extern void	s48_initializing_gc_root(void);
-
-extern void     s48_set_image_valuesB(long, long, long, long);
diff --git a/c/unix/dynamo-test.c b/c/unix/dynamo-test.c
deleted file mode 100644
index 70beb8b..0000000
--- a/c/unix/dynamo-test.c
+++ /dev/null
@@ -1,40 +0,0 @@
-
-/*
- * A simple test file for dynamic loading, dynamic name lookup, and
- * old-style external calls.
- */
-
-#include <stdio.h>
-#include "scheme48.h"
-
-/*
- * These should only be called on characters or other immediates.
- */
-
-s48_value
-s48_dynamo_test(s48_value arg0, s48_value arg1, s48_value arg2)
-{
-  int i;
-
-  s48_value vector = s48_make_vector(3, S48_FALSE);
-
-  S48_VECTOR_SET(vector, 0, arg0);
-  S48_VECTOR_SET(vector, 1, arg1);
-  S48_VECTOR_SET(vector, 2, arg2);
-
-  return vector;
-}
-
-s48_value
-s48_old_dynamo_test(long nargs, s48_value args[])
-{
-  int i;
-
-  s48_value vector = s48_make_vector(nargs, S48_FALSE);
-
-  for (i = 0; i < nargs; i++)
-    S48_VECTOR_SET(vector, i, args[i]);
-
-  return vector;
-}
-
diff --git a/c/unix/misc.c b/c/unix/misc.c
deleted file mode 100644
index f8fe75e..0000000
--- a/c/unix/misc.c
+++ /dev/null
@@ -1,129 +0,0 @@
-/* Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees.
-   See file COPYING. */
-
-#include <stdio.h>
-#include <stdlib.h>		/* for getenv(), etc. (POSIX?/ANSI) */
-#include <string.h>		/* for strncpy(), etc. (POSIX/ANSI) */
-#include <pwd.h>		/* for getpwnam() (POSIX.1) */
-#include <unistd.h>		/* for sysconf(), etc.  (POSIX.1/.2)*/
-#include <errno.h>
-#include "sysdep.h"
-
-
-#define TRUE  (0 == 0)
-#define FALSE (0 == 1)
-
-/*
-   Expanding Unix filenames
-   Unix Sucks
-   Richard Kelsey Wed Jan 17 21:40:26 EST 1990
-   Later modified by others who wish to remain anonymous
-
-   Expands initial ~ and ~/ in string `name', leaving the result in `buffer'.
-   `buffer_len' is the length of `buffer'.
-
-   Note: strncpy(x, y, n) copies from y to x.
-*/
-
-char *s48_expand_file_name (name, buffer, buffer_len)
-  char *name, *buffer;
-  int buffer_len;
-{
-#define USER_NAME_SIZE 256
-  char *dir, *p, user_name[USER_NAME_SIZE];
-  struct passwd *user_data;
-  int dir_len, i;
-  extern char *getenv();
-  int name_len = strlen(name);
-
-  dir = 0;
-
-  if (name[0] == '~') {
-    name++; name_len--;
-
-    if (name[0] == '/' || name[0] == 0) {
-      dir = getenv("HOME"); }
-
-    else {
-      for (i = 0, p = name; i < name_len && *p != '/'; i++, p++)
-	if (i > (USER_NAME_SIZE - 2)) {
-	  fprintf(stderr,
-		  "\ns48_expand_file_name: user name longer than %d characters\n",
-		  USER_NAME_SIZE - 3);
-	  return(NULL); };
-      strncpy(user_name, name, i);
-      user_name[i] = 0;
-      user_data = getpwnam(user_name);
-      if (!user_data) {
-	fprintf(stderr, "\ns48_expand_file_name: unknown user \"%s\"\n",
-		user_name);
-	return(NULL); };
-      name_len -= i;
-      name = p;
-      dir = user_data->pw_dir; } }
-
-  else if (name[0] == '$') {
-    name++; name_len--;
-
-    for (i = 0, p = name; i < name_len && *p != '/'; i++, p++)
-      if (i > (USER_NAME_SIZE - 2)) {
-	fprintf(stderr,
-		"\ns48_expand_file_name: environment variable longer than %d characters\n",
-		USER_NAME_SIZE - 3);
-	return(NULL); };
-    strncpy(user_name, name, i);
-    user_name[i] = 0;
-
-    name_len -= i;
-    name = p;
-    dir = getenv(user_name); }
-
-  if (dir) {
-    dir_len = strlen(dir);
-    if ((name_len + dir_len + 1) > buffer_len) {
-      fprintf(stderr, "\ns48_expand_file_name: supplied buffer is too small\n");
-      return(NULL); };
-    strncpy(buffer, dir, dir_len);
-    strncpy(buffer + dir_len, name, name_len);
-    buffer[name_len + dir_len] = 0; }
-
-  else {
-    if ((name_len + 1) > buffer_len) {
-      fprintf(stderr, "\ns48_expand_file_name: supplied buffer is too small\n");
-      return(NULL); };
-    strncpy(buffer, name, name_len);
-    buffer[name_len] = 0; }
-
-  return(buffer);
-}
-
-/* test routine
-main(argc, argv)
-  int argc;
-  char *argv[];
-{
-  char buffer[32];
-  s48_expand_file_name(argv[1], buffer, 32);
-  printf("%s\n", buffer);
-  return(0);
-}
-*/
-
-
-/* Driver loop for tail-recursive calls */
-
-long s48_return_value;
-
-long
-s48_run_machine(long (*proc) (void))
-{
-  while (proc != 0)
-    proc = (long (*) (void)) (*proc)();
-  return s48_return_value;
-}
-
-unsigned char *
-ps_error_string(long the_errno)
-{
-  return((unsigned char *)strerror(the_errno));
-}
diff --git a/c/unix/test.c b/c/unix/test.c
deleted file mode 100644
index 0835635..0000000
--- a/c/unix/test.c
+++ /dev/null
@@ -1,12 +0,0 @@
-
-#include "c/scheme48.h"
-
-long
-frog(long arg_count, long *args)
-{
-  long i, res;
-
-  for (i = 0, res = s48_enter_integer(-100); i < arg_count; res += args[i], i++);
-
-  return res;
-}
diff --git a/c/write-barrier.h b/c/write-barrier.h
deleted file mode 100644
index 721b011..0000000
--- a/c/write-barrier.h
+++ /dev/null
@@ -1,2 +0,0 @@
-
-#define	S48_WRITE_BARRIER(stob, address, value)	((void)0)
diff --git a/doc/hacking.txt b/doc/hacking.txt
deleted file mode 100644
index 081d7e5..0000000
--- a/doc/hacking.txt
+++ /dev/null
@@ -1,290 +0,0 @@
-
-,bench
-,load-package linker
-,new-package =link= linker debuginfo defpackage
-,load scripts.scm
-(link-initial-system)
-
-
-To change between initial image starting in mini-command (MINI) and
-command (MAXI):
-
-  1. Definition of initial system's command module in comp-packages.scm:
-     MINI: (make-mini-command scheme)
-     MAXI: (make-command scheme)
-  2. Location of (define-module (make-command ...)...):
-     MINI: more-packages.scm
-     MAXI: comp-packages.scm
-  3. Location of (define-interface command-interface ...):
-     MINI: more-interfaces.scm
-     MAXI: interfaces.scm
-
-
-
-
-> ,new-package z architecture primitives packages table enumerated debug-data
-z> (let ((i 0))
-     (table-walk (lambda (x y) (set! i (+ i 1)))
-	         location-name-table)
-      i)
-1385
-z> (vector-length (find-all-xs (name->enumerand 'location stob)))
-1259
-(vector-length (find-all-xs (name->enumerand 'record stob)))
-2150
-
-(find-all-xs (name->enumerand 'record stob))
-z> (do ((i 0 (+ i 1))
-        (j 0 (if (package? (vector-ref rs i)) (+ j 1) j))) ((= i (vector-length rs)) j))
-72
-z> 
-
-
-
-
-> ,new-package z architecture primitives compiler table
-z> (vector-ref stob 10)
-'template
-z> stob
-'#(pair symbol vector closure location port ratio record continuation extended-number template weak-pointer external unused-d-header1 unused-d-header2 string code-vector double bignum)
-z> (vector-ref stob 7)
-'record
-z> (define rs (find-all-xs 7))
-z> (vector-length rs)
-2178
-z> (define ls (find-all-xs 4))
-z> (vector-length ls)
-1266
-z> 
-
-
-
-
-To get a fresh config package:
-
-,in config (define-structures ((config1 (export)))
-	     (open defpackage built-in-structures more-structures))
-,config-package-is config1
-
-
-To load a linker with a fresh new compiler:
-    x48 -i new-scheme48.image -h 10000000 <l.s48
-
-Then  ,load scripts.scm  or whatever.
-
-
-
-
-These are all files not belonging to any package description:
-
-    boot-packages.scm
-    comp-packages.scm
-    flatload.scm
-    more-packages.scm
-    more-interfaces.scm
-    rts-packages.scm
-    scripts.scm
-    interfaces.scm
-
-    infix/
-    debug/
-    alt/
-
-    link/p-features.scm
-    link/p-record.scm
-    link/t-features.scm
-    link/t-record.scm
-
-    misc/icon.scm
-    misc/mail.scm         -- related to more-thread.scm
-    misc/more-thread.scm  -- needs work
-    misc/sicp.scm	  -- add to more-packages
-
-
-,load-package rk-extensions
-,new-package rk-user rk-extensions
-,user-package-is rk-user
-
-
-
-# If initial images starts in mini-command instead of command, the
-# rule for $(IMAGE) becomes something like this:
-#	(echo ,load more-interfaces.scm $(S48ROOT)/more-packages.scm; \
-#	 echo "(ensure-loaded command)"; \
-#	 echo ",go ((structure-ref command 'command-processor) batch)"; \
-
-
-,in config (define-structures ((reification (export reify-structures)))
-  (open scheme-level-2 table
-	signals			;error
-	packages
-	features		;location-id location?
-	scan)			;find-free-names-in-syntax-rules
-  (files (link reify)))
-
-,load-package reification
-
-debug-config> ,in reification reify-structures
-'#{Procedure 8447 reify-structures}
-debug-config> (define reify-structures ##)
-debug-config> make-simple-package
-
-Error: undefined variable
-       make-simple-package
-       (package debug-config)
-1 debug-config> 
-debug-config> (define-structures ((p (export start))) (open initial-system scheme-level-2 packages))
-debug-config> (define go (in p `(start ,(reify-structures (desirable-packages) (lambda (loc) `',loc)))))
-
-
-
-### Small images for exercising the linker and/or runtime system
-
-debug/tiny.image: debug/tiny.scm $(LINKER_IMAGE)
-	($(START_LINKER_RUNNABLE) \
-	 echo "(load \"debug/tiny-packages.scm\")"; \
-	 echo "(link-simple-system '(debug tiny) 'start tiny-system)") \
-	| $(LINKER_RUNNABLE) -i $(LINKER_IMAGE)
-
-debug/little.image: $(LINKER_IMAGE) $(CONFIG_FILES) $(little-files)
-	($(START_LINKER_RUNNABLE) \
-	 echo "(load \"scripts.scm\")";  \
-	 echo "(link-little-system)")	 \
-	| $(LINKER_RUNNABLE) -i $(LINKER_IMAGE) $(BIG_HEAP)
-
-debug/medium.image: $(LINKER_IMAGE) $(CONFIG_FILES) $(medium-files)
-	($(START_LINKER_RUNNABLE) \
-	 echo "(load \"scripts.scm\")";  \
-	 echo "(link-medium-system)") \
-	| $(LINKER_RUNNABLE) -i $(LINKER_IMAGE) $(BIG_HEAP)
-
-
-	 echo "(define l-f (package-all-filenames little-system))";  \
-	 echo "(define m-f (package-all-filenames medium-system))";  \
-
-		 'little-files l-f 'medium-files m-f	      \
-
-
-[The following is from June 1992, and probably not quite compatible
-with the current compiler internals.]
-
-To eliminate use of the stack GC to implement tail recursion, change
-comp.scm as follows:
-
-(define (compile-unknown-call exp cenv depth cont)
-  (note-source-code
-   exp
-   (maybe-push-continuation (sequentially 
-			     (push-all (cdr exp) cenv 0)
-			     (compile (car exp)
-				      cenv
-				      (length (cdr exp))
-				      (fall-through-cont))
-			     (instruction (if (return-cont? cont)
-					  op/move-args-and-call
-					  op/call)
-					  (length (cdr exp))))
-			    depth
-			    cont)))
-
-
---------------------
-
-Here's another cool thing.  6/28/93
-
-(define-interface evaluation-interface
-  (export eval load eval-from-file))
-
-(define-structure run evaluation-interface
-  (open scheme-level-2 syntactic packages scan
-	environments
-	signals
-	locations
-	features   ;force-output
-	table
-	fluids)
-  (files (debug run)))
-
-,load-package run
-,in run
-,in package-commands (environment-for-syntax-promise)
-(define cool (make-simple-package (list scheme) eval ## 'cool))
-,in command set-environment-for-commands!
-(## cool)
-
-cool> ,inspect (lambda (x) x)
-'#{Procedure 6394}
-
- [0: exp] '(lambda (x) x)
- [1: env] '#{Package 286 cool}
-inspect: 
-inspect: q
-cool> 
-
-
-
-(define (z s)
-  (define (show-type name static)
-    (write name)
-    (display "	: ")
-    (write (static-type static))
-    (newline))
-  (if (package? s)
-      (for-each-definition (lambda (name static loc)
-			     (show-type name static))
-			   s)
-      (interface-walk (lambda (name type)
-			(show-type name
-				   (car (structure-lookup
-					 s name #t))))
-		      (structure-interface s))))
-
-; ,open expander syntactic packages reconstruction
-
-(define (e x)
-  (let ((p (interaction-environment)))
-    (let ((node (expand-form x p)))
-      (write (node-type node (package->environment p)))
-      (newline)
-      (eval node p))))
-
-
-
-> (define hunk3 (lap hunk3
-		     0 (check-nargs= 3)
-		     2 (pop)
-		     3 (make-stored-object 3 0)
-		     6 (return)))
-> (hunk3 1  2 3)
-'(1 . 2)
-> (define cxr (lap cxr
-		   0 (check-nargs= 2)
-		   2 (pop)
-		   3 (stored-object-indexed-ref 0)
-		   5 (return)))
-> (cxr (hunk3 1  2 3) 2)
-3
-> 
-
-
-(define-syntax %cons
-  (lambda (e r c)
-    (let ((n (cadr e))
-	  (kind (caddr e)))
-      `(,(r 'lap) (%cons ,n ,kind)
-		  (check-nargs= ,n)
-		  (pop)
-		  (make-stored-object ,n ,kind)
-		  (return)))))
-
-
-(define (& x)
-  (or (node-ref x 'uid)
-      (begin (set! *n* (+ *n* 1))
-	     (node-set! x 'uid *n*)
-	     *n*))
-  x)
-
-(define (uid n) (node-ref (& n) 'uid))
-
-(define *n* 0)
diff --git a/doc/install.txt b/doc/install.txt
deleted file mode 100644
index 7ffcada..0000000
--- a/doc/install.txt
+++ /dev/null
@@ -1,159 +0,0 @@
--*- Mode: Indented-text; -*-
-
-Here are some remarks to complement what's in the INSTALL file.
-
------
-
-When running "make", don't worry if the ".notify" target fails.  Its
-only purpose is to send an email message to
-scheme-48-notifications@martigny.ai.mit.edu, so that we can get a
-rough idea of how much Scheme 48 is being used and by whom.  We
-promise not to use your name or email address for any commercial
-purpose.  If you don't want us to know, just do "make -t .notify"
-first. 
-     
------
-
-Customizing the installation
-
-  1. If you don't believe in configure scripts, or don't have a
-     /bin/sh that can handle the configure script, you can make
-     sysdep.h and Makefile manually from sysdep.h.in and Makefile.in.
-     The technique is fairly obvious.  For Makefile, just give
-     reasonable values for all of the variables at the top that are
-     defined as "foo = @foo@", e.g. srcdir=., CC=cc, LIBS=-lm,
-     INSTALL=cp, etc.  For sysdep.h, read the comments.  If your OS is
-     Posix compliant, you should be able to copy sysdep.h.in to
-     sysdep.h unmodified and everything should work.
-
-  2. If you definitely won't be installing Scheme 48, you should set
-     libdir to the distribution directory (e.g. "make libdir=`pwd`").
-     This will make the ,open and ,load-package commands work for the
-     library packages defined in more-packages.scm.
-
-  3. If desired, customize the contents of the development environment
-     heap image by editing the definitions of USUAL-COMMANDS and/or
-     USUAL-FEATURES in more-packages.scm; see below.
-
-  4. If you're using a DEC MIPS, and want to use the foreign function
-     interface, specify LDFLAGS=-N (with e.g. "make LDFLAGS=-N").
-
------
-
-Customizing scheme48.image
-
-By default, the image consists of a core Scheme system (Revised^5
-Scheme plus a very minimal read-eval-print loop) together with a
-standard set of "options" (command processor, debugging commands,
-inspector, disassembler, generic arithmetic).  The set of options is
-controlled by the definitions of USUAL-COMMANDS and USUAL-FEATURES in
-more-packages.scm.  If you make the (open ...) clause empty, then
-"make scheme48.image" will create a Scheme system without any extras
-(such as error recovery), and the image will be smaller.  The files
-are listed in approximate order of decreasing desirability; you'll
-probably want at least these:
-
-    package-commands, build
-       - necessary for the scheme48.image script to work
-    debuginfo, disclosers
-       - necessary if you want error messages to be at all helpful
-    debugging
-       - defines important debugging commands such as ,preview and ,trace
-
-After editing the definition of usual-features, simply
-
-        make scheme48.image
-
-to rebuild the image.
-
------
-
-Deeper changes to the system -- for example, edits to most of the
-files in the rts/ directory -- will require using the static linker to
-make a new initial.image.  After you have a working scheme48.image
-(perhaps a previous version of Scheme 48), you can create a linker
-image with
-
-        make linker
-
-after which you can say
-
-        make image
-
-to get the linker to build a new initial.image and initial.debug.
-scheme48.image will then be built from those.
-
-You might think that "make scheme48.image" ought to do this, but the
-circular dependencies
-
-  scheme48.image on initial.image
-  initial.image on link/linker.image
-  link/linker.image on scheme48.image
-
-needs to be broken somewhere, or else make will (justifiably) barf.  I
-chose to break the cycle by making scheme48.image not depend on
-initial.image, since this is most robust for installation purposes.
-
------
-
-Editor support
-
-We recommend interacting with the Scheme 48 command processor using the
-emacs/scheme interface written by Olin Shivers at CMU.  Copies of the
-relevant .el files, together with a "cmuscheme48.el", are in the
-emacs/ subdirectory of the release.  Usage information is in
-doc/user-guide.txt.
-
-You will probably want to byte-compile the .el files to get .elc
-files.  Use M-x byte-compile-file to do this.
-
------
-
-Performance
-
-If you don't have a C compiler that optimizes as well as gcc does,
-then performance may suffer.  Take a look at the automatically
-generated code in scheme48vm.c to find out why.  With a good register
-allocator, all those variables (including some of the virtual
-machine's virtual registers) get allocated to hardware registers, and
-it really flies.  Without one, performance can be pretty bad.
-
-The configure script automatically sets the Makefile variable CFLAGS
-to -O2 -g if gcc is available, or to -O if it isn't.  This can be
-overriden by specifying a different CFLAGS, e.g. "make CFLAGS=-g" for
-no optimization.
-
-Even if you do have a good compiler, you should be able to improve
-overall performance even more, maybe about 6-10%, by removing the
-range check from the interpreter's instruction dispatch.  To do this,
-use the -S flag to get assembly code for scheme48vm.c, then find the
-instructions in scheme48vm.s corresponding to the big dispatch in
-restart():
-
- L19173: {
-  code_pointer_83X = arg1K0;
-  switch ((*((unsigned char *) code_pointer_83X))) {
-    ... }
-
-There will be one or two comparison instructions to see whether the
-opcode is in range; just remove them.  For the 68000 I use a "sed"
- script
-
-    /cmpl #137,d0/ N
-    /cmpl #137,d0\n     jhi L/ d
-
-but of course the constant will probably have to change when a new
-release comes along.
-
-See the user's guide for information on the ,bench command, which
-makes programs run faster.
-
------
-
-filenames.make is "include"d by the Makefile, but is automatically
-generated from the module dependencies laid out in the various
-configuration files (*-packages.scm).  If you edit any of these .scm
-files, you may want to do a "make filenames.make" before you do any
-further "make"s in order to update the depedencies.  This step isn't
-necessary if you're using Gnu make, because Gnu make will make
-included files automatically.
diff --git a/doc/io.txt b/doc/io.txt
deleted file mode 100644
index 239e1d2..0000000
--- a/doc/io.txt
+++ /dev/null
@@ -1,201 +0,0 @@
-
-There are two types of I/O objects in Scheme 48, channels and ports.
-Channels are the raw, unbuffered ports of the operating system.  The
-only I/O operations the VM supports for channels are block reads and
-writes.  Ports are the actual Scheme ports and are implemented in Scheme,
-with some support from the VM for READ-CHAR, PEEK-CHAR, and WRITE-CHAR
-for efficiency.  The run-time system provides ports that are buffered
-versions of channels.  Other sorts of ports are in big/more-port.scm.
-
-Source files:
-
-  rts/port.scm            port operations and port handlers
-  rts/current-port.scm    current-input-port, etc.
-  rts/channel.scm         blocking on channels and handling i/o interrupts
-  rts/channel-port.scm    ports that read and write to channels
-  rts/low.scm             CHANNEL-READ and CHANNEL-WRITE
-  big/more-port.scm       additional kinds of ports
-  vm/arch.scm             fields of ports and channels
-  vm/prim-io.scm          VM i/o opcodes
-  vm/vmio.scm             implementation of channels
-  
-----------------------------------------------------------------
-
-CHANNELS
-
-The VM instructions that deal with channels are:
-
- (OPEN-CHANNEL <spec> <mode>) -> channel
-   <mode> is a from the enumeration OPEN-CHANNEL-OPTION in arch.scm.
-   <spec> is either a filename (as a string) or an OS port (as a one-word
-   code-vector), depending on the mode.
-
- (CLOSE-CHANNEL <channel>)    -> unspecific
-
- (CHANNEL-MAYBE-READ <string-or-code-vector> <start-index> <count> <wait?>
-                     <channel>)
-                              -> number of bytes read or the eof-object
- (CHANNEL-MAYBE-WRITE <string-or-code-vector> <start-index> <count> <channel>)
-                              -> number of bytes written
-   These read or write up to the specified number of characters or bytes
-   from or to the string or code-vector, with the first character or byte
-   going at <start-index>.
-
- (CHANNEL-ABORT <channel>)    -> number of bytes read or written or
-                                 the eof-object
-   This aborts any pending read or write operation on the channel.  The return
-   value reflects any partial completion.
-
-CHANNEL-MAYBE-READ and CHANNEL-MAYBE-WRITE do not block.  If the read or
-write cannot be completed immediately a PENDING-CHANNEL-I/O exception is
-raised.  It is then up to the run-time system to either wait or run some
-other thread.  The VM raises an I/O-COMPLETION interrupt whenever an i/o
-operation completes.
-
-Because CHANNEL-MAYBE-READ and CHANNEL-MAYBE-WRITE are awkward to use,
-the RTS defines somewhat simpler versions:
-
- (CHANNEL-READ <buffer> <start> <needed> <channel>)
-                              -> number of bytes read or the eof-object
- (CHANNEL-WRITE <buffer> <start> <count> <channel>)
-                              -> unspecified
-   <Buffer> is either a string or code vector and <start> is the index of the
-   first character read or written. <Needed> is one of:
-     N > 0 : the call returns when this many characters has been read or
-        an EOF is reached.
-     'IMMEDIATE : the call reads as many characters as are available and
-        returns immediately.
-     'ANY : the call returns as soon as at least one character has been read
-        or an EOF is reached.
-   <Count> is the number of characters to be written.  CHANNEL-READ will read
-   the requested number of characters unless an EOF is reached.  CHANNEL-WRITE
-   will write the requested number of characters.
-
-----------------------------------------------------------------
-
-PORTS
-
-Ports are actual Scheme port and are (usually) buffered.  They are fully
-exposed to the run-time system.  The VM instructions on ports could be
-implemented in Scheme; they are in the VM for efficiency.  Buffers are
-code-vectors (this is a micro-hack; strings have a slightly higher overhead
-because of the null terminating byte for C compatibility) (code-vectors are
-just vectors of bytes).
-
-The fields of a port are:
- 
- PORT-STATUS: a bit set represented as a fixnum.
-  Indices into this bit set are from the PORT-STATUS-OPTIONS
-  enumeration in arch.scm.  The current bits are: input, output,
-  open-for-input, open-for-output (the last two are for things like
-  sockets, on which you need to block but which do not support
-  normal reading or writing).
-
- PORT-HANDLER: a record containing three procedures.  These handle
-  printing the port, closing the port, and filling (for input ports)
-  or emptying (for output ports) buffers.
-
- PORT-DATA: ?
-  Whatever stuff the handler needs.
-
- PORT-LOCKED?, PORT-LOCK: used by the system to guarentee the atomicity
-  of i/o operations.
-
- PORT-BUFFER: a code-vector.  The input or output buffer of the port.
-
- PORT-INDEX: a fixnum.  The index of the next byte to read or written.
-
- PORT-LIMIT: a fixnum.  One past the end of the valid/available buffer space.
-
- PORT-PENDING-EOF?: true if the next read to this port should return EOF.
-
-Additional operations on ports:
-
- (READ-BLOCK string-or-code-vector start count input-port)
-    Read COUNT bytes into STRING-OR-CODE-VECTOR starting at index START.
-    Returns the number of bytes read.  Only an end-of-file will prevent
-    the requested number of bytes from being read.
- 
- (WRITE-STRING string output-port)
-    Write the characters in the string to the port.
-
- (WRITE-BLOCK string-or-code-vector start count output-port)
-    The output counterpart to READ-BLOCK.  This always writes out the
-    requested number of bytes.  Its return value is unspecified.
-
- (FORCE_OUTPUT output-port)
-    Causes any buffered characters to be written out.
-    
- (CURRENT-ERROR-PORT)
-    The current error port, analogous to Scheme's CURRENT-INPUT-PORT
-    and CURRENT-OUTPUT-PORT.
-
-The system maintains a list of output ports whose buffers should be
-periodically flushed.  The default output port and ports made by
-OPEN-OUTPUT-FILE are on this list.  (PERIODICALLY-FORCE-OUTPUT! <output-port>)
-may be used to add others.
-
-----------------------------------------------------------------
-
-PORT HANDLERS
-
-Every port has a handler with three procedures.  The first two are used
-for printing and closing ports and have the same type for all ports:
- 
- (DISCLOSE port-data) -> disclose list
- (CLOSE port-data) -> unspecific
-
-For CLOSE, The system takes care of modifying the port's status.
-
-The third procedure is used to fill and empty buffers.  Its arguments
-and return values depend on the kind of port:
-
- Buffered output ports:
-  (BUFFER-PROC port-data buffer start-index byte-count) -> unspecific
-    BYTE-COUNT bytes should be copied from the buffer beginning at
-    START-INDEX.  The buffer may be either a string or a code-vector.
-
- Unbuffered output ports:
-  (BUFFER-PROC port-data char) -> unspecific
-    Write out the given character.  The system uses this for the default
-    error port.
-
- Input ports:
-  (BUFFER-PROC data buffer start-index needed-bytes)
-     -> EOF or number of bytes read (before an EOF)
-    Bytes should be copied into the buffer starting at START-INDEX.  The
-    buffer may be either a string or a code-vector.  NEEDED-BYTES is one of:
-
-      'IMMEDIATE
-        The call should return immediately after transfering whatever number
-        of bytes are currently available, possibly none (this is used for
-	CHAR-READY?). The maximum number of characters is determined by the
-	length of BUFFER.
-
-      'ANY
-        The call should wait until at least one byte is available or an EOF
-        occurs (used for READ-CHAR and PEEK-CHAR).  The maximum number of
-	characters is determined by the length of BUFFER.
-
-      N > 0
-        The call should wait until N bytes have been copied into the buffer
-        or an EOF occurs.  If the return value is less than NEEDED-BYTES the
-        port code inserts an EOF after the last byte.
-
-----------------------------------------------------------------
-
-Ports and the Virtual Machine
-
-Ports could be implemented entirely in Scheme, with no support from
-the VM.  For efficiency reasons VM instructions are supplied for
-three port operations:
-
-  (READ-CHAR <port>)
-  (PEEK-CHAR <port>)
-  (WRITE-CHAR <char> <port>)
-
-For each of these, if there is sufficient data or space in the
-appropriate buffer the VM performs the operation.  Otherwise a
-buffer-full/empty exception is raised and the exception handler
-uses the buffer procedure from the port's handler to fill or
-empty the buffer.
diff --git a/doc/meeting.ps b/doc/meeting.ps
deleted file mode 100644
index 3fcb07d..0000000
--- a/doc/meeting.ps
+++ /dev/null
@@ -1,1090 +0,0 @@
-%!PS-Adobe-2.0
-%%Creator: dvips 5.521 Copyright 1986, 1993 Radical Eye Software
-%%CreationDate: Sat Jan 15 16:05:04 1994
-%%Pages: 8
-%%PageOrder: Ascend
-%%BoundingBox: 0 0 612 792
-%%EndComments
-%DVIPSCommandLine: dvips -f
-%DVIPSSource:  TeX output 1994.01.15:1605
-%%BeginProcSet: tex.pro
-/TeXDict 250 dict def TeXDict begin /N{def}def /B{bind def}N /S{exch}N
-/X{S N}B /TR{translate}N /isls false N /vsize 11 72 mul N /hsize 8.5 72
-mul N /landplus90{false}def /@rigin{isls{[0 landplus90{1 -1}{-1 1}
-ifelse 0 0 0]concat}if 72 Resolution div 72 VResolution div neg scale
-isls{landplus90{VResolution 72 div vsize mul 0 exch}{Resolution -72 div
-hsize mul 0}ifelse TR}if Resolution VResolution vsize -72 div 1 add mul
-TR matrix currentmatrix dup dup 4 get round 4 exch put dup dup 5 get
-round 5 exch put setmatrix}N /@landscape{/isls true N}B /@manualfeed{
-statusdict /manualfeed true put}B /@copies{/#copies X}B /FMat[1 0 0 -1 0
-0]N /FBB[0 0 0 0]N /nn 0 N /IE 0 N /ctr 0 N /df-tail{/nn 8 dict N nn
-begin /FontType 3 N /FontMatrix fntrx N /FontBBox FBB N string /base X
-array /BitMaps X /BuildChar{CharBuilder}N /Encoding IE N end dup{/foo
-setfont}2 array copy cvx N load 0 nn put /ctr 0 N[}B /df{/sf 1 N /fntrx
-FMat N df-tail}B /dfs{div /sf X /fntrx[sf 0 0 sf neg 0 0]N df-tail}B /E{
-pop nn dup definefont setfont}B /ch-width{ch-data dup length 5 sub get}
-B /ch-height{ch-data dup length 4 sub get}B /ch-xoff{128 ch-data dup
-length 3 sub get sub}B /ch-yoff{ch-data dup length 2 sub get 127 sub}B
-/ch-dx{ch-data dup length 1 sub get}B /ch-image{ch-data dup type
-/stringtype ne{ctr get /ctr ctr 1 add N}if}B /id 0 N /rw 0 N /rc 0 N /gp
-0 N /cp 0 N /G 0 N /sf 0 N /CharBuilder{save 3 1 roll S dup /base get 2
-index get S /BitMaps get S get /ch-data X pop /ctr 0 N ch-dx 0 ch-xoff
-ch-yoff ch-height sub ch-xoff ch-width add ch-yoff setcachedevice
-ch-width ch-height true[1 0 0 -1 -.1 ch-xoff sub ch-yoff .1 add]{
-ch-image}imagemask restore}B /D{/cc X dup type /stringtype ne{]}if nn
-/base get cc ctr put nn /BitMaps get S ctr S sf 1 ne{dup dup length 1
-sub dup 2 index S get sf div put}if put /ctr ctr 1 add N}B /I{cc 1 add D
-}B /bop{userdict /bop-hook known{bop-hook}if /SI save N @rigin 0 0
-moveto /V matrix currentmatrix dup 1 get dup mul exch 0 get dup mul add
-.99 lt{/QV}{/RV}ifelse load def pop pop}N /eop{SI restore showpage
-userdict /eop-hook known{eop-hook}if}N /@start{userdict /start-hook
-known{start-hook}if pop /VResolution X /Resolution X 1000 div /DVImag X
-/IE 256 array N 0 1 255{IE S 1 string dup 0 3 index put cvn put}for
-65781.76 div /vsize X 65781.76 div /hsize X}N /p{show}N /RMat[1 0 0 -1 0
-0]N /BDot 260 string N /rulex 0 N /ruley 0 N /v{/ruley X /rulex X V}B /V
-{}B /RV statusdict begin /product where{pop product dup length 7 ge{0 7
-getinterval dup(Display)eq exch 0 4 getinterval(NeXT)eq or}{pop false}
-ifelse}{false}ifelse end{{gsave TR -.1 -.1 TR 1 1 scale rulex ruley
-false RMat{BDot}imagemask grestore}}{{gsave TR -.1 -.1 TR rulex ruley
-scale 1 1 false RMat{BDot}imagemask grestore}}ifelse B /QV{gsave
-transform round exch round exch itransform moveto rulex 0 rlineto 0
-ruley neg rlineto rulex neg 0 rlineto fill grestore}B /a{moveto}B /delta
-0 N /tail{dup /delta X 0 rmoveto}B /M{S p delta add tail}B /b{S p tail}
-B /c{-4 M}B /d{-3 M}B /e{-2 M}B /f{-1 M}B /g{0 M}B /h{1 M}B /i{2 M}B /j{
-3 M}B /k{4 M}B /w{0 rmoveto}B /l{p -4 w}B /m{p -3 w}B /n{p -2 w}B /o{p
--1 w}B /q{p 1 w}B /r{p 2 w}B /s{p 3 w}B /t{p 4 w}B /x{0 S rmoveto}B /y{
-3 2 roll p a}B /bos{/SS save N}B /eos{SS restore}B end
-%%EndProcSet
-TeXDict begin 40258431 52099146 1000 300 300 () @start
-/Fa 1 111 df<383C0044C6004702004602008E06000C06000C06000C0C00180C00180C
-40181840181880300880300F00120E7F8D15>110 D E /Fb 3 111
-df<70F8F8F87005057C840D>58 D<70F8FCFC74040404080810102040060E7C840D>I<1E
-07802318C023A06043C0704380704380708700E00700E00700E00700E00E01C00E01C00E
-01C00E03821C03841C07041C07081C03083803101801E017147E931B>110
-D E /Fc 28 122 df<00003FE00000E01000018038000380780003007800070030000700
-000007000000070000000E0000000E0000000E000000FFFFE0000E00E0001C01C0001C01
-C0001C01C0001C01C0001C03800038038000380380003803800038070000380700007007
-000070071000700E2000700E2000700E2000E00E2000E0064000E0038000E0000000C000
-0001C0000001C000003180000079800000F3000000620000003C0000001D29829F1A>12
-D<7FF0FFE07FE00C037D8A10>45 D<01FFF800001F0000001E0000001E0000001E000000
-3C0000003C0000003C0000003C00000078000000780000007800000078000000F0000000
-F0000000F0000000F0000001E0000001E0000001E0000001E0008003C0010003C0010003
-C0030003C00200078006000780060007800C0007801C000F007800FFFFF800191F7D9E1D
->76 D<01FFFF80001E00E0001E0070001E0038001E003C003C003C003C003C003C003C00
-3C003C0078007800780078007800F0007800E000F003C000F00F0000FFFC0000F0000001
-E0000001E0000001E0000001E0000003C0000003C0000003C0000003C000000780000007
-80000007800000078000000F800000FFF000001E1F7D9E1F>80 D<FFF007FC0F8000E00F
-0000C00F0000800F0001000F0001000F0002000F0004000F0004000F8008000780080007
-8010000780200007802000078040000780400007808000078100000781000007C2000003
-C2000003C4000003C8000003C8000003D0000003D0000003E0000003C0000003C0000003
-80000001800000010000001E20779E22>86 D<00F1800389C00707800E03801C03803C03
-80380700780700780700780700F00E00F00E00F00E00F00E20F01C40F01C40703C40705C
-40308C800F070013147C9317>97 D<07803F8007000700070007000E000E000E000E001C
-001C001CF01D0C3A0E3C0E380F380F700F700F700F700FE01EE01EE01EE01CE03CE03860
-7060E031C01F0010207B9F15>I<007E0001C1000300800E07801E07801C07003C020078
-0000780000780000F00000F00000F00000F00000F0000070010070020030040018380007
-C00011147C9315>I<0000780003F80000700000700000700000700000E00000E00000E0
-0000E00001C00001C000F1C00389C00707800E03801C03803C0380380700780700780700
-780700F00E00F00E00F00E00F00E20F01C40F01C40703C40705C40308C800F070015207C
-9F17>I<007C01C207010E011C013C013802780C7BF07C00F000F000F000F00070007001
-70023804183807C010147C9315>I<00007800019C00033C00033C000718000700000700
-000E00000E00000E00000E00000E0001FFE0001C00001C00001C00001C00003800003800
-00380000380000380000700000700000700000700000700000700000E00000E00000E000
-00E00000C00001C00001C0000180003180007B0000F300006600003C00001629829F0E>
-I<003C6000E27001C1E00380E00700E00F00E00E01C01E01C01E01C01E01C03C03803C03
-803C03803C03803C07003C07001C0F001C17000C2E0003CE00000E00000E00001C00001C
-00301C00783800F0700060E0003F8000141D7E9315>I<01E0000FE00001C00001C00001
-C00001C000038000038000038000038000070000070000071E000763000E81800F01C00E
-01C00E01C01C03801C03801C03801C0380380700380700380700380E10700E20700C2070
-1C20700C40E00CC060070014207D9F17>I<00C001E001E001C000000000000000000000
-000000000E003300230043804300470087000E000E000E001C001C001C00384038803080
-7080310033001C000B1F7C9E0E>I<0001800003C00003C0000380000000000000000000
-000000000000000000000000003C00004600008700008700010700010700020E00000E00
-000E00000E00001C00001C00001C00001C00003800003800003800003800007000007000
-00700000700000E00000E00030E00079C000F180006300003C00001228829E0E>I<01E0
-000FE00001C00001C00001C00001C0000380000380000380000380000700000700000703
-C00704200E08E00E11E00E21E00E40C01C80001D00001E00001FC00038E0003870003870
-00383840707080707080707080703100E03100601E0013207D9F15>I<03C01FC0038003
-800380038007000700070007000E000E000E000E001C001C001C001C0038003800380038
-007000700070007100E200E200E200E200640038000A207C9F0C>I<1C0F80F0002630C3
-18004740640C004780680E004700700E004700700E008E00E01C000E00E01C000E00E01C
-000E00E01C001C01C038001C01C038001C01C038001C01C0708038038071003803806100
-380380E10038038062007007006600300300380021147C9325>I<1C0F802630C0474060
-4780604700704700708E00E00E00E00E00E00E00E01C01C01C01C01C01C01C0384380388
-3803083807083803107003303001C016147C931A>I<007C0001C3000301800E01C01E01
-C01C01E03C01E07801E07801E07801E0F003C0F003C0F003C0F00780F00700700F00700E
-0030180018700007C00013147C9317>I<01C1E002621804741C04781C04701E04701E08
-E01E00E01E00E01E00E01E01C03C01C03C01C03C01C0380380780380700380E003C1C007
-2380071E000700000700000E00000E00000E00000E00001C00001C0000FFC000171D8093
-17>I<1C1E002661004783804787804707804703008E00000E00000E00000E00001C0000
-1C00001C00001C000038000038000038000038000070000030000011147C9313>114
-D<00FC030206010C030C070C060C000F800FF007F803FC003E000E700EF00CF00CE00840
-1020601F8010147D9313>I<018001C0038003800380038007000700FFF007000E000E00
-0E000E001C001C001C001C003800380038003820704070407080708031001E000C1C7C9B
-0F>I<0E00C03300E02301C04381C04301C04701C08703800E03800E03800E03801C0700
-1C07001C07001C07101C0E20180E20180E201C1E200C264007C38014147C9318>I<0E03
-803307802307C04383C04301C04700C08700800E00800E00800E00801C01001C01001C01
-001C02001C02001C04001C04001C08000E300003C00012147C9315>I<0383800CC44010
-68E01071E02071E02070C040E00000E00000E00000E00001C00001C00001C00001C04063
-8080F38080F38100E5810084C60078780013147D9315>120 D<0E00C03300E02301C043
-81C04301C04701C08703800E03800E03800E03801C07001C07001C07001C07001C0E0018
-0E00180E001C1E000C3C0007DC00001C00001C00003800F03800F07000E06000C0C00043
-80003E0000131D7C9316>I E /Fd 10 117 df<03FF8000700000700000700000E00000
-E00000E00000E00001C00001C00001C00001C00003800003800003800003800007000007
-00100700100700200E00200E00600E00400E00C01C0380FFFF80141A7D9918>76
-D<03FFF800701C00700600700700E00700E00700E00700E00701C00E01C00E01C01C01C0
-3803807003FF800380000380000700000700000700000700000E00000E00000E00000E00
-001C0000FFC000181A7D991A>80 D<01E006181C08380870087010FFE0E000E000E000E0
-00E0086010602030C01F000D107C8F12>101 D<030706000000000000384C4E8E9C9C1C
-3838707272E2E4643808197C980C>105 D<307C005986009E07009E07009C07009C0700
-380E00380E00380E00381C00701C80701C80703880703900E01900600E0011107C8F16>
-110 D<01F006180C0C180E300E700E600EE00EE00EE00CE01CE018E030606030C01F000F
-107C8F14>I<030F000590C009E0C009C06009C06009C0600380E00380E00380E00380E0
-0701C00701800703800703000E8E000E78000E00000E00001C00001C00001C00001C0000
-FF00001317808F14>I<30F059189E389C189C009C003800380038003800700070007000
-7000E00060000D107C8F10>114 D<03E004300830187018601C001F801FC00FE000E000
-60E060E06080C041803E000C107D8F10>I<06000E000E000E000E001C001C00FFC01C00
-38003800380038007000700070007000E100E100E100E200640038000A177C960D>I
-E /Fe 24 124 df<00800100020004000C00080018003000300030006000600060006000
-E000E000E000E000E000E000E000E000E000E00060006000600060003000300030001800
-08000C00040002000100008009267D9B0F>40 D<8000400020001000180008000C000600
-060006000300030003000300038003800380038003800380038003800380038003000300
-030003000600060006000C0008001800100020004000800009267E9B0F>I<60F0F07010
-101020204080040B7D830B>44 D<60F0F06004047D830B>46 D<03000700FF0007000700
-070007000700070007000700070007000700070007000700070007000700070007000700
-FFF00C187D9713>49 D<0F80106020304038803CC01CE01C401C003C0038003800700060
-00C001800100020004040804100430083FF87FF8FFF80E187E9713>I<00300030007000
-F000F001700370027004700C7008701070307020704070C070FFFF007000700070007000
-70007007FF10187F9713>52 D<07801860303070306018E018E018E01CE01CE01C601C60
-3C303C185C0F9C001C00180018003870307060604021801F000E187E9713>57
-D<FFFF000E01C00E00E00E00300E00380E001C0E001C0E000E0E000E0E000F0E000F0E00
-0F0E000F0E000F0E000F0E000F0E000F0E000E0E000E0E001E0E001C0E00380E00380E00
-700E01C0FFFF00181A7E991D>68 D<007F000001C1C000070070000E0038001C001C003C
-001E0038000E0078000F0070000700F0000780F0000780F0000780F0000780F0000780F0
-000780F0000780F000078078000F0078000F0038000E003C001E001C001C000E00380007
-00700001C1C000007F0000191A7E991E>79 D<7FFFFF00701C0700401C0100401C0100C0
-1C0180801C0080801C0080801C0080001C0000001C0000001C0000001C0000001C000000
-1C0000001C0000001C0000001C0000001C0000001C0000001C0000001C0000001C000000
-1C0000001C0000001C000003FFE000191A7F991C>84 D<FF801FC01E000F001C0006000E
-0004000E000400070008000700080007000800038010000380100003C0300001C0200001
-C0200000E0400000E0400000E04000007080000070800000390000003900000039000000
-1E0000001E0000001E0000000C0000000C00001A1A7F991D>86 D<3F8070C070E0207000
-70007007F01C7030707070E070E071E071E0F171FB1E3C10107E8F13>97
-D<FC00001C00001C00001C00001C00001C00001C00001C00001C00001C00001CF8001F0E
-001E07001C03801C01801C01C01C01C01C01C01C01C01C01C01C01C01C03801C03001E07
-001B0C0010F000121A7F9915>I<07F80C1C381C30087000E000E000E000E000E000E000
-7000300438080C1807E00E107F8F11>I<07C01C3030187018600CE00CFFFCE000E000E0
-00E0006000300438080C1807E00E107F8F11>101 D<18003C003C001800000000000000
-000000000000FC001C001C001C001C001C001C001C001C001C001C001C001C001C001C00
-FF80091A80990A>105 D<FC7C1F001D8E63801E0781C01E0781C01C0701C01C0701C01C
-0701C01C0701C01C0701C01C0701C01C0701C01C0701C01C0701C01C0701C01C0701C0FF
-9FE7F81D107F8F20>109 D<FCF8001D0C001E0E001E0E001C0E001C0E001C0E001C0E00
-1C0E001C0E001C0E001C0E001C0E001C0E001C0E00FF9FC012107F8F15>I<07E01C3830
-0C700E6006E007E007E007E007E007E0076006700E381C1C3807E010107F8F13>I<FCF8
-001F0E001E07001C03801C03801C01C01C01C01C01C01C01C01C01C01C01C01C03801C03
-001E07001F0C001CF0001C00001C00001C00001C00001C00001C0000FF800012177F8F15
->I<FCE01D701E701E201C001C001C001C001C001C001C001C001C001C001C00FFC00C10
-7F8F0F>114 D<0400040004000C000C001C003C00FFC01C001C001C001C001C001C001C
-001C001C201C201C201C201C200E4003800B177F960F>116 D<FFFFC01201808913>123
-D E /Ff 1 50 df<0C003C00CC000C000C000C000C000C000C000C000C000C000C000C00
-0C00FF8009107E8F0F>49 D E /Fg 30 121 df<0000600000E00000E00001C00001C000
-0380000380000380000700000700000700000E00000E00001C00001C00001C0000380000
-380000380000700000700000E00000E00000E00001C00001C00003800003800003800007
-00000700000700000E00000E00001C00001C00001C000038000038000038000070000070
-0000E00000E00000C00000132D7DA11A>47 D<387CFEFEFE7C38000000000000387CFEFE
-FE7C3807147C930F>58 D<0000E000000000E000000001F000000001F000000001F00000
-0003F800000003F800000006FC00000006FC0000000EFE0000000C7E0000000C7E000000
-183F000000183F000000303F800000301F800000701FC00000600FC00000600FC00000C0
-07E00000FFFFE00001FFFFF000018003F000018003F000030001F800030001F800060001
-FC00060000FC000E0000FE00FFE00FFFE0FFE00FFFE0231F7E9E28>65
-D<0007FC02003FFF0E00FE03DE03F000FE07E0003E0FC0001E1F80001E3F00000E3F0000
-0E7F0000067E0000067E000006FE000000FE000000FE000000FE000000FE000000FE0000
-00FE0000007E0000007E0000067F0000063F0000063F00000C1F80000C0FC0001807E000
-3803F0007000FE01C0003FFF800007FC001F1F7D9E26>67 D<FFFFFFE0FFFFFFE007E007
-E007E001E007E000E007E0006007E0007007E0003007E0003007E0603007E0603007E060
-0007E0E00007E1E00007FFE00007FFE00007E1E00007E0E00007E0600007E0600C07E060
-0C07E0000C07E0001807E0001807E0001807E0003807E0007807E000F807E003F0FFFFFF
-F0FFFFFFF01E1F7E9E22>69 D<FFFFFFFF07E007E007E007E007E007E007E007E007E007
-E007E007E007E007E007E007E007E007E007E007E007E007E007E007E007E007E007E0FF
-FFFFFF101F7E9E14>73 D<FFE000003FF8FFF000007FF807F000007F0006F80000DF0006
-F80000DF0006F80000DF00067C00019F00067C00019F00063E00031F00063E00031F0006
-1F00061F00061F00061F00060F800C1F00060F800C1F000607C0181F000607C0181F0006
-07C0181F000603E0301F000603E0301F000601F0601F000601F0601F000600F8C01F0006
-00F8C01F0006007D801F0006007D801F0006003F001F0006003F001F0006003F001F0006
-001E001F00FFF01E03FFF8FFF00C03FFF82D1F7E9E32>77 D<03FC080FFF381E03F83800
-F8700078700038F00038F00018F00018F80000FC00007FC0007FFE003FFF801FFFE00FFF
-F007FFF000FFF80007F80000FC00007C00003CC0003CC0003CC0003CE00038E00078F800
-70FE01E0E7FFC081FF00161F7D9E1D>83 D<FFFF01FFE0FFFF01FFE007E0000C0007E000
-0C0007E0000C0007E0000C0007E0000C0007E0000C0007E0000C0007E0000C0007E0000C
-0007E0000C0007E0000C0007E0000C0007E0000C0007E0000C0007E0000C0007E0000C00
-07E0000C0007E0000C0007E0000C0007E0000C0007E0000C0007E0000C0003E000180001
-F000180001F000300000F8006000007E03C000001FFF80000003FC0000231F7E9E28>85
-D<07FC001FFF003F0F803F07C03F03E03F03E00C03E00003E0007FE007FBE01F03E03C03
-E07C03E0F803E0F803E0F803E0FC05E07E0DE03FF8FE0FE07E17147F9319>97
-D<01FE0007FF801F0FC03E0FC03E0FC07C0FC07C0300FC0000FC0000FC0000FC0000FC00
-00FC00007C00007E00003E00603F00C01F81C007FF0001FC0013147E9317>99
-D<0007F80007F80000F80000F80000F80000F80000F80000F80000F80000F80000F80000
-F801F8F80FFEF81F83F83E01F87E00F87C00F87C00F8FC00F8FC00F8FC00F8FC00F8FC00
-F8FC00F87C00F87C00F87E00F83E01F81F07F80FFEFF03F8FF18207E9F1D>I<01FE0007
-FF800F83C01E01E03E00F07C00F07C00F8FC00F8FFFFF8FFFFF8FC0000FC0000FC00007C
-00007C00003E00181E00180F807007FFE000FF8015147F9318>I<001F8000FFC001F3E0
-03E7E003C7E007C7E007C3C007C00007C00007C00007C00007C000FFFC00FFFC0007C000
-07C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C000
-07C00007C00007C0003FFC003FFC0013207F9F10>I<01FC3C07FFFE0F079E1E03DE3E03
-E03E03E03E03E03E03E03E03E01E03C00F07800FFF0009FC001800001800001C00001FFF
-800FFFF007FFF81FFFFC3C007C70003EF0001EF0001EF0001E78003C78003C3F01F80FFF
-E001FF00171E7F931A>I<FF0000FF00001F00001F00001F00001F00001F00001F00001F
-00001F00001F00001F00001F0FC01F3FE01F61F01FC0F81F80F81F00F81F00F81F00F81F
-00F81F00F81F00F81F00F81F00F81F00F81F00F81F00F81F00F81F00F8FFE3FFFFE3FF18
-207D9F1D>I<1C003E007F007F007F003E001C00000000000000000000000000FF00FF00
-1F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F00FFE0FFE0
-0B217EA00E>I<FF0000FF00001F00001F00001F00001F00001F00001F00001F00001F00
-001F00001F00001F01FE1F01FE1F00F01F00C01F03801F07001F0C001F18001F7C001FFC
-001F9E001F0F001E0F801E07C01E03C01E01E01E01F01E00F8FFC3FFFFC3FF18207E9F1C
->107 D<FF00FF001F001F001F001F001F001F001F001F001F001F001F001F001F001F00
-1F001F001F001F001F001F001F001F001F001F001F001F001F001F00FFE0FFE00B207E9F
-0E>I<FE0FE03F80FE1FF07FC01E70F9C3E01E407D01F01E807E01F01F807E01F01F007C
-01F01F007C01F01F007C01F01F007C01F01F007C01F01F007C01F01F007C01F01F007C01
-F01F007C01F01F007C01F01F007C01F01F007C01F0FFE3FF8FFEFFE3FF8FFE27147D932C
->I<FE0FC0FE3FE01E61F01EC0F81E80F81F00F81F00F81F00F81F00F81F00F81F00F81F
-00F81F00F81F00F81F00F81F00F81F00F81F00F8FFE3FFFFE3FF18147D931D>I<01FF00
-07FFC01F83F03E00F83E00F87C007C7C007CFC007EFC007EFC007EFC007EFC007EFC007E
-7C007C7C007C3E00F83E00F81F83F007FFC001FF0017147F931A>I<FF1FC0FF7FF01FE1
-F81F80FC1F007E1F007E1F003E1F003F1F003F1F003F1F003F1F003F1F003F1F003E1F00
-7E1F007C1F80FC1FC1F81F7FE01F1F801F00001F00001F00001F00001F00001F00001F00
-00FFE000FFE000181D7E931D>I<FE3E00FE7F801ECFC01E8FC01E8FC01F8FC01F03001F
-00001F00001F00001F00001F00001F00001F00001F00001F00001F00001F0000FFF000FF
-F00012147E9316>114 D<0FE63FFE701E600EE006E006F800FFC07FF83FFC1FFE03FE00
-1FC007C007E007F006F81EFFFCC7F010147E9315>I<0180018001800380038003800780
-0F803F80FFFCFFFC0F800F800F800F800F800F800F800F800F800F800F860F860F860F86
-0F8607CC03F801F00F1D7F9C14>I<FF07F8FF07F81F00F81F00F81F00F81F00F81F00F8
-1F00F81F00F81F00F81F00F81F00F81F00F81F00F81F00F81F01F81F01F80F06F807FCFF
-03F8FF18147D931D>I<FFE07F80FFE07F801F001C000F8018000F80180007C0300007C0
-300003E0600003E0600001F0C00001F0C00001F9C00000F9800000FF8000007F0000007F
-0000003E0000003E0000001C0000001C000019147F931C>I<FFE7FE1FE0FFE7FE1FE01F
-00F003001F00F803000F80F806000F80F8060007C1BC0C0007C1BC0C0007C1BE0C0003E3
-1E180003E31E180001F60F300001F60F300001F60FB00000FC07E00000FC07E000007803
-C000007803C000007803C000003001800023147F9326>I<FFE1FF00FFE1FF000F807000
-07C0E00007E0C00003E1800001F3800000FF0000007E0000003E0000003F0000007F8000
-006F800000C7C0000183E0000381F0000701F8000E00FC00FF81FF80FF81FF8019147F93
-1C>I E /Fh 6 106 df<FFFFFFC0FFFFFFC01A027C8B23>0 D<01800180018001800180
-C183F18F399C0FF003C003C00FF0399CF18FC1830180018001800180018010147D9417>
-3 D<03C00FF01FF83FFC7FFE7FFEFFFFFFFFFFFFFFFFFFFFFFFF7FFE7FFE3FFC1FF80FF0
-03C010127D9317>15 D<0000000400000000020000000002000000000100000000008000
-000000400000000020FFFFFFFFFCFFFFFFFFFC0000000020000000004000000000800000
-00010000000002000000000200000000040026107D922D>33 D<004000C0018001800180
-0300030003000600060006000C000C00180018001800300030003000600060006000C000
-C0006000600060003000300030001800180018000C000C00060006000600030003000300
-01800180018000C000400A2E7CA112>104 D<C000C00060006000600030003000300018
-00180018000C000C0006000600060003000300030001800180018000C000C00180018001
-800300030003000600060006000C000C00180018001800300030003000600060006000C0
-00C0000A2E7DA112>I E /Fi 40 122 df<70F8F8F8F8F8F8F8F8F8F8F8F8F8F8F8F870
-000000000070F8F8F870051C779B18>33 D<030600078F00078F00078F00078F00078F00
-078F007FFFC0FFFFE0FFFFE07FFFC00F1E000F1E000F1E000F1E000F1E000F1E007FFFC0
-FFFFE0FFFFE07FFFC01E3C001E3C001E3C001E3C001E3C001E3C000C1800131C7E9B18>
-35 D<387C7C7E3E0E0E0E1C1C38F8F0C0070E789B18>39 D<007000F001E003C007800F
-001E001C00380038007000700070007000E000E000E000E000E000E000E000E000700070
-0070007000380038001C001E000F00078003C001F000F000700C24799F18>I<6000F000
-78003C001E000F000780038001C001C000E000E000E000E0007000700070007000700070
-0070007000E000E000E000E001C001C0038007800F001E003C007800F00060000C247C9F
-18>I<01C00001C00001C00001C000C1C180F1C780F9CF807FFF001FFC0007F00007F000
-1FFC007FFF00F9CF80F1C780C1C18001C00001C00001C00001C00011147D9718>I<0060
-0000F00000F00000F00000F00000F00000F00000F0007FFFC0FFFFE0FFFFE07FFFC000F0
-0000F00000F00000F00000F00000F00000F00000600013147E9718>I<7FFF00FFFF80FF
-FF807FFF0011047D8F18>45 D<3078FCFC78300606778518>I<03F0000FFE003FFF007C
-0F807003C0E001C0F000E0F000E06000E00000E00000E00001C00001C00003C000078000
-0F00001E00003C0000780000F00001E00007C0000F80001E00E03C00E07FFFE0FFFFE07F
-FFE0131C7E9B18>50 D<07F8001FFE003FFF007807807803C07801C03001C00001C00003
-C0000380000F0003FF0003FE0003FF000007800003C00001C00000E00000E00000E0F000
-E0F000E0F001C0F003C07C07803FFF001FFE0003F800131C7E9B18>I<1FFF803FFF803F
-FF803800003800003800003800003800003800003800003800003BF8003FFE003FFF003C
-07801803C00001C00000E00000E06000E0F000E0F000E0E001C07003C07C0F803FFF001F
-FC0003F000131C7E9B18>53 D<007E0001FF0007FF800F83C01E03C01C03C03801803800
-00700000700000E1F800E7FE00FFFF00FE0780F803C0F001C0F000E0E000E0F000E07000
-E07000E07000E03801C03C03C01E07800FFF0007FE0001F800131C7E9B18>I<600000F0
-0000FC00007E00003F00001FC00007E00003F00001FC00007E00003F00001F80001F8000
-3F00007E0001FC0003F00007E0001FC0003F00007E0000FC0000F0000060000011187D99
-18>62 D<0FF0003FFC007FFF00700F00F00380F00380600780000F00003E00007C0001F0
-0001E00003C00003C00003C00003C00003C0000380000000000000000000000000000000
-0003800007C00007C00007C000038000111C7D9B18>I<007C0001FE0007FF000F87801E
-03C03C1DC0387FC070FFE071E3E071C1E0E1C1E0E380E0E380E0E380E0E380E0E380E0E3
-80E0E1C1C071C1C071E3C070FF80387F003C1C001E00E00F83E007FFC001FF80007E0013
-1C7E9B18>I<1FE0003FF8007FFC00781E00300E0000070000070000FF0007FF001FFF00
-7F0700780700E00700E00700E00700F00F00781F003FFFF01FFBF007E1F014147D9318>
-97 D<7E0000FE00007E00000E00000E00000E00000E00000E00000E3E000EFF800FFFC0
-0FC1E00F80E00F00700E00700E00380E00380E00380E00380E00380E00380F00700F0070
-0F80E00FC1E00FFFC00EFF80063E00151C809B18>I<01FE0007FF001FFF803E07803803
-00700000700000E00000E00000E00000E00000E00000E000007000007001C03801C03E03
-C01FFF8007FF0001FC0012147D9318>I<001F80003F80001F8000038000038000038000
-038000038003E3800FFB801FFF803C1F80380F80700780700380E00380E00380E00380E0
-0380E00380E00380700780700780380F803C1F801FFFF00FFBF803E3F0151C7E9B18>I<
-01F00007FC001FFE003E0F00380780700380700380E001C0E001C0FFFFC0FFFFC0FFFFC0
-E000007000007001C03801C03E03C01FFF8007FF0001FC0012147D9318>I<001F80007F
-C000FFE000E1E001C0C001C00001C00001C0007FFFC0FFFFC0FFFFC001C00001C00001C0
-0001C00001C00001C00001C00001C00001C00001C00001C00001C00001C00001C0007FFF
-007FFF007FFF00131C7F9B18>I<01E1F007FFF80FFFF81E1E301C0E0038070038070038
-07003807003807001C0E001E1E001FFC001FF80039E0003800001C00001FFE001FFFC03F
-FFE07801F0700070E00038E00038E00038E000387800F07E03F01FFFC00FFF8001FC0015
-1F7F9318>I<7E0000FE00007E00000E00000E00000E00000E00000E00000E3E000EFF80
-0FFFC00FC1C00F80E00F00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E0
-0E00E00E00E00E00E07FC3FCFFE7FE7FC3FC171C809B18>I<03800007C00007C00007C0
-000380000000000000000000000000007FC000FFC0007FC00001C00001C00001C00001C0
-0001C00001C00001C00001C00001C00001C00001C00001C00001C00001C000FFFF00FFFF
-80FFFF00111D7C9C18>I<0038007C007C007C003800000000000000000FFC1FFC0FFC00
-1C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C00
-1C001C001C001C6038F078FFF07FE03F800E277E9C18>I<7FE000FFE0007FE00000E000
-00E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E000
-00E00000E00000E00000E00000E00000E00000E00000E00000E0007FFFC0FFFFE07FFFC0
-131C7E9B18>108 D<7CE0E000FFFBF8007FFFF8001F1F1C001E1E1C001E1E1C001C1C1C
-001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C
-001C1C1C007F1F1F00FFBFBF807F1F1F001914819318>I<7E3E00FEFF807FFFC00FC1C0
-0F80E00F00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E0
-0E00E07FC3FCFFE7FE7FC3FC1714809318>I<01F0000FFE001FFF003E0F803803807001
-C07001C0E000E0E000E0E000E0E000E0E000E0F001E07001C07803C03C07803E0F801FFF
-000FFE0001F00013147E9318>I<7E3E00FEFF807FFFC00FC1E00F80E00F00700E00700E
-00380E00380E00380E00380E00380E00380F00700F00700F80E00FC1E00FFFC00EFF800E
-3E000E00000E00000E00000E00000E00000E00000E00007FC000FFE0007FC000151E8093
-18>I<01E38007FB801FFF803E1F80380F80700780700780E00380E00380E00380E00380
-E00380E00380700780700780380F803C1F801FFF800FFB8003E380000380000380000380
-000380000380000380000380003FF8003FF8003FF8151E7E9318>I<7F87E0FF9FF07FBF
-F803F87803F03003E00003C00003C0000380000380000380000380000380000380000380
-000380000380007FFE00FFFF007FFE0015147F9318>I<07F7003FFF007FFF00780F00E0
-0700E00700E007007C00007FE0001FFC0003FE00001F00600780E00380E00380F00380F8
-0F00FFFF00FFFC00E7F00011147D9318>I<0180000380000380000380000380007FFFC0
-FFFFC0FFFFC0038000038000038000038000038000038000038000038000038000038040
-0380E00380E00380E001C1C001FFC000FF80003E0013197F9818>I<7E07E0FE0FE07E07
-E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00
-E00E01E00F03E007FFFC03FFFE01FCFC1714809318>I<7F8FF0FF8FF87F8FF01E03C00E
-03800E03800E0380070700070700070700038E00038E00038E00038E0001DC0001DC0001
-DC0000F80000F80000700015147F9318>I<FF8FF8FF8FF8FF8FF83800E03800E03800E0
-1C01C01C01C01C71C01CF9C01CF9C01CD9C01CD9C00DDD800DDD800DDD800D8D800F8F80
-0F8F8007070015147F9318>I<7F8FF07F9FF07F8FF0070700078E00039E0001DC0001F8
-0000F80000700000F00000F80001DC00039E00038E000707000F07807F8FF0FF8FF87F8F
-F015147F9318>I<7F8FF0FF8FF87F8FF00E01C00E03800E038007038007070007070003
-8700038600038E0001CE0001CE0000CC0000CC0000DC0000780000780000780000700000
-700000700000F00000E00079E0007BC0007F80003F00001E0000151E7F9318>I
-E /Fj 73 123 df<001F83E000F06E3001C078780380F8780300F0300700700007007000
-0700700007007000070070000700700007007000FFFFFF80070070000700700007007000
-070070000700700007007000070070000700700007007000070070000700700007007000
-0700700007007000070070000700700007007000070070007FE3FF001D20809F1B>11
-D<003F0000E0C001C0C00381E00701E00701E00700000700000700000700000700000700
-00FFFFE00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700
-E00700E00700E00700E00700E00700E00700E00700E07FC3FE1720809F19>I<001F81F8
-0000F04F040001C07C06000380F80F000300F00F000700F00F0007007000000700700000
-0700700000070070000007007000000700700000FFFFFFFF000700700700070070070007
-007007000700700700070070070007007007000700700700070070070007007007000700
-700700070070070007007007000700700700070070070007007007000700700700070070
-070007007007007FE3FE3FF02420809F26>14 D<7038F87CFC7EFC7E743A040204020402
-0804080410081008201040200F0E7E9F17>34 D<70F8FCFC74040404080810102040060E
-7C9F0D>39 D<0020004000800100020006000C000C001800180030003000300070006000
-60006000E000E000E000E000E000E000E000E000E000E000E000E0006000600060007000
-300030003000180018000C000C000600020001000080004000200B2E7DA112>I<800040
-002000100008000C00060006000300030001800180018001C000C000C000C000E000E000
-E000E000E000E000E000E000E000E000E000E000C000C000C001C0018001800180030003
-00060006000C00080010002000400080000B2E7DA112>I<70F8FCFC7404040408081010
-2040060E7C840D>44 D<FFC0FFC00A027F8A0F>I<70F8F8F87005057C840D>I<03F0000E
-1C001C0E00180600380700700380700380700380700380F003C0F003C0F003C0F003C0F0
-03C0F003C0F003C0F003C0F003C0F003C0F003C0F003C0F003C070038070038070038078
-07803807001806001C0E000E1C0003F000121F7E9D17>48 D<018003800F80F380038003
-800380038003800380038003800380038003800380038003800380038003800380038003
-80038003800380038007C0FFFE0F1E7C9D17>I<03F0000C1C00100E0020070040078080
-0780F007C0F803C0F803C0F803C02007C00007C0000780000780000F00000E00001C0000
-380000700000600000C0000180000300000600400C00401800401000803FFF807FFF80FF
-FF80121E7E9D17>I<03F0000C1C00100E00200F00780F80780780780780380F80000F80
-000F00000F00000E00001C0000380003F000003C00000E00000F000007800007800007C0
-2007C0F807C0F807C0F807C0F00780400780400F00200E001C3C0003F000121F7E9D17>
-I<000600000600000E00000E00001E00002E00002E00004E00008E00008E00010E00020E
-00020E00040E00080E00080E00100E00200E00200E00400E00C00E00FFFFF0000E00000E
-00000E00000E00000E00000E00000E0000FFE0141E7F9D17>I<1803001FFE001FFC001F
-F8001FE00010000010000010000010000010000010000011F000161C00180E0010070010
-07800003800003800003C00003C00003C07003C0F003C0F003C0E0038040038040070020
-0600100E000C380003E000121F7E9D17>I<007C000182000701000E03800C07801C0780
-380300380000780000700000700000F1F000F21C00F40600F80700F80380F80380F003C0
-F003C0F003C0F003C0F003C07003C07003C07003803803803807001807000C0E00061C00
-01F000121F7E9D17>I<4000007FFFC07FFF807FFF804001008002008002008004000008
-0000080000100000200000200000400000400000C00000C00001C0000180000380000380
-00038000038000078000078000078000078000078000078000078000030000121F7D9D17
->I<03F0000C0C001006003003002001806001806001806001807001807803003E03003F
-06001FC8000FF00003F80007FC000C7E00103F00300F806003804001C0C001C0C000C0C0
-00C0C000C0C000806001802001001002000C0C0003F000121F7E9D17>I<03F0000E1800
-1C0C00380600380700700700700380F00380F00380F003C0F003C0F003C0F003C0F003C0
-7007C07007C03807C0180BC00E13C003E3C0000380000380000380000700300700780600
-780E00700C002018001070000FC000121F7E9D17>I<70F8F8F870000000000000000000
-0070F8F8F87005147C930D>I<70F8F8F8700000000000000000000070F0F8F878080808
-101010202040051D7C930D>I<0FC0307040384038E03CF03CF03C603C0038007000E000
-C001800180010003000200020002000200020002000000000000000000000007000F800F
-800F8007000E207D9F15>63 D<000100000003800000038000000380000007C0000007C0
-000007C0000009E0000009E0000009E0000010F0000010F0000010F00000207800002078
-000020780000403C0000403C0000403C0000801E0000801E0000FFFE0001000F0001000F
-0001000F00020007800200078002000780040003C00E0003C01F0007E0FFC03FFE1F207F
-9F22>65 D<FFFFE0000F80380007801E0007801F0007800F0007800F8007800F8007800F
-8007800F8007800F8007800F0007801F0007801E0007803C0007FFF00007803C0007801E
-0007800F0007800F8007800780078007C0078007C0078007C0078007C0078007C0078007
-8007800F8007800F0007801F000F803C00FFFFF0001A1F7E9E20>I<000FC040007030C0
-01C009C0038005C0070003C00E0001C01E0000C01C0000C03C0000C07C0000407C000040
-78000040F8000000F8000000F8000000F8000000F8000000F8000000F8000000F8000000
-F8000000780000007C0000407C0000403C0000401C0000401E0000800E00008007000100
-0380020001C0040000703800000FC0001A217D9F21>I<FFFFE0000F803C0007801E0007
-80070007800380078003C0078001E0078001E0078001F0078000F0078000F0078000F807
-8000F8078000F8078000F8078000F8078000F8078000F8078000F8078000F8078000F007
-8000F0078000F0078001E0078001E0078003C0078003800780070007800E000F803C00FF
-FFE0001D1F7E9E23>I<FFFFFF000F800F00078003000780030007800100078001800780
-00800780008007800080078080800780800007808000078080000781800007FF80000781
-800007808000078080000780800007808000078000200780002007800020078000400780
-004007800040078000C0078000C0078001800F800F80FFFFFF801B1F7E9E1F>I<FFFFFF
-000F800F0007800300078003000780010007800180078000800780008007800080078000
-80078080000780800007808000078080000781800007FF80000781800007808000078080
-000780800007808000078000000780000007800000078000000780000007800000078000
-00078000000FC00000FFFE0000191F7E9E1E>I<000FE0200078186000E004E0038002E0
-070001E00F0000E01E0000601E0000603C0000603C0000207C00002078000020F8000000
-F8000000F8000000F8000000F8000000F8000000F8000000F8007FFCF80003E0780001E0
-7C0001E03C0001E03C0001E01E0001E01E0001E00F0001E0070001E0038002E000E00460
-00781820000FE0001E217D9F24>I<FFF8FFF80F800F8007800F0007800F0007800F0007
-800F0007800F0007800F0007800F0007800F0007800F0007800F0007800F0007800F0007
-FFFF0007800F0007800F0007800F0007800F0007800F0007800F0007800F0007800F0007
-800F0007800F0007800F0007800F0007800F0007800F000F800F80FFF8FFF81D1F7E9E22
->I<FFFC0FC0078007800780078007800780078007800780078007800780078007800780
-0780078007800780078007800780078007800780078007800FC0FFFC0E1F7F9E10>I<0F
-FFC0007C00003C00003C00003C00003C00003C00003C00003C00003C00003C00003C0000
-3C00003C00003C00003C00003C00003C00003C00003C00003C00003C00003C00203C00F8
-3C00F83C00F83C00F0380040780040700030E0000F800012207E9E17>I<FFFC0FFC0FC0
-03E007800180078001000780020007800400078008000780100007802000078040000780
-8000078100000783000007878000078F80000793C0000791E00007A1E00007C0F0000780
-F0000780780007803C0007803C0007801E0007801E0007800F0007800780078007800780
-07C00FC007E0FFFC3FFC1E1F7E9E23>I<FFFE000FC00007800007800007800007800007
-800007800007800007800007800007800007800007800007800007800007800007800007
-800007800007800207800207800207800207800607800407800407800C07801C0F807CFF
-FFFC171F7E9E1C>I<FF803FF807C007C007C0038005E0010005E0010004F00100047801
-0004780100043C0100043C0100041E0100040F0100040F010004078100040781000403C1
-000401E1000401E1000400F1000400F1000400790004003D0004003D0004001F0004001F
-0004000F0004000700040007000E0003001F000300FFE001001D1F7E9E22>78
-D<001F800000F0F00001C0380007801E000F000F000E0007001E0007803C0003C03C0003
-C07C0003E0780001E0780001E0F80001F0F80001F0F80001F0F80001F0F80001F0F80001
-F0F80001F0F80001F0F80001F0780001E07C0003E07C0003E03C0003C03C0003C01E0007
-800E0007000F000F0007801E0001C0380000F0F000001F80001C217D9F23>I<FFFFE000
-0F80780007801C0007801E0007800F0007800F8007800F8007800F8007800F8007800F80
-07800F8007800F0007801E0007801C000780780007FFE000078000000780000007800000
-078000000780000007800000078000000780000007800000078000000780000007800000
-078000000FC00000FFFC0000191F7E9E1F>I<FFFF80000F80F0000780780007803C0007
-801E0007801E0007801F0007801F0007801F0007801F0007801E0007801E0007803C0007
-8078000780F00007FF80000781C0000780E0000780F00007807000078078000780780007
-80780007807C0007807C0007807C0007807C0407807E0407803E040FC01E08FFFC0F1000
-0003E01E207E9E21>82 D<07E0800C1980100780300380600180600180E00180E00080E0
-0080E00080F00000F000007800007F00003FF0001FFC000FFE0003FF00001F8000078000
-03C00003C00001C08001C08001C08001C08001C0C00180C00380E00300F00600CE0C0081
-F80012217D9F19>I<7FFFFFE0780F01E0600F0060400F0020400F0020C00F0030800F00
-10800F0010800F0010800F0010000F0000000F0000000F0000000F0000000F0000000F00
-00000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F00
-00000F0000000F0000000F0000000F0000001F800007FFFE001C1F7E9E21>I<FFFC3FF8
-0FC007C00780038007800100078001000780010007800100078001000780010007800100
-078001000780010007800100078001000780010007800100078001000780010007800100
-0780010007800100078001000780010007800100038002000380020001C0020001C00400
-00E008000070180000382000000FC0001D207E9E22>I<FFF003FE1F8000F80F0000600F
-800060078000400780004003C0008003C0008003C0008001E0010001E0010001F0010000
-F0020000F0020000F806000078040000780400003C0800003C0800003C0800001E100000
-1E1000001F3000000F2000000F20000007C0000007C0000007C000000380000003800000
-038000000100001F207F9E22>I<FFF07FF81FF01F800FC007C00F00078003800F000780
-01000F0007C00100078007C00200078007C00200078007C0020003C009E0040003C009E0
-040003C009E0040003E010F00C0001E010F0080001E010F0080001F02078080000F02078
-100000F02078100000F0403C10000078403C20000078403C20000078C03E2000003C801E
-4000003C801E4000003C801E4000001F000F8000001F000F8000001F000F8000001E0007
-8000000E00070000000E00070000000C000300000004000200002C207F9E2F>I<7FF83F
-F80FE00FC007C0070003C0020001E0040001F00C0000F0080000781000007C1000003C20
-00003E4000001E4000000F8000000F8000000780000003C0000007E0000005E0000009F0
-000018F8000010780000207C0000603C0000401E0000801F0001800F0001000780020007
-C0070003C01F8007E0FFE01FFE1F1F7F9E22>I<08041008201020104020402080408040
-8040B85CFC7EFC7E7C3E381C0F0E7B9F17>92 D<081020204040808080B8FCFC7C38060E
-7D9F0D>96 D<1FE000303000781800781C00300E00000E00000E00000E0000FE00078E00
-1E0E00380E00780E00F00E10F00E10F00E10F01E10781E103867200F83C014147E9317>
-I<0E0000FE00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00
-000E3E000EC3800F01C00F00E00E00E00E00700E00700E00780E00780E00780E00780E00
-780E00780E00700E00700E00E00F00E00D01C00CC300083E0015207F9F19>I<03F80E0C
-1C1E381E380C70007000F000F000F000F000F000F00070007000380138011C020E0C03F0
-10147E9314>I<000380003F800003800003800003800003800003800003800003800003
-8000038000038003E380061B801C0780380380380380700380700380F00380F00380F003
-80F00380F00380F003807003807003803803803807801C07800E1B8003E3F815207E9F19
->I<03F0000E1C001C0E00380700380700700700700380F00380F00380FFFF80F00000F0
-0000F000007000007000003800801800800C010007060001F80011147F9314>I<007C00
-C6018F038F07060700070007000700070007000700FFF007000700070007000700070007
-00070007000700070007000700070007000700070007007FF01020809F0E>I<0000E003
-E3300E3C301C1C30380E00780F00780F00780F00780F00780F00380E001C1C001E380033
-E0002000002000003000003000003FFE001FFF800FFFC03001E0600070C00030C00030C0
-0030C000306000603000C01C038003FC00141F7F9417>I<0E0000FE00000E00000E0000
-0E00000E00000E00000E00000E00000E00000E00000E00000E3E000E43000E81800F01C0
-0F01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C0
-0E01C00E01C00E01C0FFE7FC16207F9F19>I<1C003E003E003E001C0000000000000000
-00000000000E007E000E000E000E000E000E000E000E000E000E000E000E000E000E000E
-000E000E000E00FFC00A1F809E0C>I<00E001F001F001F000E000000000000000000000
-0000007007F000F000700070007000700070007000700070007000700070007000700070
-00700070007000700070007000706070F060F0C061803F000C28829E0E>I<0E0000FE00
-000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0FF00E03
-C00E03000E02000E04000E08000E10000E30000E70000EF8000F38000E1C000E1E000E0E
-000E07000E07800E03800E03C00E03E0FFCFF815207F9F18>I<0E00FE000E000E000E00
-0E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E00
-0E000E000E000E000E000E000E000E00FFE00B20809F0C>I<0E1F01F000FE618618000E
-81C81C000F00F00E000F00F00E000E00E00E000E00E00E000E00E00E000E00E00E000E00
-E00E000E00E00E000E00E00E000E00E00E000E00E00E000E00E00E000E00E00E000E00E0
-0E000E00E00E000E00E00E00FFE7FE7FE023147F9326>I<0E3E00FE43000E81800F01C0
-0F01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C0
-0E01C00E01C00E01C0FFE7FC16147F9319>I<01F800070E001C03803801C03801C07000
-E07000E0F000F0F000F0F000F0F000F0F000F0F000F07000E07000E03801C03801C01C03
-80070E0001F80014147F9317>I<0E3E00FEC3800F01C00F00E00E00E00E00F00E00700E
-00780E00780E00780E00780E00780E00780E00700E00F00E00E00F01E00F01C00EC3000E
-3E000E00000E00000E00000E00000E00000E00000E00000E0000FFE000151D7F9319>I<
-03E0800619801C05803C0780380380780380700380F00380F00380F00380F00380F00380
-F003807003807803803803803807801C0B800E138003E380000380000380000380000380
-000380000380000380000380003FF8151D7E9318>I<0E78FE8C0F1E0F1E0F0C0E000E00
-0E000E000E000E000E000E000E000E000E000E000E000E00FFE00F147F9312>I<1F9030
-704030C010C010C010E00078007F803FE00FF00070803880188018C018C018E030D0608F
-800D147E9312>I<020002000200060006000E000E003E00FFF80E000E000E000E000E00
-0E000E000E000E000E000E000E080E080E080E080E080610031001E00D1C7F9B12>I<0E
-01C0FE1FC00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E
-01C00E01C00E01C00E01C00E03C00603C0030DC001F1FC16147F9319>I<FF83F81E01E0
-1C00C00E00800E00800E008007010007010003820003820003820001C40001C40001EC00
-00E80000E80000700000700000700000200015147F9318>I<FF9FE1FC3C0780701C0300
-601C0380200E0380400E0380400E03C0400707C0800704C0800704E08003886100038871
-0003C8730001D0320001D03A0000F03C0000E01C0000E01C0000601800004008001E147F
-9321>I<7FC3FC0F01E00701C007018003810001C20000E40000EC00007800003800003C
-00007C00004E000087000107000303800201C00601E01E01E0FF07FE1714809318>I<FF
-83F81E01E01C00C00E00800E00800E008007010007010003820003820003820001C40001
-C40001EC0000E80000E800007000007000007000002000002000004000004000004000F0
-8000F08000F100006200003C0000151D7F9318>I<3FFF380E200E201C40384078407000
-E001E001C00380078007010E011E011C0338027006700EFFFE10147F9314>I
-E /Fk 3 54 df<03000700FF000700070007000700070007000700070007000700070007
-00070007000700070007007FF00C157E9412>49 D<00300030007000F001F00170027004
-7008701870107020704070C070FFFE0070007000700070007003FE0F157F9412>52
-D<20303FE03FC0240020002000200020002F8030E020700030003800384038E038E03880
-30406020C01F000D157E9412>I E /Fl 20 118 df<000E00001E00007E0007FE00FFFE
-00FFFE00F8FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE
-0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE
-0000FE0000FE0000FE0000FE0000FE0000FE0000FE007FFFFE7FFFFE7FFFFE17277BA622
->49 D<00FF800003FFF0000FFFFC001F03FE003800FF007C007F80FE003FC0FF003FC0FF
-003FE0FF001FE0FF001FE07E001FE03C003FE000003FE000003FC000003FC000007F8000
-007F000000FE000000FC000001F8000003F0000003E00000078000000F0000001E000000
-3C00E0007000E000E000E001C001C0038001C0070001C00FFFFFC01FFFFFC03FFFFFC07F
-FFFFC0FFFFFF80FFFFFF80FFFFFF801B277DA622>I<007F800001FFF00007FFF8000FE0
-FC001F807E003F803F007F003F007F001F80FF001F80FF001FC0FF001FC0FF001FC0FF00
-1FE0FF001FE0FF001FE0FF001FE07F001FE07F003FE03F003FE01F807FE00F807FE007C1
-DFE003FF9FE0007E1FE000001FE000001FC000001FC000001FC000003F801F003F803F80
-3F003F803F003F807E003F807C001F01F8001E03F0000FFFE00007FF800001FE00001B27
-7DA622>57 D<1C003E007F00FF80FF80FF807F003E001C00000000000000000000000000
-0000000000001C003E007F00FF80FF80FF807F003E001C00091B7B9A13>I<01FFFFF001
-FFFFF001FFFFF00001FE000001FE000001FE000001FE000001FE000001FE000001FE0000
-01FE000001FE000001FE000001FE000001FE000001FE000001FE000001FE000001FE0000
-01FE000001FE000001FE000001FE000001FE000001FE000001FE000001FE000001FE0000
-01FE000001FE001801FE007E01FE00FF01FE00FF01FE00FF01FE00FF01FC007E03F8007C
-03F0003E0FE0000FFFC00003FE00001C297DA824>74 D<FFFE0000001FFFC0FFFE000000
-1FFFC0FFFF0000003FFFC003FF0000003FF00003FF0000003FF00003BF80000077F00003
-BF80000077F000039FC00000E7F000039FC00000E7F000038FE00001C7F000038FE00001
-C7F0000387F0000387F0000387F0000387F0000387F0000387F0000383F8000707F00003
-83F8000707F0000381FC000E07F0000381FC000E07F0000380FE001C07F0000380FE001C
-07F0000380FF003807F00003807F003807F00003807F003807F00003803F807007F00003
-803F807007F00003801FC0E007F00003801FC0E007F00003800FE1C007F00003800FE1C0
-07F00003800FE1C007F000038007F38007F000038007F38007F000038003FF0007F00003
-8003FF0007F000038001FE0007F000038001FE0007F000038000FC0007F000038000FC00
-07F000FFFE00FC01FFFFC0FFFE007801FFFFC0FFFE007801FFFFC03A297DA841>77
-D<007F806003FFF0E007FFF9E00F807FE01F001FE03E0007E07C0003E07C0001E0FC0001
-E0FC0001E0FC0000E0FE0000E0FE0000E0FF000000FFC000007FFE00007FFFE0003FFFFC
-001FFFFE000FFFFF8007FFFFC003FFFFE000FFFFE00007FFF000007FF000000FF8000007
-F8000003F8600001F8E00001F8E00001F8E00001F8F00001F0F00001F0F80003F0FC0003
-E0FF0007C0FFE01F80F3FFFF00E0FFFE00C01FF0001D297CA826>83
-D<7FFFFFFFFFC07FFFFFFFFFC07FFFFFFFFFC07F803FC03FC07E003FC007C078003FC003
-C078003FC003C070003FC001C0F0003FC001E0F0003FC001E0E0003FC000E0E0003FC000
-E0E0003FC000E0E0003FC000E0E0003FC000E000003FC0000000003FC0000000003FC000
-0000003FC0000000003FC0000000003FC0000000003FC0000000003FC0000000003FC000
-0000003FC0000000003FC0000000003FC0000000003FC0000000003FC0000000003FC000
-0000003FC0000000003FC0000000003FC0000000003FC0000000003FC0000000003FC000
-0000003FC00000007FFFFFE000007FFFFFE000007FFFFFE0002B287EA730>I<001FF800
-00FFFE0003F01F0007E03F800FC03F801F803F803F801F007F800E007F0000007F000000
-FF000000FF000000FF000000FF000000FF000000FF000000FF0000007F0000007F000000
-7F8000003F8001C01F8001C00FC0038007E0070003F01E0000FFFC00001FE0001A1B7E9A
-1F>99 D<003FE00001FFF80003F07E0007C01F000F801F801F800F803F800FC07F000FC0
-7F0007C07F0007E0FF0007E0FF0007E0FFFFFFE0FFFFFFE0FF000000FF000000FF000000
-7F0000007F0000007F0000003F8000E01F8000E00FC001C007E0038003F81F0000FFFE00
-001FF0001B1B7E9A20>101 D<0007F0003FFC00FE3E01F87F03F87F03F07F07F07F07F0
-3E07F00007F00007F00007F00007F00007F00007F000FFFFC0FFFFC0FFFFC007F00007F0
-0007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F0
-0007F00007F00007F00007F00007F00007F00007F0007FFF807FFF807FFF80182A7EA915
->I<00FF81F003FFE7F80FC1FE7C1F80FC7C1F007C383F007E107F007F007F007F007F00
-7F007F007F007F007F007F007F003F007E001F007C001F80FC000FC1F8001FFFE00018FF
-800038000000380000003C0000003E0000003FFFF8001FFFFF001FFFFF800FFFFFC007FF
-FFE01FFFFFF03E0007F07C0001F8F80000F8F80000F8F80000F8F80000F87C0001F03C00
-01E01F0007C00FC01F8003FFFE00007FF0001E287E9A22>I<FFE0000000FFE0000000FF
-E00000000FE00000000FE00000000FE00000000FE00000000FE00000000FE00000000FE0
-0000000FE00000000FE00000000FE00000000FE00000000FE00000000FE07F00000FE1FF
-C0000FE787E0000FEE03F0000FF803F0000FF803F8000FF003F8000FF003F8000FE003F8
-000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F800
-0FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000F
-E003F800FFFE3FFF80FFFE3FFF80FFFE3FFF80212A7DA926>I<07000F801FC03FE03FE0
-3FE01FC00F8007000000000000000000000000000000FFE0FFE0FFE00FE00FE00FE00FE0
-0FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE0FFFE
-FFFEFFFE0F2B7DAA14>I<FFC07F800FF000FFC1FFE03FFC00FFC383F0707E000FC603F8
-C07F000FCC01F9803F000FD801FF003F800FF001FE003F800FF001FE003F800FE001FC00
-3F800FE001FC003F800FE001FC003F800FE001FC003F800FE001FC003F800FE001FC003F
-800FE001FC003F800FE001FC003F800FE001FC003F800FE001FC003F800FE001FC003F80
-0FE001FC003F800FE001FC003F800FE001FC003F800FE001FC003F800FE001FC003F80FF
-FE1FFFC3FFF8FFFE1FFFC3FFF8FFFE1FFFC3FFF8351B7D9A3A>109
-D<FFC07F0000FFC1FFC000FFC787E0000FCE03F0000FD803F0000FD803F8000FF003F800
-0FF003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000F
-E003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE0
-03F8000FE003F8000FE003F800FFFE3FFF80FFFE3FFF80FFFE3FFF80211B7D9A26>I<00
-3FE00001FFFC0003F07E000FC01F801F800FC03F800FE03F0007E07F0007F07F0007F07F
-0007F0FF0007F8FF0007F8FF0007F8FF0007F8FF0007F8FF0007F8FF0007F8FF0007F87F
-0007F07F0007F03F800FE03F800FE01F800FC00FC01F8007F07F0001FFFC00003FE0001D
-1B7E9A22>I<03FE300FFFF01E03F03800F0700070F00070F00070F80070FC0000FFE000
-7FFE007FFF803FFFE01FFFF007FFF800FFF80003FC0000FC60007CE0003CF0003CF00038
-F80038FC0070FF01E0F7FFC0C1FF00161B7E9A1B>115 D<007000007000007000007000
-00F00000F00000F00001F00003F00003F00007F0001FFFF0FFFFF0FFFFF007F00007F000
-07F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F038
-07F03807F03807F03807F03807F03803F03803F87001F86000FFC0001F8015267FA51B>
-I<FFE03FF800FFE03FF800FFE03FF8000FE003F8000FE003F8000FE003F8000FE003F800
-0FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000F
-E003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE0
-07F80007E007F80007E00FF80003F03BFF8001FFF3FF80003FC3FF80211B7D9A26>I
-E end
-%%EndProlog
-%%BeginSetup
-%%Feature: *Resolution 300dpi
-TeXDict begin
-
-%%EndSetup
-%%Page: 1 1
-1 0 bop 551 311 a Fl(The)23 b(Sc)n(heme)e(of)i(Things:)530
-407 y(The)f(June)h(1992)h(Meeting)1245 385 y Fk(1)751
-522 y Fj(Jonathan)15 b(Rees)715 579 y(Cornell)h(Univ)o(ersit)o(y)682
-635 y Fi(jar@cs.cornell.edu)220 796 y Fj(An)21 b(informally)i
-(constituted)e(group)g(of)g(p)q(eople)h(in)o(terested)g(in)g(the)f
-(future)g(of)149 852 y(the)f(Sc)o(heme)g(programming)f(language)h(met)g
-(at)f(the)g(Xero)o(x)g(P)o(alo)h(Alto)f(Researc)o(h)149
-909 y(Cen)o(ter)d(on)f(25)h(June)g(1992.)k(The)c(main)h(purp)q(ose)f
-(of)f(the)h(meeting)g(w)o(as)f(to)g(w)o(ork)g(on)149
-965 y(the)h(tec)o(hnical)g(con)o(ten)o(t)f(of)g(the)g(next)g(revision)i
-(of)d(the)i(Sc)o(heme)g(rep)q(ort.)220 1021 y(W)l(e)f(made)h(progress)e
-(on)h(sev)o(eral)h(fron)o(ts:)218 1112 y Fh(\017)22 b
-Fj(Some)15 b(di\013erences)i(with)e(the)g(IEEE)h(Sc)o(heme)g(standard)e
-(w)o(ere)h(resolv)o(ed.)218 1205 y Fh(\017)22 b Fj(Prop)q(osals)13
-b(for)g(m)o(ultiple)i(return)e(v)m(alues)i(and)e Fi(dynamic-wind)f
-Fj(w)o(ere)h(adopted.)218 1297 y Fh(\017)22 b Fj(A)15
-b(prop)q(osal)h(for)e(an)h Fi(eval)g Fj(pro)q(cedure)h(w)o(as)f
-(adopted.)218 1390 y Fh(\017)22 b Fj(The)d(high-lev)o(el)h(macro)e
-(facilit)o(y)h(describ)q(ed)h(in)g(the)e(Revised)1354
-1373 y Fk(4)1394 1390 y Fj(Rep)q(ort's)g(ap-)263 1446
-y(p)q(endix)f(will)g(b)q(e)f(mo)o(v)o(ed)e(in)o(to)i(the)f(rep)q(ort)g
-(prop)q(er.)220 1537 y(Tw)o(o)d(sub)q(committees)i(w)o(ere)e(formed:)19
-b(one)13 b(to)f(w)o(ork)g(on)h(exceptions,)h(and)f(one)g(to)149
-1593 y(c)o(harter)i(the)g(formation)f(of)h(a)g(standard)f(library)l(.)
-21 b(The)16 b(sub)q(committees)f(will)i(rep)q(ort)149
-1650 y(bac)o(k)f(to)e(the)h(group)g(with)h(prop)q(osals)f(for)g
-(inclusion)i(in)f(the)g(rep)q(ort.)220 1706 y(It)j(had)g(b)q(een)i(hop)
-q(ed)f(that)e(there)h(w)o(ould)h(b)q(e)g(progress)e(on)h(some)g(other)g
-(fron)o(ts)149 1763 y(\(user-de\014ned)e(t)o(yp)q(es,)e(dynamic)h
-(binding,)h(impro)o(v)o(emen)o(ts)e(to)f(\\rest")g(parameters\),)149
-1819 y(but)20 b(after)e(inconclusiv)o(e)j(discussion)g(these)e(topics)g
-(w)o(ere)g(dropp)q(ed.)32 b(These)19 b(topics)149 1876
-y(will)e(probably)f(b)q(e)g(tak)o(en)f(up)g(again)h(in)g(the)f(future.)
-220 1932 y(Norman)e(Adams)g(w)o(as)f(app)q(oin)o(ted)i(the)f(Revised)
-1068 1916 y Fk(5)1103 1932 y Fj(Rep)q(ort's)g(editor.)19
-b(It)13 b(is)h(hop)q(ed)149 1989 y(that)f(it)g(will)i(b)q(e)e(ready)g
-(b)o(y)g(early)h(1993,)e(so)g(as)h(to)f(precede)i(the)f(reconstitution)
-h(of)f(the)149 2045 y(IEEE)j(standard)f(group.)220 2102
-y(This)f(article)g(is)g(m)o(y)f(o)o(wn)g(in)o(terpretation)h(of)f(what)
-g(transpired,)h(and)g(should)g(not)149 2158 y(b)q(e)i(construed)g(as)f
-(de\014nitiv)o(e.)149 2277 y Fg(Agreemen)o(t)h(with)i(the)g(IEEE)g(Sc)o
-(heme)f(standard)149 2363 y Fj(Un)o(til)e(no)o(w,)f(the)g(Sc)o(heme)h
-(rep)q(orts)e(ha)o(v)o(e)h(encouraged)g(but)g(not)g(required)h(the)f
-(empt)o(y)149 2420 y(list)j Fi(\(\))e Fj(and)h(the)f(b)q(o)q(olean)i
-(false)f(v)m(alue)g Fi(#f)f Fj(to)g(b)q(e)i(distinct.)22
-b(It)15 b(has)g(b)q(een)i(the)f(in)o(ten)o(t)p 149 2453
-598 2 v 201 2480 a Ff(1)219 2496 y Fe(T)m(o)c(app)q(ear)i(in)g
-Fd(Lisp)f(Pointers)e Fe(V\(4\),)h(Octob)q(er{Decem)o(b)q(er)j(1992.)885
-2620 y Fj(1)p eop
-%%Page: 2 2
-2 1 bop 307 311 a Fj(ev)o(er)14 b(since)h(the)f(Revised)i(Revised)f
-(Rep)q(ort,)g(ho)o(w)o(ev)o(er,)e(that)g(this)h(distinction)i(w)o(ould)
-307 368 y(ev)o(en)o(tually)h(b)q(e)g(required.)25 b(The)16
-b(IEEE)h(Sc)o(heme)g(standard)f(bit)h(the)f(bullet)i(in)f(1990,)307
-424 y(and)f(no)o(w)e(the)i(Revised)721 408 y Fk(5)757
-424 y Fj(rep)q(ort)f(follo)o(ws.)378 482 y(The)20 b(standard)f(also)h
-(dropp)q(ed)h(the)f(distinction)i(b)q(et)o(w)o(een)e(essen)o(tial)h
-(and)f(not-)307 538 y(essen)o(tial)e(language)e(features;)h(most)f
-(features)g(that)g(w)o(ere)g(formerly)h(not)f(essen)o(tial,)307
-595 y(suc)o(h)11 b(as)f(n-ary)g Fi(+)g Fj(and)g Fi(apply)p
-Fj(,)g(are)g(no)o(w)g(required.)19 b(The)11 b(Revised)1427
-578 y Fk(5)1458 595 y Fj(Rep)q(ort)g(will)h(adopt)307
-651 y(this)18 b(stance,)g(at)f(least)h(as)g(regards)f(language)h
-(features)f(that)g(are)h(shared)f(with)h(the)307 708
-y(IEEE)h(standard.)30 b(Non-essen)o(tial)20 b(non-IEEE)g(o)q(ddities)g
-(suc)o(h)f(as)f Fi(transcript-on)307 764 y Fj(and)13
-b Fi(transcript-off)d Fj(and)i(the)h(prop)q(osed)f Fi
-(interaction-environment)d Fj(\(see)k(b)q(e-)307 821
-y(lo)o(w\))20 b(w)o(ere)f(not)h(discussed)h(at)e(the)h(meeting,)h(ho)o
-(w)o(ev)o(er,)f(and)g(consensus)g(on)g(their)307 877
-y(status)15 b(will)h(ha)o(v)o(e)f(to)g(b)q(e)h(reac)o(hed)f(via)h
-(electronic)g(mail.)378 935 y(A)g(third)h(asp)q(ect)g(of)f(the)g
-(standard)g(that)g(w)o(as)f(adopted)i(w)o(as)e(a)h(certain)h(obscure)
-307 991 y(paragraph)11 b(regarding)h(assignmen)o(ts)f(to)g(top-lev)o
-(el)i(v)m(ariables)g(\(section)f(6,)f(paragraph)307 1048
-y(2\).)19 b(The)12 b(e\013ect)h(of)f(this)h(is)g(that)f(if)i(a)e
-(program)f(con)o(tains)i(an)g(assignmen)o(t)f(to)g(an)o(y)h(top-)307
-1104 y(lev)o(el)j(v)m(ariable,)g(then)f(the)f(program)g(m)o(ust)g(con)o
-(tain)h(a)f Fi(define)g Fj(for)g(that)f(v)m(ariable;)j(it)307
-1161 y(is)e(not)f(su\016cien)o(t)i(that)d(the)i(v)m(ariable)h(b)q(e)f
-(b)q(ound.)20 b(This)14 b(has)g(b)q(een)g(the)g(case)f(for)g(most)307
-1217 y(v)m(ariables,)22 b(but)e(the)h(rule)f(applies)i(as)e(w)o(ell)h
-(to)e(v)m(ariables)i(suc)o(h)f(as)g Fi(car)g Fj(that)f(ha)o(v)o(e)307
-1274 y(built-in)h(bindings.)30 b(In)18 b(addition,)i(it)e(is)g
-(clari\014ed)h(that)f(if)g(a)f(program)g(mak)o(es)g(suc)o(h)307
-1330 y(a)d(de\014nition)i(or)e(assignmen)o(t,)g(then)h(the)f(b)q(eha)o
-(vior)h(of)f(built-in)j(pro)q(cedures)e(will)h(not)307
-1387 y(b)q(e)j(a\013ected.)28 b(F)l(or)17 b(example,)j(rede\014ning)f
-Fi(length)e Fj(cannot)h(a\013ect)f(the)h(b)q(eha)o(vior)h(of)307
-1443 y(the)14 b(built-in)j Fi(list->vector)c Fj(pro)q(cedure.)20
-b(If)14 b(in)i(some)d(particular)i(implemen)o(tation)307
-1500 y Fi(list->vector)f Fj(is)j(written)e(in)i(Sc)o(heme)f(and)g
-(calls)h Fi(length)p Fj(,)e(then)h(it)g(m)o(ust)f(b)q(e)h(sure)307
-1556 y(to)d(call)i(the)f(built-in)i Fi(length)d Fj(pro)q(cedure,)h(not)
-f(whatev)o(er)g(happ)q(ens)i(to)e(b)q(e)i(the)e(v)m(alue)307
-1612 y(of)i(the)g(v)m(ariable)i Fi(length)p Fj(.)307
-1740 y Fg(Multiple)i(return)e(v)m(alues)307 1828 y Fj(The)d
-Fi(call-with-values)d Fj(and)i Fi(values)f Fj(pro)q(cedures)i(w)o(ere)f
-(describ)q(ed)i(in)f(an)g(earlier)307 1885 y(Sc)o(heme)e(of)e(Things)h
-(\()p Fc(Lisp)h(Pointers)p Fj(,)e(v)o(olume)h(IV,)g(n)o(um)o(b)q(er)g
-(1\),)g(but)g(I'll)h(review)g(them)307 1941 y(here.)20
-b(The)c(follo)o(wing)g(is)g(adapted)f(from)f(John)i(Ramsdell's)g
-(concise)h(description:)421 2054 y Fi(\(values)23 b Fc(obje)n(ct)g
-Fb(:)8 b(:)g(:)n Fi(\))600 b Fj(essen)o(tial)16 b(pro)q(cedure)421
-2132 y Fi(values)e Fj(deliv)o(ers)j(all)f(of)f(its)g(argumen)o(ts)f(to)
-h(its)g(con)o(tin)o(uation.)421 2249 y Fi(\(call-with-values)21
-b Fc(thunk)j(r)n(e)n(c)n(eiver)o Fi(\))268 b Fj(essen)o(tial)16
-b(pro)q(cedure)421 2326 y Fi(call-with-values)c Fj(calls)j(its)f
-Fc(thunk)g Fj(argumen)o(t)g(with)g(a)g(con)o(tin)o(uation)h(that,)421
-2383 y(when)h(passed)g(some)f(v)m(alues,)i(calls)g(the)f
-Fc(r)n(e)n(c)n(eiver)e Fj(pro)q(cedure)j(with)f(those)g(v)m(al-)421
-2439 y(ues)22 b(as)g(argumen)o(ts.)40 b(The)23 b(con)o(tin)o(uation)f
-(for)g(the)g(call)h(to)f Fc(r)n(e)n(c)n(eiver)f Fj(is)h(the)421
-2496 y(con)o(tin)o(uation)15 b(of)g(the)g(call)i(to)d
-Fi(call-with-values)p Fj(.)1043 2620 y(2)p eop
-%%Page: 3 3
-3 2 bop 220 311 a Fj(Except)17 b(for)g(con)o(tin)o(uations)h(created)f
-(b)o(y)g(the)g Fi(call-with-values)e Fj(pro)q(cedure,)149
-368 y(all)21 b(con)o(tin)o(uations)g(tak)o(e)e(exactly)h(one)h(v)m
-(alue,)h(as)d(no)o(w;)j(the)e(e\013ect)g(of)f(passing)i(no)149
-424 y(v)m(alue)i(or)e(more)g(than)g(one)g(v)m(alue)i(to)d(con)o(tin)o
-(uations)i(that)f(w)o(ere)g(not)g(created)g(b)o(y)149
-481 y Fi(call-with-values)13 b Fj(is)j(unsp)q(eci\014ed)i(\(as)c
-(indeed)j(it)f(is)g(unsp)q(eci\014ed)h(no)o(w\).)220
-537 y Fi(values)d Fj(migh)o(t)h(b)q(e)h(de\014ned)h(as)e(follo)o(ws:)
-245 623 y Fi(\(define)23 b(\(values)g(.)g(things\))293
-679 y(\(call-with-current-cont)o(inuation)340 736 y(\(lambda)g
-(\(cont\))g(\(apply)g(cont)h(things\)\)\)\))149 822 y
-Fj(That)g(is,)j(the)d(pro)q(cedures)h(supplied)i(b)o(y)d
-Fi(call-with-current-continua)o(tion)149 878 y Fj(m)o(ust)18
-b(b)q(e)h(passed)g(the)f(same)g(n)o(um)o(b)q(er)h(of)f(argumen)o(ts)f
-(as)h(v)m(alues)i(exp)q(ected)f(b)o(y)g(the)149 934 y(con)o(tin)o
-(uation.)220 991 y(Because)14 b(the)g(b)q(eha)o(vior)g(of)g(a)f(n)o(um)
-o(b)q(er-of-v)m(alues)i(mismatc)o(h)f(b)q(et)o(w)o(een)g(a)f(con)o
-(tin-)149 1047 y(uation)f(and)g(its)f(in)o(v)o(ok)o(er)h(is)g(unsp)q
-(eci\014ed,)i(some)d(implemen)o(tations)i(ma)o(y)e(assign)g(some)149
-1104 y(sp)q(eci\014c)19 b(meaning)f(to)e(suc)o(h)h(situations;)h(for)f
-(example,)g(extra)g(v)m(alues)h(migh)o(t)f(b)q(e)g(ig-)149
-1160 y(nored,)f(or)f(defaults)h(migh)o(t)g(b)q(e)g(supplied)i(for)d
-(missing)i(v)m(alues.)22 b(Th)o(us)16 b(this)g(m)o(ultiple)149
-1217 y(return)k(v)m(alue)g(prop)q(osal)g(is)g(compatible)g(with)g
-(Common)f(Lisp's)h(m)o(ultiple)h(v)m(alues,)149 1273
-y(but)e(strictly)g(more)f(conserv)m(ativ)o(e)i(than)e(it.)30
-b(The)19 b(b)q(eha)o(vior)g(of)g(programs)e(in)i(suc)o(h)149
-1330 y(situations)e(w)o(as)e(a)h(p)q(oin)o(t)g(of)g(con)o(ten)o(tion)g
-(among)g(the)g(authors,)f(whic)o(h)i(is)f(wh)o(y)g(only)149
-1386 y(the)g(least)f(common)g(denominator)g(b)q(eha)o(vior)h(w)o(as)e
-(sp)q(eci\014ed.)149 1505 y Fg(Un)o(wind/wind)19 b(protection)149
-1590 y Fi(dynamic-wind)p Fj(,)13 b(whic)o(h)i(w)o(as)e(describ)q(ed)j
-(previously)f(in)g(this)g(column)g(\(when)f(it)h(w)o(as)149
-1647 y(The)k(Sc)o(heme)g(En)o(vironmen)o(t;)g Fc(Lisp)f(Pointers)p
-Fj(,)g(v)o(olume)g(I,)h(n)o(um)o(b)q(er)f(2\),)g(is)h(already)149
-1703 y(implemen)o(ted)24 b(in)f(man)o(y)e(Sc)o(heme)h(dialects.)41
-b Fi(dynamic-wind)20 b Fj(tak)o(es)h(three)h(argu-)149
-1760 y(men)o(ts,)15 b(all)h(of)f(whic)o(h)h(are)f(th)o(unks)h(\(pro)q
-(cedures)f(of)g(no)g(argumen)o(ts\).)k(It)d(b)q(eha)o(v)o(es)f(as)149
-1816 y(if)h(it)g(w)o(ere)e(de\014ned)j(with)245 1902
-y Fi(\(define)23 b(\(dynamic-wind)f(before)h(during)g(after\))293
-1958 y(\(before\))293 2015 y(\(call-with-values)e(during)340
-2071 y(\(lambda)i(results)388 2128 y(\(after\))388 2184
-y(\(apply)g(values)g(results\)\)\)\))149 2270 y Fj(except)17
-b(that)f(the)h(execution)g(of)f(the)h Fi(during)e Fj(th)o(unk)i(is)g
-(\\protected")e(against)h(non-)149 2326 y(lo)q(cal)e(en)o(tries)f(and)g
-(exits:)19 b(a)12 b(thro)o(w)g(out)g(of)g(the)h(execution)h(of)e
-Fi(during)g Fj(will)i(cause)f(the)149 2383 y Fi(after)h
-Fj(th)o(unk)g(to)f(b)q(e)i(in)o(v)o(ok)o(ed,)f(and)g(a)g(thro)o(w)e
-(from)i(outside)g(bac)o(k)g(in)h(will)g(cause)g(the)149
-2439 y Fi(before)10 b Fj(th)o(unk)h(to)f(b)q(e)h(in)o(v)o(ok)o(ed.)19
-b(\(By)10 b(\\thro)o(w")f(I)i(mean)g(an)g(in)o(v)o(o)q(cation)g(of)f
-(an)h(explicit)149 2496 y(con)o(tin)o(uation)16 b(as)f(obtained)h(from)
-e Fi(call-with-current-continuati)o(on)p Fj(.\))885 2620
-y(3)p eop
-%%Page: 4 4
-4 3 bop 378 311 a Fj(F)l(or)14 b(details,)h(the)f(earlier)i(Sc)o(heme)f
-(En)o(vironmen)o(t)g(column)g(refers)f(the)h(reader)f(to)307
-368 y(F)l(riedman)19 b(and)f(Ha)o(ynes's)f(pap)q(er)h(\\Constraining)g
-(Con)o(trol")f(in)i(POPL)f(1985,)f(but)307 424 y(to)h(sa)o(v)o(e)g(y)o
-(ou)h(the)g(trouble)g(of)g(lo)q(oking)g(that)f(up,)i(I)f(ha)o(v)o(e)g
-(supplied)i(a)d(more)h(direct)307 481 y(implemen)o(tation)e(of)d
-Fi(dynamic-wind)g Fj(in)i(an)f(app)q(endix)i(to)e(the)g(presen)o(t)g
-(column.)378 537 y Fi(dynamic-wind)9 b Fj(w)o(as)i(adopted)g(with)h
-(the)f(follo)o(wing)i(clari\014cations:)19 b(The)11 b(seman-)307
-594 y(tics)18 b(of)g Fi(\(dynamic-wind)k Fc(b)n(efor)n(e)h(during)h
-(after)p Fi(\))18 b Fj(should)h(lea)o(v)o(e)f(unsp)q(eci\014ed)i(what)
-307 650 y(happ)q(ens)i(if)g(a)f(thro)o(w)f(o)q(ccurs)i(out)f(of)f
-Fc(b)n(efor)n(e)h Fj(or)g Fc(after)5 b Fj(;)24 b(and)d(it)g(is)h(b)q
-(est)g(to)e(defer)307 707 y(in)o(terrupts)c(during)g
-Fc(b)n(efor)n(e)e Fj(and)i Fc(after)p Fj(.)307 827 y
-Fg(Ev)m(aluating)k(computed)e(expressions)307 913 y Fj(The)f(original)g
-(1975)f(memo)g(on)g(Sc)o(heme)h(describ)q(ed)h Fi(evaluate)p
-Fj(,)e(whic)o(h)h(w)o(as)e(analo-)307 970 y(gous)g(to)f(Lisp's)i
-(traditional)g Fi(eval)e Fj(function.)21 b Fi(evaluate)14
-b Fj(to)q(ok)g(a)h(single)i(argumen)o(t,)307 1026 y(an)e(S-expression,)
-h(and)g(in)o(v)o(ok)o(ed)f(an)g(in)o(terpreter)h(on)f(it.)20
-b(F)l(or)15 b(example:)403 1121 y Fi(\(let)23 b(\(\(name)g('+\)\))g
-(\(evaluate)g(\(list)g(name)g(2)h(3\)\)\))498 1177 y
-Fh(\000)-7 b(!)48 b Fi(5)307 1271 y Fj(Sc)o(heme)11 b(b)q(eing)h
-(lexically)h(scop)q(ed,)f(ho)o(w)o(ev)o(er,)e(there)g(w)o(as)g(some)g
-(confusion)h(o)o(v)o(er)f(whic)o(h)307 1328 y(en)o(vironmen)o(t)16
-b(the)f(expression)h(w)o(as)e(to)h(b)q(e)h(ev)m(aluated)g(in.)21
-b(Should)403 1422 y Fi(\(let)i(\(\(name)g('+\)\))450
-1479 y(\(let)h(\(\(+)f(*\)\))498 1535 y(\(evaluate)g(\(list)g(name)g(2)
-h(3\)\)\)\))307 1629 y Fj(ev)m(aluate)16 b(to)f(5)g(or)f(to)h(6?)378
-1686 y(T)l(o)c(clarify)i(matters,)d(the)i(Revised)h(Rep)q(ort)f
-(replaced)h Fi(evaluate)e Fj(with)h Fi(enclose)p Fj(,)307
-1742 y(whic)o(h)k(to)q(ok)f(t)o(w)o(o)f(argumen)o(ts,)h(a)g
-Fi(lambda)p Fj(-expression)g(and)h(a)f(represen)o(tation)h(of)f(an)307
-1799 y(en)o(vironmen)o(t)h(from)f(whic)o(h)h(to)f(supply)h(bindings)i
-(of)d(the)g Fi(lambda)p Fj(-expression's)g(free)307 1855
-y(v)m(ariables.)21 b(F)l(or)15 b(example:)403 1950 y
-Fi(\(let)23 b(\(\(name)g('+\)\))450 2006 y(\(let)h(\(\(+)f(*\)\))498
-2063 y(\(\(enclose)g(\(list)g('lambda)g('\(\))g(\(list)g(name)h(2)f
-(3\)\))737 2119 y(\(list)g(\(cons)g('+)h(+\)\)\)\)\)\))498
-2176 y Fh(\000)-7 b(!)48 b Fi(6)307 2270 y Fj(This)20
-b(forced)g(the)g(programmer)e(to)h(b)q(e)i(explicit)h(ab)q(out)d(the)h
-Fi(lambda)p Fj(-expression's)307 2326 y(enclosing)d(en)o(vironmen)o(t.)
-378 2383 y(F)l(or)d(v)m(arious)h(tec)o(hnical)i(and)e(practical)g
-(reasons,)f(there)h(w)o(as)f(no)h Fi(eval)f Fj(analogue)307
-2439 y(in)21 b(subsequen)o(t)g(Sc)o(heme)f(rep)q(orts.)34
-b(The)20 b(ma)s(jor)f(stum)o(bling)h(blo)q(c)o(ks)h(w)o(ere)f(ho)o(w)f
-(to)307 2496 y(describ)q(e)j Fi(eval)d Fj(formally)h(and)g(ho)o(w)g(to)
-f(de\014ne)i(something)f(that)f(mak)o(es)g(sense)i(in)1043
-2620 y(4)p eop
-%%Page: 5 5
-5 4 bop 149 311 a Fj(all)17 b(extan)o(t)f(v)m(arian)o(ts)g(of)f(the)h
-(language.)23 b(Some)16 b(Sc)o(heme)g(implemen)o(tations)i(con)o(tain)
-149 368 y(a)e(distinguished)i(top-lev)o(el)f(en)o(vironmen)o(t,)e
-(while)i(others)e(extend)h(the)g(language)g(b)o(y)149
-424 y(pro)o(viding)j(w)o(a)o(ys)e(to)g(create)g(m)o(ultiple)j(en)o
-(vironmen)o(ts,)e(an)o(y)g(of)f(whic)o(h)h(migh)o(t)g(serv)o(e)149
-481 y(equally)f(w)o(ell.)220 537 y(The)12 b Fi(eval)g
-Fj(prop)q(osal)g(adopted)g(at)g(the)g(June)h(meeting,)g(whic)o(h)f(I)h
-(repro)q(duce)g(here,)149 594 y(is)j(one)f(that)g(comes)g(from)g(Bill)i
-(Rozas.)263 702 y Fi(\(eval)23 b Fc(expr)n(ession)g(envir)n(onment-sp)n
-(e)n(ci\014er)m Fi(\))190 b Fj(essen)o(tial)16 b(pro)q(cedure)263
-777 y Fi(eval)10 b Fj(ev)m(aluates)h Fc(expr)n(ession)e
-Fj(in)h(the)h(en)o(vironmen)o(t)f(indicated)i(b)o(y)e
-Fc(envir)n(onment-)263 834 y(sp)n(e)n(ci\014er)p Fj(.)21
-b Fc(envir)n(onment-sp)n(e)n(ci\014er)13 b Fj(ma)o(y)i(b)q(e)i(the)f
-(return)g(v)m(alue)h(of)e(one)h(of)g(the)263 890 y(three)21
-b(pro)q(cedures)g(describ)q(ed)h(b)q(elo)o(w,)g(or)e(implemen)o
-(tation-sp)q(eci\014c)j(exten-)263 947 y(sions.)31 b(No)19
-b(other)g(op)q(erations)g(on)f(en)o(vironmen)o(t)i(sp)q(eci\014ers)g
-(are)f(de\014ned)h(b)o(y)263 1003 y(this)c(prop)q(osal.)263
-1079 y(Implemen)o(tations)g(ma)o(y)e(allo)o(w)h(non-expression)h
-(programs)e(\(i.e.)g(de\014nitions\))263 1135 y(as)j(the)h(\014rst)f
-(argumen)o(t)g(to)g Fi(eval)g Fc(only)h Fj(when)g(the)f(second)i
-(argumen)o(t)e(is)h(the)263 1192 y(return)i(v)m(alue)h(of)f
-Fi(interaction-environment)d Fj(or)j(some)f(implemen)o(tation)263
-1248 y(extension.)i(In)16 b(other)e(w)o(ords,)g Fi(eval)h
-Fj(will)i(nev)o(er)e(create)g(new)h(bindings)h(in)f(the)263
-1305 y(return)f(v)m(alue)i(of)d Fi(null-environment)f
-Fj(or)i Fi(scheme-report-environment)p Fj(.)263 1420
-y Fi(\(scheme-report-environment)20 b Fc(version)p Fi(\))193
-b Fj(essen)o(tial)16 b(pro)q(cedure)263 1495 y Fc(V)m(ersion)21
-b Fj(m)o(ust)i(b)q(e)g(an)g(exact)f(non-negativ)o(e)h(in)o(teger)g
-(corresp)q(onding)h(to)e(a)263 1552 y(v)o(ersion)e(of)f(one)h(of)f(the)
-h(Revised)857 1535 y Fa(n)902 1552 y Fj(Rep)q(orts)g(on)g(Sc)o(heme.)34
-b(This)20 b(pro)q(cedure)263 1608 y(returns)g(a)g(sp)q(eci\014er)h(for)
-f(an)g(en)o(vironmen)o(t)g(that)f(con)o(tains)i(exactly)f(the)g(set)263
-1665 y(of)d(bindings)i(sp)q(eci\014ed)g(in)f(the)g(corresp)q(onding)g
-(rep)q(ort)f(that)f(the)i(implemen-)263 1721 y(tation)h(supp)q(orts.)32
-b(Not)18 b(all)i(v)o(ersions)g(ma)o(y)e(b)q(e)i(a)o(v)m(ailable)h(in)f
-(all)g(implemen-)263 1778 y(tations)g(at)f(all)i(times.)35
-b(Ho)o(w)o(ev)o(er,)20 b(an)g(implemen)o(tation)i(that)d(conforms)g(to)
-263 1834 y(v)o(ersion)e Fb(n)g Fj(of)f(the)h(Revised)748
-1818 y Fa(n)789 1834 y Fj(Rep)q(orts)g(on)g(Sc)o(heme)g(m)o(ust)f
-(accept)h(v)o(ersion)g Fb(n)p Fj(.)263 1891 y(If)e Fi
-(scheme-report-environmen)o(t)d Fj(is)i(a)o(v)m(ailable,)i(but)f(the)f
-(sp)q(eci\014ed)j(v)o(ersion)263 1947 y(is)f(not,)e(the)i(pro)q(cedure)
-g(will)g(signal)h(an)e(error.)263 2023 y(The)e(e\013ect)g(of)f
-(assigning)i(\(through)e(the)h(use)g(of)g Fi(eval)p Fj(\))f(a)g(v)m
-(ariable)j(b)q(ound)e(in)h(a)263 2079 y Fi(scheme-report-environment)8
-b Fj(\(e.g.)j Fi(car)p Fj(\))f(is)i(unsp)q(eci\014ed.)22
-b(Th)o(us)11 b(the)h(en)o(vi-)263 2136 y(ronmen)o(ts)e(sp)q(eci\014ed)i
-(b)o(y)e(the)g(return)g(v)m(alues)i(of)d Fi(scheme-report-environment)
-263 2192 y Fj(ma)o(y)15 b(b)q(e)g(imm)o(utable.)263 2307
-y Fi(\(null-environment\))572 b Fj(essen)o(tial)16 b(pro)q(cedure)263
-2383 y(This)d(pro)q(cedure)h(returns)f(a)f(sp)q(eci\014er)j(for)d(an)h
-(en)o(vironmen)o(t)g(that)f(con)o(tains)h(no)263 2439
-y(v)m(ariable)f(bindings,)g(but)f(con)o(tains)f(\(syn)o(tactic\))g
-(bindings)i(for)d(all)j(the)e(syn)o(tactic)263 2496 y(k)o(eyw)o(ords)k
-(de\014ned)j(in)f(the)f(rep)q(ort,)g(and)g(no)g(others.)885
-2620 y(5)p eop
-%%Page: 6 6
-6 5 bop 421 311 a Fi(\(interaction-environment\))585
-b Fj(pro)q(cedure)421 387 y(This)20 b(pro)q(cedure)g(returns)g(a)f(sp)q
-(eci\014er)i(for)e(an)h(en)o(vironmen)o(t)g(that)e(con)o(tains)421
-444 y(implementation-de\014ned)k(bindings,)e(t)o(ypically)g(a)f(sup)q
-(erset)g(of)f(those)g(listed)421 500 y(in)h(the)g(rep)q(ort.)30
-b(The)19 b(in)o(ten)o(t)g(is)h(that)e(this)h(pro)q(cedure)g(will)i
-(return)e(a)f(sp)q(eci-)421 557 y(\014er)f(for)e(the)i(en)o(vironmen)o
-(t)g(in)g(whic)o(h)g(the)g(implemen)o(tation)h(w)o(ould)f(ev)m(aluate)
-421 613 y(expressions)f(dynamically)h(t)o(yp)q(ed)e(b)o(y)h(the)f
-(user.)378 722 y(Rozas)c(explains:)19 b(\\The)11 b(prop)q(osal)g(do)q
-(es)g(not)g(imply)h(the)f(existence)h(or)f(supp)q(ort)g(of)307
-778 y(\014rst-class)j(en)o(vironmen)o(ts,)g(although)h(it)f(is)g
-(compatible)h(with)g(them.)k(The)14 b(prop)q(osal)307
-835 y(only)22 b(requires)g(a)f(w)o(a)o(y)f(of)h(asso)q(ciating)h(tags)e
-(with)i(a)f(\014nite)h(set)f(of)g(distinguished)307 891
-y(en)o(vironmen)o(ts)d(whic)o(h)g(the)f(implemen)o(tations)i(can)f
-(main)o(tain)f(implicitl)q(y)j(\(without)307 947 y(rei\014cation\).)378
-1004 y(\\)7 b(`P)o(ascal-lik)o(e')k(implemen)o(tations)h(can)f(supp)q
-(ort)f(b)q(oth)h Fi(null-environment)d Fj(and)307 1061
-y Fi(scheme-report-environment)f Fj(since)k(the)g(en)o(vironmen)o(ts)f
-(sp)q(eci\014ed)i(b)o(y)e(the)h(return)307 1117 y(v)m(alues)j(of)e
-(these)g(pro)q(cedures)i(need)f(not)f(share)h(an)o(y)f(bindings)i(with)
-f(the)f(curren)o(t)h(pro-)307 1174 y(gram.)k(A)11 b(v)o(ersion)f(of)g
-Fi(eval)f Fj(that)h(supp)q(orts)g(these)g(but)h(not)e
-Fi(interaction-environment)307 1230 y Fj(can)j(b)q(e)g(written)g(p)q
-(ortably)l(,)h(but)e(can)h(b)q(e)h(b)q(etter)e(written)h(b)o(y)g(the)g
-(implemen)o(tor,)g(since)307 1287 y(it)k(can)f(share)g(co)q(de)h(with)f
-(the)h(default)f(ev)m(aluator)h(or)e(compiler.")378 1343
-y(Here)f(\\P)o(ascal-lik)o(e")i(refers)e(to)g(implemen)o(tations)h
-(that)f(are)g(restricted)h(to)f(static)307 1400 y(compilation)f(and)e
-(linking.)20 b(Because)11 b(an)f Fi(eval)g Fj(that)f(do)q(esn't)h(supp)
-q(ort)g Fi(interaction-)307 1456 y(environment)15 b Fj(can)i(b)q(e)h
-(written)e(en)o(tirely)i(in)g(the)f(Sc)o(heme)g(language)g(describ)q
-(ed)i(b)o(y)307 1513 y(the)g(rest)f(of)f(the)i(rep)q(ort,)f(it)h
-(raises)f(no)h(troublesome)f(questions)h(ab)q(out)f(its)h(formal)307
-1569 y(seman)o(tics.)307 1692 y Fg(Macros)307 1778 y
-Fj(The)11 b(consensus)g(of)f(the)g(meeting)h(w)o(as)e(that)h
-Fi(define-syntax)p Fj(,)f Fi(syntax-rules)p Fj(,)g Fi(let-)307
-1835 y(syntax)p Fj(,)14 b(and)h Fi(letrec-syntax)f Fj(should)i(b)q(e)g
-(mo)o(v)o(ed)f(out)f(of)h(the)g(rep)q(ort's)g(app)q(endix)307
-1891 y(in)o(to)e(the)h(main)g(b)q(o)q(dy)g(of)e(the)i(rep)q(ort.)19
-b(Although)14 b(ev)o(ery)o(one)f(agrees)g(that)f(a)h(lo)o(w-lev)o(el)
-307 1948 y(macro)j(facilit)o(y)i(is)f(imp)q(ortan)o(t,)g(the)g(sub)s
-(ject)f(is)h(to)q(o)g(con)o(ten)o(tious)f(at)g(presen)o(t,)h(with)307
-2004 y(three)h(or)f(more)g(comp)q(eting)h(prop)q(osals)f(at)g(presen)o
-(t.)27 b(The)17 b(disp)q(osition)i(of)e(the)h(rest)307
-2061 y(of)f(the)h(app)q(endix)h(and)f(of)f(the)g(other)g(lo)o(w-lev)o
-(el)i(prop)q(osals)f(will)h(b)q(e)f(left)g(up)g(to)e(the)307
-2117 y(rep)q(ort's)f(editor.)307 2240 y Fg(Committee)j(w)o(ork)307
-2326 y Fj(There)c(is)h(a)e(strong)g(sense)i(that)e(some)h(kind)h(of)e
-(exception)i(system)f(is)g(needed.)21 b(Ho)o(w-)307 2383
-y(ev)o(er,)15 b(no)g(sp)q(eci\014c)i(prop)q(osal)e(w)o(as)f(ready)h(at)
-g(the)g(time)g(of)g(the)g(meeting.)20 b(A)15 b(commit-)307
-2439 y(tee)k(has)g(b)q(een)g(formed)g(to)f(w)o(ork)g(on)g(one.)31
-b(What)18 b(seems)h(to)f(b)q(e)h(in)h(the)f(air)g(migh)o(t)307
-2496 y(b)q(e)d(describ)q(ed)h(as)d(a)h(highly)i(distilled)g(v)o(ersion)
-f(of)e(the)h(condition)h(system)f(that)f(Ken)o(t)1043
-2620 y(6)p eop
-%%Page: 7 7
-7 6 bop 149 311 a Fj(Pitman)18 b(dev)o(elop)q(ed)h(for)d(Common)h
-(Lisp.)27 b(I)18 b(hop)q(e)g(that)f(I'll)h(b)q(e)g(able)g(to)f(rep)q
-(ort)g(on)149 368 y(this)f(in)g(a)f(future)g(column.)220
-424 y(On)i(the)f(sub)s(ject)g(of)g(libraries,)i(Will)g(Clinger's)e(min)
-o(utes)h(rep)q(ort)f(that)g(\\the)g(au-)149 481 y(thors)h(p)q(erceiv)o
-(e)i(a)e(need)i(to)d(giv)o(e)i(some)f(library)i(o\016cial)f(status.)26
-b(In)18 b(fact,)f(w)o(e)g(need)149 537 y(to)e(giv)o(e)h(o\016cial)h
-(sanction)f(to)f(m)o(ultiple)i(libraries.)23 b(There)16
-b(is)g(reason)g(to)f(distinguish)149 594 y(b)q(et)o(w)o(een)d(accepted)
-f(\(or)g(standard\))f(libraries,)j(exp)q(erimen)o(tal)f(libraries,)i
-(and)d(prop)q(os-)149 650 y(als.)26 b(The)17 b(accepted)h(libraries)g
-(can)g(reduce)g(the)f(in)o(tellectual)i(size)f(of)e(the)i(language)149
-707 y(b)o(y)g(remo)o(ving)f(things)g(lik)o(e)h Fi(string->list)e
-Fj(from)g(the)i(rep)q(ort.)25 b(The)17 b(exp)q(erimen)o(tal)149
-763 y(libraries)i(w)o(ould)f(con)o(tain)g(solid)g(implemen)o(tations)h
-(of)e(exp)q(erimen)o(tal)i(features,)e(in-)149 819 y(cluding)i(things)e
-(that)g(migh)o(t)f(nev)o(er)h(deserv)o(e)g(to)g(b)q(e)g(in)h(the)f(rep)
-q(ort.)24 b(The)18 b(prop)q(osal)149 876 y(libraries)f(could)f(con)o
-(tain)g(an)o(ything)f(implemen)o(ted)i(in)f(p)q(ortable)g(Sc)o(heme.")
-220 932 y(Among)11 b(the)g(con)o(ten)o(t)g(of)g(the)g(accepted)h
-(libraries,)h(some)e(features)g(\(suc)o(h)g(as)g(those)149
-989 y(that)18 b(ma)o(y)f(b)q(e)h(mo)o(v)o(ed)g(out)f(of)h(the)g(b)q(o)q
-(dy)g(of)g(the)g(rep)q(ort\))f(ma)o(y)g(b)q(e)i(required)g(to)e(b)q(e)
-149 1045 y(built)e(in)f(to)f(implemen)o(tations,)h(while)h(others)e
-(will)i(b)q(e)f(exp)q(ected)g(to)f(b)q(e)h(a)o(v)m(ailable)h(on)149
-1102 y(demand)g(\(p)q(erhaps)f(using)h(something)g(similar)g(to,)e(but)
-i(not)e(the)h(same)g(as,)g Fi(require)149 1158 y Fj(as)h(found)h(in)g
-(Common)e(Lisp)j(and)e(GNU)g(Emacs\).)220 1215 y(A)f(librarian)h(w)o
-(as)d(app)q(oin)o(ted)j(\(Rees\),)e(and)h(a)f(library)i(committee)e(is)
-h(dev)o(eloping)149 1271 y(prop)q(osals)i(for)e(the)i(c)o(harter,)e
-(structure,)g(and)i(con)o(ten)o(t)e(of)h(the)g(libraries.)817
-1394 y Fh(\003)45 b(\003)g(\003)220 1517 y Fj(I)17 b(w)o(ould)g(lik)o
-(e)h(to)e(ac)o(kno)o(wledge)h(Will)h(Clinger,)g(who)e(prepared)h(the)g
-(min)o(utes)g(of)149 1574 y(the)i(meeting,)g(and)g(the)g(v)m(arious)g
-(p)q(eople)h(who)e(con)o(tributed)h(prop)q(osals,)g(including)149
-1630 y(Bill)f(Rozas)d(and)h(John)f(Ramsdell.)22 b(An)o(y)15
-b(errors)g(here)h(are)f(m)o(y)g(resp)q(onsibilit)o(y)l(,)i(ho)o(w-)149
-1687 y(ev)o(er.)j(Thanks)15 b(also)g(to)f(Norman)g(Adams)h(and)g(Ric)o
-(hard)h(Kelsey)g(for)e(corrections)h(to)149 1743 y(a)g(draft)g(of)g
-(this)g(article.)220 1799 y(I)i(w)o(ould)g(also)g(lik)o(e)h(to)f(b)q
-(elatedly)h(ac)o(kno)o(wledge)f(Norman)g(Adams,)f(P)o(a)o(v)o(el)h
-(Cur-)149 1856 y(tis,)g(Bruce)g(Donald,)f(and)h(Ric)o(hard)g(Kelsey)g
-(for)f(their)h(commen)o(ts)f(on)g(drafts)f(of)h(m)o(y)149
-1912 y(previous)g(column.)220 1969 y(F)l(or)e(future)g(columns,)h(I)g
-(am)f(en)o(tertaining)h(v)m(arious)g(topic)g(p)q(ossibilities,)i
-(includ-)149 2025 y(ing)h Fi(eval)p Fj(,)e(threads,)g
-Fi(amb)p Fj(,)g(and)h(monads.)24 b(If)17 b(y)o(ou)f(ha)o(v)o(e)h(other)
-f(ideas,)h(and)g(particu-)149 2082 y(larly)f(if)g(y)o(ou)e(think)i(the)
-f(written)h(record)f(on)g(the)g(language)g(is)h(particularly)g(p)q(o)q
-(or)f(in)149 2138 y(certain)h(areas,)e(please)i(write)g(and)f(let)h(me)
-f(kno)o(w.)149 2297 y Fg(App)q(endix:)23 b(An)17 b(implemen)o(tation)i
-(of)f Fi(dynamic-wind)149 2383 y Fj(This)c(program)e(is)h(based)g(on)g
-(m)o(y)g(v)m(ague)g(recollection)i(of)d(an)h(ancien)o(t)h(man)o
-(uscript)f(b)o(y)149 2439 y(Chris)k(Hanson)f(and)h(John)g(Lamping.)24
-b(I)17 b(ap)q(ologize)g(for)f(the)g(lac)o(k)h(of)f(data)f(abstrac-)149
-2496 y(tion,)h(but)f(the)g(co)q(de)h(is)g(more)e(concise)j(this)e(w)o
-(a)o(y)l(.)885 2620 y(7)p eop
-%%Page: 8 8
-8 7 bop 378 311 a Fj(A)11 b(state)f(space)h(is)h(a)f(tree)g(with)g(the)
-g(curren)o(t)g(state)f(at)h(the)g(ro)q(ot.)17 b(Eac)o(h)11
-b(no)q(de)h(other)307 368 y(than)i(the)f(ro)q(ot)g(is)h(a)g(triple)g
-Fh(h)p Fc(b)n(efor)n(e)o Fb(;)8 b Fc(after)p Fb(;)g Fc(p)n(ar)n(ent)o
-Fh(i)p Fj(,)13 b(represen)o(ted)h(in)g(this)h(implemen-)307
-424 y(tation)e(as)f(t)o(w)o(o)g(pairs)h Fi(\(\()p Fc(b)n(efor)n(e)23
-b Fi(.)h Fc(after)p Fi(\))g(.)g Fc(p)n(ar)n(ent)o Fi(\))p
-Fj(.)19 b(Na)o(vigating)13 b(b)q(et)o(w)o(een)g(states)307
-481 y(requires)j(re-ro)q(oting)f(the)h(tree)f(b)o(y)g(rev)o(ersing)g
-(paren)o(t-c)o(hild)i(links.)378 537 y(Since)c Fi(dynamic-wind)d
-Fj(in)o(teracts)h(with)h Fi(call-with-current-continua)o(tion)p
-Fj(,)307 594 y(this)k(implemen)o(tation)g(m)o(ust)f(replace)h(the)f
-(usual)h(de\014nition)h(of)e(the)g(latter.)307 700 y
-Fi(\(define)23 b(*here*)g(\(list)g(#f\)\))307 795 y(\(define)g
-(original-cwcc)f(call-with-current-continuat)o(ion\))307
-891 y(\(define)h(\(call-with-current-continua)o(tion)e(proc\))355
-948 y(\(let)i(\(\(here)g(*here*\)\))403 1004 y(\(original-cwcc)f
-(\(lambda)g(\(cont\))808 1060 y(\(proc)h(\(lambda)g(results)999
-1117 y(\(reroot!)g(here\))999 1173 y(\(apply)g(cont)h
-(results\)\)\)\)\)\)\))307 1269 y(\(define)f(\(dynamic-wind)f(before)h
-(during)g(after\))355 1325 y(\(let)g(\(\(here)g(*here*\)\))403
-1382 y(\(reroot!)f(\(cons)i(\(cons)f(before)g(after\))g(here\)\))403
-1438 y(\(call-with-values)e(during)450 1495 y(\(lambda)i(results)498
-1551 y(\(reroot!)g(here\))498 1608 y(\(apply)g(values)g
-(results\)\)\)\)\))307 1703 y(\(define)g(\(reroot!)g(there\))355
-1760 y(\(if)g(\(not)h(\(eq?)f(*here*)g(there\)\))450
-1816 y(\(begin)g(\(reroot!)g(\(cdr)g(there\)\))617 1873
-y(\(let)h(\(\(before)e(\(caar)i(there\)\))761 1929 y(\(after)f(\(cdar)g
-(there\)\)\))665 1986 y(\(set-car!)g(*here*)g(\(cons)g(after)g
-(before\)\))665 2042 y(\(set-cdr!)g(*here*)g(there\))665
-2098 y(\(set-car!)g(there)g(#f\))665 2155 y(\(set-cdr!)g(there)g
-('\(\)\))665 2211 y(\(set!)g(*here*)g(there\))665 2268
-y(\(before\)\)\)\)\))1043 2620 y Fj(8)p eop
-%%Trailer
-end
-userdict /end-hook known{end-hook}if
-%%EOF
diff --git a/doc/news.txt b/doc/news.txt
deleted file mode 100644
index c8eb269..0000000
--- a/doc/news.txt
+++ /dev/null
@@ -1,700 +0,0 @@
--*- Mode: Indented-text; -*-
-
-Recent changes to Scheme 48.
-
-2/24/99  (version 0.53)
-	 Additions:
-	  DEFINE-FINITE-TYPE and DEFINE-ENUMERATED-TYPE (in structure
-	   FINITE-TYPES; documented in doc/utilities.ps and
-	   doc/html/utilities.html.
-          Added CHAR-SOURCE->INPUT-PORT, CHAR-SINK->OUTPUT-PORT,
- 	   MAKE-STRING-OUTPUT-PORT, STRING-OUTPUT-SOURCE-OUTPUT to
-	   the extended-ports structure.
-	  The structure BYTE-VECTORS is the same as CODE-VECTORS with `byte'
-	   replacing `code' in all the names.  The underlying datatype is the
-	   same for both, and uses `byte' when printing.
-	  There is a new and much improved interface to C code, thanks to
-           Mike Sperber.  It is documented in in doc/external.ps and
-	   doc/html/external.html.
-         Bug fixes:
-	  Session-data and user-context records are no longer in the fluid env.
-	  Lexical environments can now be nested up to 65k deep.
-	  ,expand no longer prints `definition in expression context' warnings.
-	  Added ARRAY? and SEARCH-TREE? to the array and search tree structures.
-	  Flat environments work again.
-	  Templates of the form `var ... ...' now work in syntax rules.
-	  Reinstated caching of SCHEMIFY results to greatly reduce the space
-           used by debugging info.
-	  Added argument checking to STRING->NUMBER and NUMBER->STRING.
-	  Fixed space blow-up in LOAD.
-	  Unused ports are closed more reliably.
-	 Changes:
-	  The heap, gc, and image code is now in three separate modules.
-          The symbol table is now held in a VM register.
-	  Inlined SHOWING-FOCUS-VALUES into the main command loop and moved
-	   the sentinal call to reduce the noise at the base of ,preview output.
-	  The tables returned by MAKE-TABLE now use EQV? for comparison (instead
-	   of EQ?).  This makes these tables about 50% slower when numbers are
-           used as keys, but significantly more accurate.
-	  Floating-point numbers are no longer double boxed.
-	  The channels structure has been split into channels and low-channels.
-
-7/22/98  (version 0.52)
-         Bug fixes:
-	  Fixed problems with unbound variables in SET! and the inliner.
-	  Made macro expansion a bit less eager; this should reduce the amount
-           of heap space needed for compilation.
-
-6/29/98  (version 0.51)
-	 Incompatible changes:
-          BIG-SCHEME no longer exports its version of DEFINE-RECORD-TYPE (but
-	   it is available from the structure DEFRECORD).  I am slowly removing
-           all uses of this version of DEFINE-RECORD-TYPE from the sources.
-	  The version of DEFINE-RECORD-TYPE exported by DEFINE-RECORD-TYPES
-	   checks that every constructor argument corresponds to a field.
-	  Uses of LAP must list their free variables (see env/assem.scm).
-	 Changes:
-	  The functions exported by BIG-SCHEME that were not available elsewhere
-	   are now exported by BIG-UTIL as well.
-          MAKE-RANDOM now checks its argument (but is still a fairly poor
-           source of pseudo-randomness).
-	  SIGPIPE no longer kills the S48 process (this was done earlier but
-	   not listed here).
-	  The macro/module/compiler code has been reorganized.  Hopefully
-	   the only noticable difference is in the babble written when loading
-           files and packages.
-	  Added CODE-QUOTE (in its own structure of the same name) for use
-           in writing hygienic macro-generating macros.  CODE-QUOTE is the
-           same as QUOTE except that it does not strip off any of the macro
-	   system's name annotations.
-	  The FLOATNUMS package now exports FLOATNUM?.
-	 Bug fixes:
-	  Fixed phony stack-overflow bug.
-	  Fixed a bug in thread time-debit mechanism.
-	  Made floating point numbers always print as inexact.
-	  Got rid of bogus type-error warnings when using floatnums.
-	  Fixed declaration of call_startup_procedure in c/main.c.
-
-2/11/98  (version 0.50)
-         Fixed bug in closed-compiled version of READ-CHAR.
-	 Fixed negative-key bug in integer tables.
-
-11/18/97 (version 0.49)
-	 Removed some non-portable Kali code that had been accidentally
-	  included in c/extension.c.
-
-10/29/97 (version 0.48)
-         The VM's calling convention now has the caller doing protocol checking,
-	  instead of the callee.  The *NARGS* register no longer exists.
-	 Scheme's variable-arity procedures (APPLY, MAKE-VECTOR, +, -, etc.)
-	  are usually handled without raising an exception.  Calls with an
-	  `atypical' number of arguments are now much faster.
-	 Opcodes were added for >, <=, and >=.
-	 Procedures can take up to about 8k arguments.  The limit is determined
-	  by the value of AVAILABLE-STACK-SPACE in scheme/vm/arch.scm.
-         Compiler detects wrong number of arguments in ((lambda ...) ...).
-	 Removed the dynamic point from the dynamic environment to make
-          DYNAMIC-WIND behave reasonably with threads.
-	 KILL-THREAD! should work more reliably.
-	 The I/O primitives now pass OS error messages to the exception handlers.
-	 I/O errors when flushing buffers no longer crash the system.
-	 The Pre-Scheme compiler's hack for shadowing global variables with
-	  local copies is no longer used.
-	 Incompatible changes:
-	  The internal thread interface was simplified.
-	  There are some architecture changes; .image files will have to
-	   be rebuilt.
-          ACCESS-SCHEME-48 and scheme/misc/slib-init.scm have been removed
-	   (thanks to Mike Sperber's updating of slib).
-
-1/27/97	 (version 0.47)
-	 Fixed ,exit and added ,exit-when-done.
-	 CASE now uses EQV? exclusively.
-
-11/5/96	 (version 0.46)
-	 Fixed a few minor thread problems.
-         opt/analyze.scm now writes to current-noise-port.
-         DELQ and DELETE now delete every instance, as the documentation claims.
-	 There should be no more spurious heap-overflow interrupts.
-	 Fixed bugs that caused the system to die if stdout blocked.
-	 Template offsets have been increased to two bytes.
-	 Disassembly of flat-lambda now works (fix from Michael Sperber).
-
-8/23/96	 (version 0.45)
-	 Fixed various problems with thread termination and nested schedulers.
-	 Changed thread-internal interface to make schedulers easier to write.
-	 BITWISE-{AND,IOR,XOR} now take an arbitrary number of arguments.
-	 Output ports have their buffers flushed when Scheme 48 terminates.
-	 In keeping with RnRS, CLOSE-{IN,OUT}PUT-PORT are now idempotent.
-	 MODULO now handles negative arguments properly.
-
-6/20/96  (version 0.44)
-	 The VM's byte-code interpreter and storage management code are
-	  now compiled to separate C files.
-	 The socket code works again.
-
-5/10/96  (version 0.42-0.43)
-	 Various fixes to the thread and I/O systems.
-	 The Unix interface code is more portable.
-         EOF (control-D) now resumes running all non-broken threads on
-	  resumed command level.  Thus EOF after a keyboard interrupt
-	  (control-C) resumes running the interrupted thread.
-	 
-11/30/95 (version 0.41)
-         The distribution has been reorganized to reduce the number of files
-	  in the top-level directory.
-	 The threads implementation has been replaced with one based on engines
-	  to allow for nested schedulers.
-         Threads are now included in the initial image.
-         The I/O system has been fixed and automatic periodic output buffer
-	  flushing has been reinstalled.
-	 Command levels have been integrated with the threads system to ensure
-          that at most one REPL is active at any time.
-	 CONDVAR has been changed to PLACEHOLDER (condition variables being
-	  something quite different).
-	 ,profile no longer works, it will be fixed in a later version.
-         MIN and MAX now do inexact contagion.
-
-4/13/95  (version 0.40)
-	 Renamed error-output-port to current-error-port.
-	 Reinstated ".gdbinit"...
-	 segment->template now takes parent templates debug data as an
-	   argument.
-	 Automatic periodic output buffer flushing has been
-	   temporarily disabled.  A future version of the I/O system
-	   will fix it.
-	 Fixed expansion of named LET.
-	 The bummed-define-record-types structure is now gone; use
-	   define-record-types instead.
-	 There is somewhat better syntax checking now.
-
-8/12/94  (versions 0.38-0.39)
-         ,profile <command> prints out profiling information
-         An interrupt is raised after ever GC; the default handler checks
-           to see if some reasonable amount of storage was reclaimed.
-         Some of the standard Scheme procedures, including LENGTH, FOR-EACH,
-           VECTOR, and ASSQ, are now significantly faster.
-	 Making, accessing, and setting records is faster.
-         tar file now includes the top-level directory
-         The "scheme-level-2-internal" structure has been renamed to
-           "usual-resumer".
-         ` ( . ' is now illegal (as required by the R4RS grammar).
-	 Made DELAY and FORCE comply with R4RS.
-         The EXPAND optimizer does a topological sort on definitions.
-         (optimize flat-environments) causes the compiler to produce
-           flat (instead of nested) lexical environments.
-         The I/O system has been rewritten to do its own buffering.  There
-           are significant changes to unix.c to support this.  See doc/io.txt.
-         (ERROR-OUTPUT) is now available from the structure i/o.
-	 jar-defrecord has been replaced with a modified bummed-jar-defrecord
-         Files load about 25% faster, for a number of reasons.
-	 Removed the copy of vm/arch.scm from the rts directory.
-	 Threads and sockets work together; SOCKET-ACCEPT no longer blocks.
-         The compiler no longer prints out .'s as it compiles definitions.
-
-7/5/94   (version 0.37)
-         I/O opcodes now raise an interrupt instead of blocking (they still
-           block if no corresponding interrupt handler has been installed).
-         The threads code has been rewritten; threads that block on I/O
-           do not busy wait and THREAD-READ-CHAR and THREAD-PEEK-CHAR have
-           been removed.
-         Attempting to obtain a lock twice or to release an unowned lock
-           now signal errors.
-	 READ-CHAR-WITH-TIMEOUT returns #F if the timeout occurs.
-         The socket structure is back in more-packages.scm.
-         Renamed .gdbinit to gdbinit
-	 tar file now contains a top-level directory
-
-3/22/94  (version 0.36)
-         Removed doc/lsc.ps for copyright reasons.
-         Fixed (* 47123 46039) multiply bug.
-         Modified vm/README to make it easier to run the VM.
-
-3/16/94  (version 0.35)
-	 Fixed (exact->inexact 0.1) -> 0..1. bug.
-         Fixed VM bug that permitted the creation of stored objects with
-	   negative sizes.
-
-3/8/94   (version 0.34)
-	 "make check" target tests out various features.
-	 Fixes for SGI IRIX 4.0.5 and MIPS RISC/OS 4.51, courtesy
-	   Bryan O'Sullivan.
-	 debug/run.scm and the "medium system" work again now.
-	 misc/static.scm should work on the 68000.
-	 Command processor no longer fluid-binds (interaction-environment)
-	   on recursive entry.
-
-2/24/94  (version 0.33)
-	 Fixed bug in VM's interrupt system.
-	 Made non-local srcdir work in Makefile.
-	 Added (load-package 'bigbit) to vm/README.
-
-2/23/94  (version 0.32)
-	 Some incompatible changes to the VM; .image files will have
-	   to be rebuilt.
-	 Improvements to configuration script and to unix.c to support
-	   a wider variety of Unixes.  The system should now work
-	   under any Posix-compliant Unix (except maybe for
-	   char-ready?; see comments in unix.c).
-	 Upped the default heap size from 4 meg (2 per semispace) to 6
-	   meg (3 per semispace).
-	 New command line argument -s <size> for specifying size of
-	   stack buffer.  Default is 2500 (words).
-         $@ -> "$@" in script (thanks to Paul Stodghill for this fix).
-	 Obscure interrupt/exception VM bug fixed.
-	 It is now possible to put an initial heap image into static
-	   memory (effectively allocated by OS process creation).
-	   Immutable initial objects go into static read-only memory,
-	   and mutable initial objects go into static read-write
-	   memory.  Initial objects not copied by the GC.  There is no
-	   documentation yet, but look at the rules for little and
-	   debug/little.o in the Makefile if you're interested.
-
-2/13/94  (version 0.31)
-	 Incompatible changes:
-	   In interfaces, all exported syntactic keywords must be
-	     given type :syntax.  For example,
-	       (define-interface my-macros
-	         (export (my-macro :syntax) ...))
-	   Image entry procedures for the ,build command are now
-	     passed a list of strings, not just a single string, for
-	     the command line arguments following -a.
-	   The names of the macros defined in scheme48.h
-	     (pairp, car, string_length, etc.) are now all upper case.
-	 New "configure" script generates Makefile from Makefile.in
-	   and sysdep.h from sysdep.h.in (thanks to Gnu autoconf).
-	   See INSTALL and doc/install.txt.
-	 Bug fixes:
-           Can now make vectors (strings, etc.) as big as the amount
-             of heap space available (but you're still screwed if you
-             try to make one bigger than 2^23-1 bytes - don't do it).
-	   Non-ANSI-ness fixed in scheme48vm.c (jump out of, then
-	     back into, a block expected block-local variables to be
-	     unchanged).
-	   Fixed big/external.scm (had VECTOR-POSQ instead of ENUM).
-	   In (define-syntax foo bar) you got an error if bar was a
-	     variable reference.
-	   Plugged a storage leak (file-environments table in
-	     env/debug.scm).  Images made with ,build were too large.
-	   Flushed extraneous delay from make-reflective-tower.
-	 Renamed variables in Makefile to resemble Gnu standards.
-	 Fixed definition of LINKER_RUNNABLE in Makefile.
-	 Added doc/call-back.txt.
-	 Fixed define-enumerated documentation (doc/big-scheme.txt).
-	 Environment maps no longer retained for things in initial.image
-	   and scheme48.image.  This makes scheme48.image about 170K
-	   smaller.
-
-2/3/94   (version 0.30)
-	 Faster EXPT.
-	 FLOATNUMS improvement: (inexact->exact <float>) should now
-	   work, e.g. 
-           (inexact->exact (/ 1. 3.)) => 6004799503160661/18014398509481984
-         Reinstated ACCESS-SCHEME-48 for the benefit of PSD (portable
-           scheme debugger) and a certain other software package that
-           shall remain nameless.  It only knows about a small number of
-           procedures, including things like ERROR and FORCE-OUTPUT.
-         Various changes to support the Pre-Scheme compiler, notably
-	   SET-REFLECTIVE-TOWER-MAKER!.
-	 Incompatible change to the ENUMERATED structure: the names
-	   foo/bar no longer become defined.  Write (enum foo bar)
-	   instead.  This will macro expand into the correct small
-	   integer.
-
-1/30/94  (version 0.29)
-	 Fixed ps_run_time() to call sysconf() to find out how many
-	   ticks there are per second.  It used to assume 60.  This
-	   affects the output of the ,time command, so don't try
-	   comparing numbers from this version with numbers from older
-	   versions.
-	 ,time command will now accept a command, e.g.
-	   ,time ,load foo.scm.
-	 It appears that if multiple arguments follow -a on the
-	   argument line, they are concatenated together with spaces
-	   separating them and passed to the startup procedure.  I
-	   don't know how long this has worked.  This will change in
-	   the future so that the startup procedure gets a list of
-	   strings.
-	 Installed what used to be called the GENERAL-TABLES structure
-	   as the TABLES structure used by the system.  This allows
-	   the use of other comparison predicates besides EQ?, and
-	   eliminates some code that had a restrictive copyright
-	   notice.
-         ENUM, NAME->ENUMERAND, and ENUMERAND->NAME are all macros.
-         Enumerated types themselves are now macros as well.
-
-1/23/94  Fixed bad multiplication bug in VM: (* 214760876 10) was
-	   returning 125112.
-	 Moved RECORD-TYPE? and RECORD-TYPE-FIELD-NAMES from the
-	   RECORDS-INTERNAL interface to the RECORDS interface, for
-	   a somewhat closer approximation to MIT Scheme.
-         Various type system improvements.
-	 Still no documentation for the ,exec package, but see
-	   link/load-linker.exec for an example.
-	 New generic function feature, exported by the METHODS
-	   interface (see interfaces.scm), almost like in a certain
-	   dynamic object-oriented language.
-
-1/11/94  (version 0.27)
-	 Change:
-	   The isomorphism used by CHAR->INTEGER and INTEGER->CHAR is
-	     no longer ASCII.  This change was introduced in order to
-	     assist the development of portable programs.  If you need
-	     ASCII encoding, you should open the ASCII structure and
-	     use the procedures CHAR->ASCII and ASCII->CHAR.
-         Features:
-	   The help system is somewhat improved.
-	   New form DEFINE-STRUCTURE defines a single structure.
-	 Incompatible changes to package system:
-	   Renamed DEFINE-PACKAGE to DEFINE-STRUCTURES
-	   Renamed DEFINE-STRUCTURE to DEFINE
-	   Renamed all the base types from FOO to :FOO.  E.g.
-	     :SYNTAX, :VALUE, :PAIR, etc.
-         Other:
-	   Removed socket support due to restrictive copyright on some
-	     of the C code that was in extension.c.
-
-12/21/93 ,take has been flushed in favor of ,exec ,load.  Commands are
-	   now accessed via a distinguished package instead of a table.
-	   Documentation pending.
-         Postscript (.ps) files now included in doc/ subdirectory.  (I
-           thought they had been there all along, but apparently I was
-           wrong.)
-         Enhanced, but still kludgey, floating point support.  Use
-	   ,open floatnum.
-
-12/12/93 (version 0.26)
-	 NetBSD port.
-	 Hacked write-level and write-depth for inspecting circular
-	   structure.
-	 Recursive FORCEs signal errors, e.g.
-	   (force (letrec ((loser (delay (force loser)))) loser))
-
-12/7/93 (version 0.25)
-         Bug fix:
-	   filenames.make can now be remade using initial.image.  This
-	     means that you can snarf a distribution and then edit
-	     USUAL-FEATURES before making scheme48.image.
-
-
-12/6/93  Incompatible changes:
-	   Change of terminology: "signature" --> "interface".
-	     This means that DEFINE-SIGNATURE is now called
-	     DEFINE-INTERFACE, etc.
-           Some structures have been renamed:
-	     condition -> conditions
-	     continuation -> continuations
-	     exception -> exceptions
-	     queue -> queues
-	     port -> ports
-	     record -> records, record-internal -> records-internal
-	     table -> tables
-	     template -> templates
-	   The ,load-into command has been removed.  Use ,in ... ,load
-	     instead (see below), e.g.
-	       ,in mumble ,load myfile.scm
-           The heap size for -h is specified in words, not bytes.  As
-	     before, the size must account for both semispaces; -h 2n
-	     means n words per semispace.  This change was actually
-	     made a while ago, but I was confused as to what it meant.
-         Bug fixes:
-	   #e1.7 reads as 17/10, (exact? 1+1.0i) => #f, and 1.0+i prints.
-         Features:
-	   Things like ((structure-ref scheme if) 1 2 3) work.
-	   The following commands now take arbitrary commands to execute
-	     in the specified package, not just forms:
-	       ,config   ,user   ,for-syntax   ,in <package>
-             For example, you can say
-	       ,in mumble ,trace foo
-             This subsumes the functionality of the ,load-into and
-	     ,load-config commands.
-           Dynamic loading of shared libraries for System V systems
-	     (untested).
-         Documentation:
-	   Somewhat improved.  user-guide.txt now lists most of the
-	   interesting built-in packages.  lsc.ps is a draft of "A
-	   Tractable Scheme Implementation," a paper submitted to Lisp
-	   and Symbolic Computation.  See also doc/big-scheme.txt,
-	   doc/thread.txt, and doc/external.txt.
-
-
-10/30/93 LET-SYNTAX and LETREC-SYNTAX.
-	 Arrays (see big/array.scm).
-	 Lots of internal changes.
-
-7/20/93  Features:
-	   Type system.  See doc/types.txt.
-
-7/4/93   Features:
-           New define-package clause (for-syntax <clause>*).
-	     E.g. (define-package ((my-package ...))
-		    (open ...)
-		    (for-syntax (open scheme my-utilities)
-			        (files more-crud-for-syntax))
-                    ...)
-           A file name to package map is now used by the emacs
-	     interface.  Whenever you load a file, or zap from a file that
-	     hasn't been previously loaded or zapped, the package in
-	     which forms are being evaluated is remembered in a table.
-	     The next time you zap some forms from the same file, they
-	     will be evaluated in that package.
-	     Sometimes you may get an association you don't want.  In that
-	     situation, you can use the ,forget command to delete an
-	     entry in the table.
-           A new ,push command goes to a deeper command level.
-	   Experimental "command preferred" command processor mode: if
-	     you give the command ",form-preferred off", commands will
-	     be "preferred" to forms, meaning that you don't need to
-	     type a comma before giving a command.  To see the value
-	     of a variable FOO you have to say (begin foo).
-           Experimental "no levels" command processor mode: if you
-	     give the command ",levels off", then an error will not
-	     push a new command level.  If you want to ignore an
-	     error, you don't need to take any action - further
-	     evaluations will happen at top level.  If you want to
-	     enter the inspector or get a preview, you can issue these
-	     commands or a ,push command immediately after the error
-	     occurs (more precisely, any time until the focus object
-	     is set by some other command).
-	   All of the mode-control commands (batch, bench,
-	     break-on-warnings, form-preferred, and levels) take
-	     an optional argument.  When no argument is given, they
-	     will toggle the corresponding mode.  With an argument of
-	     ON or OFF, they turn the mode on or off.
-           The ,flush and ,keep commands have been made more flexible
-	     and verbose.
-
-
-6/18/93  Incompatible changes:
-	   The access-scheme48 procedure has gone away.  Use ,open
-	     or the module system instead.
-           The user, configuration, and for-syntax packages no longer
-	     have variables bound to them in the configuration package.
-	     Where previously you said:       Now you should say:
-	      ,in user <form>                  ,user <form>
-	      ,in config <form>                ,config <form>
-	      ,in for-syntax <form>            ,for-syntax <form>
-	      ,load-into config <file>         ,load-config <file>
-	      ,load-into for-syntax <file>     ,for-syntax (load "file")
-
-	 Features:
-           There is an ,expand <form> command for debugging macros.
-	   The ,open  command takes any number of structure names, and opens
-	     them all (like ,new-package).
-	   New procedure DEFINE-INDENTATION exported by the PP structure.
-	     E.g. (define-indentation 'let-fluid 1) is like Gnu emacs's
-	     (put 'let-fluid 'scheme-indent-hook 1).
-           The inspector simplifies generated names in continuation
-	     source code display.  E.g. when formerly it said
-	       "Waiting for (#{Generated lambda} () (x->node (car exps)))"
-	     now it says 
-	       "Waiting for (lambda () (x->node (car exps)))"
-           Macros can signal syntax errors by returning input expression
-	     unchanged.  (Comparison uses EQ?.)
-
-         Documentation:
-	   The doc/ directory contains a draft of a "Scheme 48
-	     Progress Report."
-
-         Cleanup:
-	   Procedure NULL-TERMINATE added to structure EXTERNALS's
-	     signature.
-	   "Vulgar Scheme" renamed to "Big Scheme".
-	   Two new subdirectories, env/ (for programming environment)
-	     and big/ (for Big Scheme), now contain most of what was
-	     in the misc/ directory.
-           Several source files that were in the top level and link/
-	     directories have moved to the env/ and alt/ directories.
-
-
-5/6/93   Bug fixes:
-	   Fixed -h command line switch.  The size was being improperly
-	     divided by 4, so if you asked for an N megabyte heap, you'd
-	     actually only get an N/4 megabyte heap.
-	   Nested backquotes were broken for a while; should be fixed
-	     now.
-
-         Features:
-	   Quoted structure is read-only: e.g. (set-car! '(a b) 3) will
-	     produce an exception.
-	   ,config [<form>] and ,user [<form>] are like ,in <struct> <form>.
-	   Unix socket support; see misc/socket.scm.
-	   Now using gzip instead of compress for distributions.
-	   ,open command offers to load packages.
-	   A .gdbinit file sets a breakpoint at CM's exception raising
-	     code, and defines a handy "preview" command.
-
-1/18/93  Feature:
-           Scheme 48 distributions now have version numbers.  The
-	     version number is printed in the image startup message.
-	     Please include it in bug reports.
-         The module system is now documented.  See doc/module.tex.
-
-12/17/92 Bug fixes:
-           Macro templates of the form (x ... y) are supported.
-	   Macro templates are now less fussy about meta-variable
-	     rank: you can do "(x y) ..." even when the rank of either
-	     x or y (but not both) is too low; the low-ranking text
-	     will be copied as many times as necessary.  (A
-	     meta-variable's "rank" is the number of ...'s it sits
-	     under in the left-hand side of the rewrite rule.)
-	   SYNTAX-RULES is now itself hygienic.  This means you can
-	     have a meta-variable named CAR, for instance.
-
-         New development environment features:
-	   Commands now start with comma (",") instead of colon
-	     (":").  (Easier to type since it's not shifted.)
-	   values, call-with-values, dynamic-wind, eval,
-	     interaction-environment, and scheme-report-environment
-	     added per upcoming Revised^5 Scheme report.  See
-	     doc/meeting.tex.
-	   Modifications to quoted structure will now be detected and
-	     reported as errors.
-	   An interrupt will occur if an insufficient amount of memory
-	     is reclaimed by a garbage collection.
-	   Inspector now accepts arbitrary command processor commands
-	     (with or without leading comma)
-           ,keep command controls retention of debugging information.
-
-	 Features removed:
-	   #\page and #\tab.  These aren't in the Scheme report.
-	     Their absence in Scheme 48 will encourage portability.
-	   access-scheme48 works with fewer names than before.  Use the
-	     package system instead.
-           Complex numbers not in the system, by default.  Get them
-	     back by changing usual-features in more-packages.scm.
-
-	 Features changed:
-	   Many changes to package system.  See doc/module.tex.
-           The :identify-image command is gone.  Instead, supply a
-	     second argument (optional) to the ,dump command.
-	   The inspector's TEM command has been shortened to T.
-
-         Internal changes and features:
-	   Stored objects types are now part of the virtual machine
-	     architecture, i.e. known to the byte-code compiler.
-	   Run-time system is split up into many little modules.
-	   File names are retained in debug database.  (But not used for
-	     anything yet...)
-	   Tweaks to table package reduce standard image size by 50K
-	     and increase compiler speed by 7%.
-	   Immutability bit in object headers.
-	   Weak pointers.
-
-7/18/92  Features removed:
-	   Table package's default hash function no longer supports
-	     string, pairs, or vectors.
-
-7/9/92   Bug fixes:
-	   (- 0 -536870912)
-	   Inspector now uses command i/o ports instead of current ones
-	   Inexact integers print as N. instead of #iN
-	   Throwing back into a call-with-....put-port now produces a
-	     warning instead of an error
-
-	 Feature fixes:
-	   In DEFINE-PACKAGE, OPEN no longer implies ACCESS.
-	   misc/receive.scm renamed to rts/values.scm, made to conform
-	     with Revised^5 Report, and installed internally.
-
-	 Features:
-	   New :load-package command.  Uses file names in (file ...) clause
-	     of a define-package.  These are interpreted relative to the
-	     directory in which the file containing the define-package
-	     was found.
-	   #\tab and #\page now print this way.
-
-
-6/17/92  Bug fixes:
-	   Fixed bug in modulo.
-	   Flushed LAST-PAIR (which disappeared between R^3 and R^4).
-	   DEFINE-SYNTAX and SYNTAX-RULES now exist.
-	   CEILING, FLOOR, and ROUND now exist.
-	   GCD and LCM are now n-ary.
-	   STRING-CI=? and STRING-COPY fixed.
-	   STRING->SYMBOL now copies its argument before handing it to
-	     INTERN.
-	   =, <, etc. now work with more than two arguments.
-	   CHAR-READY? exists.
-	   Calls via APPLY are now tail-recursive.
-	   DISPLAY of vectors and lists works (ugh).
-
-	 Development environment improvements:
-	   Type ? at inspector to get list of inspector commands.
-	   Inspector D command goes to next continuation.
-	   Inspector M command shows more of a long menu.
-	   Inspector TEM command goes to a continuation's or closure's
-	     template.
-	   For closures and continuations, inspector displays local
-	     variables with their names. 
-	   For continuations, inspector displays source code for
-	     expression into which control will return.
-	   Multiple command loop levels.  EOF (control-D) now only pops
-	     out a single level.  :reset pops all the way out.  :level n
-	     goes out to level n.
-	   Can disable benchmark mode.
-	   Procedures made with (let ((f (lambda ...))) ...) now print
-	     with names.
-
-	 Features:
-	   Package system: special forms define-package and package-ref;
-	     command processor commands :set-package, :load-into,
-	     :clear-package, :new-package, :export, :open-package, etc.
-	   In misc directory: threads, queues, extended ports, format, etc.
-
-	 Changes to system environment:
-	   user-initial-environment -> user-package
-	   record-updator -> record-modifier
-	   primitive-throw superseded by with-continuation
-	   ash -> arithmetic-shift
-	   New bootstrap regime.
-	   Support for threads: alarm clock interrupt, etc.
-
-	 Etc.:
-	   Liberal COPYRIGHT file, and a little notice in each source file.
-	   INSTALL and NEWS split off from README.
-	   doc.txt renamed to user-guide.txt.
-	   The Makefile now provides two ways to make "s48" for
-	     installation.  One depends on the exec #! script execution
-	     feature and the other doesn't.
-	   "make" targets for testsys.image and little.image.
-	   Runs Jaffer's test suite and library.
-	   Flushed s48.el.  Use cmuscheme instead.
-
-
-9/5/90   Command processor argument parser revamped.
-	 :load, :trace, and :untrace commands take arbitrary number
-	   of arguments.  Argument to :proceed is optional.
-	 New (but undocumented) :identify-image command.
-	 Better error messages: wrong number of arguments, undefined
-	   variable.
-	 +, *, min, max, apply are now n-ary; -, /, make-string,
-	   make-vector, read-char, peek-char, write-char have
-	   appropriate argument optionality.
-	 Better internal support for macros; not yet ready for release.
-	 Added STRING as per R^3.99RS.
-	 More testing of Scheme version of bytecode interpreter.
-	 Better scoping of ##; files can't see command processor context.
-	 OR and CASE don't cons closures.
-	 VM checks for non-existent heap image file, gives error
-	   message instead of "bus error".
-	 Numerous internal changes in compiler and exception system.
-	 Fixed char<?.
-	 Fixed -.5 bug in string->number.
-
-8/26/90  Tested (link-system) inside of T; seems to work.
-	 Benchmark mode available via :BENCH command.
-	 System is 15K bigger due to new fatter global environment
-	   representations.
-	 Inspector abbreviation improved.
-	 Disassembler now works on continuations, sort of.
-
-7/26/90  ((lambda ...) ...) no longer makes a closure
-	 Features now in default system:
-	    :inspect
-	    :dis[assemble]
-	    Generic arithmetic: bignums, rationals, complexes
-	    rationalize
-	    :time command is more verbose
-	 MOREFILES variable in Makefile for loading extra stuff
-	 Default heap size increased to 2 megabytes per semispace
diff --git a/doc/no-leaf-env.txt b/doc/no-leaf-env.txt
deleted file mode 100644
index 87a6967..0000000
--- a/doc/no-leaf-env.txt
+++ /dev/null
@@ -1,175 +0,0 @@
-Return-Path: <kelsey@ccs.neu.edu>
-Date: Mon, 14 Jun 93 14:34:40 -0400
-To: jar@cs.cornell.edu
-Subject: environments for leaf procedures
-From: kelsey@flora.ccs.neu.edu
-Sender: kelsey@ccs.neu.edu
-
-
-I merged the no-leaf-environments code back into the system, and this
-time it may be worth it.  Loading pp.scm sped up by 2%, even though
-the compiler is doing more work.  Benchmark times (in seconds):
-
-                    old    new   speedup
-quicksort           1.48   1.39     6%
-towers              1.05   1.05     0%
-matrix-multiply     3.32   3.10     7%
-matrix-multiply2    1.94   1.80     7%
-
-Local variable names are screwed up:
-
-  > (define (f x) (let ((y 4)) (+ x y)))
-  > (f 'a)
-
-  Error: exception
-         (+ 'a 4)
-  1> ,debug
-  '#{Continuation (pc 13) f}
-
-   [0] 4
-   [1: y] 'a
-  inspect: 
-
-There is probably a simple fix for this.
-
-Here is the diff:
-
-% diff comp.scm comp.scm.save
-26d25
-< (define $compiling-leaf (make-fluid 'no))
-28,33d26
-< (define (note-not-leaf!)
-<   (set-fluid! $compiling-leaf 'no))
-< 
-< (define (compiling-leaf?)
-<   (eq? 'yes (fluid $compiling-leaf)))
-< 
-63,82c56,66
-<     (deliver-value (if (env-ref? den)
-< 		       (local-variable den cenv depth #f)
-< 		       (instruction-with-variable op/global exp den #f))
-< 		   cont)))
-< 
-< (define (local-variable den cenv depth set?)
-<   (let ((back (env-ref-back den cenv))
-< 	(over (env-ref-over den)))
-<     (if (and (compiling-leaf?)
-< 	     (= back 0))
-< 	(instruction (if set? op/stack-set! op/stack-ref)
-< 		     (+ (- over 1) depth))
-< 	(let ((back (if (compiling-leaf?) (- back 1) back)))
-< 	  (if set?
-< 	      (instruction op/set-local! back over)
-< 	      (case back
-< 		((0) (instruction op/local0 over)) ;+++
-< 		((1) (instruction op/local1 over)) ;+++
-< 		((2) (instruction op/local2 over)) ;+++
-< 		(else (instruction op/local back over))))))))
----
->     (if (env-ref? den)
-> 	(let ((back (env-ref-back den cenv))
-> 	      (over (env-ref-over den)))
-> 	  (deliver-value (case back
-> 			   ((0) (instruction op/local0 over)) ;+++
-> 			   ((1) (instruction op/local1 over)) ;+++
-> 			   ((2) (instruction op/local2 over)) ;+++
-> 			   (else (instruction op/local back over)))
-> 			 cont))
-> 	(deliver-value (instruction-with-variable op/global exp den #f)
-> 		       cont))))
-143,145c127,132
-< 	  (if (env-ref? den)
-< 	      (local-variable den cenv depth #t)
-< 	      (instruction-with-variable op/set-global! name den #t)))
----
-> 	  (cond ((env-ref? den)
-> 		 (instruction op/set-local!
-> 			      (env-ref-back den cenv)
-> 			      (env-ref-over den)))
-> 		(else
-> 		 (instruction-with-variable op/set-global! name den #t))))
-203d189
-<   (note-not-leaf!)  ; this isn't strictly necessary, but it keeps things simpler
-222,231c208,215
-<   (cond ((return-cont? cont) 
-< 	 code)
-< 	(else
-< 	 (note-not-leaf!)  ; this isn't strictly necessary, but it keeps things simpler
-< 	 (sequentially (instruction-with-offset&byte op/make-cont
-< 						     (segment-size code)
-< 						     depth)
-< 		       (note-source-code (cont-source-info cont)
-< 					 code)
-< 		       (cont-segment cont)))))
----
->   (if (return-cont? cont) 
->       code
->       (sequentially (instruction-with-offset&byte op/make-cont
-> 						  (segment-size code)
-> 						  depth)
-> 		    (note-source-code (cont-source-info cont)
-> 				      code)
-> 		    (cont-segment cont))))
-264d247
-<   (note-not-leaf!)
-280,315c263,284
-<   (let-fluids $compiling-leaf 'maybe
-<     (lambda ()
-<       (let ((code (really-compile-lambda-code formals body cenv name)))
-< 	(if (eq? (fluid $compiling-leaf) 'maybe)
-< 	    (let-fluids $compiling-leaf 'yes
-< 	      (lambda ()
-< 		(really-compile-lambda-code formals body cenv name)))
-< 	    code)))))
-< 
-< (define (really-compile-lambda-code formals body cenv name)
-<   (let* ((nargs (number-of-required-args formals))
-< 	 (vars (normalize-formals formals))
-< 	 (cenv (if (null? formals)
-< 		   cenv			;+++
-< 		   (bind-vars vars cenv))))
-<     (sequentially
-<      (cond ((n-ary? formals)
-< 	    (sequentially
-< 	     (instruction op/make-rest-list nargs)
-< 	     (instruction op/push)
-< 	     (if (compiling-leaf?)
-< 		 empty-segment
-< 		 (instruction op/make-env (+ nargs 1)))))
-< 	   ((null? formals)
-< 	    (note-not-leaf!) ; no point if no variables
-< 	    empty-segment)
-< 	   ((compiling-leaf?)
-< 	    empty-segment)
-< 	   (else
-< 	    (instruction op/make-env nargs)))
-<      (note-environment
-<        vars
-<        (compile-body body
-< 		     cenv
-< 		     0
-< 		     (return-cont name))))))
----
->   (if (null? formals)
->       (compile-body body		;+++ Don't make null environment
-> 		    cenv
-> 		    0
-> 		    (return-cont name))
->       (sequentially
->        (let ((nargs (number-of-required-args formals)))
-> 	 (if (n-ary? formals)
-> 	     (sequentially
-> 	      (instruction op/make-rest-list nargs)
-> 	      (instruction op/push)
-> 	      (instruction op/make-env (+ nargs 1)))
-> 	     (instruction op/make-env nargs)))
->        (let* ((vars (normalize-formals formals))
-> 	      (cenv (bind-vars vars cenv)))
-> 	 (note-environment
-> 	  vars
-> 	  (compile-body body
-> 			cenv
-> 			0
-> 			(return-cont name)))))))
-> 
-
diff --git a/doc/scheme48.man b/doc/scheme48.man
deleted file mode 100644
index 6463bae..0000000
--- a/doc/scheme48.man
+++ /dev/null
@@ -1,81 +0,0 @@
-.TH LS48 1
-.\" File scheme48.man:  Manual page template for Scheme 48.
-.\" Replace LS48 with the name of your default image and LLIB with the
-.\" directory containing scheme48vm and default image.
-.SH NAME
-LS48 \- a Scheme interpreter
-.SH SYNOPSIS
-.B LS48
-[-i image] [-h heapsize] [-a argument]
-.SH DESCRIPTION
-.B LS48
-is an implementation of the Scheme programming language as described in
-the
-.I "Revised^4 Report on the Algorithmic Language Scheme."
-A runnable system requires two parts, an executable program that implements
-the Scheme 48 virtual machine, and an image that is used to initialize
-the store of the virtual machine.
-.B LS48
-is a shell script that starts the virtual machine with an image that runs
-in a Scheme command loop.
-.PP
-The
-.B LS48
-command loop reads Scheme expressions, 
-evaluates them, and prints their results.
-It also executes commands, which are identified by an initial comma character.
-Type the command
-.I ,help
-to receive a list of available commands.
-.PP
-The
-.B \-h
-option causes 
-.IR heapsize
-words to be allocated for both semispaces of the copying garbage
-collector.  One word is four bytes.  Cons cells are currently 3 words,
-so if you want to make sure you can allocate, say, a million cons
-cells, you should specify
-.B \-h
-6000000 (actually a little more, to account for the initial heap
-image and breathing room).
-.PP
-The 
-.I ,dump
-and
-.I ,build
-commands put heap images in files.
-The 
-.B \-i
-option causes the initial heap image to be taken from file
-.IR image .
-The
-.B \-a
-option causes a list of strings to be passed as the argument
-to an image generated using the 
-.I ,build
-command.  The first argument to
-.I ,build
-is a procedure that is passed
-the arguments following
-.B \-a
-and which should return an integer (which is the
-return value of the Scheme 48 process).
-.PP
-.nf
-     > ,build (lambda (a) (display a) (newline) 0) foo.image
-     > ,exit
-     $ LS48 -i foo.image -a mumble
-     mumble
-     $ 
-.PP
-.fi
-.SH FILES
-.TP 40
-.B LLIB/scheme48vm
-the virtual machine.
-.TP
-.B LLIB/LS48.image
-the default image.
-.SH BUGS
-Procedure calls with more than 63 explicit arguments might not work.
diff --git a/doc/src/code.tex b/doc/src/code.tex
deleted file mode 100644
index aa8de05..0000000
--- a/doc/src/code.tex
+++ /dev/null
@@ -1,94 +0,0 @@
-% Latex Macros for Lisp code in text.
-% Based on macros found in C. Rich's library.
-
-\makeatletter
-
-% \vobeyspaces turns all spaces into non-breakable spaces.
-% Note: this is like \@vobeyspaces except without spurious space in defn.
-
-{\catcode`\ =\active\gdef\vobeyspaces{\catcode`\ =\active\let =\@xobeysp}}
-
-% \def\vobeytabs turns all tabs into 8 non-breakable spaces
-
-{\catcode`\^^I=\active\gdef\vobeytabs{\catcode`\^^I=\active\let^^I=\xvobeytabs}}
-
-\def\xvobeytabs{\@xobeysp\@xobeysp\@xobeysp\@xobeysp\@xobeysp\@xobeysp\@xobeysp\@xobeysp}
-
-% \vobeylines turns all cr's into non-breakable \par's
-
-{\catcode`\^^M=\active\gdef\vobeylines{\catcode`\^^M=\active\let^^M=\xvobeylines}}
-
-\def\xvobeylines{\par\penalty10000}
-
-% \obeycrsp turns cr's into non-breakable spaces
-
-{\catcode`\^^M=\active\gdef\obeycrsp{\catcode`\^^M=\active\let^^M=\@xobeysp}}
-
-%% \@noligs prevents ?` and !` from being treated as ligatures
-%% added 19 April 86  [copied from Latex sources]
-
-\begingroup
-\catcode``=13
-\gdef\@noligs{\let`=\@lquote}
-\endgroup
-
-% Set up code environment, in which most of the common special characters
-% appearing in code are treated verbatim, namely: _ # & ^ $ ~ @ " %
-%  *** JAR NEEDED $ AND _ IN SOME CODE ***
-
-% Note: \ { } are still enabled so that macros can be called in this
-% environment.  Use \\, \{ and \} to use these characters verbatim
-% in this environment.  
-
-% Note: this environment allows no breaking of lines whatsoever; not
-% at spaces or hypens.  To arrange for a break use the standard \- macro,
-% or the \= macro which breaks, but inserts nothing.  This is useful,
-% for example for allowing hypenated identifiers to be broken, e.g.
-% FOO-\=BAR.
-
-\def\setupcode{\parsep=0pt\parindent=0pt
-  \tt\frenchspacing\catcode``=13\@noligs%
-  \def\\{\char`\\}%
-  \@makeother\#\@makeother\&\@makeother\^%\@makeother\_\@makeother\$%
-  \@makeother\`\@makeother\'%
-  \@makeother\~\@makeother\@\@makeother\"\@makeother\%\vobeytabs\vobeyspaces}
-
-% Code environment as described above.  Note that blank lines are
-% not preserved, and lines are not kept on one page.  Code is
-% indented by the same amount as quotes.
-% Note: to increase left margin, use \leftmargini=1in.
-%  was  {\list{}{\parsep=0pt}\item[]\setupcode\obeylines}%
-% then {\list{\parsep=0pt\listparindent=0pt\leftmargin=0pt}{}\item[]\setupcode%
-
-\newenvironment{bigcode}%
-  {\list{}{\parsep=0pt\leftmargin=0pt\labelwidth=0pt\itemindent=0pt%
-\listparindent=0pt}\item[]\setupcode%
-\obeylines}%
-  {\endlist}
-
-% Code is just like bigcode, but everything inside is kept on one page
-% Note: This actually works by setting a huge penalty for breaking
-% between lines of code.
-%  was  {\list{}{\parsep=0pt}\item[]\setupcode\vobeylines}%
-
-\newenvironment{code}%
-  {\list{}{\parsep=0pt\leftmargin=0pt\labelwidth=0pt\itemindent=0pt%
-\listparindent=0pt}\item[]\setupcode%
-\vobeylines}%
-  {\endlist}
-
-% Reasonable separation between lines of code
-
-\newcommand{\codeskip}{\penalty0\vspace{2ex}}
-
-% \cd is used to build a code environment in the middle of text.
-% Note: only difference from display code is that cr's are taken
-% as unbreakable spaces instead of \par's.
-
-\newcommand{\cd}{\begingroup\setupcode\obeycrsp\startcode}
-
-\newcommand{\startcode}[1]{#1\endgroup}
-
-%\setbox0\hbox{\@xobeysp}\hline{43\wd0}
-
-\makeatother
diff --git a/doc/src/meeting.tex b/doc/src/meeting.tex
deleted file mode 100644
index 4a696cb..0000000
--- a/doc/src/meeting.tex
+++ /dev/null
@@ -1,439 +0,0 @@
-\documentstyle[11pt,twoside]{article}
-
-\input{code}
-\input{latex-stuff}
-
-\advance \textheight by 2ex
-
-\begin{document}
-
-\begin{center}
-{\Large\bf The Scheme of Things:} \\
-\vspace{2ex}
-{\Large\bf The June 1992 Meeting$^{\hbox{\scriptsize 1}}$} \\
-\vspace{3ex}
-Jonathan Rees \\
-Cornell University \\
-{\tt jar@cs.cornell.edu}
-\end{center}
-
-\vspace{3ex}
-
-\footnotetext[1]{To appear in {\em Lisp Pointers} V(4),
-October--December 1992.}
-
-
-An informally constituted group of people interested in the future of
-the Scheme programming language met at the Xerox Palo Alto Research
-Center on 25 June 1992.  The main purpose of the meeting was to work
-on the technical content of the next revision of the Scheme report.
-
-We made progress on several fronts:
-\begin{itemize}
-\item Some differences with the IEEE Scheme standard were resolved.
-
-\item Proposals for multiple return values and {\tt dynamic-wind} were
-adopted.
-
-\item A proposal for an {\tt eval} procedure was adopted.
-
-\item The high-level macro facility described in the 
-Revised$^4$ Report's appendix will be moved into the report proper.
-\end{itemize}
-
-Two subcommittees were formed: one to work on exceptions, and one to
-charter the formation of a standard library.  The subcommittees will
-report back to the group with proposals for inclusion in the report.
-
-It had been hoped that there would be progress on some other fronts
-(user-defined types, dynamic binding, improvements to ``rest''
-parameters), but after inconclusive discussion these topics were
-dropped.  These topics will probably be taken up again in the future.
-
-Norman Adams was appointed the Revised$^5$ Report's editor.  It is
-hoped that it will be ready by early 1993, so as to precede the
-reconstitution of the IEEE standard group.
-
-This article is my own interpretation of what transpired, and should
-not be construed as definitive.
-
-
-\piece{Agreement with the IEEE Scheme standard}
-
-Until now, the Scheme reports have encouraged but not required the
-empty list {\tt()} and the boolean false value {\tt\#f} to be
-distinct.  It has been the intent ever since the Revised Revised
-Report, however, that this distinction would eventually be required.
-The IEEE Scheme standard bit the bullet in 1990, and now the
-Revised$^5$ report follows.
-
-The standard also dropped the distinction between essential and
-not-essential language features; most features that were formerly not
-essential, such as n-ary {\tt+} and {\tt apply}, are now required.
-The Revised$^5$ Report will adopt this stance, at least as regards
-language features that are shared with the IEEE standard.
-Non-essential non-IEEE oddities such as {\tt transcript-on} and {\tt
-transcript-off} and the proposed {\tt interaction-\ok{}environment} (see
-below) were not discussed at the meeting, however, and consensus on
-their status will have to be reached via electronic mail.
-
-A third aspect of the standard that was adopted was a certain obscure
-paragraph regarding assignments to top-level variables (section 6,
-paragraph 2).  The effect of this is that if a program contains an
-assignment to any top-level variable, then the program must contain a
-{\tt define} for that variable; it is not sufficient that the variable
-be bound.  This has been the case for most variables, but the rule
-applies as well to variables such as {\tt car} that have built-in
-bindings.  In addition, it is clarified that if a program makes such a
-definition or assignment, then the behavior of built-in procedures
-will not be affected.  For example, redefining {\tt length} cannot
-affect the behavior of the built-in {\tt list->vector} procedure.
-If in some particular implementation {\tt list->vector} is written
-in Scheme and calls {\tt length}, then it must be sure to call the
-built-in {\tt length} procedure, not whatever happens to be the value
-of the variable {\tt length}.
-
-
-\piece{Multiple return values}
-
-The {\tt call-with-values} and {\tt values} procedures were described
-in an earlier Scheme of Things ({\em Lisp Pointers}, volume IV, number
-1), but I'll review them here.  The following is adapted from John Ramsdell's
-concise description:
-
-\begin{list}{}{}{}\item
-    {\tt(values \var{object} $\ldots$)}
-        \hfill {\rm essential procedure}
-
-    {\tt values} delivers all of its arguments to its continuation.  
-
-    \vspace{2ex}
-
-    {\tt(call-with-values \var{thunk} \var{receiver})}
-        \hfill {\rm essential procedure}
-
-    {\tt call-with-values} calls its \var{thunk} argument with a
-    continuation that, when passed some values, calls the
-    \var{receiver} procedure with those values as arguments.
-    The continuation for the call to \var{receiver} is the
-    continuation of the call to {\tt call-with-values}.
-\end{list}
-
-Except for continuations created by the {\tt call-with-values}
-procedure, all continuations take exactly one value, as now; the
-effect of passing no value or more than one value to continuations
-that were not created by {\tt call-with-values} is unspecified (as
-indeed it is unspecified now).
-
-{\tt values} might be defined as follows:
-\begin{code}
-    (define (values . things)
-      (call-with-current-continuation 
-        (lambda (cont) (apply cont things))))
-\end{code}
-That is, the procedures supplied by {\tt
-call-with-current-continuation} must be passed the same number of
-arguments as values expected by the continuation.
-
-Because the behavior of a number-of-values mismatch between a
-continuation and its invoker is unspecified, some implementations may
-assign some specific meaning to such situations; for example, extra
-values might be ignored, or defaults might be supplied for missing
-values.  Thus this multiple return value proposal is compatible with
-Common Lisp's multiple values, but strictly more conservative than it.
-The behavior of programs in such situations was a point of contention
-among the authors, which is why only the least common denominator
-behavior was specified.
-
-
-\piece{Unwind/wind protection}
-
-{\tt dynamic-wind}, which was described previously in this column (when it
-was The Scheme Environment; {\em Lisp Pointers}, volume I, number 2),
-is already implemented in many Scheme dialects.  {\tt dynamic-wind}
-takes three arguments, all of which are thunks (procedures of no arguments).
-It behaves as if it were defined with
-\begin{code}
-    (define (dynamic-wind before during after)
-      (before)
-      (call-with-values during
-        (lambda results
-          (after)
-          (apply values results))))
-\end{code}
-except that the execution of the {\tt during} thunk is ``protected''
-against non-local entries and exits: a throw out of the execution
-of {\tt during} will cause the {\tt after} thunk to be invoked, and a
-throw from outside back in will cause the {\tt before} thunk to be
-invoked.  (By ``throw'' I mean an invocation of an explicit
-continuation as obtained from {\tt call-with-current-continuation}.)
-
-For details, the earlier Scheme Environment column refers the reader
-to Friedman and Haynes's paper ``Constraining Control'' in POPL 1985,
-but to save you the trouble of looking that up, I have supplied a more
-direct implementation of {\tt dynamic-wind} in an appendix to the
-present column.
-
-{\tt dynamic-wind} was adopted with the following clarifications: The
-semantics of {\tt(dynamic-wind \var{before} \var{during} \var{after})}
-should leave unspecified what happens if a throw occurs out of {\em
-before} or {\em after}\/; and it is best to defer interrupts during {\em
-before} and {\em after}.
-
-
-
-\piece{Evaluating computed expressions}
-
-The original 1975 memo on Scheme described {\tt evaluate},
-which was analogous to Lisp's traditional {\tt eval} function.  {\tt
-evaluate} took a single argument, an S-expression, and invoked an
-interpreter on it.  For example:
-\begin{code}
-    (let ((name '+)) (evaluate (list name 2 3)))
-        \ev  5
-\end{code}
-Scheme being lexically scoped, however, there was some confusion over
-which environment the expression was to be evaluated in.  Should
-\begin{code}
-    (let ((name '+))
-      (let ((+ *))
-        (evaluate (list name 2 3))))
-\end{code}
-evaluate to 5 or to 6?
-
-To clarify matters, the Revised Report replaced {\tt evaluate} with
-{\tt enclose}, which took two arguments, a {\tt lambda}-expression and
-a representation of an environment from which to supply bindings of the
-{\tt lambda}-expression's free variables.  For example:
-\begin{code}
-    (let ((name '+))
-      (let ((+ *))
-        ((enclose (list 'lambda '() (list name 2 3))
-                  (list (cons '+ +))))))
-        \ev  6
-\end{code}
-This forced the programmer to be explicit about the {\tt
-lambda}-expression's enclosing environment.
-
-For various technical and practical reasons, there was no {\tt eval}
-analogue in subsequent Scheme reports.  The major stumbling blocks
-were how to describe {\tt eval} formally and how to define something
-that makes sense in all extant variants of the language.  Some Scheme
-implementations contain a distinguished top-level environment, while
-others extend the language by providing ways to create multiple
-environments, any of which might serve equally well.
-
-The {\tt eval} proposal adopted at the June meeting, which I reproduce
-here, is one that comes from Bill Rozas.
-
-\begin{list}{}{}{}\item
-
-    {\tt(eval \var{expression} \var{environment-specifier})}
-        \hfill {\rm essential procedure}
-
-    {\tt eval} evaluates \var{expression} in the environment indicated
-    by {\em environment-\discretionary{}{}{}specifier}.  {\em
-    environment-specifier} may be the return value of one of the three
-    procedures described below, or implementation-specific extensions.
-    No other operations on environment specifiers are defined by this
-    proposal.
-
-    Implementations may allow non-expression programs (i.e.\
-    definitions) as the first argument to {\tt eval} \var{only} when
-    the second argument is the return value of {\tt interaction-environment}
-    or some implementation extension.  In other words, {\tt eval} will never
-    create new bindings in the return value of {\tt null-environment} or
-    {\tt scheme-report-environment}.
-
-    \vspace{2ex}
-
-    {\tt(scheme-report-environment \var{version})}
-        \hfill {\rm essential procedure}
-
-    {\em Version} must be an exact non-negative integer corresponding to a
-    version of one of the Revised$^n$ Reports on Scheme.  This procedure
-    returns a specifier for an environment that contains exactly the
-    set of bindings specified in the corresponding report that the
-    implementation supports.  Not all versions may be available in all
-    implementations at all times.  However, an implementation that
-    conforms to version $n$ of the Revised$^n$ Reports on Scheme must
-    accept version $n$.  If {\tt scheme-report-environment} is
-    available, but the specified version is not, the procedure will
-    signal an error.
-
-    The effect of assigning (through the use of {\tt eval}) a variable
-    bound in a {\tt scheme-report-environment} (e.g.\ {\tt car}) is
-    unspecified. Thus the environments specified by the return
-    values of {\tt scheme-report-environment} may be immutable.
-
-    \vspace{2ex}
-
-    {\tt(null-environment)}
-        \hfill {\rm essential procedure}
-
-    This procedure returns a specifier for an environment that contains no
-    variable bindings, but contains (syntactic) bindings for all the
-    syntactic keywords defined in the report, and no others.
-
-    \vspace{2ex}
-    %\newpage  %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-    {\tt(interaction-environment)}
-        \hfill {\rm procedure}
-
-    This procedure returns a specifier for an environment that
-    contains imple\-men\-ta\-tion-defined bindings, typically a superset of
-    those listed in the report.  The intent is that this procedure
-    will return a specifier for the environment in which the
-    implementation would evaluate expressions dynamically typed by the
-    user.
-
-\end{list}
-
-Rozas explains:
-``The proposal does not imply the existence or support of first-class
-environments, although it is compatible with them.
-The proposal only requires a way of associating tags with a finite set
-of distinguished environments which the implementations can maintain
-implicitly (without reification).
-
-``\,`Pascal-like' implementations can support both {\tt null-environment} and
-%\penalty0
-{\tt scheme-report-environment} since the environments specified by
-the return values of these procedures need not share any bindings with
-the current program.  A version of {\tt eval} that supports these but
-not {\tt interaction-environment} can be written portably,
-but can be better written by the implementor, since it can share code
-with the default evaluator or compiler.''
-
-Here ``Pascal-like'' refers to implementations that are restricted to
-static compilation and linking.  Because an {\tt eval} that doesn't
-support
-\penalty0
-{\tt interaction-\discretionary{}{}{}environment} can be written
-entirely in the Scheme language described by the rest of the report,
-it raises no troublesome questions about its formal semantics.
-
-
-\piece{Macros}
-
-The consensus of the meeting was that {\tt define-syntax}, {\tt
-syntax-rules}, {\tt let-\discretionary{}{}{}syntax}, and {\tt
-letrec-syntax} should be moved out of the report's appendix into the
-main body of the report.  Although everyone agrees that a low-level
-macro facility is important, the subject is too contentious at
-present, with three or more competing proposals at present.  The
-disposition of the rest of the appendix and of the other low-level
-proposals will be left up to the report's editor.
-
-
-\piece{Committee work}
-
-There is a strong sense that some kind of exception system is needed.
-However, no specific proposal was ready at the time of the meeting.  A
-committee has been formed to work on one.  What seems to be in the
-air might be described as a highly distilled version of the condition
-system that Kent Pitman developed for Common Lisp.  I hope that I'll
-be able to report on this in a future column.
-
-
-On the subject of libraries, Will Clinger's minutes report that
-``the authors perceive a need to give some library official status.  In
-fact, we need to give official sanction to multiple libraries.  There
-is reason to distinguish between accepted (or standard) libraries,
-experimental libraries, and proposals.  The accepted libraries can
-reduce the intellectual size of the language by removing things like
-{\tt string->list} from the report.  The experimental libraries would
-contain solid implementations of experimental features, including
-things that might never deserve to be in the report.  The proposal
-libraries could contain anything implemented in portable Scheme.''
-
-
-Among the content of the accepted libraries, some features (such as
-those that may be moved out of the body of the report) may be required
-to be built in to implementations, while others will be expected to be
-available on demand (perhaps using something similar to, but not the
-same as, {\tt require} as found in Common Lisp and GNU Emacs).
-
-A librarian was appointed (Rees), and a library committee is
-developing proposals for the charter, structure, and content of the
-libraries.
-
-
-\separator
-
-I would like to acknowledge Will Clinger, who prepared the minutes of
-the meeting, and the various people who contributed proposals,
-including Bill Rozas and John Ramsdell.  Any errors here are my
-responsibility, however.  Thanks also to Norman Adams and Richard
-Kelsey for corrections to a draft of this article.
-
-I would also like to belatedly acknowledge Norman Adams, Pavel
-Curtis, Bruce Donald, and Richard Kelsey for their comments on drafts of
-my previous column.
-
-For future columns, I am entertaining various topic possibilities,
-including {\tt eval}, threads, {\tt amb}, and monads.
-If you have other ideas, and particularly if you think the written
-record on the language is particularly poor in certain areas, please
-write and let me know.
-
-\vspace{2ex}
-
-%\newpage
-
-%\bgroup \small
-
-\piece{Appendix: An implementation of {\tt dynamic-wind}}
-
-This program is based on my vague recollection of an ancient
-manuscript by Chris Hanson and John Lamping.  I apologize for the lack
-of data abstraction, but the code is more concise this way.
-
-A state space is a tree with the current state at the root.  Each node other
-than the root is a triple $\langle\var{before}, \var{after},
-\var{parent}\rangle$, represented in this implementation as two pairs
-{\tt((\var{before} .\ \var{after}) .\ \var{parent})}.
-Navigating between states requires re-rooting the tree by reversing
-parent-child links.
-
-Since {\tt dynamic-wind} interacts with {\tt
-call-with-current-continuation}, this implementation must replace the
-usual definition of the latter.
-
-\begin{code}
-(define *here* (list #f))
-\codeskip
-(define original-cwcc call-with-current-continuation)
-\codeskip
-(define (call-with-current-continuation proc)
-  (let ((here *here*))
-    (original-cwcc (lambda (cont)
-                     (proc (lambda results
-                             (reroot! here)
-                             (apply cont results)))))))
-\codeskip
-(define (dynamic-wind before during after)
-  (let ((here *here*))
-    (reroot! (cons (cons before after) here))
-    (call-with-values during
-      (lambda results
-        (reroot! here)
-        (apply values results)))))
-\codeskip
-(define (reroot! there)
-  (if (not (eq? *here* there))
-      (begin (reroot! (cdr there))
-             (let ((before (caar there))
-                   (after (cdar there)))
-               (set-car! *here* (cons after before))
-               (set-cdr! *here* there)
-               (set-car! there #f)
-               (set-cdr! there '())
-               (set! *here* there)
-               (before)))))
-\end{code}
-
-%\egroup
-
-\end{document}
diff --git a/doc/src/summary.tex b/doc/src/summary.tex
deleted file mode 100644
index 17c8555..0000000
--- a/doc/src/summary.tex
+++ /dev/null
@@ -1,83 +0,0 @@
-\documentstyle[11pt]{article}
-
-\pagestyle{empty}
-\setlength{\textheight}{9in}
-\setlength{\footheight}{0.0in}
-\setlength{\topmargin}{0in}
-
-%Defaults from art10.sty:
-%\textwidth 345pt \columnsep 10pt \columnseprule 0pt 
-%\oddsidemargin 63pt
-
-\advance\textwidth by 0.5in
-\advance\oddsidemargin by -0.25in
-
-
-\begin{document}
-
-\vspace*{-0.3in}
-
-\begin{center}
-{\large\bf Scheme 48} \\
-\vspace{1ex}
-Richard Kelsey ({\tt kelsey@corwin.ccs.northeastern.edu}) \\
-Jonathan Rees ({\tt jar@cs.cornell.edu}) \\
-June 1992
-\end{center}
-
-\vspace{1ex}
-
-Scheme 48 is an implementation of the Scheme programming language based
-on a virtual machine architecture.  The following is an overview of
-the project.
-
-\paragraph{Goals}
-
-\begin{itemize}
-\setlength{\itemsep}{0pt}
-\item Straightforward, minimal implementation.
-\item Flexible experimental apparatus for research in programming
-      language design and implementation.
-\item Easy to make changes to internal data representations, memory
-      management, and compilation strategy.
-\item High reliability.
-\item Fast and complete enough to be a good
-      development environment for Scheme programs.
-\end{itemize}
-
-
-\paragraph{Virtual machine}
-
-The virtual machine executes a simple byte-code instruction set
-similar to the target of the Scheme 311 compiler [Clinger, LFP 1984].
-The interpreter for the virtual instruction set is itself written in
-PreScheme, a systems programming dialect of Scheme.  A PreScheme
-compiler applies intensive source-to-source rewrites to the
-interpreter source code and emits low-level C code.  When the output
-is then compiled by an optimizing C compiler such as gcc, the result
-is a very efficient and portable emulator.
-
-\paragraph{Run-time system}
-
-The virtual machine is initialized from a specified memory image
-containing byte-compiled Scheme code and data.  Images (including
-small stand-alone applications) are built either by a linker or by
-writing out the state of an executing program.  A standard memory
-image contains a Scheme run-time library ({\tt append}, {\tt read},
-{\tt write}, etc.), a compiler from Scheme to the virtual instruction
-set, and a command processor and debugger.  In this way Scheme 48 can
-be configured to look like a conventional Lisp interpreter.
-
-In addition to the Scheme run-time library and development
-environment, library software includes support for multitasking,
-modules (packages), hygienic macros (as described in the Revised$^4$
-Scheme report), records, and exception handling.
-
-\paragraph{Applications}
-
-The Scheme 48 system is being used at several sites for research in
-memory management, embedded systems, multiprocessing, and computer
-system verification.  Scheme 48 was chosen as the platform for these
-projects because of its internal tractability and flexibility.
-
-\end{document}
diff --git a/doc/threads.txt b/doc/threads.txt
deleted file mode 100644
index 393f006..0000000
--- a/doc/threads.txt
+++ /dev/null
@@ -1,87 +0,0 @@
-
-			       Threads
-
-The following are exported by the THREADS structure.
-
-(SPAWN thunk)
-(SPAWN thunk name)
-  Create and schedule a new thread that will execute <thunk>.  The optional
-  name is used when printing the thread.
-
-(RELINQUISH-TIMESLICE)
-  Let other threads run for a while.
-
-(SLEEP time)
-  Sleep for <time> milliseconds.
-
-(TERMINATE-CURRENT-THREAD)
-  Kill the current thread.
-
-(THREAD? thing)
-  #T if thing is a thread, #F otherwise.
-
-(THREAD-NAME thread)
-(THREAD-UID thread)
-  For printing debugging information.
-
------
-
-The following are exported by the LOCKS structure.
-
-(MAKE-LOCK) => lock
-(OBTAIN-LOCK lock)
-(RELEASE-LOCK lock)
-  Locks are semaphores.
-
------
-
-The following are exported by the PLACEHOLDERS structure.
-
-(MAKE-PLACEHOLDER) => placeholder
-(PLACEHOLDER-VALUE placeholder) => value of placeholder
-(PLACEHOLDER-SET! placeholder value)
-(PLACEHOLDER? thing) => #t or #f
-  Attempts to reference a placeholder before it has been set cause the
-  referencing thread to block.  Setting a placeholder to two different
-  values is an error.  (Previous versions of Scheme 48 called these
-  `condition variables', which turn out to be somewhat different.)
-
------
-
-Threads and the command interpreter.
-
-Each level of the command interpreter has its own set of active
-threads.  Moving to a new level, for example when an error occurs,
-halts all threads belonging to the previous level.  Resuming the
-a level causes its associated threads to continue running.
-
-The ,threads command inspects the threads running in the stopped
-command level.
-
-
-    > ,open threads
-    > (define (foo) (sleep 1000) (display "Hi") (newline) (foo))
-    > (spawn foo 'my-thread)
-    > Hi
-    (begin (sleep 10000) (display "Done") (newline))
-    Hi
-    
-    Interrupt: keyboard
-    1> (sleep 5000)
-    ; note that the Hi thread doesn't run in this command level
-    1> ,proceed 0
-    Hi
-    ; but it resumes when we resume this level
-    Hi
-    Done
-    > Hi
-    Hi
-    Hi
-    
-    Interrupt: keyboard
-    1> ,threads
-    '(#{Thread 28 my-thread} #{Thread 27 command-loop})
-    
-     [0] '#{Thread 28 my-thread}
-     [1] '#{Thread 27 command-loop}
-    inspect: 
diff --git a/doc/todo.txt b/doc/todo.txt
deleted file mode 100644
index e9e79c3..0000000
--- a/doc/todo.txt
+++ /dev/null
@@ -1,243 +0,0 @@
---*- Mode: Indented-text; -*-
-
-Scheme 48: list of bugs and things to do.
-Last update by RAK on 28 April 1998.
-
-Run-time system bugs:
-    Shadowing can fail sometimes for macro-referenced variables.  E.g.
-      the following sequence will lose if entered interactively as
-      three separate forms:
-        (define (foo x) `(a ,x))
-	(define cons list)
-	(foo 1) => (a (1 ()))
-
-Programming environment:
-    Fuller on-line documentation.
-    Error recovery.  Can do better than ,proceed.  LOAD should set up
-      restart continuations.
-    Types in scheme-interface (and elsewhere) aren't as tight as they
-      could be.
-    LET continuation "pessimization" to retain the environment longer.
-    Have the disassembler display local variable names.
-    This ought to be recoverable, but isn't always:
-	> (let loop ((x '())) (loop (cons 3 x)))
-	not enough room in heap for stack
-    The get-cont-from-heap instruction should have an exception
-      discloser that indicates the actual error (returning a
-      non-fixnum from application top level).
-    Separate compilation (compile a module, writing object code to a
-      file).  (Rudiments in misc/separate.scm)
-    Semicolon comments don't quite work after commands (extra newline
-      required).
-    Command (and procedure) to change current directory.
-    Some procedure in EXEC to take the place of ## in moving values from
-      one package to another: (transport <from-package> <exp> <to-package>
-      [<id>]), and/or have eval etc. commands return the value
-    Batch mode should write error messages to (error-output).
-
-Performance:
-    Generational GC.
-    More compact representation for debugging data?
-    Leaf procedure compilation (RK's rts/no-leaf-env.scm): if no
-      continuations or lambdas, skip the make-env and access locals
-      using stack-ref.  Expected to gain about 6% in speed.
-    Optimize loops somehow (maybe using call-template opcode and/or
-      opportunistic compilation).
-    The CAML light implementation has good documentation and patches
-      for optimizing the interpreter's switch (*pc++); perhaps we
-      could lift some of it.  (Range check isn't necessary.)
-    Floating point support in VM.
-    Bignum support in VM: use MIT Scheme bignums or GNU Multiple
-      Precision Arithmetic Library (Torbjorn Granlund <tege@sics.se>).
-    Faster bignum printer (e.g. the one Richard wrote - but it would be
-      nice if it were an option tied to bignums, not built in to the
-      initial image).
-    Ratnum multiplication and division might be made more efficient by
-      taking cross-GCD's.
-    Native code compiler...
-
-Big Scheme bugs / features:
-    It would be nice to be able to simulate control-C interrupts on
-      a port other than the initial input port - e.g., on a socket.
-      This would require creating a new thread to act as a front end.
-      The new thread would read characters eagerly, buffering
-      everything except control-C's for the thread that is doing the
-      real work, and converting control-C's into interrupts.
-    How about deleting entries from tables?
-    RPC.
-    Add call/gcc (invokes the Gnu C compiler).
-
-Module system bugs:
-    ,untrace should undefine as well if the variable wasn't bound
-      before.
-    Compound signatures don't get updated when a component signature
-      changes.  They contain a list of signatures with no reinitialization
-      thunk a la structures and packages.
-
-Module system features:
-    Check for name conflicts between opened structures.
-    Implement interface subtraction as a way of dealing with such
-      conflicts: (WITHOUT (<name> ...) <interface>)
-    Check for cycles in structure inheritance.
-    An ,access command, similar to ,open.
-    Deal with package system state better (for linker).  Maybe each
-      package should point to a data structure containing
-      *location-uid*, location-name-table, *package-uid*,
-      package-name-table, and perhaps the compiler-state as well (see
-      segment.scm).
-
-VM:
-    Heaps that can grow larger.
-    Add a test to configure.in that can determine whether ld -A works.
-      If both it and dlopen() work, then both kinds of dynamic loading
-      should be made available.
-    Merge in Olin's changes and extensions (command line processing,
-      the #! syntax for scripts, external function call, etc.).
-    Interrupt while writing out image causes an exit.  [Fixed?]
-    A jump-back instruction?  Might be easier to use than call-template.
-    Scrutinize all VM fatal errors to see if any can be recovered
-      from.  E.g. "out of ports" shouldn't cause a VM halt, it should
-      just cause open-port to return #f or an error code.  [Fixed?]
-    Get VM interp.scm-without-gc.scm working again.
-
-Documentation:
-    Describe (optimize auto-integrate).
-    How to use the static linker.
-    How initial.image and scheme48.image get built, really.
-    Techniques for debugging the runtime system (debug/for-debugging.scm).
-
-Cleanup:
-  VM:
-    Rename "unassigned" to "uninitialized"?  Or phase it out entirely.
-    In unix.c, use getrusage(), when available, to get run time.
-  Run-time / features / development environment:
-    A DIVIDE procedure (maybe an instruction as well) that returns two
-      values.
-    Figure out how to merge the two type systems (META-METHODS and
-      META-TYPES).  The generic function system could make use of the
-      SUBTYPE? and INTERSECT? predicates.
-    Correct floating point, esp. reading and printing.  And
-      (= 1/3 (/ 1. 3.)) returns #t, but ought to return #f.
-    Parameterize over file name syntax somehow.  Currently
-      big/filename.scm assumes Unix (cf. DIRECTORY-COMPONENT-SEPARATOR,
-      FILE-NAME-PREFERRED-CASE).  Perhaps there should be VM support for
-      this.
-    Make sure that the disassembler and assembler are inverses of one
-      another.
-    Disassembler should generate S-expression first, and then print
-      it independently.
-    Combine conditions, signals, and handle into a single structure?
-    Figure out a better way to implement ##.
-    Be consistent about "filename" versus "file-name".
-  Compiler / linker / module system:
-    The "reflective tower" isn't really a reflective tower, it's a
-      syntactic tower.  Rename it.
-    The scanner (file loader) should operate on streams, not lists.
-      This would result in more uniform and flexible internal
-      protocols for reading files, scanning for DEFINEs, compiling,
-      and running - passes could be interleaved or separated easily.
-    Flush link/data.scm.  Linker should instead open the VM module
-      that includes vm/data.scm.
-    Flush (optimize ...) clause in DEFINE-STRUCTURE in favor of
-      optimizer argument to SCAN-STRUCTURES.
-    Vector patterns and templates ought to be supported in
-      SYNTAX-RULES.
-    The DEFINE-INTERFACE forms should contain types for every exported
-      variable; the code in cprim.scm (and recon.scm?) shouldn't have
-      to worry about setting up types.
-    Add ENVIRONMENT-DEFINED? ?
-    Make USUAL-TRANSFORM return a transform?
-    Add enough to the node signature to make it usable on its own?
-    make-c-header-file should put definitions for the interrupt
-      enumeration into scheme48.h, and unix.c et al should use them.
-    Flatloading and loading are very different operations, so FLATLOAD
-      shouldn't do SET-PACKAGE-LOADED?!; instead it should maintain its
-      own list of flatloaded packages (in a global variable, say).
-  Etc:
-    Start using a source control system (like rcs).
-    There ought to be a sanity check to ensure that the size of the
-      area as computed by static.scm agrees with the size as computed
-      by C's sizeof() operator.
-
-What should (syntax-rules (x) ((foo ?body) (let ((x 1)) ?body))) do?
-
-
-To: jar@cs.cornell.edu
-Subject: Not a bug this time. :-)
-Date: Tue, 22 Feb 94 19:13:37 -0500
-From: Paul Stodghill <stodghil@cs.cornell.edu>
-
-The result of ,expand can be confusing. In particular, it doesn't
-distinguish between different identifiers that have the same name.
-
-For instance, in the example below, it would be more useful if the result
-of the ,expand was something like,
-
-	'((lambda (.x.1) (set! x (- .x.1))) x)
-
-Welcome to Scheme 48 0.31 (made by jar on Sun Feb 13 18:33:57 EST 1994).
-Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees.
-Please report bugs to scheme-48-bugs@altdorf.ai.mit.edu.
-Type ,? (comma question-mark) for help.
-> (define-syntax foo
-    (syntax-rules ()
-      ((foo var) ((lambda (x) (set! var (- x))) var))))
-> (define x 1)
-> ,expand (foo x)
-'((lambda (x) (set! x (- x))) x)
-> 
-
-
-
-Date: Mon, 14 Jun 93 18:33:30 HKT
-From: shivers@csd.hku.hk
-To: kelsey@flora.ccs.neu.edu
-Cc: jar@cs.cornell.edu
-Subject: Scheme 48
-
-...
-All true.  My major motivation was portability. I also found the module system
-to be a big win. Other things that influenced me were (1) elegance and
-modularity -- I felt I could comprehend and mung the system as needed (2)
-reasonable efficiency and small size and (3) real, full R4RS+ support (most
-small systems do it partly).
-
-Actually, I wouldn't say the programming environment is particularly
-exceptional, unless you count the module system.
-
-A small thing lacking in other Schemes that really reduced my debug times: the
-loader would complain about undefined free var refs in my code. This
-frequently picked out variable spelling errors, inconsistent name linkages,
-and forgotten procedure defs. Not a big thing, but really effective.
-
-Another win was simply having the implementors around for detailed
-explanations and support.
-
-Problems I had with S48: 
-- Inability to mess with the VM, as it is written in a language that can
-  be compiled by only 1 person in the world.
-
-- The foreign-function support was quite limited, and the foreign-data support
-  was basically non-existent. Exporting gc'd data to C, gc'ing data allocated
-  in C, hooks into the GC, importing C data into Scheme -- no support.  Elk
-  handles this better, as that is critical to the type of applications at
-  which elk is targeted.
-
-  I fixed some of this myself -- helped by your general, portable low-level ff
-  interface, which was well-designed in terms of those goals -- but I couldn't
-  do much about foreign-data support.
-
-- No support currently for linking static heap data into a text-pages
-  area to reduce gc copying and shrink the dynamic heap.
-
-- The module system was frequently frustrating. The non-uniform , command 
-  language, bugs, the restrictions of living with a module system,
-  being blocked from accessing primitives whose bindings had been
-  gc'd away at link time, and awkwardnesses in the user interface really
-  slowed me down.
-
-  The module system was also a great help; these are simply the problems
-  of life with an experimental system, as opposed to a polished final
-  product.
-
-[But] all in all, S48 was the best choice I could have made.  
diff --git a/doc/type.txt b/doc/type.txt
deleted file mode 100644
index 1aa60f6..0000000
--- a/doc/type.txt
+++ /dev/null
@@ -1,240 +0,0 @@
-
-			   The Type System
-
-
-Scheme 48 has a rudimentary type system.  Its main purpose is to
-generate helpful compile-time diagnostics.
-
-Currently you don't get much checking beyond wrong number of arguments
-warnings unless you're compiling a package that has an (OPTIMIZE ...)
-clause in its definition (e.g. (OPTIMIZE EXPAND) or (OPTIMIZE
-AUTO-INTEGRATE)).  The reason that type checking is disabled most of
-the time is that it increases compilation time by about 33%.
-
-A design goal is to assign types to all valid Scheme programs.  That
-is, type warnings should not be generated for programs that could work
-according to Scheme's dynamic semantics.  For example, no warning
-should be produced for
-
-    (define (foo x y) (if x (+ y 1) (car y)))
-
-Warnings could in principle be produced for particular calls to FOO
-that would definitely go wrong, such as (foo #t 'a).
-
-The type system assumes that all code is potentially reachable.  This
-means that there will be some warnings for programs that cannot go
-wrong, e.g. (if #t 3 (car 7)).
-
-Additionally, it's assumed that in a (BEGIN ...) or combination, every
-argument or command will always be executed.  This won't be the case
-if there can be a throw out of the middle.  For example, in
-
-    (call-with-current-continuation
-      (lambda (k)
-        (if (not (number? x))
-	    (k #f))
-        (+ x 1)))
-
-the type system might deduce that X must be a number (which is false).
-
-The type reconstruction algorithm (such as it is) is in
-bcomp/recon.scm.  The implementation finds some specific procedure
-types for LAMBDA expressions, but generally gives up pretty quickly.
-
-Notation
---------
-
-F : T means that form F has static type T.  T1 <= T2, or T1 is under
-T2, means that T1 is a subtype of T2; that is, if a form of type T2 is
-acceptable in some context, then so is a form of type T1.
-
-Non-expressions
----------------
-
-Not every valid Scheme form is an expression.  Forms that are not
-expressions are syntactic keywords, definitions, types, and structure
-names.
-
-If a name is bound to a macro or special operator, then an occurrence
-of that name has type :SYNTAX.  E.g.
-
-    cond : :syntax
-
-Definitions have type :DEFINITION.  E.g.
-
-    (begin (define x 1) (define y 2)) : :definition
-
-Thus type checking subsumes syntax checking.
-
-Types (other than :TYPE itself?) have type :TYPE.
-
-The type of a structure is its interface.  E.g.
-
-    (define-structure foo (export a b) ...)
-    foo : (export a b)
-
-Values
-------
-
-All expressions have type :VALUES.  They may have more specific
-types as well.
-
-If E1 ... En have types T1 ... Tn with Ti <= :VALUE, then
-the expression (VALUES E1 ... En) has type (SOME-VALUES T1 ... Tn).
-
-If T <= :VALUE then (SOME-VALUES T) is equivalent to T.
-
-Procedure types
----------------
-
-Procedure types have the form (PROCEDURE T1 T2), where T1 and T2 are
-under :VALUES.  Examples:
-
-    (lambda (x) (values x 1)) :
-       (procedure (some-values :value) (some-values :value :number))
-
-    cons : (procedure (some-values :value :value) :pair)
-
-Fixed-arity procedure types (PROCEDURE (SOME-VALUES T1 ... TN) T) are
-so common that the abbreviated syntax (PROC (T1 ... Tn) T) is
-defined to mean the same thing.  E.g.
-
-    cons : (proc (:value :value) :pair)
-
-E : (PROCEDURE T1 T2) means that in a call to a value of E, if the
-argument sequence has any type other than T1, then the call can be
-expected to "go wrong" (provoke a type error) at run time.  This is
-not to say it will definitely go wrong, but that it is just a matter
-of luck if it doesn't.  If the argument sequence does have type T1,
-then the call might or might not go wrong, and any return value(s)
-will have type T2.
-
-For example,
-
-    (lambda (x) (+ (begin (set! x '(3)) 5) (car x))) :
-       (proc (:pair) :value),
-
-because if the arguments to + are evaluated from right to left, and X
-is not a pair, then there will be a run time type error.
-
-Some primitive procedures have their own special typing rules.
-Examples include VALUES, CALL-WITH-VALUES, and PRIMITIVE-CATCH.
-
-Variable types
---------------
-
-Assignable variables have type (VARIABLE T), where T for now will
-always be :VALUE.  In (SET! V E), V must have type (VARIABLE T) for
-some T.
-
-Loopholes
----------
-
-The construct (loophole T E) is considered to have type T no matter
-what type E has.  Among other things, this allows a rudimentary static
-abstract data type facility.  For example, record types defined using
-DEFINE-RECORD-TYPE (rts/bummed-jar-defrecord.scm) are established as
-new base types.
-
-Type lattice
-------------
-
-The subtype relation is implemented by the procedure COMPATIBLE-TYPES?
-(in bcomp/mtypes.scm).  If (COMPATIBLE-TYPES? T1 T2) is 'definitely,
-then T1 <= T2.  If it's #T, then T1 and T2 intersect.
-
-The type lattice has no bottom or top elements.
-
-The types :SYNTAX, :VALUES, :DEFINITION, :STRUCTURE, and :TYPE are
-incomparable and maximal.
-
-The following are a comprehensive set of subtyping rules for the type
-system as it stands.  Additional rules may be added in the future.
-
-   - (SOME-VALUES T1 ... Tn) <= :VALUES.
-
-   - If T1 <= T1', ..., Tn <= Tn' then (SOME-VALUES T1 ... Tn) <=
-     (SOME-VALUES T1' ... Tn').
-
-   - T <= (SOME-VALUES T).
-
-   - Basic value types, which include :NUMBER, :CHAR, :BOOLEAN, :PAIR,
-     :STRING, and :UNSPECIFIC, are all under :VALUE.
-
-   - If T1' <= T1 and T2 <= T2', then (PROCEDURE T1 T2) <= (PROCEDURE
-     T1' T2').
-
-   - (VARIABLE T) <= T.
-
-   - :ZERO, the result type of infinite loops and calls to
-     continuations, is under :VALUE, but perhaps shouldn't be.  (E.g.
-     maybe it should be just under :VALUES instead.)
-
-   - (EXPORT (<name> T) ...) is under :STRUCTURE.
-     [Not yet implemented.]
-
-Type well-formedness
---------------------
-
-In (SOME-VALUES T1 ... Tn), T1 ... Tn must be under :VALUE.
-
-In (PROCEDURE T1 T2), T1 and T2 must be under :VALUES.
-
-In (VARIABLE T), T must be under :VALUE.
-
-Module system
--------------
-
-The rules for interfaces and structures are not yet very well worked
-out.
-
-Interfaces are types.  The type of a structure is its interface.
-(Compare with Pebble's "bindings" and "declarations".)
-
-An interface has the basic form (EXPORT (<name> <type>) ...).
-There are two kinds of abbreviations:
-  - (EXPORT ... <name> ...) means the same as
-    (EXPORT ... (<name> :VALUE) ...)
-  - (EXPORT ... ((<name1> <name2> ...) <type>) ...) means the same as
-    (EXPORT ... (<name1> <type>) (<name2> <type>) etc. ...)
-
-Distinct interfaces are not comparable.
-
-If a form S has type (EXPORT ... (name T) ...), then the form
-(STRUCTURE-REF S name) has type T.  Note that T needn't be a :VALUE
-type; e.g.
-
-    (structure-ref scheme cond) : :syntax
-
-When a package is loaded or otherwise compiled, the type that is
-reconstructed or inherited for each exported name is checked against
-the type specified in the signature.  (Cf. procedure SCAN-STRUCTURES
-in bcomp/scan.scm.)
-
-<explain the role of the expander in type checking... compile-call
-doesn't do much checking if the arguments aren't expanded...>
-
-Future work
------------
-
-There probably ought to be dependent sums and products and/or
-universal and existential types.  In particular, it would be nice to
-be able to get static checking for abstract types, even if they're not
-implemented using records.
-
-Type constructors (like STREAM-OF or COMPUTATION-OF) would be nice.
-
-There are many loose ends in the implementation.  For example, type
-and type constructor names aren't always lexically scoped; sometimes
-their scope is global.  Packages that open the LOOPHOLES structure
-(which exports LOOPHOLE) don't always open TYPES (which would be a bad
-idea given the way TYPES is currently defined); LOOPHOLE works in
-spite of that.
-
-Figure out whether :TYPE : :TYPE.
-
-
------
-
-Original by JAR, 20 July 93.
-Updated by JAR, 5 December 93.
diff --git a/emacs/README b/emacs/README
deleted file mode 100644
index 02079d7..0000000
--- a/emacs/README
+++ /dev/null
@@ -1,47 +0,0 @@
-Date: Thu, 9 Jul 92 13:26:05 HKT
-From: shivers@csd.hku.hk (Olin G. Shivers)
-To: jar@cs.cornell.edu
-In-Reply-To: Jonathan Rees's message of Wed, 8 Jul 92 22:15:22 -0400 <9207090215.AA00991@sindri.cs.cornell.edu>
-Subject: cmulisp
-
-It's also in Ozan's repository, but I don't know how up-to-date it is.
-It's always useful to list his repository as a possible location, tho.
-	-Olin
-
-/afs/cs.cmu.edu/user/shivers/lib/Readme:
-This directory contains the following subdirectories:
-    emacs   Gnu emacs packages.
-    papers  My papers, in .dvi and postscript form.
-    tex     LaTeX packages.
-All of these files can be anonymously ftp'd.
-    -Olin
-     July 3, 1991
-
-===============================================================================
-Directions for anonymous ftp:
-1. ftp to any CMU machine with access to the /afs network file system.
-   Almost any machine will do; some possibilities are:
-    	cs.cmu.edu  	    128.2.222.173
-    	a.gp.cs.cmu.edu	    128.2.242.7
-    	f.gp.cs.cmu.edu	    128.2.250.164
-    	h.gp.cs.cmu.edu	    128.2.254.156
-    	k.gp.cs.cmu.edu	    128.2.254.137
-
-2. login as anonymous
-   You are supposed to provide username@host as the password. The CMU
-   ftp demon actually checks to ensure there's an "@" in the password.
-   So you can't just say "foo"; you have to say "foo@bar".
-
-3. cd /afs/cs.cmu.edu/user/shivers/lib
-   CMU ftp restricts the directories you can access anonymously,
-   so you must cd straight to the .../lib directory or its descendants.
-4. If you are transfering .dvi or other binary files, set the file transfer
-   mode to raw binary with one of the following commands:
-        type image
-    	type binary
-    	image
-    	binary
-   If you don't do this, the files may be garbled.
-5. Use dir or ls to list the directory.
-6. Transfer the files you want.
-
diff --git a/emacs/cmuscheme48.el b/emacs/cmuscheme48.el
deleted file mode 100644
index b7b8888..0000000
--- a/emacs/cmuscheme48.el
+++ /dev/null
@@ -1,99 +0,0 @@
-;;; cmuscheme48.el -- Scheme process in a buffer.  Adapted from cmuscheme.el.
-
-(provide 'cmuscheme48)
-(require 'cmuscheme)
-
-(define-key scheme-mode-map "\M-\C-x" 'scheme48-send-definition);gnu convention
-(define-key scheme-mode-map "\C-x\C-e" 'scheme48-send-last-sexp);gnu convention
-(define-key scheme-mode-map "\C-ce"    'scheme48-send-definition)
-(define-key scheme-mode-map "\C-c\C-e" 'scheme48-send-definition-and-go)
-(define-key scheme-mode-map "\C-cr"    'scheme48-send-region)
-(define-key scheme-mode-map "\C-c\C-r" 'scheme48-send-region-and-go)
-(define-key scheme-mode-map "\C-cl"    'scheme48-load-file)
-
-(defun scheme48-send-region (start end)
-  "Send the current region to the inferior Scheme process."
-  (interactive "r")
-  (comint-send-string (scheme-proc)
-		      (concat ",from-file "
-			      (enough-scheme-file-name
-			       (buffer-file-name (current-buffer)))
-			      "\n"))
-  (comint-send-region (scheme-proc) start end)
-  (comint-send-string (scheme-proc) " ,end\n"))
-
-; This assumes that when you load things into Scheme 48, you type
-; names of files in your home directory using the syntax "~/".
-; Similarly for current directory.  Maybe we ought to send multiple
-; file names to Scheme and let it look at all of them.
-
-(defun enough-scheme-file-name (file)
-  (let* ((scheme-dir
-	  (save-excursion
-	    (set-buffer scheme-buffer)
-	    (expand-file-name default-directory)))
-	 (len (length scheme-dir)))
-    (if (and (> (length file) len)
-	     (string-equal scheme-dir (substring file 0 len)))
-	(substring file len)
-	(if *scheme48-home-directory-kludge*
-	    (let* ((home-dir (expand-file-name "~/"))
-		   (len (length home-dir)))
-	      (if (and (> (length file) len)
-		       (string-equal home-dir (substring file 0 len)))
-		  (concat "~/" (substring file len))
-		  file))
-	    file))))
-
-(defvar *scheme48-home-directory-kludge* t)
-
-(defun scheme48-send-definition (losep)
-  "Send the current definition to the inferior Scheme48 process."
-  (interactive "P")
-  (save-excursion
-   (end-of-defun)
-   (let ((end (point)))
-     (beginning-of-defun)
-     (if losep
-	 (let ((loser "/tmp/s48lose.tmp"))
-	   (write-region (point) end loser)
-	   (scheme48-load-file loser))
-	 (scheme48-send-region (point) end)))))
-
-(defun scheme48-send-last-sexp ()
-  "Send the previous sexp to the inferior Scheme process."
-  (interactive)
-  (scheme48-send-region (save-excursion (backward-sexp) (point)) (point)))
-
-(defun scheme48-send-region-and-go (start end)
-  "Send the current region to the inferior Scheme48 process,
-and switch to the process buffer."
-  (interactive "r")
-  (scheme48-send-region start end)
-  (switch-to-scheme t))
-
-(defun scheme48-send-definition-and-go (losep)
-  "Send the current definition to the inferior Scheme48,
-and switch to the process buffer."
-  (interactive "P")
-  (scheme48-send-definition losep)
-  (switch-to-scheme t))
-
-(defun scheme48-load-file (file-name)
-  "Load a Scheme file into the inferior Scheme48 process."
-  (interactive (comint-get-source "Load Scheme48 file: "
-				  scheme-prev-l/c-dir/file
-				  scheme-source-modes t)) ; T because LOAD 
-                                                          ; needs an exact name
-  (comint-check-source file-name) ; Check to see if buffer needs saved.
-  (setq scheme-prev-l/c-dir/file (cons (file-name-directory    file-name)
-				       (file-name-nondirectory file-name)))
-  (comint-send-string (scheme-proc)
-		      (concat ",load "
-			      (enough-scheme-file-name file-name)
-			      "\n")))
-
-
-; For Pertti Kellom\"aki's debugger.
-; Cf. misc/psd-s48.scm.
-(defvar psd-using-slib nil "Scheme 48, not SLIB.")
diff --git a/emacs/jar-hacks.el b/emacs/jar-hacks.el
deleted file mode 100644
index 4fdf572..0000000
--- a/emacs/jar-hacks.el
+++ /dev/null
@@ -1,91 +0,0 @@
-
-; Comment out region
-
-(defun comment-out-region (arg)
-  "Insert comment string at beginning of each line in the region."
-  (interactive "P")
-  (let (start end)
-    (if (< (point) (mark))
-        (setq start (point) end (mark-marker))
-        (setq start (mark) end (point-marker)))
-    (save-excursion
-      (untabify start (marker-position end))
-      (goto-char start)
-      (if (not (bolp))
-	  (progn (end-of-line) (forward-char)))
-      (while (< (point) (marker-position end))
-	(if (eq arg '-)
-	    (if (looking-at comment-start)
-		(delete-char (length comment-start)))
-	    (insert comment-start))
-	(end-of-line)
-	(forward-char)))))
-
-;(defun uncomment-out-region (arg)
-;  (interactive nil)
-;  (comment-out-region '-))
-
-
-; Mini-Find Tag
-
-(defvar last-mini-tag "" "Last tag sought by mini-find-tag.")
-
-(defun mini-find-tag (tagname &optional next)
-  "Search for a definition of TAGNAME in current buffer.
- If TAGNAME is a null string, the expression in the buffer
-around or before point is used as the tag name.
- If second arg NEXT is non-nil (interactively, with prefix arg),
-searches for the next definition in the buffer
-that matches the tag name used in the previous mini-find-tag."
-
-  (interactive (if current-prefix-arg
-		   '(nil t)
-		 (list (read-string "Mini-find tag: "))))
-  (if (equal tagname "")             ;See definition of find-tag.
-      (setq tagname (save-excursion
-		      (buffer-substring
-		       (progn (backward-sexp 1) (point))
-		       (progn (forward-sexp 1) (point))))))
-  (let ((pt (save-excursion
-	      (if (not next)
-		  (goto-char (point-min))
-		(setq tagname last-mini-tag))
-	      (setq last-mini-tag tagname)
-	      (if (re-search-forward
-		     (concat "^(def.*" tagname)
-		     nil t)
-		  (point)
-		nil))))
-    (if pt
-	(progn (set-mark-command nil)
-	       (goto-char pt))
-      (signal 'search-failed '()))))
-
-; indent-differently
-
-(defun indent-differently ()
-  "Make the current line indent like the body of a special form by
-changing the operator's scheme-indent-hook appropriately."
-  (interactive nil)
-  (let ((here (point)))
-    (save-excursion
-      (back-to-indentation)
-      (backward-up-list 1)
-      (forward-char 1)
-      (let ((i -1)
-	    (function nil)
-	    (p (point)))
-	(while (<= (point) here)
-	  (setq i (+ i 1))
-	  (forward-sexp 1)
-	  (if (= i 0)
-	      (setq function (buffer-substring p (point)))))
-	(setq i (- i 1))
-	(let ((name (intern (downcase function))))
-	  (cond ((equal (get name 'scheme-indent-hook) i)
-		 (message "Indent %s nil" name)
-		 (put name 'scheme-indent-hook nil))
-		(t
-		 (message "Indent %s %d" name i)
-		 (put name 'scheme-indent-hook i))))))
-    (scheme-indent-line)))
diff --git a/install-sh b/install-sh
deleted file mode 100755
index 5871924..0000000
--- a/install-sh
+++ /dev/null
@@ -1,238 +0,0 @@
-#! /bin/sh
-#
-# install - install a program, script, or datafile
-# This comes from X11R5.
-#
-# Calling this script install-sh is preferred over install.sh, to prevent
-# `make' implicit rules from creating a file called install from it
-# when there is no Makefile.
-#
-# This script is compatible with the BSD install script, but was written
-# from scratch.
-#
-
-
-# set DOITPROG to echo to test this script
-
-# Don't use :- since 4.3BSD and earlier shells don't like it.
-doit="${DOITPROG-}"
-
-
-# put in absolute paths if you don't have them in your path; or use env. vars.
-
-mvprog="${MVPROG-mv}"
-cpprog="${CPPROG-cp}"
-chmodprog="${CHMODPROG-chmod}"
-chownprog="${CHOWNPROG-chown}"
-chgrpprog="${CHGRPPROG-chgrp}"
-stripprog="${STRIPPROG-strip}"
-rmprog="${RMPROG-rm}"
-mkdirprog="${MKDIRPROG-mkdir}"
-
-transformbasename=""
-transform_arg=""
-instcmd="$mvprog"
-chmodcmd="$chmodprog 0755"
-chowncmd=""
-chgrpcmd=""
-stripcmd=""
-rmcmd="$rmprog -f"
-mvcmd="$mvprog"
-src=""
-dst=""
-dir_arg=""
-
-while [ x"$1" != x ]; do
-    case $1 in
-	-c) instcmd="$cpprog"
-	    shift
-	    continue;;
-
-	-d) dir_arg=true
-	    shift
-	    continue;;
-
-	-m) chmodcmd="$chmodprog $2"
-	    shift
-	    shift
-	    continue;;
-
-	-o) chowncmd="$chownprog $2"
-	    shift
-	    shift
-	    continue;;
-
-	-g) chgrpcmd="$chgrpprog $2"
-	    shift
-	    shift
-	    continue;;
-
-	-s) stripcmd="$stripprog"
-	    shift
-	    continue;;
-
-	-t=*) transformarg=`echo $1 | sed 's/-t=//'`
-	    shift
-	    continue;;
-
-	-b=*) transformbasename=`echo $1 | sed 's/-b=//'`
-	    shift
-	    continue;;
-
-	*)  if [ x"$src" = x ]
-	    then
-		src=$1
-	    else
-		# this colon is to work around a 386BSD /bin/sh bug
-		:
-		dst=$1
-	    fi
-	    shift
-	    continue;;
-    esac
-done
-
-if [ x"$src" = x ]
-then
-	echo "install:	no input file specified"
-	exit 1
-else
-	true
-fi
-
-if [ x"$dir_arg" != x ]; then
-	dst=$src
-	src=""
-	
-	if [ -d $dst ]; then
-		instcmd=:
-	else
-		instcmd=mkdir
-	fi
-else
-
-# Waiting for this to be detected by the "$instcmd $src $dsttmp" command
-# might cause directories to be created, which would be especially bad 
-# if $src (and thus $dsttmp) contains '*'.
-
-	if [ -f $src -o -d $src ]
-	then
-		true
-	else
-		echo "install:  $src does not exist"
-		exit 1
-	fi
-	
-	if [ x"$dst" = x ]
-	then
-		echo "install:	no destination specified"
-		exit 1
-	else
-		true
-	fi
-
-# If destination is a directory, append the input filename; if your system
-# does not like double slashes in filenames, you may need to add some logic
-
-	if [ -d $dst ]
-	then
-		dst="$dst"/`basename $src`
-	else
-		true
-	fi
-fi
-
-## this sed command emulates the dirname command
-dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'`
-
-# Make sure that the destination directory exists.
-#  this part is taken from Noah Friedman's mkinstalldirs script
-
-# Skip lots of stat calls in the usual case.
-if [ ! -d "$dstdir" ]; then
-defaultIFS='	
-'
-IFS="${IFS-${defaultIFS}}"
-
-oIFS="${IFS}"
-# Some sh's can't handle IFS=/ for some reason.
-IFS='%'
-set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'`
-IFS="${oIFS}"
-
-pathcomp=''
-
-while [ $# -ne 0 ] ; do
-	pathcomp="${pathcomp}${1}"
-	shift
-
-	if [ ! -d "${pathcomp}" ] ;
-        then
-		$mkdirprog "${pathcomp}"
-	else
-		true
-	fi
-
-	pathcomp="${pathcomp}/"
-done
-fi
-
-if [ x"$dir_arg" != x ]
-then
-	$doit $instcmd $dst &&
-
-	if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi &&
-	if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi &&
-	if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi &&
-	if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi
-else
-
-# If we're going to rename the final executable, determine the name now.
-
-	if [ x"$transformarg" = x ] 
-	then
-		dstfile=`basename $dst`
-	else
-		dstfile=`basename $dst $transformbasename | 
-			sed $transformarg`$transformbasename
-	fi
-
-# don't allow the sed command to completely eliminate the filename
-
-	if [ x"$dstfile" = x ] 
-	then
-		dstfile=`basename $dst`
-	else
-		true
-	fi
-
-# Make a temp file name in the proper directory.
-
-	dsttmp=$dstdir/#inst.$$#
-
-# Move or copy the file name to the temp name
-
-	$doit $instcmd $src $dsttmp &&
-
-	trap "rm -f ${dsttmp}" 0 &&
-
-# and set any options; do chmod last to preserve setuid bits
-
-# If any of these fail, we abort the whole thing.  If we want to
-# ignore errors from any of these, just make sure not to ignore
-# errors from the above "$doit $instcmd $src $dsttmp" command.
-
-	if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi &&
-	if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi &&
-	if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi &&
-	if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi &&
-
-# Now rename the file to the real destination.
-
-	$doit $rmcmd -f $dstdir/$dstfile &&
-	$doit $mvcmd $dsttmp $dstdir/$dstfile 
-
-fi &&
-
-
-exit 0
diff --git a/ps-compiler/compile-vm-no-gc.scm b/ps-compiler/compile-vm-no-gc.scm
deleted file mode 100644
index 7c6fd85..0000000
--- a/ps-compiler/compile-vm-no-gc.scm
+++ /dev/null
@@ -1,27 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-(config '(load "../scheme/vm/macro-package-defs.scm"))
-(load-package 'vm-architecture)
-(in 'forms '(run (set! *duplicate-lambda-size* 30)))
-(in 'simplify-let '(run (set! *duplicate-lambda-size* 15)))
-(in 'prescheme-compiler
-    '(run (prescheme-compiler
-	   '(vm external-gc-roots)
-	   '("../scheme/vm/interfaces.scm"
-	     "../scheme/vm/ps-package-defs.scm"
-	     "../scheme/vm/package-defs.scm"
-	     "../scheme/vm/no-gc-package-defs.scm")
-	   's48-init
-	   "../scheme/vm/scheme48vm.c"
-	   '(header "#include \"scheme48vm-prelude.h\"")
-	   '(copy (interpreter push-continuation-on-stack))
-	   '(no-copy (interpreter interpret
-				  application-exception
-				  handle-interrupt
-				  uuo)
-		     ;(vm restart)
-		     (interpreter-gc collect-saving-temp
-				     collect-saving-temps)))))
-;	   '(shadow ((interpreter restart)
-;		     (interpreter *val* *code-pointer*)
-;		     (stack *stack* *env*))))))
diff --git a/ps-compiler/compile-vm.scm b/ps-compiler/compile-vm.scm
deleted file mode 100644
index 16d9f33..0000000
--- a/ps-compiler/compile-vm.scm
+++ /dev/null
@@ -1,29 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-(config '(load "../scheme/vm/macro-package-defs.scm"))
-(load-package 'vm-architecture)
-(in 'forms '(run (set! *duplicate-lambda-size* 30)))
-(in 'simplify-let '(run (set! *duplicate-lambda-size* 15)))
-(in 'prescheme-compiler
-    '(run (prescheme-compiler
-	   '(interpreter heap-init)
-	   '("../scheme/vm/interfaces.scm"
-	     "../scheme/vm/ps-package-defs.scm"
-	     "../scheme/vm/package-defs.scm")
-	   'scheme48-init
-	   "../scheme/vm/scheme48vm.c"
-	   '(header "#include \"scheme48vm-prelude.h\"")
-	   '(copy (heap walk-over-type-in-area)
-		  (fixnum-arithmetic quotient-carefully))
-	   '(no-copy (interpreter interpret
-				  application-exception
-				  handle-interrupt
-				  uuo
-				  collect-saving-temp
-				  do-gc))
-	   '(integrate (copy-next do-gc)
-		       (copy-object do-gc))
-	   '(shadow ((interpreter do-gc) (heap *hp*))
-		    ((interpreter restart)
-		     (interpreter *val* *code-pointer*)
-		     (stack *stack* *env*))))))
diff --git a/ps-compiler/doc/node.txt b/ps-compiler/doc/node.txt
deleted file mode 100644
index cc9ce41..0000000
--- a/ps-compiler/doc/node.txt
+++ /dev/null
@@ -1,340 +0,0 @@
-
-In the compiler `continuation' means a continuation that is a lambda node.
-Non-lambda continuation arguments, such as the argument to a RETURN, are
-not referred to as continuations (the argument isn't a continuation, it
-is a variable that is bound to a continuation).
-
-
-Every node has the following fields:
-
-  variant     ; one of LITERAL, REFERENCE, LAMBDA, or CALL
-  parent      ; parent node
-  index       ; index of this node in parent, if parent is a call node
-  simplified? ; true if it has already been simplified; if this is #F
-              ; then all of this node's ancestors must also be unsimplified
-  flag        ; useful flag, all users must leave this is #F
-
-
-Literal nodes:
-
-  value     ; the value
-  type      ; the type of the value (important for statically typed languages,
-            ; not so useful for Scheme)
-
-Reference nodes:
-
-  variable  ; the referenced variable; the binder of the variable must be
-            ; an ancestor of the reference node
-
-Call nodes:
-  primop    ; the primitive being called
-  args      ; vector of argument nodes
-  exits     ; the number of arguments that are continuations; the continuation
-            ; arguments come before the non-continuation ones
-  source    ; source info; used for error messages
-
-Primops are either trivial or nontrivial.  Trivial primops only return a value
-and have no side effects.  Calls to trivial primops never have continuation
-arguments and are always arguments to other calls.  Calls to nontrivial primops
-may or may not have continuations and are always the body of a lambda node.
-
-Lambda nodes:
-
-  type      ; one of PROC, CONT, or JUMP (and maybe THROW at some point)
-  name      ; symbol          (for debugging)
-  id        ; unique integer  (for debugging)
-  body      ; the call-node that is the body of the lambda
-  variables ; a list of variable records, with #Fs for ignored positions
-  source    ; source info; used for error messages
-  protocol  ; calling protocol from the source language
-  block     ; for use during code generation
-  env       ; for use when adding explicit environments
-
-PROC's are general procedures.  The first variable of a PROC will be bound
-to the PROC's continuation.
-
-CONT's are continuation arguments to calls.
-
-JUMP's are continuations bound by LET or LETREC, whose calling points are
-known, and which are created and called within a single PROC.
-
-Variables:
-
-  name      ; source code name for variable (used for debugging only)
-  id        ; unique numeric identifier     (used for debugging only)
-  type      ; type of variable's value
-  binder    ; LAMBDA node which binds this variable (or #F if none)
-  refs      ; list of reference nodes n for which (REFERENCE-VARIABLE n)
-            ;  = this variable
-  flag      ; useful slot, used by shapes, COPY-NODE, NODE->VECTOR, etc.
-            ; all users must leave this is #F
-  flags     ; list of various annotations, e.g. IGNORABLE
-  generate  ; for whatever code generation wants
-
-----------------------------------------------------------------
-The node tree has a very regular lexical structure:
-
-  The body of every lambda node is a non-trivial call.
-  The parent of every non-trivial call is a lambda node.
-  Every CONT lambda is a continuation of a non-trivial call.
-  Every JUMP lambda is an argument to either the LET or the LETREC 
-   primops (described below).
-  The lambda node that binds a variable is an ancestor of every reference
-   to that variable.
-  
-If you start from any leaf node and follow the parent pointers up through the
-node tree, you first go through some number, possible zero, of trivial calls
-until a non-trivial call is reached.  From that point on non-trivial calls
-alternate with CONT nodes until a PROC or JUMP lambda is reached.  Going up
-from a PROC lambda is the same as going up from a leaf, while JUMP lambdas
-are always arguments to LET or LETREC, both of which are non-trivial.
-
-A basic block appears as a sequence of non-trivial calls with a single
-continuation apiece.  The block begins with a PROC or JUMP lambda, or
-with a CONT lambda that is an argument to a call with two or more
-continuations, and ends with a call that has either no continuations,
-or two or more.
-
-Basic blocks are grouped into trees.  The root of every tree is either
-a PROC or JUMP lambda, the branch points are calls with two or more
-continuations, and the leaves are jumps or returns.  Within a tree
-the control flow follows the lexical structure of the program from
-parent to child (if we ignore calls to other PROCs).
-
-Every JUMP lambda is called from within only one PROC lambda, so a PROC
-can be considered to consist of a set of trees, the leaves of which either
-return from that PROC or jump to the top of another tree in the set.
-
-----------------------------------------------------------------
-
-Primops:
-
-  id                 ; unique symbol identifying this primop
-  trivial?           ; #t if this primop has does not accept a continuation
-  side-effects       ; one of #F, READ, WRITE, ALLOCATE, or IO
-  simplify-call-proc ; simplify method
-  primop-cost-proc   ; cost of executing this operation
-                     ; (in some undisclosed metric)
-  return-type-proc   ; the type of the value returned (for trivial primops only)
-  proc-data          ; more data for the procedure primops
-  cond-data          ; more data for conditional primops
-  code-data          ; code generation data
-
-`procedure' primops are those that call one of their values.
-`conditional' primops are those that have more than one continuation.
-
-Below is a list of the standard primops.  All but the last two are non-trivial.
-
-For the following the five primops the lambda node being called, jumped to,
-or whatever has been identified by the compiler, and the number of variables
-that the lambda node has matches the number of arguments.
-
-   (CALL <cont> <proc> . <args>)
-   (TAIL-CALL <cont-var> <proc> . <args>)
-   (RETURN <cont-var> . <args>)
-   (JUMP <jump-var> . <args>)
-;  (THROW <throw-var> . <args>)  not yet implemented
-
-These are the same as the above except that the procedure has not been
-identified by the compiler.  There is no UNKNOWN-JUMP because all calls
-to JUMP lambdas must be known.
-
-   (UNKNOWN-CALL <cont> <proc> . <args>)
-   (UNKNOWN-TAIL-CALL <cont> <proc> . <args>)
-   (UNKNOWN-RETURN <cont-var> . <args>)
-
-PROC lambdas are called with either CALL or TAIL-CALL if all of their call
-sites have been identified, or with UNKNOWN-CALL or UNKNOWN-TAIL-CALL if not.
-JUMP lambdas are called using JUMP.
-
-
-LET binds random values, such as lambda nodes or the results of trivial
-calls, to variables.  This primop only exists because of the requirement
-that every call have a primop; all it does is apply <cont> to <args>
-(it is called LET instead of APPLY because LET forms in the source code
-become calls to this primop).
-
-   (LET <cont> . <args>)
-
-
-Recursive binding:
-
-   (LETREC1 <cont>)
-   (LETREC2 <cont> <id-var> <lambda1> <lambda2> ...)
-
-These are always used together, with the body of the continuation to LETREC1
-being a call to LETREC2.  The two calls together look like:
-
- (LETREC1 (lambda (<id-var> <var1> ... <varN>)
-            (LETREC2 <cont> <id-var> <lambda1> ... <lambdaN>)))
-
-which the CPS pretty-printer prints as:
-
- (let* (...
-        ((id-var var1 ... varN) (letrec1))
-	(() (letrec2 id-var lambda1 ... lambdaN))
-	...)
-   ...)
-
-The end result is to bind <varI> to <lambdaI>.  The point to the excercise
-is that lambdas occur within the scope of the variables.
-
-
-Undefined effect.  This takes a continuation variable as an argument only
-so that the continuation variable is always reached.
-
-   (UNDEFINED-EFFECT <cont-var> ...)
-
-
-Accessing and mutating the store.
-Cells are used to implement SET! on lexically bound variables.  GLOBAL-SET!
-and GLOBAL-REF are used for module variables that may be set.
-
-   (CELL-SET! <cont> <cell> <value>)
-   (GLOBAL-SET! <cont> <global-var> <value>)
-
-   (CELL-REF <cell>)                 ; trivial
-   (GLOBAL-REF <global-var>)         ; trivial
-
-----------------------------------------------------------------
-Printing out the node tree.
-
-The following procedure:
-
-   (define (fact n)
-     (let loop ((n n) (r 1))
-       (if (< n 2)
-           r
-           (loop (- n 1) (* n r)))))
-
-when converted into nodes is:
-
-(LAMBDAp (c_6 n_1)
-  (letrec1 (LAMBDAc (x_13 loop_2)
-             (letrec2 (LAMBDAc ()
-	                (unknown-tail-call c_6 loop_2 n_1 '1))
-		      x_13
-                      (LAMBDAp (c_8 n_3 r_4)
-                        (test
-                          (LAMBDAc ()
-                            (unknown-return c_8 r_4))
-                          (LAMBDAc ()
-                            (unknown-tail-call c_8 loop_2 (- n_3 '1) (* n_3 r_4)))
-                          (< n_3 '2)))))))
-
-where LAMBDAp is a PROC lambda and LAMBDAc is a CONT lambda.  Lexically bound
-variables are printed as <name>_<id> and constants as '<value>.  This is not
-very readable, and larger procedures are much worse.  The first step in making
-it more comprehensible is to print each lambda node separately with a marker
-to indicate where it appears in the tree.
-
-(LAMBDAp fact_7 (c_6 n_1)
-  (letrec1 1 ^c_14))
-
-  (LAMBDAc c_14 (x_13 loop_2)
-    (letrec2 1 ^c_12 x_13 ^loop_9))
-
-    (LAMBDAc c_12 ()
-      (unknown-tail-call 0 c_6 loop_2 n_1 '1))
-
-    (LAMBDAp loop9 (c_8 n_3 r_4)
-      (test 2 ^g_10 ^g_11 (< n_3 '2)))
-
-      (LAMBDAc g_10 ()
-        (unknown-return 0 c_8 r_4))
-
-      (LAMBDAc g_11 ()
-        (unknown-tail-call 0 c_8 loop_2 (- n_3 '1) (* n_3 r_4)))
-
-The labels used are the names and id's of the lambda nodes, with a ^ in front
-to distinguish them from variables.  The code for each lambda is indented
-slightly more than the lambda in which it actually occurs.  To make the
-distinction between continuation and non-continuation lambdas clearer the
-number of continuation arguments to a call is printed just after the primop
-(for example the first two arguments to TEST are continuations).
-
-The first three calls form a basic block because the first two calls have
-exactly one continuation apiece.  To make this more easily seen these
-calls can be printed using a more condensed notation:
-
-(LAMBDAp fact_7 (c_6 n_1)
-  (LET* (((x_13 loop_2) (letrec1))
-         (()            (letrec2 x_13 ^loop_9)))
-    (unknown-tail-call 0 c_6 loop_2 n_1 '1)))
-
-The continuations are not printed as arguments but instead their variables
-are printed to the left of the call in a parody of Scheme's LET*.  The results
-of the LETREC1 are bound to the variables X_13 and LOOP_2 as would happen with
-the real LET* (if it allowed calls to return multiple values).
-
-Finally, here is the way the code for FACT is actually printed:
-
-7   (P fact_7 (c_6 n_1)
-14    (LET* (((x_13 loop_2)
-                         (letrec1))
-12           (()         (letrec2 x_13 ^loop_9)))
-        (unknown-tail-call 0 c_6 loop_2 n_1 '1)))
-
-9    (P loop_9 (c_8 n_3 r_4)
-       (test 2 ^g_10 ^g_11 (< n_3 '2)))
-
-10    (C g_10 ()
-        (unknown-return 0 c_8 r_4))
-
-11    (C g_11 ()
-        (unknown-tail-call 0 c_8 loop_2 (- n_3 '1) (* n_3 r_4)))
-
-The ID number of every lambda node is printed out at the beginning of the
-line on which the code for the lambda appears.  This is redundant for the
-lambdas that are not printed as part of a LET*.  The word `LAMBDA' is not
-printed.  The (letrec1) call appears on a new line because the printer
-indents the calls in LET* a fixed amount.
-
-The reason for printing the ID numbers is so that the actual nodes can be
-obtained.  Once a lambda has been printed (either by the pretty printer or
-by the regular printer), (NODE-UNHASH <id>) will return it:
-
-  scheme-compiler> (node-unhash 9)
-  '#{Node lambda loop 9}
-  scheme-compiler> ,inspect ##
-  '#{Node lambda loop 9}
-
-   [0: variant] 'lambda
-   [1: parent] '#{Node call letrec2}
-   [2: index] 2
-   [3: simplified?] #t
-   [4: flag] #f
-   [5: stuff-0] '#{Node call test}
-   [6: stuff-1] '(#{Variable n 3} #{Variable r 4})
-   [7: stuff-2] '(#{Name #} (n r) (if # r #))
-   [8: stuff-3] '#{Lambda-data}
-
-----------------------------------------------------------------
-Simplification.
-
-The factorial procedure above is how it looks when originally translated
-into a node tree.  The next step in compilation is to simplify the tree,
-doing constant folding, identifying call points, and so on.  The simplified
-version of FACT is:
-
-7   (P fact_7 (c_6 n_1)
-14    (LET* (((x_13 loop_2)
-                         (letrec1))
-12           (()         (letrec2 x_13 ^loop_9)))
-        (jump 0 loop_2 n_1 '1)))
-
-9    (J loop_9 (n_3 r_4)
-       (test 2 ^g_10 ^g_11 (< n_3 '2)))
-
-10    (C g_10 ()
-        (unknown-return 0 c_6 r_4))
-
-11    (C g_11 ()
-        (jump 0 loop_2 (+ '-1 n_3) (* n_3 r_4)))
-
-The only change is that the loop has been turned into a JUMP lambda.
-
-----------------------------------------------------------------
-Still to describe:
- protocol determination
- simplifier moving stuff down, duplicating, later passes move values back up
diff --git a/ps-compiler/doc/todo.txt b/ps-compiler/doc/todo.txt
deleted file mode 100644
index 281f1a3..0000000
--- a/ps-compiler/doc/todo.txt
+++ /dev/null
@@ -1,15 +0,0 @@
-There is a question about the simplifier for -.
-Also, should (- x x) be checked for?
-
-Join substitute is not quite right: might have (some-test cont1 cont2 V <huge>)
-where V is being tested.  As it stands we'll duplicate <huge>.  Should check
-that it is either small or contains no references to V (in which case we lift
-it with the conts).
-
-Need to come up with good numbers for the maximum size of procs and jumps
-that should be duplicated.
-
-Can join-substitute move stuff above a test?
-
-Pre-Scheme type checker dies on (car '()) if a LET has more variables
-than values.
diff --git a/ps-compiler/front/cps.scm b/ps-compiler/front/cps.scm
deleted file mode 100644
index f5974f4..0000000
--- a/ps-compiler/front/cps.scm
+++ /dev/null
@@ -1,124 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-; (cps-call <primop> <exits> <first-arg-index> <args> <cps>) ->
-;                   <call-node> + <top-call-node> + <bottom-lambda-node>
-;
-; (cps-sequence <nodes> <cps>) -> <last-node> + <top-call> + <bottom-lambda>
-;
-; (<cps> <node>) -> <value-node> + <top-call-node> + <bottom-lambda-node>
-
-(define (cps-call primop exits first-arg-index args cps)
-  (let ((call (make-call-node primop
-			      (+ (length args) first-arg-index)
-			      exits))
-	(arguments (make-arg-nodes args first-arg-index cps)))
-    (let loop ((args arguments) (first #f) (last #f))
-      (if (null? args)
-	  (values call first last)
-	  (let ((arg (car args)))
-	    (attach call (arg-index arg) (arg-value arg))
-	    (if (and last (arg-first arg))
-		(attach-body last (arg-first arg)))
-	    (loop (cdr args)
-		  (or first (arg-first arg))
-		  (or (arg-last arg) last)))))))
-	    
-; Record to hold information about arguments to calls.
-
-(define-record-type arg :arg
-  (make-arg index rank value first last)
-  arg?
-  (index arg-index)  ; The index of this argument in the call.
-  (rank arg-rank)    ; The estimated cost of executing this node at run time.
-  (value arg-value)  ; What CPS returned for this argument.
-  (first arg-first)
-  (last arg-last))
-
-; Convert the elements of EXP into nodes (if they aren't already) and put
-; them into an ARG record.  Returns the list of ARG records sorted
-; by ARG-RANK.
-
-(define (make-arg-nodes exp start cps)
-  (do ((index start (+ index 1))
-       (args exp (cdr args))
-       (vals '() (cons (receive (value first last)
-			   (cps (car args))
-			 (make-arg index (node-rank first) value first last))
-		       vals)))
-      ((null? args)
-       (sort-list vals
-                  (lambda (v1 v2)
-		    (> (arg-rank v1) (arg-rank v2)))))))
-
-; Complexity analysis used to order argument evaluation.  More complex
-; arguments are to be evaluated first.  This just counts reference nodes.
-; It is almost certainly a waste of time.
-
-(define (node-rank first)
-  (if (not first)
-      0
-      (complexity-analyze-vector (call-args first))))
-
-(define (complexity-analyze node)
-  (cond ((empty? node)
-         0)
-        ((reference-node? node)
-         1)
-        ((lambda-node? node)
-	 (if (not (empty? (lambda-body node)))
-	     (complexity-analyze-vector (call-args (lambda-body node)))
-	     0))
-	((call-node? node)
-	 (complexity-analyze-vector (call-args node)))
-        (else
-         0)))
-
-(define (complexity-analyze-vector vec)
-  (do ((i 0 (+ i 1))
-       (q 0 (+ q (complexity-analyze (vector-ref vec i)))))
-      ((>= i (vector-length vec))
-       q)))
-
-;----------------------------------------------------------------
-; (cps-sequence <nodes> <values-cps>) ->
-;   <last-node> + <top-call> + <bottom-lambda>
-; <values-cps> is the same as the <cps> used above, except that it returns
-; a list of value nodes instead of exactly one.
-
-(define (cps-sequence nodes values-cps)
-  (if (null? nodes)
-      (bug "CPS: empty sequence"))
-  (let loop ((nodes nodes) (first #f) (last #f))
-    (if (null? (cdr nodes))
-	(values (car nodes) first last)
-	(receive (exp-first exp-last)
-	    (cps-sequent (car nodes) values-cps)
-	  (if (and last exp-first)
-	      (attach-body last exp-first))
-	  (loop (cdr nodes) (or first exp-first) (or exp-last last))))))
-
-(define (cps-sequent node values-cps)	  
-  (receive (vals exp-first exp-last)
-      (values-cps node)
-    (receive (calls other)
-	(partition-list call-node? vals)
-      (map erase other)
-      (if (null? calls)
-	  (values exp-first exp-last)
-	  (insert-let calls exp-first exp-last)))))
-
-(define (insert-let calls exp-first exp-last)
-  (let* ((vars (map (lambda (call)
-		      (make-variable 'v (trivial-call-return-type call)))
-		    calls))
-	 (cont (make-lambda-node 'c 'cont vars))
-	 (call (make-call-node (get-primop (enum primop let))
-			       (+ 1 (length calls))
-			       1)))
-    (attach-call-args call (cons cont calls))
-    (cond (exp-first
-	   (attach-body exp-last call)
-	   (values exp-first cont))
-	  (else
-	   (values call cont)))))
-
diff --git a/ps-compiler/front/jump.scm b/ps-compiler/front/jump.scm
deleted file mode 100644
index d584f44..0000000
--- a/ps-compiler/front/jump.scm
+++ /dev/null
@@ -1,319 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-
-; Code to turn PROC lambdas into JUMP lambdas.
-
-(define (integrate-jump-procs!)
-  (receive (hits useless)
-      (find-jump-procs (filter proc-lambda? (make-lambda-list)) find-calls)
-    (remove-unused-procedures! useless)
-    (for-each (lambda (p)
-		(procs->jumps (cdr p)
-			      (map bound-to-variable (cdr p))
-			      (car p)))
-	      hits)
-    (not (and (null? hits) (null? useless)))))
-
-; Make a call graph with extra nodes inserted for continuations:
-;
-; If F calls G tail-recursively, add an edge F->G
-; If F calls G ... with continuation K, add a node K and edges F->K, K->G ...
-;
-; Then FIND-JOINS will return a list of the nodes that are passed two or
-; more distinct continuations.  The rest can be merged with their callers.
-;
-; Need a root node, so make one that points to all procs with unknown calls.
-
-(define-record-type node :node
-  (really-make-node proc cont successors join? merged?)
-  node?
-  (proc node-proc)             ; lambda node (or #f for continuation holders)
-  (cont node-cont)             ; lambda node (or #f for procs)
-  (successors node-successors set-node-successors!)
-  (temp node-temp set-node-temp!)
-  (join? node-join? set-node-join?!)
-  (merged? node-merged? set-node-merged?!))
-
-(define (make-node proc cont)
-  (really-make-node proc cont '() #f #f))
-
-(define-record-discloser :node
-  (lambda (node)
-    (list 'node (node-proc node) (node-cont node))))
-
-(define (add-child! parent child)
-  (if (not (memq? child (node-successors parent)))
-      (set-node-successors! parent (cons child (node-successors parent)))))
-
-; We want to find subsets of ALL-PROCS such that all elements of a subset
-; are always called with the same continuation.  (PROC->USES <proc>) returns
-; the references to <proc> that are calls, or #f if there are references that
-; are not calls.
-;
-; We proceed as follows:
-;  1. Partition the procs depending on whether all their calls are known or not.
-;  2. Build a call graph:
-;       Nodes represent either procedures or continuations.  If there is a
-;       tail-recursive call to procedure B in procedure A, then there is an
-;       edge from A to B.  For continuation C such that there is a call in
-;       procedure A to procedure B with that continuation, there are edges
-;       from A to C and from C to B.
-;         In other words, it is a call graph where the edges that represent
-;       non-tail-recursive calls are replaced by two edges, with a node for
-;       the continuation in between.
-;         There is a special root node (representing `outside'), that has
-;       edges to the nodes representing procedures whose call sites have not
-;       been identified.
-;  3. Determine the dominance frontiers in the graph.
-;  4. Find the nodes in the graph that are reachable from more than one
-;     continuation (the joins).
-;  5. Starting from each node that represents a continuation (the joins,
-;     procs whose calls aren't known, and the continuations themselves),
-;     find the set of nodes reachable from that node without going through
-;     some other continuation node.
-
-(define (find-jump-procs all-procs proc->uses)
-  (for-each (lambda (l)
-	      (set-lambda-block! l (make-node l #f)))
-	    all-procs)
-  (receive (known unknown)
-      (partition-list calls-known? all-procs)
-    (let ((root (make-node #f #f))
-	  (conts-cell (list '()))
-	  (known-blocks (map lambda-block known))
-	  (procs-cell (list (map lambda-block unknown))))
-      (note-calls! known conts-cell procs-cell proc->uses)
-      (let ((unknown-blocks (car procs-cell))
-	    (conts (car conts-cell)))
-	(set-node-successors! root unknown-blocks)
-	(graph->ssa-graph! root node-successors node-temp set-node-temp!)
-	(let ((joins (find-joins (append conts unknown-blocks) node-temp)))
-	  (for-each (lambda (n)
-		      (set-node-join?! n #t))
-		    joins)
-	  (let* ((mergable (filter-map find-mergable
-				       (append joins unknown-blocks conts)))
-		 (useless  (filter (lambda (p)
-				     (not (or (node-join? (lambda-block p))
-					      (node-merged? (lambda-block p)))))
-				   known)))
-	    (for-each (lambda (p)
-			(set-lambda-block! p #f))
-		      all-procs)
-	    (values mergable useless)))))))
-
-; Walk KNOWN-PROCS adding edges to the call graph.
-
-(define (note-calls! known-procs conts-cell procs-cell proc->uses)
-  (for-each (lambda (proc)
-	      (for-each (lambda (ref)
-			  (note-call! (lambda-block proc)
-				      ref
-				      conts-cell procs-cell))
-			(proc->uses proc)))
-	    known-procs))
-
-; Add an edge from the node containing REF to PROC-NODE.  Tail calls add an
-; edge directly from the calling node, non-tail calls add an edge from the
-; successor to the calling node that represents the call's continuation.
-
-(define (note-call! proc-node ref conts-cell procs-cell)
-  (let ((caller (get-lambda-block (containing-procedure ref) procs-cell)))
-    (add-child! (if (calls-this-primop? (node-parent ref) 'tail-call)
-		    caller
-		    (get-cont-block caller
-				    (call-arg (node-parent ref) 0)
-				    conts-cell))
-		proc-node)))
-
-; Get the block for lambda-node PROC, making a new one if necessary.
-
-(define (get-lambda-block proc procs-cell)
-  (let ((block (lambda-block proc)))
-    (if (node? block)
-	block
-	(let ((new (make-node proc #f)))
-	  (set-lambda-block! proc new)
-	  (set-car! procs-cell (cons new (car procs-cell)))
-	  new))))
-
-; Get the successor to CALLER containing CONT, making it if necessary.
-
-(define (get-cont-block caller cont conts-cell)
-  (or (any (lambda (node)
-	     (and (node-cont node)
-		  (node-equal? cont (node-cont node))))
-	   (node-successors caller))
-      (let ((cont-node (make-node #f cont)))
-	(set-car! conts-cell (cons cont-node (car conts-cell)))
-	(add-child! caller cont-node)
-	cont-node)))
-
-;----------------
-
-(define (find-mergable node)
-  (let ((mergable (really-find-mergable node)))
-    (if (null? mergable)
-	#f
-	(cons (or (node-cont node)
-		  (car (variable-refs (car (lambda-variables (node-proc node))))))
-	      mergable))))
-
-(define (really-find-mergable node)    
-  (let recur ((nodes (node-successors node)) (res '()))
-    (if (null? nodes)
-	res
-	(recur (cdr nodes)
-	       (let ((node (car nodes)))
-		 (cond ((or (node-join? node)    ; gets two or more continuations
-			    (node-merged? node)  ; already merged
-			    (node-cont node))    ; different continuation
-			res)
-;		       ((node-cont node)          ; not a lambda
-;			(recur (node-successors node) res))
-		       (else
-			(set-node-merged?! node #t)
-			(recur (node-successors node)
-			       (cons (node-proc node) res)))))))))
-
-;=============================================================================;
-; Part 2.  PROCS is a list of procedures that are only called by each other;
-; with no entry point they are useless and can be removed.
-
-(define (remove-unused-procedures! procs)
-  (for-each (lambda (proc)
-	      (let ((var (bound-to-variable proc)))
-		(if (not var)
-		    (bug "known procedure has no variable ~S" proc))
-		(format #t "Removing unused procedure: ~S~%"
-			(variable-name var)) ; would LAMBDA-NAME be better?
-		(mark-changed (node-parent proc))
-		(detach-bound-value var proc)
-		(erase proc)))
-	    procs))
-
-;=============================================================================;
-; Part 3.  Turn JUMP-PROCS from procs to jumps.  CONT is the continuation they
-; all receive, and is also turned into a jump.
-
-; This creates a LETREC to bind all CONT and any of JUMP-PROCS that are
-; passed CONT directly and are bound abouve the LCA of all calls to JUMP-PROCS
-; that use CONT.  Then every jump-proc is changed from a proc lambda to a
-; jump lambda and has its continuation removed.  Returns are replaced with
-; jumps to CONT.  If CONT is not a variable some protocol adjustment may be
-; required.
-
-(define (procs->jumps jump-procs vars cont)
-  (receive (called-vars called-procs lca)
-      (find-cont-uses cont vars jump-procs)
-    (let ((proc (containing-procedure cont))
-	  (lca (if (call-node? lca) lca (node-parent lca)))
-	  (cvar (if (lambda-node? cont)
-		    (make-variable 'w (node-type cont))
-		    #f)))
-      (receive (called-vars called-procs)
-	  (bound-above? lca called-vars called-procs)
-	(for-each detach-bound-value called-vars called-procs)
-	(cond ((lambda-node? cont)
-	       (determine-continuation-protocol cont jump-procs)
-	       (move cont (lambda (ignore) (make-literal-node '#f '#f)))
-	       (put-in-letrec (cons cvar called-vars)
-			      (cons cont called-procs)
-			      lca)
-	       (change-lambda-type cont 'jump))
-	      (else
-	       (put-in-letrec called-vars called-procs lca))))
-      (for-each proc-calls->jumps jump-procs)
-      (for-each (lambda (p)
-		  (let* ((v (car (lambda-variables p)))
-			 (refs (variable-refs v)))
-		    (set-variable-refs! v '())
-		    (for-each (lambda (r)
-				(if (lambda-node? cont)
-				    (return->jump (node-parent r) cvar cont)
-				    (replace r (make-reference-node
-						(car (lambda-variables proc))))))
-			      refs)
-		    (remove-variable p v)))
-		jump-procs)
-      (values))))
-
-; Returns those of VALS and VARS where there is a call to the variable that
-; passes CONT as a continuation, or where the variable is not bound.  The
-; third values returned is the least-common-ancestor of all calls to VARS
-; that use CONT.
-
-(define (find-cont-uses cont vars vals)
-  (let loop ((vars vars) (vals vals) (r-vars '()) (r-vals '()) (uses '()))
-    (if (null? vars)
-	(values r-vars r-vals (least-common-ancestor uses))
-	(let ref-loop ((refs (variable-refs (car vars))) (my-uses uses))
-	  (cond ((not (null? refs))
-		 (ref-loop (cdr refs)
-			   (if (node-equal? cont
-					    (call-arg (node-parent (car refs)) 0))
-			       (cons (car refs) my-uses)
-			       my-uses)))
-		((and (variable-binder (car vars))
-		      (eq? my-uses uses))
-		 (loop (cdr vars) (cdr vals) r-vars r-vals uses))
-		(else
-		 (loop (cdr vars) (cdr vals)
-		       (cons (car vars) r-vars)
-		       (cons (car vals) r-vals)
-		       my-uses)))))))
-
-; Return the list of VARS and VALS where the variable is either global
-; or bound above CALL.
-
-(define (bound-above? call vars vals)
-  (set-node-flag! call #t)
-  (let loop ((vars vars) (vals vals) (r-vars '()) (r-vals '()))
-    (cond ((null? vars)
-	   (set-node-flag! call #f)
-	   (values r-vars r-vals))
-	  ((and (variable-binder (car vars))
-		(marked-ancestor (variable-binder (car vars))))
-	   (loop (cdr vars) (cdr vals) r-vars r-vals))
-	  (else
-	   (loop (cdr vars) (cdr vals)
-		 (cons (car vars) r-vars)
-		 (cons (car vals) r-vals))))))
-
-(define (detach-bound-value var node)
-  (if (variable-binder var)
-      (let ((binder (variable-binder var))
-	    (parent (node-parent node))
-	    (index (node-index node)))
-	(set-lambda-variables! binder (delq! var (lambda-variables binder)))
-	(detach node)
-	(remove-call-arg parent index))))
-  
-; Turn all calls to PROC into jumps.
-
-(define (proc-calls->jumps proc)
-  (for-each (lambda (n)
-	      (call->jump (node-parent n)))
-	    (find-calls proc))
-  (change-lambda-type proc 'jump))
-
-; Change a call to a jump by changing the primop and removing the continuation.
-
-(define (call->jump call)
-  (case (primop-id (call-primop call))
-    ((call tail-call)
-     (set-call-primop! call (get-primop (enum primop jump)))
-     (remove-call-arg call 0))
-    (else
-     (bug "odd call primop ~S" (call-primop call)))))
-
-; Change a return to a jump.  VAR is a variable bound to JUMP, the lambda
-; being jumped to.
-
-(define (return->jump call var jump)
-  (case (primop-id (call-primop call))
-    ((return)
-     (set-call-primop! call (get-primop (enum primop jump)))
-     (replace (call-arg call 0) (make-reference-node var)))
-    (else
-     (bug "odd return primop ~S" (call-primop call)))))
diff --git a/ps-compiler/front/special.scm b/ps-compiler/front/special.scm
deleted file mode 100644
index 783517f..0000000
--- a/ps-compiler/front/special.scm
+++ /dev/null
@@ -1,224 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-; This file is obsolete and no longer used.
-
-;----------------------------------------------------------------------------
-;                           SPECIAL FORMS
-;
-;              QUOTE CALL RETURN BLOCK LAMBDA LETREC
-;               + LET for reasons of type-checking
-;
-;----------------------------------------------------------------------------
-
-(define-record-type quote-exp :quote-exp
-  (make-quote-exp value type)
-  quote-exp?
-  (value quote-exp-value)
-  (type quote-exp-type set-quote-exp-type!))
-
-(define-record-type call-exp :call-exp
-  (make-call-exp! proc exits type args source)
-  call-exp?
-  (proc call-exp-proc)
-  (exits call-exp-exits)
-  (type call-exp-type set-call-exp-type!)
-  (args call-exp-args)
-  (source call-exp-source))
-
-(define-record-type let-exp :let-exp
-  (make-let-exp vars vals body source)
-  let-exp?
-  (vars let-exp-vars)
-  (vals let-exp-vals)
-  (body let-exp-body set-let-exp-body!)
-  (source let-exp-source))
-
-(define-record-type return-exp :return-exp
-  (make-return-exp protocol type args)
-  return-exp?
-  (protocol return-exp-protocol)
-  (type return-exp-type)
-  (args return-exp-args))
-
-(define-record-type block-exp :block-exp
-  (make-block-exp exps)
-  block-exp?
-  (exps block-exp-exps))
-
-(define-record-type lambda-exp :lambda-exp
-  (make-lambda-exp id return-type protocol vars body source)
-  lambda-exp?
-  (id lambda-exp-id)
-  (return-type lambda-exp-return-type set-lambda-exp-return-type!)
-  (protocol lambda-exp-protocol)
-  (vars lambda-exp-vars)
-  (body lambda-exp-body set-lambda-exp-body!)
-  (source lambda-exp-source))
-
-(define (make-continuation-exp vars body)
-  (make-lambda-exp #f #f #f vars body #f))
-
-(define-record-type letrec-exp :letrec-exp
-  (make-letrec-exp vars vals body source)
-  letrec-exp?
-  (vars letrec-exp-vars)
-  (vals letrec-exp-vals)
-  (body letrec-exp-body set-letrec-exp-body!)
-  (source letrec-exp-source))
-
-(define-record-type external-value :external-value
-  (make-external-value type)
-  external-value?
-  (type external-value-type set-external-value-type!))
-
-; Creating nodes and CPS converting calls and blocks.
-;-------------------------------------------------------------------------------
-; (CPS expression) => value + first-call + last-lambda
-;  = the value of the expression
-;    + the first of any calls that must be executed to get the value
-;    + the continuation lambda of the last of the necessary calls
-; The first call and the last lambda will be #F if the value is trivial.
-;
-; (TAIL-CPS expression continuation-variable) => call
-;  = the first call to execute to return the value of the expression to
-;    the continuation variable
-
-(define (cps exp)
-  (let ((value (cps-value exp)))
-    (if value
-	(values value #f #f)
-	(generic-cps exp #f))))
-
-(define (tail-cps exp cont-var)
-  (receive (value type)
-      (cps-value+type exp)
-    (if value
-	(make-value-return cont-var value type)
-	(generic-cps exp cont-var))))
-
-(define (cps-value exp)
-  (receive (value type)
-      (cps-value+type exp)
-    value))
-
-(define (cps-value+type exp)
-  (cond ((variable? exp)
-	 (values (make-reference-node exp) (variable-type exp)))
-	((quote-exp? exp)
-	 (values (make-literal-node (quote-exp-value exp)
-				    (quote-exp-type exp))
-		 (quote-exp-type exp)))
-	((lambda-exp? exp)
-	 (let ((node (lambda-exp->node exp)))
-	   (values node (lambda-node-type node))))
-	(else
-	 (values #f #f))))
-
-(define (generic-cps exp cont-var)
-  (cond ((block-exp? exp)
-	 (make-block (block-exp-exps exp) cont-var))
-	((return-exp? exp)
-	 (make-return-call exp cont-var))
-	((call-exp? exp)
-	 (make-primop-call exp cont-var))
-	((let-exp? exp)
-	 (make-lambda-call exp cont-var))
-	((letrec-exp? exp)
-	 (letrec-exp->node exp cont-var))
-        (else
-         (bug "unknown syntax~% ~S" exp))))
-
-(define (lambda-exp->node exp)
-  (let* ((cvar (make-variable 'c (lambda-exp-return-type exp)))
-         (node (make-lambda-node (lambda-exp-id exp)
-				 'proc
-				 (cons cvar (copy-list (lambda-exp-vars exp))))))
-    (set-lambda-protocol! node (lambda-exp-protocol exp))
-    (set-lambda-source! node (lambda-exp-source exp))
-    (attach-body node (tail-cps (lambda-exp-body exp) cvar))
-    node))
-
-(define (letrec-exp->node exp cont-var)
-  (let ((vals (map cps-value (letrec-exp-vals exp)))
-	(vars (letrec-exp-vars exp))
-	(cont (make-lambda-node 'c 'cont '())))
-    (let-nodes ((top (letrec1 1 l1))
-		(l1 ((x #f) . vars) call2)
-		(call2 (letrec2 1 cont (* x) . vals)))
-      (set-call-source! top (letrec-exp-source exp))
-      (happens-after top cont (letrec-exp-body exp) cont-var))))
-
-; (CATCH id . body)
-; (THROW primop rep id . args)
-
-(define (make-undefined-value)
-  (make-quote-exp the-undefined-value #f))
-
-(define (exp->s-exp exp)
-  (cond ((variable? exp)
-	 (format #f "~S_~S" (variable-name exp) (variable-id exp)))
-	((quote-exp? exp)
-	 (list 'quote (quote-exp-value exp)))
-	((block-exp? exp)
-	 (cons 'begin (map exp->s-exp (block-exp-exps exp))))
-	((return-exp? exp)
-	 (cons 'return (map exp->s-exp (return-exp-args exp))))
-	((call-exp? exp)
-	 `(,(primop-id (call-exp-proc exp))
-	   ,(call-exp-exits exp)
-	   . ,(map exp->s-exp (call-exp-args exp))))
-	((let-exp? exp)
-	 `(let ,(map list
-		     (map exp->s-exp (let-exp-vars exp))
-		     (map exp->s-exp (let-exp-vals exp)))
-	    ,(exp->s-exp (let-exp-body exp))))
-	((lambda-exp? exp)
-	 `(lambda ,(map exp->s-exp (lambda-exp-vars exp))
-	    ,(exp->s-exp (lambda-exp-body exp))))
-	((letrec-exp? exp)
-	 `(letrec ,(map list
-			(map exp->s-exp (letrec-exp-vars exp))
-			(map exp->s-exp (letrec-exp-vals exp)))
-	    ,(exp->s-exp (letrec-exp-body exp))))
-        (else
-         (error '"unknown syntax~% ~S" exp))))
-
-(define (exp-source exp)
-  (cond ((call-exp? exp)
-	 (call-exp-source exp))
-	((let-exp? exp)
-	 (let-exp-source exp))
-	((letrec-exp? exp)
-	 (letrec-exp-source exp))
-	((lambda-exp? exp)
-	 (lambda-exp-source exp))
-	(else
-	 #f)))
-
-(define (find-some-source top-exp exp)
-  (or (exp-source exp)
-      (call-with-current-continuation
-	(lambda (exit)
-	  (let recur ((at top-exp))
-	    (let ((hit? (cond ((eq? at exp)
-			       #t)
-			      ((call-exp? at)
-			       (or (recur (call-exp-proc at))
-				   (any recur (call-exp-args at))))
-			      ((let-exp? at)
-			       (or (recur (let-exp-body at))
-				   (any recur (let-exp-vals at))))
-			      ((letrec-exp? at)
-			       (or (recur (letrec-exp-body at))
-				   (any recur (letrec-exp-vals at))))
-			      ((return-exp? at)
-			       (any recur (return-exp-args at)))
-			      ((lambda-exp? at)
-			       (recur (lambda-exp-body at)))
-			      ((block-exp? at)
-			       (any recur (block-exp-exps at)))
-			      (else #f))))
-	      (if (and hit? (exp-source at))
-		  (exit (exp-source at)))
-	      hit?))))))
-  
\ No newline at end of file
diff --git a/ps-compiler/front/top.scm b/ps-compiler/front/top.scm
deleted file mode 100644
index 5230961..0000000
--- a/ps-compiler/front/top.scm
+++ /dev/null
@@ -1,91 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-
-; Debugging aids
-
-(define *bad-ids*     '())
-(define *all-procs?*  #f)
-(define *checkpoints* '())
-
-(define all-checkpoints
-  '(node-made
-    simplify1
-    protocols
-    simplify2
-    node->vector
-    pre-simplify-proc
-    envs-added
-    ))
-
-(define (debug-breakpoint loc id data)
-  (if (and (memq? loc *checkpoints*)
-           (or (not id)
-               *all-procs?*
-               (memq? id *bad-ids*)))
-      (breakpoint "~S at ~S is ~S" id loc data)))
-
-(define (add-checks . locs)
-  (receive (okay wrong)
-           (partition-list (lambda (l) (memq? l all-checkpoints))
-                           locs)
-    (set! *checkpoints* (union okay *checkpoints*))
-    (for-each (lambda (l)
-		(format #t '"~&~S is not a checkpoint~%" l))
-	      wrong)
-    *checkpoints*))
-
-(define (clear-checks . locs)
-  (set! *checkpoints*
-	(if (null? locs)
-	    '()
-	    (set-difference *checkpoints* locs))))
-
-(define (add-procs . locs)
-  (if (null? locs)
-      (set! *all-procs?* #t)
-      (set! *bad-ids* (union locs *bad-ids*))))
-
-(define (clear-procs . locs)
-  (cond ((null? locs)
-         (set! *all-procs?* #f)
-         (set! *bad-ids* '()))
-        (else
-         (set! *bad-ids*
-	       (if (null? locs)
-		   '()
-		   (set-difference *bad-ids* locs))))))
-
-(define add-check   add-checks)
-(define clear-check clear-checks)
-(define add-proc    add-procs)
-(define clear-proc  clear-procs)
-
-;------------------------------------------------------------------------------
-
-(define *remove-cells?* #f)
-(define *flow-values?*  #f)
-
-(define (simplify-all node id)
-  (debug-breakpoint 'node-made id node)
-  (simplify-node node)
-  (debug-breakpoint 'simplify1 id node)
-  (determine-protocols)
-  (debug-breakpoint 'protocols id node)
-  (if (integrate-jump-procs!)
-      (simplify-node node))
-  (cond (*remove-cells?*
-         (remove-cells-from-tree node (make-lambda-list))
-         (simplify-node node)))
-  (cond (*flow-values?*
-         (flow-values node (make-lambda-list))
-         (simplify-node node)))
-  (debug-breakpoint 'simplify2 id node)
-  (values))
-
-(define (determine-protocols)
-  (walk-lambdas (lambda (l)
-		  (cond ((and (eq? 'proc (lambda-type l))
-			      (node? (node-parent l))
-			      (find-calls l))
-			 => (lambda (calls)
-			      (determine-lambda-protocol l calls)))))))
diff --git a/ps-compiler/interfaces.scm b/ps-compiler/interfaces.scm
deleted file mode 100644
index 48be74d..0000000
--- a/ps-compiler/interfaces.scm
+++ /dev/null
@@ -1,258 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-
-(define-interface utilities-interface
-  (export bug
-          user-error
-          user-warning
-          true false
-          or-map
-          remove-similar-elts
-          select-from-table
-          table->list table->entry-list
-          table-push table-pop
-          merge-lists
-          vector-every?
-          make-ignorable
-          sub-vector->list
-          flag-assq
-
-          enforce
-          writec
-          mem?
-          walk-vector
-          vector-replace
-          copy-list
-          copy-vector
-          symbol-hash
-          string-hash
-          char->ascii
-          object-hash
-          union intersection set-difference
-
-          make-xvector xvector-length xvector-ref xvector-set! xvector->vector
-
-          (define-subrecord :syntax)
-          ;(define-simple-record-type :syntax)
-          (define-local-syntax :syntax)
-          ))
-
-(define-interface primop-interface
-  (export primop? make-primop make-proc-primop make-conditional-primop
-          all-primops get-primop
-
-          primop-id primop-trivial? primop-side-effects
-          primop-cost
-          simplify-call
-          primop-procedure? primop-call-index
-          primop-conditional?
-          expand-to-conditional
-          simplify-conditional?
-          primop-code-data set-primop-code-data!
-	  trivial-call-return-type
-
-	  (primop :syntax)
-          ))
-
-(define-interface variable-interface
-  (export variable? make-variable
-          global-variable? make-global-variable
-          variable-name set-variable-name!
-          variable-id
-          variable-type   set-variable-type!
-          variable-binder set-variable-binder!
-          variable-refs   set-variable-refs!
-          variable-flag   set-variable-flag!
-          variable-flags  set-variable-flags!
-	  variable-generate set-variable-generate!
-          erase-variable
-          variable-index copy-variable used? unused?
-          variable-known-value
-	  add-variable-known-value!
-	  remove-variable-known-value!
-          variable-simplifier
-	  add-variable-simplifier!
-	  remove-variable-simplifier!
-	  note-known-global-lambda!
-          ))
-
-(define-interface node-interface
-  (compound-interface
-   primop-interface
-   variable-interface
-   (export reset-node-id node-hash node-unhash
-
-           node? node-variant
-           node-parent set-node-parent!
-           node-index set-node-index!
-           node-simplified? set-node-simplified?!
-           node-flag set-node-flag!
-
-           empty empty? proclaim-empty
-
-           erase
-
-           detach detach-body
-           attach attach-body
-           move move-body
-           insert-body
-           replace replace-body
-
-           mark-changed
-
-           leaf-node?
-          
-           literal-node? make-literal-node
-           literal-value set-literal-value!
-           literal-type  set-literal-type!
-           copy-literal-node
-
-           reference-node? make-reference-node
-           reference-variable set-reference-variable!
-
-           call-node? make-call-node
-           call-primop set-call-primop!
-           call-args set-call-args!
-           call-exits set-call-exits!
-           call-source set-call-source!
-           call-arg call-arg-count
-
-           lambda-node? make-lambda-node
-           lambda-body set-lambda-body!
-           lambda-variables set-lambda-variables!
-           lambda-name set-lambda-name!
-           lambda-id
-           lambda-type
-           lambda-block set-lambda-block!
-	   lambda-env set-lambda-env!
-           lambda-protocol set-lambda-protocol!
-           lambda-source set-lambda-source!
-           lambda-variable-count
-           calls-known? set-calls-known?!
-	   proc-lambda?
-
-           initialize-lambdas add-lambda add-lambdas
-           change-lambda-type
-           walk-lambdas make-lambda-list
-          
-           loc/owner loc/type loc/rep
-           set/owner set/type set/rep set/value
-
-           node-base containing-procedure
-           trivial? nontrivial?
-           nontrivial-ancestor
-           calls-this-primop?
-           bound-to-variable
-           walk-refs-safely
-           small-node?
-           side-effects?
-           called-node? called-node
-           called-lambda
-           get-lambda-value
-           ;set-reference?
-
-           attach-call-args remove-call-args replace-call-args
-           remove-null-arguments
-           shorten-call-args insert-call-arg remove-call-arg
-           append-call-arg
-
-           remove-body
-
-	   put-in-letrec
-
-           remove-lambda-variable remove-variable remove-unused-variables
-
-           substitute substitute-vars-in-node-tree
-           replace-call-with-value
-
-           copy-node-tree
-
-           mark-ancestors marked-ancestor? unmarked-ancestor?
-           node-ancestor? marked-ancestor least-common-ancestor
-           proc-ancestor
-
-           hoistable-node?
-
-           find-scoping
-
-           (let-nodes :syntax)
-
-           node-equal?
-
-           no-free-references?
-
-	   find-calls
-
-	   node-type
-
-           the-undefined-value
-           undefined-value?
-           undefined-value-node?
-           make-undefined-literal
-           )))
-
-(define-interface simplify-internal-interface
-  (export simplify-node
-          default-simplifier
-	  simplify-arg
-          simplify-args
-          simplify-lambda-body
-	  simplify-known-lambda
-          
-          (pattern-simplifier :syntax)
-
-          simplify-allocation
-          simplify-known-call
-          simplify-known-tail-call
-          simplify-unknown-call
-          simplify-return
-          simplify-jump
-          ; simplify-undefined-value
-          simplify-test expand-test simplify-test?
-          ))
-
-(define-interface front-debug-interface
-  (export debug-breakpoint
-          add-checks add-check clear-checks clear-check
-          add-procs add-proc clear-procs clear-proc))
-
-(define-interface front-interface
-  (export simplify-all
-          integrate-jump-procs!  ; for debugging
-          ))
-
-(define-interface annotated-read-interface
-  (export read-and-annotate
-          pair-annotation
-          annotated-cons
-          annotation?
-          annotation-file
-          annotation-form
-          annotation-row
-          annotation-column
-          ))
-
-(define-interface compiler-byte-vector-interface
-  (export make-byte-vector byte-vector? byte-vector-length
-          byte-vector-ref  byte-vector-word-ref  byte-vector-half-word-ref
-          byte-vector-set! byte-vector-word-set! byte-vector-half-word-set!
-          byte-vector-endianess set-byte-vector-endianess!
-          ))
-
-(define-interface parameter-interface
-  (export lookup-primop
-	  lookup-imported-variable
-          
-          type/unknown
-	  type-eq?
-
-          lambda-node-type
-
-          true-value
-          false-value
-
-	  determine-lambda-protocol
-	  determine-continuation-protocol
-          ))
-
-
diff --git a/ps-compiler/load-ps-compiler.scm b/ps-compiler/load-ps-compiler.scm
deleted file mode 100644
index cb6703e..0000000
--- a/ps-compiler/load-ps-compiler.scm
+++ /dev/null
@@ -1,40 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-; -*- Mode: Scheme; -*-
-
-; To load the Pre-Scheme compiler into Scheme 48:
-;   ,exec ,load load-ps-compiler.scm
-; It needs a larger than default sized heap.  4000000 is big enough to
-; load the pre-scheme compiler but not big enough to compile the VM,
-; 12000000 is enough to compile the VM.
-;
-; compile-vm.exec is an exec script to compile the Scheme 48 virtual machine.
-;
-; This requires that Pre-Scheme already be loaded.
-
-(user '(run (let ((minor-number (call-with-input-file
-				    "minor-version-number"
-				  (lambda (in)
-				    (read in)))))
-	      (newline)
-	      (newline)
-	      (display "Pre-Scheme compiler version 0.")
-	      (display minor-number)
-	      (newline)
-	      (display "Copyright (c) 1994-1999 by Richard Kelsey.")
-	      (newline)
-	      (display "Please report bugs to pre-scheme@martigny.ai.mit.edu.")
-	      (newline)
-	      (newline))))
-
-
-(config)
-(structure 'reflective-tower-maker
-           '(export-reflective-tower-maker))
-(load "interfaces.scm")
-(load "package-defs.scm")
-(load "prescheme/interfaces.scm")
-(load "prescheme/package-defs.scm")
-(load-package 'let-nodes)       ; used in FOR-SYNTAX
-(load-package 'simp-patterns)   ; used in FOR-SYNTAX
-(load-package 'prescheme-compiler)
diff --git a/ps-compiler/load-scheme.scm b/ps-compiler/load-scheme.scm
deleted file mode 100644
index a11b9ff..0000000
--- a/ps-compiler/load-scheme.scm
+++ /dev/null
@@ -1,11 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-; Load the Scheme front-end
-
-(config)
-(load "interfaces.scm")
-(load "package-defs.scm")
-(load "scheme-to-c/package-defs.scm")
-(load-package 'let-nodes)       ; used in FOR-SYNTAX
-(load-package 'simp-patterns)   ; used in FOR-SYNTAX
-(load-package 'scheme-test)
diff --git a/ps-compiler/minor-version-number b/ps-compiler/minor-version-number
deleted file mode 100644
index 7ed6ff8..0000000
--- a/ps-compiler/minor-version-number
+++ /dev/null
@@ -1 +0,0 @@
-5
diff --git a/ps-compiler/node/arch.scm b/ps-compiler/node/arch.scm
deleted file mode 100644
index 9e5e0fa..0000000
--- a/ps-compiler/node/arch.scm
+++ /dev/null
@@ -1,40 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-
-; These are all of the primitives that are known to the compiler.
-
-; The enumeration is needed by the expander for LET-NODES so it ends up
-; being loaded into two separate packages.
-
-(define-enumeration primop
-  (
-   ; Nontrivial Primops
-   call              ; see below
-   tail-call
-   return
-   jump
-   throw
-
-   unknown-call
-   unknown-tail-call
-   unknown-return
-
-   dispatch          ; (dispatch <cont1> ... <contN> <exp>)
-   let               ; (let <lambda-node> . <args>)
-   letrec1           ; (letrec1 (lambda (x v1 v2 ...)
-   letrec2           ;            (letrec2 <cont> x <lambda1> <lambda2> ...)))
-
-   cell-set!
-   global-set!
-
-   undefined-effect  ; (undefined-effect . <maybe-args>)
-
-   ; Trivial Primops
-   make-cell
-   cell-ref
-   global-ref
-
-   ; Environment stuff, these are both trivial
-   closure
-   env-ref
-   ))
diff --git a/ps-compiler/node/leftovers.scm b/ps-compiler/node/leftovers.scm
deleted file mode 100644
index e94104e..0000000
--- a/ps-compiler/node/leftovers.scm
+++ /dev/null
@@ -1,23 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-
-; Identifying values called by primops
-
-; Is NODE the value being called by a primop?
-                            
-(define (procedure-node? node)
-  (let ((parent (node-parent node)))
-    (and (node? parent)
-	 (let ((primop (call-primop parent)))
-	   (and (primop-procedure? primop)
-		(eq? (primop-call-index primop)
-		     (node-index node)))))))
-
-; Get the node called at CALL.
-
-(define (called-procedure-node call)
-  (cond ((and (primop-procedure? (call-primop call))
-	      (primop-call-index (call-primop call)))
-	 => (lambda (i)
-	      (call-arg call i)))
-	(else '#f)))
diff --git a/ps-compiler/node/let-nodes.scm b/ps-compiler/node/let-nodes.scm
deleted file mode 100644
index bf3aefb..0000000
--- a/ps-compiler/node/let-nodes.scm
+++ /dev/null
@@ -1,280 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-
-;   This is a backquote-like macro for building nodes.
-;
-;   One goal is to produce code that is as efficient as possible.
-;
-; (LET-NODES (<spec1> ... <specN>) . <body>)
-;
-; <spec> ::= (<ident> <real-call>) |                            ; call node
-;            (<ident> (<var1> ... <varN>) <call>) |             ; lambda node
-;            (<ident> (<var1> ... <varN> . <last-vars>) <call>) ; lambda node
-;
-; <var>  ::= #f |             Ignored variable position
-;            <ident> |        Evaluate <ident> and copy it, rebinding <ident>
-;            '<ident> |       Evaluate <ident> to get the variable
-;            (<ident> <rep>)  (MAKE-VARIABLE <ident> <rep>)
-;
-; <last-vars> ::= <ident>
-;
-; <call> ::= <ident> | <real-call>
-;
-; <real-call> ::= (<primop-id> <exits> . <arg-list>)
-;
-; <arg-list> ::= (<arg1> ... <argN>) | (<arg1> ... <argN> . <last-args>)
-;
-; <last-args> ::= <ident>
-;
-; <arg>  ::= 'foo        literal node containing the value of foo, no rep
-;            '(foo rep)     "     "       "       "    "   "   " , using rep
-;            (* foo)     reference to foo (which evaluates to a variable)
-;            (! foo)     foo evaluates to a node
-;            foo         short for (! foo) when foo is an atom
-;            #f          put nothing here
-;            (<primop-id> . <args>)   a nested call
-;--------------------------------------
-;
-; Example:
-;
-;  (let-nodes ((c1 (l1 1 cont))
-;              (l1 ((j type/pointer)) (proc 2 l2 l3 . rest))
-;              (l2 () ((jump cont (* j)) '(true-value type/boolean)))
-;              (l3 () ((jump cont (* j)) '(false-value type/boolean))))
-;    (replace-body node c1))
-;
-;  ==>
-;
-;  (LET ((J (CREATE-VARIABLE 'J TYPE/POINTER)))
-;    (LET ((C1 (CREATE-CALL-NODE '2 1))
-;          (C.1225 (CREATE-CALL-NODE (+ '3 (LENGTH REST)) '2))
-;          (L1 (CREATE-LAMBDA-NODE 'C 'CONT (FLIST1 J '())))
-;          (C.1224 (CREATE-CALL-NODE '4 0))
-;          (L2 (CREATE-LAMBDA-NODE 'C 'CONT '()))
-;          (C.1223 (CREATE-CALL-NODE '4 0))
-;          (L3 (CREATE-LAMBDA-NODE 'C 'CONT '())))
-;      (ATTACH 0 C1 L1)
-;      (ATTACH 1 C1 CONT)
-;      (ATTACH 0 C.1225 PROC)
-;      (ATTACH-CALL-ARGS C.1225 (APPEND (LIST L2 L3) REST))
-;      (ATTACH-BODY L1 C.1225)
-;      (ATTACH 0 C.1224 (CREATE-PRIMOP-NODE PRIMOP/JUMP))
-;      (ATTACH-THREE-CALL-ARGS C.1224
-;                              (CREATE-JUMP-MARKER CONT)
-;                              (CREATE-REFERENCE-NODE J)
-;                              (CREATE-LITERAL-NODE TRUE-VALUE TYPE/BOOLEAN))
-;      (ATTACH-BODY L2 C.1224)
-;      (ATTACH 0 C.1223 (CREATE-PRIMOP-NODE PRIMOP/JUMP))
-;      (ATTACH-THREE-CALL-ARGS C.1223
-;                              (CREATE-JUMP-MARKER CONT)
-;                              (CREATE-REFERENCE-NODE J)
-;                              (CREATE-LITERAL-NODE FALSE-VALUE TYPE/BOOLEAN))
-;      (ATTACH-BODY L3 C.1223)
-;      (REPLACE-BODY NODE C1)))
-; 
-
-(define (expand-let-nodes form rename compare)
-  (destructure (((#f specs . body) form))
-    (receive (vars nodes code)
-	(parse-node-specs specs rename compare)
-      `(,(rename 'let) ,vars
-         (,(rename 'let) ,nodes
-	    ,@code
-	    ,@body)))))
-
-(define (test form)
-  (destructure (((#f specs . body) form))
-    (receive (vars nodes code)
-	(parse-node-specs specs identity eq?)
-      `(let ,vars
-	 (let ,nodes
-	    ,@code
-	    ,@body)))))
-
-; Parse the specs, returning a list of variable specs, a list of node specs,
-; and a list of construction forms.  An input spec is either a call or a
-; lambda, each is parsed by an appropriate procedure.
-
-(define (parse-node-specs specs r c)
-  (let loop ((specs (reverse specs)) (vars '()) (nodes '()) (codes '()))
-    (if (null? specs)
-        (values vars nodes codes)
-        (destructure ((((name . spec) . rest) specs))
-          (cond ((null? (cdr spec))
-                 (receive (node code)
-		     (construct-call name (car spec) r c)
-                   (loop rest vars
-                         `((,name ,node) . ,nodes) (append code codes))))
-                ((= 2 (length spec))
-                 (receive (vs node new-spec call)
-		     (construct-lambda (car spec) (cadr spec) r c)
-                   (loop (if new-spec (cons new-spec rest) rest)
-                         (append vs vars)
-                         `((,name ,node) . ,nodes)
-                         (if call 
-                             `((attach-body ,name ,call) . ,codes)
-                             codes))))
-                (else
-                 (error "illegal spec in LET-NODES ~S" (cons name spec))))))))
-
-; The names of the call-arg relation procedures, indexed by the number of
-; arguments handled.
-
-(define call-attach-names
-  '#(#f
-     #f
-     attach-two-call-args
-     attach-three-call-args
-     attach-four-call-args
-     attach-five-call-args))
-
-; Return the node spec and construction forms for a call.  This dispatches
-; on whether the argument list is proper or not.
-;
-; <real-call> ::= (<arg0> <exits> <arg1> ... <argN>) |
-;                 (<arg0> <exits> <arg1> ... <argN> . <last-args>))
-;                 ((JUMP l-node value) <arg1> ... <argN>)
-;                 ((JUMP l-node value) <arg1> ... <argN> . <last-args>)
-
-(define (construct-call name specs r c)
-  (destructure (((proc . args) specs))
-    (really-construct-call name proc (car args) '() (cdr args) r c)))
-
-(define (construct-nested-call specs r c)
-  (destructure (((primop-id . args) specs))
-    (let ((name (r 'call)))
-      (receive (node code)
-	  (really-construct-call name primop-id 0 '() args r c)
-	`(,(r 'let) ((,name ,node)) ,@code ,name)))))
-		    
-(define (really-construct-call name primop-id exits extra args r c)
-  (receive (arg-count arg-code)
-      (parse-call-args name extra args r c)
-    (let ((primop-code (get-primop-code primop-id r)))
-      (values `(,(r 'make-call-node) ,primop-code ,arg-count ,exits)
-	      arg-code))))
-
-(define (get-primop-code id r)
-  (cond ((name->enumerand id primop)
-	 => (lambda (n)
-	      `(,(r 'get-primop) ,n)))
-	(else
-	 `(,(r 'lookup-primop) ',id))))
-
-; NAME     = the call node which gets the arguments
-; EXTRA    = initial, already expanded arguments
-; ARGS     = unexpanded arguments
-; LAST-ARG = an atom whose value is added to the end of the arguments
-; Returns ARG-COUNT-CODE and ARG-CODE
-
-(define (parse-call-args name extra args r c)
-  (receive (args last-arg)
-      (decouple-improper-list args)
-    (let* ((args (append extra (map (lambda (a) (construct-node a r c)) args)))
-	   (count (length args)))
-      (if (not (null? last-arg))
-	  (values `(,(r '+) ,count (,(r 'length) ,last-arg))
-		  `((,(r 'attach-call-args)
-		     ,name
-		     ,(if (null? args)
-			  last-arg
-			  `(,(r 'append) (,(r 'list) . ,args) ,last-arg)))))
-	  (values count
-		  (cond ((= count 0)
-			 '())
-			((and (= count 1) (car args))
-			 `((,(r 'attach) ,name 0 ,(car args))))
-			((and (< count 6)
-			      (every? identity args))
-			 `((,(r (vector-ref call-attach-names count))
-			    ,name
-			    ,@args)))
-			(else
-			 `((,(r 'attach-call-args) ,name (list . ,args))))))))))
-
-; Return proper part of the list and its last-cdr separately.
-
-(define (decouple-improper-list list)
-  (do ((list list (cdr list))
-       (res '() (cons (car list) res)))
-      ((atom? list)
-       (values (reverse! res) list))))
-
-; Dispatch on the type of the SPEC and return the appropriate code.
-;
-; <arg>  ::= 'foo         literal node containing the value of foo, no rep
-;            '(foo rep)   literal node containing the value of foo
-;            (* foo)      reference to foo (which evaluates to a variable)
-;            (! foo)      foo evaluates to a node
-;            name         short for (! name) when foo is an atom
-
-(define (construct-node spec r c)
-  (cond ((atom? spec) spec)
-        (else
-         (destructure (((key data) spec))
-           (case key
-             ((*)     `(,(r 'make-reference-node) ,data))
-             ((quote) (if (pair? data)
-                          `(,(r 'make-literal-node) . ,data)
-                          `(,(r 'make-literal-node) ,data type/unknown)))
-             ((!)     data)
-             (else
-	      (construct-nested-call spec r c)))))))
-
-; Parse a lambda spec.  This returns a list of variable specs, code to
-; construct the lambda node, a spec for the body if necessary, and
-; the code needed to put it all together.
-
-(define (construct-lambda vars call r c)
-  (receive (vars node)
-           (construct-vars vars r c)
-    (cond ((null? call)
-           (values vars node #f #f))
-          ((atom? call)
-           (values vars node #f call))
-          (else
-           (let ((sym (r (generate-symbol 'c))))
-             (values vars node `(,sym ,call) sym))))))
-
-; Returns the code needed to construct the variables and the code to make
-; the lambda node that binds the variables.
-;
-; <var>  ::= #f |             Ignored variable position
-;            <ident> |        Evaluate <ident> and copy it, rebinding <ident>
-;            '<ident> |       Evaluate <ident> to get the variable
-;            (<ident> <rep>)  (MAKE-VARIABLE <ident> <rep>)
-
-(define (construct-vars vars r c)
-  (let loop ((vs vars) (vlist '()) (code '()))
-    (cond ((atom? vs)
-           (let ((vars (if (null? vs)
-			   `(,(r 'list) . ,(reverse! vlist))
-			   `(,(r 'append) (,(r 'list) . ,(reverse! vlist))
-					  ,vs))))
-             (values code `(,(r 'make-lambda-node) 'c 'cont ,vars))))
-          (else
-           (let ((spec (car vs))
-                 (rest (cdr vs)))
-             (cond ((null? spec)
-                    (loop rest (cons #f vlist) code))
-                   ((atom? spec)
-                    (loop rest (cons spec vlist)
-                          `((,spec (,(r 'copy-variable) ,spec)) . ,code)))
-                   ((c (car spec) 'quote)
-                    (loop rest (cons (cadr spec) vlist) code))
-                   (else
-                    (loop rest (cons (car spec) vlist)
-                          `((,(car spec)
-                             (,(r 'make-variable) ',(car spec) ,(cadr spec)))
-                            . ,code)))))))))
-
-;------------------------------------------------------------------------------
-; GENSYM utility
-
-(define *generate-symbol-index* 0)
-
-(define (generate-symbol sym)
-  (let ((i *generate-symbol-index*))
-    (set! *generate-symbol-index* (+ i 1))
-    (concatenate-symbol sym "." i)))
-
diff --git a/ps-compiler/node/node-equal.scm b/ps-compiler/node/node-equal.scm
deleted file mode 100644
index 2466d09..0000000
--- a/ps-compiler/node/node-equal.scm
+++ /dev/null
@@ -1,77 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-
-; Determining if two nodes are functionally identical.
-
-(define (node-equal? n1 n2)
-  (if (call-node? n1)
-      (and (call-node? n2)
-           (call-node-eq? n1 n2))
-      (value-node-eq? n1 n2)))
-
-; Compare two call nodes.  The arguments to the nodes are compared
-; starting from the back to do leaf nodes first (usually).
-
-(define (call-node-eq? n1 n2)
-  (and (= (call-arg-count n1) (call-arg-count n2))
-       (= (call-exits     n1) (call-exits     n2))
-       (eq? (call-primop n1) (call-primop n2))
-       (let ((v1 (call-args n1))
-             (v2 (call-args n2)))
-         (let loop ((i (- (vector-length v1) '1)))
-           (cond ((< i '0)
-                  #t)
-                 ((node-equal? (vector-ref v1 i) (vector-ref v2 i))
-                  (loop (- i '1)))
-                 (else
-                  #f))))))
-
-; Compare two value nodes.  Reference nodes are the same if they refer to the
-; same variable or if they refer to corresponding variables in the two node
-; trees.  Primop and literal nodes must be identical.  Lambda nodes are compared
-; by their own procedure.
-
-(define (value-node-eq? n1 n2)
-  (cond ((neq? (node-variant n1) (node-variant n2))
-	 #f)
-	((reference-node? n1)
-	 (let ((v1 (reference-variable n1))
-	       (v2 (reference-variable n2)))
-	   (or (eq? v1 v2) (eq? v1 (variable-flag v2)))))
-	((literal-node? n1)
-	 (and (eq? (literal-value n1) (literal-value n2))
-	      (eq? (literal-type  n1) (literal-type  n2))))
-	((lambda-node? n1)
-	 (lambda-node-eq? n1 n2))))
-
-; Lambda nodes are identical if they have identical variable lists and identical
-; bodies.  The variables of N1 are stored in the flag fields of the variables of
-; N2 for the use of VALUE-NODE-EQ?.
-
-(define (lambda-node-eq? n1 n2)
-  (let ((v1 (lambda-variables n1))
-        (v2 (lambda-variables n2)))
-    (let ((ok? (let loop ((v1 v1) (v2 v2))
-                 (cond ((null? v1)
-                        (if (null? v2)
-                            (call-node-eq? (lambda-body n1) (lambda-body n2))
-                            #f))
-                       ((null? v2) #f)
-                       ((variable-eq? (car v1) (car v2))
-                        (loop (cdr v1) (cdr v2)))
-                       (else #f)))))
-      (map (lambda (v) (if v (set-variable-flag! v #f))) v2)
-      ok?)))
-
-(define (variable-eq? v1 v2)
-  (cond ((not v1)
-         (not v2))
-        ((not v2) #f)
-        ((eq? (variable-type v1) (variable-type v2))
-         (set-variable-flag! v2 v1)
-         #t)
-        (else #f)))
-
-
-
-
diff --git a/ps-compiler/node/node-util.scm b/ps-compiler/node/node-util.scm
deleted file mode 100644
index 1c85262..0000000
--- a/ps-compiler/node/node-util.scm
+++ /dev/null
@@ -1,723 +0,0 @@
- 
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-; This file contains miscellaneous utilities for accessing and modifying the
-; node tree.
-
-; Get the root of the tree containing node.
-
-(define (node-base node)
-  (do ((p node (node-parent p)))
-      ((not (node? (node-parent p)))
-       p)))
-
-; Find the procedure node that contains NODE.  Go up one parent at a time
-; until a lambda node is found, then go up two at a time, skipping the
-; intervening call nodes.
-
-(define (containing-procedure node)
-  (do ((node (node-parent node) (node-parent node)))
-      ((lambda-node? node)
-       (do ((node node (node-parent (node-parent node))))
-	   ((proc-lambda? node) node)))))
-
-; Trivial calls are those whose parents are call nodes.
-
-(define (trivial? call)
-  (call-node? (node-parent call)))
-
-(define (nontrivial? call)
-  (lambda-node? (node-parent call)))
-
-(define (nontrivial-ancestor call)
-  (let loop ((call call))
-    (if (or (not (node? (node-parent call)))
-	    (nontrivial? call))
-	call
-	(loop (node-parent call)))))
-
-(define (calls-this-primop? call id)
-  (eq? id (primop-id (call-primop call))))
-
-; Return the variable to which a value is bound by LET or LETREC.
-
-(define (bound-to-variable node)
-  (let ((parent (node-parent node)))
-    (case (primop-id (call-primop parent))
-      ((let)
-       (if (n= 0 (node-index node))
-	   (list-ref (lambda-variables (call-arg parent 0))
-		     (- (node-index node) 1))
-	   #f))
-      ((letrec2)
-       (if (< 1 (node-index node))
-	   (list-ref (lambda-variables
-		      (variable-binder
-		       (reference-variable (call-arg parent 1))))
-		     (- (node-index node) 1))
-	   #f))
-      (else #f))))
-
-; Return a list of all the reference to lambda-node L's value that call it.
-; If not all can be identified then #F is returned.
-
-(define (find-calls l)
-  (let ((refs (cond ((bound-to-variable l)
-		     => variable-refs)
-		    ((called-node? l)
-		     (list l))
-		    (else
-		     #f))))
-    (cond ((and refs (every? called-node? refs))
-	   refs)
-	  ((calls-known? l)
-	   (bug "cannot find calls for known lambda ~S" l))
-	  (else #f))))
-
-; Walk (or map) a tree-modifying procedure down a variable's references.
-
-(define (walk-refs-safely proc var)
-  (for-each proc (copy-list (variable-refs var))))
-
-; Return #t if the total primop-cost of NODE is less than SIZE.
-
-(define (small-node? node size)
-  (let label ((call (lambda-body node)))
-    (set! size (- size (primop-cost call)))
-    (if (>= size 0)
-	(walk-vector (lambda (n)
-		       (cond ((lambda-node? n)
-			      (label (lambda-body n)))
-			     ((call-node? n)
-			      (label n))))
-		     (call-args call))))
-  (>= size 0))
-
-; True if executing NODE involves side-effects.
-
-(define (side-effects? node . permissable)
-  (let ((permissable (cons #f permissable)))
-    (let label ((node node))
-      (cond ((not (call-node? node))
-	     #f)
-	    ((or (n= 0 (call-exits node))
-		 (not (memq (primop-side-effects (call-primop node))
-			    permissable)))
-	     #t)
-	    (else
-	     (let loop ((i (- (call-arg-count node) 1)))
-	       (cond ((< i 0) #f)
-		     ((label (call-arg node i)) #t)
-		     (else (loop (- i 1))))))))))
-
-; A conservative check - is there only one SET-CONTENTS call for the owner and
-; are all calls between CALL and the LETREC call that binds the owner calls to
-; SET-CONTENTS?
-
-;(define (single-letrec-set? call)
-;  (let ((owner (call-arg call set/owner)))
-;    (and (reference-node? owner)
-;	 (every? (lambda (ref)
-;		   (or (eq? (node-parent ref) call)
-;		       (not (set-reference? ref))))
-;		 (variable-refs (reference-variable owner))))))
-    
-;(define (set-reference? node)
-;  (and (eq? 'set-contents
-;	    (primop-id (call-primop (node-parent node))))
-;       (= (node-index node) set/owner)))
-
-;-------------------------------------------------------------------------------
-
-(define the-undefined-value (list '*undefined-value*))
-
-(define (undefined-value? x)
-  (eq? x the-undefined-value))
-
-(define (undefined-value-node? x)
-  (and (literal-node? x)
-       (undefined-value? (literal-value x))))
-
-(define (make-undefined-literal)
-  (make-literal-node the-undefined-value #f))
-
-;-------------------------------------------------------------------------------
-; Finding the lambda node called by CALL, JUMP, or RETURN
-
-(define (called-node? node)
-  (and (node? (node-parent node))
-       (eq? node (called-node (node-parent node)))))
-						   
-(define (called-node call)
-  (cond ((and (primop-procedure? (call-primop call))
-	      (primop-call-index (call-primop call)))
-	 => (lambda (i)
-	      (call-arg call i)))
-	(else '#f)))
-
-(define (called-lambda call)
-  (get-lambda-value (call-arg call (primop-call-index (call-primop call)))))
-
-(define (get-lambda-value value)
-  (cond ((lambda-node? value)
-	 value)
-	((reference-node? value)
-	 (get-variable-lambda (reference-variable value)))
-	(else
-	 (error "peculiar procedure in ~S" value))))
-
-(define (get-variable-lambda variable)
-  (if (global-variable? variable)
-      (or (variable-known-lambda variable)
-	  (error "peculiar procedure variable ~S" variable))
-      (let* ((binder (variable-binder variable))
-	     (index (node-index binder))
-	     (call (node-parent binder))
-	     (lose (lambda ()
-		     (error "peculiar procedure variable ~S" variable))))
-	(case (primop-id (call-primop call))
-	  ((let)
-	   (if (= 0 index)
-	       (get-lambda-value (call-arg call (+ 1 (variable-index variable))))
-	       (lose)))
-	  ((letrec1)
-	   (if (= 0 index)
-	       (get-letrec-variable-lambda variable)
-	       (lose)))
-	  ((call)
-	   (if (and (= 1 index)
-		    (= 0 (variable-index variable))) ; var is a continuation var
-	       (get-lambda-value (call-arg call 0))
-	       (lose)))
-	  (else
-	   (lose))))))
-
-; Some of the checking can be removed once I know the LETREC code works.
-
-(define (get-letrec-variable-lambda variable)
-  (let* ((binder (variable-binder variable))
-	 (call (lambda-body binder)))
-    (if (and (eq? 'letrec2 (primop-id (call-primop call)))
-	     (reference-node? (call-arg call 1))
-	     (eq? (car (lambda-variables binder))
-		  (reference-variable (call-arg call 1))))
-	(call-arg call (+ 1 (variable-index variable)))
-	(error "LETREC is incorrectly organized ~S" (node-parent binder)))))
-
-;(define (get-cell-variable-lambda variable)
-;  (let ((ref (first set-reference? (variable-refs variable))))
-;    (if (and ref
-;	     (eq? 'letrec
-;		  (literal-value (call-arg (node-parent ref) set/type))))
-;	(get-lambda-value (call-arg (node-parent ref) set/value))
-;	(error "peculiar lambda cell ~S" variable))))
-  
-;-------------------------------------------------------------------------------
-; Attaching and detaching arguments to calls
-
-; Make ARGS the arguments of call node PARENT.  ARGS may contain #f.
-
-(define (attach-call-args parent args)
-  (let ((len (call-arg-count parent)))
-    (let loop ((args args) (i 0))
-      (cond ((null? args)
-             (if (< i (- len 1))
-                 (bug '"too few arguments added to node ~S" parent))
-             (values))
-            ((>= i len)
-             (bug '"too many arguments added to node ~S" parent))
-            (else
-	     (if (car args)
-		 (attach parent i (car args)))
-	     (loop (cdr args) (+ 1 i)))))))
-
-; Remove all of the arguments of NODE.
-
-(define (remove-call-args node)
-  (let ((len (call-arg-count node)))
-    (do ((i 1 (+ i 1)))
-        ((>= i len))
-      (if (not (empty? (call-arg node i)))
-          (erase (detach (call-arg node i)))))
-    (values)))
-
-; Replace the arguments of call node NODE with NEW-ARGS.
-
-(define (replace-call-args node new-args)
-  (let ((len (length new-args)))
-    (remove-call-args node)
-    (if (n= len (call-arg-count node))
-        (let ((new (make-vector len empty))
-              (old (call-args node)))
-          (set-call-args! node new)))
-    (attach-call-args node new-args)))
-
-; Remove all arguments to CALL that are EMPTY?.  COUNT is the number of
-; non-EMPTY? arguments.
-
-(define (remove-null-arguments call count)
-  (let ((old (call-args call))
-        (new (make-vector count empty)))
-    (let loop ((i 0) (j 0))
-      (cond ((>= j count)
-	     (values))
-            ((not (empty? (vector-ref old i)))
-             (set-node-index! (vector-ref old i) j)
-             (vector-set! new j (vector-ref old i))
-             (loop (+ i 1) (+ j 1)))
-            (else
-             (loop (+ i 1) j))))
-    (set-call-args! call new)
-    (values)))
-
-; Remove all but the first COUNT arguments from CALL.
-
-(define (shorten-call-args call count)
-  (let ((old (call-args call))
-        (new (make-vector count empty)))
-    (vector-replace new old count)
-    (do ((i (+ count 1) (+ i 1)))
-        ((>= i (vector-length old)))
-      (erase (vector-ref old i)))
-    (set-call-args! call new)
-    (values)))
-
-; Insert ARG as the INDEXth argument to CALL.
-
-(define (insert-call-arg call index arg)
-  (let* ((old (call-args call))
-         (len (vector-length old))
-         (new (make-vector (+ 1 len) empty)))
-    (vector-replace new old index)
-    (do ((i index (+ i 1)))
-        ((>= i len))
-      (vector-set! new (+ i 1) (vector-ref old i))
-      (set-node-index! (vector-ref old i) (+ i 1)))
-    (set-call-args! call new)
-    (attach call index arg)
-    (values)))
-
-; Remove the INDEXth argument to CALL.
-
-(define (remove-call-arg call index)
-  (let* ((old (call-args call))
-         (len (- (vector-length old) 1))
-         (new (make-vector len)))
-    (vector-replace new old index)
-    (if (node? (vector-ref old index))
-        (erase (detach (vector-ref old index))))
-    (do ((i index (+ i 1)))
-        ((>= i len))
-      (vector-set! new i (vector-ref old (+ i 1)))
-      (set-node-index! (vector-ref new i) i))
-    (set-call-args! call new)
-    (if (< index (call-exits call))
-        (set-call-exits! call (- (call-exits call) 1)))
-    (values)))
-
-; Add ARG to the end of CALL's arguments.
-
-(define (append-call-arg call arg)
-  (insert-call-arg call (call-arg-count call) arg)) 
-
-; Replace CALL with the body of its continuation.
-
-(define (remove-body call)
-  (if (n= 1 (call-exits call))
-      (bug "removing a call with ~D exits" (call-exits call))
-      (replace-body call (detach-body (lambda-body (call-arg call 0))))))
-
-; Avoiding N-Ary Procedures
-; These are used in the expansion of the LET-NODES macro.
-
-(define (attach-two-call-args node a0 a1)
-  (attach node 0 a0)
-  (attach node 1 a1))
-
-(define (attach-three-call-args node a0 a1 a2)
-  (attach node 0 a0)
-  (attach node 1 a1)
-  (attach node 2 a2))
-
-(define (attach-four-call-args node a0 a1 a2 a3)
-  (attach node 0 a0)
-  (attach node 1 a1)
-  (attach node 2 a2)
-  (attach node 3 a3))
-
-(define (attach-five-call-args node a0 a1 a2 a3 a4)
-  (attach node 0 a0)
-  (attach node 1 a1)
-  (attach node 2 a2)
-  (attach node 3 a3)
-  (attach node 4 a4))
-
-;-------------------------------------------------------------------------------
-; Bind VARS to VALUES using letrec at CALL.  If CALL is already a letrec
-; call, just add to it, otherwise make a new one.
-
-(define (put-in-letrec vars values call)
-  (cond ((eq? 'letrec2 (primop-id (call-primop call)))
-	 (let ((binder (node-parent call)))
-	   (mark-changed call)
-	   (for-each (lambda (var)
-		       (set-variable-binder! var binder))
-		     vars)
-	   (set-lambda-variables! binder
-				  (append (lambda-variables binder) vars))
-	   (for-each (lambda (value)
-		       (append-call-arg call value))
-		     values)))
-	(else
-	 (move-body
-	  call
-	  (lambda (call)
-	    (let-nodes ((c (letrec1 1 l2))
-			(l2 ((x #f) . vars) (letrec2 1 l3 (* x) . values))
-			(l3 () call))
-	      c))))))
-
-;-------------------------------------------------------------------------------
-; Changing lambda-nodes' variable lists
-
-(define (remove-lambda-variable l-node index)
-  (remove-variable l-node (list-ref (lambda-variables l-node) index)))
-
-(define (remove-variable l-node var)
-  (if (used? var)
-      (bug '"cannot remove referenced variable ~s" var))
-  (erase-variable var)
-  (let ((vars (lambda-variables l-node)))
-    (if (eq? (car vars) var)
-        (set-lambda-variables! l-node (cdr vars))
-        (do ((vars vars (cdr vars)))
-            ((eq? (cadr vars) var)
-             (set-cdr! vars (cddr vars)))))))
-
-; Remove all of L-NODES' unused variables.
-
-(define (remove-unused-variables l-node)
-  (set-lambda-variables! l-node
-			 (filter! (lambda (v)
-				    (cond ((used? v)
-					   #t)
-					  (else
-					   (erase-variable v)
-					   #f)))
-				  (lambda-variables l-node))))
-
-;------------------------------------------------------------------------------
-; Substituting Values For Variables
-
-; Substitute VAL for VAR.  If DETACH? is true then VAL should be detached
-; and so can be used instead of a copy for the first substitution.
-;
-; If VAL is a reference to a variable named V, it was probably introduced by
-; the CPS conversion code.  In that case, the variable is renamed with the
-; name of VAR.  This helps considerably when debugging the compiler.
-
-(define (substitute var val detach?)
-  (if (and (reference-node? val)
-           (eq? 'v (variable-name (reference-variable val)))
-	   (not (global-variable? (reference-variable val))))
-      (set-variable-name! (reference-variable val)
-           (variable-name var)))
-  (let ((refs (variable-refs var)))
-    (set-variable-refs! var '())
-    (cond ((not (null? refs))
-           (for-each (lambda (ref)
-		       (replace ref (copy-node-tree val)))
-		     (if detach? (cdr refs) refs))
-           (if detach? (replace (car refs) (detach val))))
-          (detach?
-           (erase (detach val))))))
-
-; Walk the tree NODE replacing references to variables in OLD-VARS with
-; the corresponding variables in NEW-VARS.  Uses VARIABLE-FLAG to mark
-; the variables being replaced.
-
-(define (substitute-vars-in-node-tree node old-vars new-vars)
-  (for-each (lambda (old new)
-	      (set-variable-flag! old new))
-	    old-vars
-	    new-vars)
-  (let tree-walk ((node node))
-    (cond ((lambda-node? node)
-           (walk-vector tree-walk (call-args (lambda-body node))))
-          ((call-node? node)
-           (walk-vector tree-walk (call-args node)))
-          ((and (reference-node? node)
-                (variable-flag (reference-variable node)))
-           => (lambda (new)
-                (replace node (make-reference-node new))))))
-  (for-each (lambda (old) 
-	      (set-variable-flag! old #f))
-	    old-vars))
-
-; Replaces the call node CALL with VALUE.
-; (<proc> <exit> . <args>) => (<exit> <value>)
-
-(define (replace-call-with-value call value)
-  (cond ((n= 1 (call-exits call))
-         (bug '"can only substitute for call with one exit ~s" call))
-        (else
-	 (let ((cont (detach (call-arg call 0))))
-	   (set-call-exits! call 0)
-	   (replace-call-args call (if value (list cont value) (list cont)))
-	   (set-call-primop! call (get-primop (enum primop let)))))))
-
-;------------------------------------------------------------------------------
-; Copying Node Trees
-
-; Copy the node-tree NODE.  This dispatches on the type of NODE.
-; Variables which have been copied have the copy in the node-flag field.
-
-(define (copy-node-tree node)
-  (let ((new (cond ((lambda-node? node)
-		    (copy-lambda node))
-		   ((reference-node? node)
-		    (let ((var (reference-variable node)))
-		      (cond ((and (variable-binder var)
-				  (variable-flag var))
-			     => make-reference-node)
-			    (else
-			     (make-reference-node var)))))
-		   ((call-node? node)
-		    (copy-call node))
-		   ((literal-node? node)
-		    (copy-literal-node node)))))
-    new))
-
-; Copy a lambda node and its variables.  The variables' copies are put in
-; their VARIABLE-FLAG while the lambda's body is being copied.
-
-(define (copy-lambda node)
-  (let* ((vars (map (lambda (var)
-		      (if var
-			  (let ((new (copy-variable var)))
-			    (set-variable-flag! var new)
-			    new)
-			  #f))
-		    (lambda-variables node)))
-         (new-node (make-lambda-node (lambda-name node)
-				     (lambda-type node)
-				     vars)))
-    (attach-body new-node (copy-call (lambda-body node)))
-    (set-lambda-protocol! new-node (lambda-protocol node))
-    (set-lambda-source! new-node (lambda-source node))
-    (for-each (lambda (var)
-		(if var (set-variable-flag! var #f)))
-	      (lambda-variables node))
-    new-node))
-
-(define (copy-call node)
-  (let ((new-node (make-call-node (call-primop node)
-				  (call-arg-count node)
-				  (call-exits node))))
-    (do ((i 0 (+ i 1)))
-        ((>= i (call-arg-count node)))
-      (attach new-node i (copy-node-tree (call-arg node i))))
-    (set-call-source! new-node (call-source node))
-    new-node))
-
-;------------------------------------------------------------------------------
-; Checking the scoping of identifers
-
-; Mark all ancestors of N with FLAG
-
-(define (mark-ancestors n flag)
-  (do ((n n (node-parent n)))
-      ((not (node? n)) (values))
-    (set-node-flag! n flag)))
-
-; Does N have an ancestor with a non-#f flag?
-
-(define (marked-ancestor? n)
-  (do ((n n (node-parent n)))
-      ((or (not (node? n))
-           (node-flag n))
-       (node? n))))
-
-; Does N have an ancestor with a #f flag?
-
-(define (unmarked-ancestor? n)
-  (do ((n n (node-parent n)))
-      ((or (not (node? n))
-           (not (node-flag n)))
-       (node? n))))
-
-; Is ANC? an ancestor of NODE?
-
-(define (node-ancestor? anc? node)
-  (set-node-flag! anc? #t)
-  (let ((okay? (marked-ancestor? node)))
-    (set-node-flag! anc? #f)
-    okay?))
-
-; Find the lowest ancestor of N that has a non-#f flag
-
-(define (marked-ancestor n)
-  (do ((n n (node-parent n)))
-      ((or (not (node? n))
-           (node-flag n))
-       (if (node? n) n #f))))
-
-; Mark the ancestors of START with #f, stopping when END is reached
-
-(define (unmark-ancestors-to start end)
-  (do ((node start (node-parent node)))
-      ((eq? node end))
-    (set-node-flag! node #f)))
-
-; Return the lowest node that is above all NODES
-
-(define (least-common-ancestor nodes)
-  (mark-ancestors (car nodes) #t)
-  (let loop ((nodes (cdr nodes)) (top (car nodes)))
-    (cond ((null? nodes)
-           (mark-ancestors top #f)
-           top)
-          (else
-           (let ((new (marked-ancestor (car nodes))))
-             (unmark-ancestors-to top new)
-             (loop (cdr nodes) new))))))
-
-; Can TO be moved to FROM without taking variables out of scope.
-; This first marks all of the ancestors of FROM, and then unmarks all of the
-; ancestors of TO.  The net result is to mark every node that is above FROM but
-; not above TO.  Then if any reference-node below FROM references a variable
-; with a marked binder, that node, and thus FROM itself, cannot legally be
-; moved to TO.
-
-; This is not currently used anywhere, and it doesn't know about trivial
-; calls.
-
-(define (hoistable-node? from to)
-  (let ((from (if (call-node? from)
-		  (node-parent (nontrivial-ancestor from))
-		  from)))
-    (mark-ancestors (node-parent from) #t)
-    (mark-ancestors to #f)
-    (let ((okay? (let label ((n from))
-                   (cond ((lambda-node? n)
-                          (let* ((vec (call-args (lambda-body n)))
-                                 (c (vector-length vec)))
-                            (let loop ((i 0))
-                              (cond ((>= i c) #t)
-                                    ((label (vector-ref vec i))
-                                     (loop (+ i 1)))
-                                    (else #f)))))
-                         ((reference-node? n)
-                          (let ((b (variable-binder (reference-variable n))))
-                            (or (not b) (not (node-flag b)))))
-                         (else #t)))))
-      (mark-ancestors (node-parent from) #f)
-      okay?)))
-
-; Mark all of the lambda nodes which bind variables referenced below NODE.
-
-(define (mark-binders node)
-  (let label ((n node))
-    (cond ((lambda-node? n)
-           (walk-vector label (call-args (lambda-body n))))
-          ((reference-node? n)
-           (let ((b (variable-binder (reference-variable n))))
-             (if b (set-node-flag! b #f))))))
-  (values))
-
-
-;------------------------------------------------------------------------------
-; For each lambda-node L this sets (PARENT L) to be the enclosing PROC node
-; of L and, if L is a PROC node, sets (KIDS L) to be the lambda nodes it
-; encloses.
-
-(define (find-scoping lambdas parent set-parent! kids set-kids!)
-  (receive (procs others)
-      (partition-list proc-lambda? lambdas)
-    (for-each (lambda (l)
-		(set-parent! l #f)
-		(set-kids!   l '()))
-	      procs)
-    (for-each (lambda (l)
-		(set-parent! l #f))
-	      others)
-    (letrec ((set-lambda-parent!
-	      (lambda (l)
-		(cond ((parent l)
-		       => identity)
-		      ((proc-ancestor l)
-		       => (lambda (p)
-			    (let ((p (if (proc-lambda? p)
-					 p
-					 (set-lambda-parent! p))))
-			      (set-kids! p (cons l (kids p)))
-			      (set-parent! l p)
-			      p)))
-		      (else #f)))))
-      (for-each set-lambda-parent! lambdas))
-    (values procs others)))
-
-(define (proc-ancestor node)
-  (let ((p (node-parent node)))
-    (if (not (node? p))
-        #f
-        (let ((node (do ((p p (node-parent p)))
-			((lambda-node? p)
-			 p))))
-          (do ((node node (node-parent (node-parent node))))
-              ((proc-lambda? node)
-	       node))))))
-
-(define (no-free-references? node)
-  (if (call-node? node)
-      (error "NO-FREE-REFERENCES only works on value nodes: ~S" node))
-  (let label ((node node))
-    (cond ((reference-node? node)
-	   (let ((b (variable-binder (reference-variable node))))
-	     (or (not b)
-		 (node-flag b))))
-	  ((lambda-node? node)
-	   (set-node-flag! node #t)
-	   (let* ((vec (call-args (lambda-body node)))
-		  (res (let loop ((i (- (vector-length vec) 1)))
-			 (cond ((< i 0) #t)
-			       ((not (label (vector-ref vec i))) #f)
-			       (else (loop (- i 1)))))))
-	     (set-node-flag! node #f)
-	     res))
-	  (else
-	   #t))))
-
-(define (node-type node)
-  (cond ((literal-node? node)
-	 (literal-type node))
-	((reference-node? node)
-	 (variable-type (reference-variable node)))
-	((lambda-node? node)
-	 (lambda-node-type node))
-	((and (call-node? node)
-	      (primop-trivial? (call-primop node)))
-	 (trivial-call-return-type node))
-	(else
-	 (error "node ~S does not represent a value" node))))
-
-;----------------------------------------------------------------
-; Debugging utilities
-
-(define (show-simplified node)
-  (let loop ((n node) (r '()))
-    (if (node? n)
-	(loop (node-parent n) (cons (node-simplified? n) r))
-	(reverse r))))
-
-(define (show-flag node)
-  (let loop ((n node) (r '()))
-    (if (node? n)
-        (loop (node-parent n) (cons (node-flag n) r))
-	(reverse r))))
-
-(define (reset-simplified node)
-  (let loop ((n node))
-    (cond ((node? n)
-	   (set-node-simplified?! n #f)
-	   (loop (node-parent n))))))
diff --git a/ps-compiler/node/node.scm b/ps-compiler/node/node.scm
deleted file mode 100644
index 0139bc0..0000000
--- a/ps-compiler/node/node.scm
+++ /dev/null
@@ -1,544 +0,0 @@
-
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-; This file contains the definitions of the node tree data structure.
-
-;---------------------------------------------------------------------------
-; Records to represent variables.
-
-(define-record-type variable
-  ((name)        ; Source code name for variable (used for debugging only)
-   (id)          ; Unique numeric identifier     (used for debugging only)
-   (type)        ; Type for variable's value
-   )
-  (binder        ; LAMBDA node which binds this variable
-   (refs '())    ; List of leaf nodes n for which (REFERENCE-VARIABLE n) = var.
-   (flag #f)     ; Useful slot, used by shapes, COPY-NODE, NODE->VECTOR, etc.
-                 ; all users must leave this is #F
-   (flags '())   ; For various annotations, e.g. IGNORABLE
-   (generate #f) ; For whatever code generation wants
-   ))
-
-(define-record-discloser type/variable
-  (lambda (var)
-    (node-hash var)
-    (list 'variable (variable-name var) (variable-id var))))
-
-(define (make-variable name type)
-  (variable-maker name (new-id) type))
-
-(define (make-global-variable name type)
-  (let ((var (make-variable name type)))
-    (set-variable-binder! var #f)
-    var))
-
-(define (global-variable? var)
-  (not (variable-binder var)))
-
-; Every variable has a unique numeric identifier that is used for printing.
-
-(define *variable-id* 0)
-
-(define (new-id)
-  (let ((id *variable-id*))
-    (set! *variable-id* (+ 1 *variable-id*))
-    id))
-
-(define (erase-variable var)
-  (cond ((eq? (variable-id var) '<erased>)
-	 (bug "variable ~S already erased" var))
-	(else
-	 (set-variable-id! var '<erased>))))
-
-(define *node-hash-table* #f)
-
-(define (reset-node-id)
-  (set! *variable-id* 0)
-  (set! *node-hash-table* (make-table)))
-
-(define (node-hash var-or-lambda)
-  (let ((id (if (variable? var-or-lambda)
-		(variable-id var-or-lambda)
-		(lambda-id var-or-lambda))))
-    (table-set! *node-hash-table* id var-or-lambda)))
-
-(define (node-unhash n)
-  (table-ref *node-hash-table* n))
-
-; The index of VAR in the variables bound by its binder.
-
-(define (variable-index var)
-  (let ((binder (variable-binder var)))
-    (if (not binder)
-	(bug "VARIABLE-INDEX called on global variable ~S" var)
-	(do ((i 0 (+ i 1))
-	     (vs (lambda-variables binder) (cdr vs)))
-	    ((eq? (car vs) var)
-	     i)))))
-
-; Copy an old variable.
-
-(define (copy-variable old)
-  (let ((var (make-variable (variable-name old) (variable-type old))))
-    (set-variable-flags! var (variable-flags old))
-    var))
-
-; An unused variable is either #F or a variable with no references.
-
-(define (used? var)
-  (and var
-       (not (null? (variable-refs var)))))
-
-(define (unused? var)
-  (not (used? var)))
-
-; known values for top-level variables
-
-(define (flag-accessor flag)
-  (lambda (var)
-    (let ((p (flag-assq flag (variable-flags var))))
-      (if p (cdr p) #f))))
-
-(define (flag-setter flag)
-  (lambda (var value)
-    (set-variable-flags! var
-			 (cons (cons flag value)
-			       (variable-flags var)))))
-
-(define (flag-remover flag)
-  (lambda (var)
-    (set-variable-flags! var (filter (lambda (x)
-				       (or (not (pair? x))
-					   (not (eq? (car x) flag))))
-				     (variable-flags var)))))
-  
-(define variable-known-value (flag-accessor 'known-value))
-(define add-variable-known-value! (flag-setter 'known-value))
-(define remove-variable-known-value! (flag-remover 'known-value))
-
-(define variable-simplifier (flag-accessor 'simplifier))
-(define add-variable-simplifier! (flag-setter 'simplifier))
-(define remove-variable-simplifier! (flag-remover 'simplifier))
-
-(define variable-known-lambda (flag-accessor 'known-lambda))
-(define note-known-global-lambda! (flag-setter 'known-lambda))
-
-;----------------------------------------------------------------------------
-; The main record for the node tree
-
-(define-record-type node
-  ((variant)           ; One of LAMBDA, CALL, REFERENCE, LITERAL
-   )
-  ((parent empty)      ; Parent node
-   (index '<free>)     ; Index of this node in parent
-   (simplified? #f)    ; True if it has already been simplified.
-   (flag #f)           ; Useful flag, all users must leave this is #F
-   stuff-0             ; Variant components - each type of node has a different
-   stuff-1             ; use for these fields
-   stuff-2
-   stuff-3
-   ))
-
-(define-record-discloser type/node
-  (lambda (node)
-    `(node ,(node-variant node)
-	   . ,(case (node-variant node)
-		((lambda)
-		 (node-hash node)
-		 (list (lambda-name node) (lambda-id node)))
-		((call)
-		 (list (primop-id (call-primop node))))
-		((reference)
-		 (let ((var (reference-variable node)))
-		   (list (variable-name var) (variable-id var))))
-		((literal)
-		 (list (literal-value node)))
-		(else
-		 '())))))
-
-(define make-node node-maker)
-
-;--------------------------------------------------------------------------
-; EMPTY is used to mark empty parent and child slots in nodes.
-
-(define empty
-  (list 'empty))
-
-(define (empty? obj) (eq? obj empty))
-
-(define (proclaim-empty probe)
-  (cond ((not (empty? probe))
-         (bug "not empty - ~S" probe))))
-
-;----------------------------------------------------------------------------
-; This walks the tree rooted at NODE and removes all pointers that point into
-; this tree from outside.
-
-(define (erase node)
-  (let label ((node node))
-    (cond ((empty? node)
-           #f)
-          (else
-           (case (node-variant node)
-             ((lambda)
-              (label (lambda-body node)))
-             ((call)
-              (walk-vector label (call-args node))))
-           (really-erase node)))))
-
-; This does the following:
-; Checks that this node has not already been removed from the tree.
-;
-; Reference nodes are removed from the refs list of the variable they reference.
-;
-; For lambda nodes, the variables are erased, non-CONT lambdas are removed from
-; the *LAMBDAS* list (CONT lambdas are never on the list).
-;
-; Literal nodes whose values have reference lists are removed from those
-; reference lists.
-
-(define (really-erase node)
-  (cond ((empty? node)
-         #f)
-        (else
-         (cond ((eq? (node-index node) '<erased>)
-                (bug "node erased twice ~S" node))
-               ((reference-node? node)
-		(let ((var (reference-variable node)))
-		  (set-variable-refs! var
-				      (delq! node (variable-refs var)))))
-               ((lambda-node? node)
-                (for-each (lambda (v)
-			    (if v (erase-variable v)))
-			  (lambda-variables node))
-                (if (neq? (lambda-type node) 'cont)
-                    (delete-lambda node))
-                (set-lambda-variables! node '()))  ; safety
-               ((literal-node? node)
-                (let ((refs (literal-refs node)))
-                  (if refs
-		      (set-literal-reference-list!
-		       refs
-                       (delq! node (literal-reference-list refs)))))))
-;	 (erase-type (node-type node))
-         (set-node-index! node '<erased>))))
-
-;---------------------------------------------------------------------------
-; CONNECTING AND DISCONNECTING NODES
-;
-; There are two versions of each of these routines, one for value nodes
-; (LAMBDA, REFERENCE, or LITERAL), and one for call nodes.
-
-; Detach a node from the tree.
-
-(define (detach node)
-  (vector-set! (call-args (node-parent node))
-	       (node-index node)
-	       empty)
-  (set-node-index! node #f)
-  (set-node-parent! node empty)
-  node)
-
-(define (detach-body node)
-  (set-lambda-body! (node-parent node) empty)
-  (set-node-index! node #f)
-  (set-node-parent! node empty)
-  node)
-
-; Attach a node to the tree.
-
-(define (attach parent index child)
-  (proclaim-empty (node-parent child))
-  (proclaim-empty (vector-ref (call-args parent) index))
-  (vector-set! (call-args parent) index child)
-  (set-node-parent! child parent)
-  (set-node-index! child index)
-  (values))
-
-(define (attach-body parent call)
-  (proclaim-empty (node-parent call))
-  (proclaim-empty (lambda-body parent))
-  (set-lambda-body! parent call)
-  (set-node-parent! call parent)
-  (set-node-index! call '-1)
-  (values))
-
-; Replace node in tree with value of applying proc to node.
-; Note the fact that a change has been made at this point in the tree.
-
-(define (move node proc)
-  (let ((parent (node-parent node))
-        (index (node-index node)))
-    (detach node)
-    (let ((new (proc node)))
-      (attach parent index new)
-      (mark-changed new))))
-
-(define (move-body node proc)
-  (let ((parent (node-parent node)))
-    (detach-body node)
-    (let ((new (proc node)))
-      (attach-body parent new)
-      (mark-changed new))))
-
-; Put CALL into the tree as the body of lambda-node PARENT, making the current
-; body of PARENT the body of lambda-node CONT.
-
-(define (insert-body call cont parent)
-  (move-body (lambda-body parent)
-             (lambda (old-call)
-               (attach-body cont old-call)
-               call)))
-
-; Replace old-node with new-node, noting that a change has been made at this
-; point in the tree.
-
-(define (replace old-node new-node)
-  (let ((index (node-index old-node))
-        (parent (node-parent old-node)))
-    (mark-changed old-node)
-    (erase (detach old-node))
-    (attach parent index new-node)
-    (set-node-simplified?! new-node #f)
-    (values)))
-
-(define (replace-body old-node new-node)
-  (let ((parent (node-parent old-node)))
-    (mark-changed old-node)
-    (erase (detach-body old-node))
-    (attach-body parent new-node)
-    (set-node-simplified?! new-node #f)
-    (values)))
-
-; Starting with the parent of NODE, set the SIMPLIFIED? flags of the
-; ancestors of NODE to be #F.
-
-(define (mark-changed node)
-  (do ((p (node-parent node) (node-parent p)))
-      ((or (empty? p)
-           (not (node-simplified? p))))
-    (set-node-simplified?! p #f)))
-
-;-------------------------------------------------------------------------
-; Syntax for defining the different types of nodes.
-
-(define-syntax define-node-type
-  (lambda (form rename compare)
-    (let ((id (cadr form))
-	  (slots (cddr form)))
-      (let ((pred (concatenate-symbol id '- 'node?)))
-	`(begin (define (,pred x)
-		  (eq? ',id (node-variant x)))
-		. ,(do ((i 0 (+ i 1))
-			(s slots (cdr s))
-			(r '() (let ((n (concatenate-symbol id '- (car s)))
-				     (f (concatenate-symbol 'node-stuff- i)))
-				 `((define-node-field ,n ,pred ,f)
-				   . ,r))))
-		       ((null? s) (reverse r))))))))
-
-; These are used to rename the NODE-STUFF fields of particular node variants.
-
-(define-syntax define-node-field
-  (lambda (form rename compare)
-    (let ((id (cadr form))
-	  (predicate (caddr form))
-	  (field (cadddr form)))
-      `(begin
-	 (define (,id node)
-	   (,field (enforce ,predicate node)))
-	 (define (,(concatenate-symbol 'set- id '!) node val)
-	   (,(concatenate-symbol 'set- field '!)
-	    (enforce ,predicate node)
-	    val))))))
-
-;-------------------------------------------------------------------------
-; literals
-
-(define-node-type literal
-  value  ; the value
-  type   ; the type of the value
-  refs   ; either #F or a literal-reference record; only a few types of literal
-  )      ; literal values require reference lists
-
-(define-record-type literal-reference
-  ()
-  ((list '())  ; list of literal nodes that refer to a particular value
-   ))
-
-(define make-literal-reference-list literal-reference-maker)
-
-(define (make-literal-node value type)
-  (let ((node (make-node 'literal)))
-    (set-literal-value! node value)
-    (set-literal-type!  node type)
-    (set-literal-refs!  node #f)
-    node))
-
-(define (copy-literal-node node)
-  (let ((new (make-node 'literal))
-        (refs (literal-refs node)))
-    (set-literal-value! new (literal-value node))
-    (set-literal-type!  new (literal-type  node))
-    (set-literal-refs!  new refs)
-    (if refs (set-literal-reference-list!
-	      refs
-	      (cons new (literal-reference-list refs))))
-    new))
-
-(define (make-marked-literal value refs)
-  (let ((node (make-node 'literal)))
-    (set-literal-value!   node value)
-    (set-literal-refs!    node refs)
-    (set-literal-reference-list! refs
-				 (cons node (literal-reference-list refs)))
-    node))
-
-;-------------------------------------------------------------------------
-; These just contain an identifier.
-
-(define-node-type reference
-  variable
-  )
-
-(define (make-reference-node variable)
-  (let ((node (make-node 'reference)))
-    (set-reference-variable! node variable)
-    (set-variable-refs! variable (cons node (variable-refs variable)))
-    node))
-
-; Literal and reference nodes are leaf nodes as they do not contain any other
-; nodes.
-
-(define (leaf-node? n)
-  (or (literal-node? n)
-      (reference-node? n)))
-
-;--------------------------------------------------------------------------
-; Call nodes
-
-(define-node-type call
-  primop     ; the primitive being called
-  args       ; vector of child nodes
-  exits      ; the number of arguments that are continuations
-  source     ; source info
-  )
-
-; Create a call node with primop P, N children and EXITS exits.
-
-(define (make-call-node primop n exits)
-  (let ((node (make-node 'call)))
-    (set-call-primop! node primop)
-    (set-call-args!   node (make-vector n empty))
-    (set-call-exits!  node exits)
-    (set-call-source! node #f)
-    node))
-
-(define (call-arg call index)
-  (vector-ref (call-args call) index))
-
-(define (call-arg-count call)
-  (vector-length (call-args call)))
-
-;----------------------------------------------------------------------------
-; LAMBDA NODES
-
-(define-node-type lambda
-  body       ; the call-node that is the body of the lambda
-  variables  ; a list of variable records with #Fs for ignored positions
-  source     ; source code for the lambda (if any)
-  data       ; a LAMBDA-DATA record (lambdas have more associated data than
-  )          ; the other node types.)
-
-(define-subrecord lambda lambda-data lambda-data
-  ((name)          ; symbol          (for debugging only)
-   id              ; unique integer  (for debugging only)
-   (type))         ; PROC, KNOWN-PROC, CONT, or JUMP (maybe ESCAPE at some point)
-  ((block #f)      ; either a basic-block (for flow analysis) or a code-block
-                   ; (for code generation).
-   (env #f)        ; a record containing lexical environment data
-   (protocol #f)   ; calling protocol from the source language
-   (prev #f)       ; previous node on *LAMBDAS* list
-   (next #f)       ; next node on *LAMBDAS* list
-   ))
-
-; Doubly linked list of all non-CONT lambdas
-(define *lambdas* #f)
-
-(define (initialize-lambdas)
-  (set! *lambdas* (make-lambda-node '*lambdas* 'cont '()))
-  (link-lambdas *lambdas* *lambdas*))
-
-(define (link-lambdas node1 node2)
-  (set-lambda-prev! node2 node1)
-  (set-lambda-next! node1 node2))
-
-(define (add-lambda node)
-  (let ((next (lambda-next *lambdas*)))
-    (link-lambdas *lambdas* node)
-    (link-lambdas node next)))
-
-(define (delete-lambda node)
-  (link-lambdas (lambda-prev node) (lambda-next node))
-  (set-lambda-prev! node #f)
-  (set-lambda-next! node #f))
-
-(define (walk-lambdas proc)
-  (do ((n (lambda-next *lambdas*) (lambda-next n)))
-      ((eq? n *lambdas*))
-    (proc n))
-  (values))
-
-(define (make-lambda-list)
-  (do ((n (lambda-next *lambdas*) (lambda-next n))
-       (l '() (cons n l)))
-      ((eq? n *lambdas*)
-       l)))
-
-(define (add-lambdas nodes)
-  (for-each add-lambda nodes))
-
-;    Create a lambda node.  NAME is used as the name of the lambda node's
-; self variable.  VARS is a list of variables.  The VARIABLE-BINDER slot
-; of each variable is set to be the new lambda node.
-
-(define (make-lambda-node name type vars)
-  (let ((node (make-node 'lambda))
-        (data (lambda-data-maker name (new-id) type)))
-    (set-lambda-body!      node empty)
-    (set-lambda-variables! node vars)
-    (set-lambda-data!      node data)
-    (set-lambda-source!    node #f)
-    (for-each (lambda (var)
-		(if var (set-variable-binder! var node)))
-	      vars)
-    (if (neq? type 'cont)
-	(add-lambda node))
-    node))
-
-; Change the type of lambda-node NODE to be TYPE.  This may require adding or
-; deleting NODE from the list *LAMBDAS*.
-
-(define (change-lambda-type node type)
-  (let ((has (lambda-type node)))
-    (cond ((neq? type (lambda-type node))
-	   (set-lambda-type! node type)
-	   (cond ((eq? type 'cont)
-		  (delete-lambda node))
-		 ((eq? has 'cont)
-		  (add-lambda node)))))
-    (values)))
-
-(define (lambda-variable-count node)
-  (length (lambda-variables node)))
-
-(define (calls-known? node)
-  (neq? (lambda-type node) 'proc))
-
-(define (set-calls-known?! node)
-  (set-lambda-type! node 'known-proc))
-
-(define (proc-lambda? node)
-  (or (eq? 'proc (lambda-type node))
-      (eq? 'known-proc (lambda-type node))))
-
diff --git a/ps-compiler/node/pp-cps.scm b/ps-compiler/node/pp-cps.scm
deleted file mode 100644
index 28ed49a..0000000
--- a/ps-compiler/node/pp-cps.scm
+++ /dev/null
@@ -1,355 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-; Pretty-printing the node tree
-
-; Sample output:
-
-;  34  (F_12 (C_11 UNIT_0)
-;        (SET-CONTENTS 1 C_11 UNIT_0 UNIT '0 ^F_14))
-;
-;  35   (F_14 (C_13 N_1)
-;  36     (LET* (((LOOP_73)  (CONS CELL '0))
-;  37            (()         (SET-CONTENTS LOOP_73 CELL '0 ^F_34))
-;  38            ((V_77)     (CONTENTS LOOP_73 CELL '0)))
-;           (V_77 1 C_13 N_1 '1)))
-;
-;  39    (F_34 (C_33 I_9 R_7)
-;  40      (LET* (((V_61)     (CONTENTS UNIT_0 UNIT '3))
-;  41             ((V_63)     (V_61 I_9 '0)))
-;            (TRUE? 2 ^C_58 ^C_41 V_63)))
-;
-;  42     (C_58 ()
-;           (C_33 0 R_7))
-;
-;  43     (C_41 ()
-;  44       (LET* (((V_46)     (CONTENTS UNIT_0 UNIT '2))
-;  45              ((V_56)     (V_46 I_9 R_7))
-;  46              ((V_44)     (CONTENTS UNIT_0 UNIT '1))
-;  47              ((V_54)     (V_44 I_9 '1))
-;  48              ((V_52)     (CONTENTS LOOP_73 CELL '0)))
-;             (V_52 1 C_33 V_54 V_56)))
-
-; What it means:
-
-; Variables    `<name>_<id>'         V_61
-; Primops      `<primop name>'       CONTENTS
-; Lambdas      `^<self variable>'    ^F_34
-; Literals     `'<value>'            '0
-
-;  35   (F_14 (C_13 N_1)
-; This is the header for a lambda node.  `35' is the object hash of the node.
-; `F_14' is the LAMBDA-NAME and LAMBDA-ID, `(C_13 N_1)' is the variable list.  The
-; start of this line (not counting the object hash) is indented one column
-; more than the start of the lexically superior lambda.
-
-;  36     (LET* (((LOOP_73)  (CONS CELL '0))
-;  37            (()         (SET-CONTENTS LOOP_73 CELL '0 ^F_34))
-;  38            ((V_77)     (CONTENTS LOOP_73 CELL '0)))
-;           (V_77 1 C_13 N_1 '1)))
-; This is the body of the lambda.  It is a block consisting of three simple
-; calls and then a tail recursive call.  The simple calls are in the form
-; of a LET* that allows multiple value returns.  The actual body of the
-; lambda is the call `(CONS CELL '0)'.  The continuation to this call is
-; a lambda node `(LAMBDA (LOOP_73) (SET-CONTENTS ...))'.  `36' is the
-; object hash of this continuation lambda.
-;    After the block any lambdas in the block are printed.  This lambda is
-; followed by `F_34'.
-
-; (PP-CPS node . port)
-;---------------------------------------------------------------------------
-; Print CPS node tree in linear form.  Port defaults to the current output port.
-; This just dispatches on the type of NODE.
-
-(define (pp-cps node . port)
-  (let* ((port (if (null? port) (current-output-port) (car port)))
-	 (port (if (current-column port)
-		   port
-		   (make-tracking-output-port port))))
-    (set! *rereadable?* #f)
-    (cond ((lambda-node? node)
-           (pp-cps-lambda node 4 port))
-          ((call-node? node)
-           (write-non-simple-call node port))
-          (else
-           (write-node-value node port)))
-    (newline port)
-    ((structure-ref i/o force-output) port)))
-
-(define (rereadable-pp-cps node port)
-  (set! *rereadable?* #t)
-  (pp-cps-lambda node 4 port)
-  (values))
-
-(define (indent port count)
-  (let ((count (cond ((<= (current-column port) count)
-		      (- count (current-column port)))
-		     (else
-		      (newline port)
-		      count))))
-    (do ((count count (- count 1)))
-	((>= 0 count))
-      (writec port #\space))))
-		      
-(define *rereadable?* #f)
-(define *next-pp-id* 0)
-
-(define (reset-pp-cps)
-  (set! *next-pp-id* 0))
-
-(define (next-pp-id)
-  (let ((id *next-pp-id*))
-    (set! *next-pp-id* (+ *next-pp-id* 1))
-    id))
-
-; Print a lambda node by printing its identifiers, then its call, and finally
-; any other lambdas that it includes.
-
-(define (pp-cps-lambda node indent-to port)
-  (format port "~&~%")
-  (cond ((not *rereadable?*)
-	 (node-hash node)
-	 (format port "~D" (lambda-id node))))
-  (indent port indent-to)
-  (write-lambda-header node port)
-  (let ((internal (pp-cps-body (lambda-body node) indent-to port)))
-    (writec port #\))
-    (for-each (lambda (n)
-		(pp-cps-lambda n (+ indent-to 1) port))
-	      internal)))
-
-(define (write-lambda-header node port)
-  (writec port '#\()
-  (writec port (case (lambda-type node)
-                 ((proc known-proc) #\P)
-                 ((cont)            #\C)
-                 ((jump)            #\J)
-                 ((escape)          #\E)))
-  (writec port #\space)
-  (print-lambda-name node port)
-  (writec port #\space)
-  (write-lambda-vars node port))
-
-(define (write-lambda-vars node port)
-  (let ((vars (lambda-variables node)))
-    (cond ((not (null? vars))
-           (writec port '#\()
-           (print-variable-name (car vars) port)
-           (do ((v (cdr vars) (cdr v)))
-               ((null? v))
-             (writec port '#\space)
-             (print-variable-name (car v) port))
-           (writec port '#\)))
-          (else
-           (format port "()")))))
-
-; Print the body of a lambda node.  A simple call is one that has exactly
-; one exit.  They and calls to lambda nodes are printed as a LET*.
-
-(define (pp-cps-body call indent-to port)
-  (newline port)
-  (cond ((or (simple-call? call)
-             (let-call? call))
-         (write-let* call indent-to port))
-        (else
-         (indent port (+ '2 indent-to))
-         (write-non-simple-call call port))))
-
-; Write out a series of calls as a LET*.  The LET* ends when a call is reached
-; that is neither a simple call or a call to a lambda.
-
-(define (write-let* call indent-to port)
-  (cond ((not *rereadable?*)
-	 (node-hash (call-arg call 0))
-	 (format port "~D" (lambda-id (call-arg call '0)))))
-  (indent port (+ '2 indent-to))
-  (writec port '#\()
-  (format port "LET* ")
-  (writec port '#\()
-  (let loop ((call (next-call call))
-	     (ns (write-simple-call call indent-to port)))
-    (cond ((or (simple-call? call)
-               (let-call? call))
-           (newline port)
-	   (cond ((not *rereadable?*)
-		  (format port "~D" (lambda-id (call-arg call '0)))
-		  (node-hash (call-arg call 0))))
-           (indent port (+ '9 indent-to))
-           (loop (next-call call)
-                 (append (write-simple-call call indent-to port) ns)))
-          (else
-           (writec port '#\))
-           (newline port)
-           (indent port (+ '4 indent-to))
-           (let ((ns (append (write-non-simple-call call port) ns)))
-             (writec port '#\))
-             ns)))))
-
-(define (simple-call? call)
-  (and (= '1 (call-exits call))
-       (not (lambda-block (call-arg call 0)))))
-
-(define (let-call? call)
-  (calls-this-primop? call 'let))
-
-; Get the call that follows CALL in a LET*.
-
-(define (next-call call)
-  (lambda-body (call-arg call '0)))
-
-; Write out one line of a LET*.
-
-(define (write-simple-call call indent-to port)
-  (if (let-call? call)
-      (write-let-call call indent-to port)
-      (really-write-simple-call call indent-to port)))
-
-; Write the variables bound by the continuation and then the primop and
-; non-continuation arguments of the call.
-
-(define (really-write-simple-call call indent-to port)
-  (writec port '#\()
-  (write-lambda-vars (call-arg call '0) port)
-  (indent port (+ indent-to '21))
-  (writec port '#\()
-  (format port "~S" (primop-id (call-primop call)))
-  (write-call-args call '1 port)
-  (writec port '#\))
-  (find-lambda-nodes call 1))
-
-; Write the variables of the lambda and then the values of the arguments.
-
-(define (write-let-call call indent-to port)
-  (writec port '#\()
-  (write-lambda-vars (call-arg call '0) port)
-  (cond ((= '1 (vector-length (call-args call)))
-         (writec port '#\))
-         '())
-        (else
-	 (writec port #\*)
-         (indent port (+ indent-to '21))
-         (write-node-value (call-arg call '1) port)
-         (write-call-args call '2 port)
-	 (find-lambda-nodes call 1))))
-
-(define (find-lambda-nodes call start)
-  (reverse (let label ((call call) (start start) (ls '()))
-	     (do ((i start (+ i 1))
-		  (ls ls (let ((arg (call-arg call i)))
-			   (cond ((call-node? arg)
-				  (label arg 0 ls))
-				 ((lambda-node? arg)
-				  (cons arg ls))
-				 (else ls)))))
-		 ((>= i (call-arg-count call))
-		  ls)))))
-
-; Write out a call that ends a LET* block.
-
-(define (write-non-simple-call call port)
-  (writec port '#\()
-  (format port "~A ~D" (primop-id (call-primop call)) (call-exits call))
-  (write-call-args call '0 port)
-  (find-lambda-nodes call 0))
-
-; Write out the arguments of CALL starting with START.
-
-(define (write-call-args call start port)
-  (let* ((vec (call-args call))
-         (len (vector-length vec)))
-    (do ((i start (+ i '1)))
-        ((>= i len))
-      (writec port '#\space)
-      (write-node-value (vector-ref vec i) port))
-    (writec port '#\))))
-
-; Print out a literal value.
-
-(define (cps-print-literal value port)
-  (format port "'~S" value))
-
-; Dispatch on the type of NODE to get the appropriate printing method.
-
-(define (write-node-value node port)
-  (cond ((not (node? node))
-         (format port "{not a node}"))
-        ((lambda-node? node)
-         (writec port '#\^)
-         (print-lambda-name node port))
-	((call-node? node)
-	 (format port "(~S" (primop-id (call-primop node)))
-	 (write-call-args node '0 port))
-        ((literal-node? node)
-         (cps-print-literal (literal-value node) port))
-        ((reference-node? node)
-         (print-variable-name (reference-variable node) port))
-        (else
-         (bug "WRITE-NODE-VALUE got funny node ~S" node))))
-
-; Printing variables and lambda nodes
-
-; #T if variables are supposed to print as the name of the register containing
-; them instead of their name.
-
-(define *pp-register-names?* '#f)
-
-; A whole bunch of different entry points for printing variables in slightly
-; different ways.
-
-(define (print-variable-name var port)
-  (cond ((not var)
-         (format port "#f"))
-;        ((and *pp-register-names?*
-;              (reg? (variable-register var)))
-;         (format port "~S" (reg-name (variable-register var))))
-        (else
-	 (let ((id (cond ((not *rereadable?*)
-			  (variable-id var))
-			 ((variable-flag var)
-			  => identity)
-			 (else
-			  (let ((id (next-pp-id)))
-			    (set-variable-flag! var id)
-			    id)))))
-	   (format port "~S_~S" (variable-name var) id)))))
-
-; Same as the above without the check for a register.
-
-(define (print-variable-plain-name var port)
-  (cond ((not var)
-         (format port "#f"))
-        (else
-         (format port "~S_~D" (variable-name var) (variable-id var)))))
-
-; Return the name as a string.
-
-(define (variable-print-name var)
-  (print-variable-name var '#f))
-
-; Return the name as a symbol.
-
-(define (variable-unique-name var)
-  (string->symbol (variable-print-name var)))
-
-; Printing lambda-nodes as variables
-
-(define (print-lambda-name lnode port)
-  (let ((id (cond ((not *rereadable?*)
-		    (lambda-id lnode))
-		  ((node-flag lnode)
-		   => identity)
-		  (else
-		   (let ((id (next-pp-id)))
-		     (set-node-flag! lnode id)
-		     id)))))
-    (format port "~S_~D" (lambda-name lnode) id)))
-
-(define (lambda-print-name lnode)
-  (print-lambda-name lnode '#f))
-
-(define (lambda-unique-name lnode)
-  (string->symbol (lambda-print-name lnode)))
-
-
-
-
-
diff --git a/ps-compiler/node/primop.scm b/ps-compiler/node/primop.scm
deleted file mode 100644
index 97027eb..0000000
--- a/ps-compiler/node/primop.scm
+++ /dev/null
@@ -1,128 +0,0 @@
-
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-;   The information about a primitive operation.
-
-(define-record-type primop
-  (id             ; Symbol identifying this primop
-
-   trivial?       ; #t if this primop has does not require a continuation
-   side-effects   ; side-effects of this primop
-
-   simplify-call-proc ; Simplify method
-   primop-cost-proc   ; Cost of executing this operation
-                      ; (in some undisclosed metric)
-   return-type-proc   ; Give the return type (for trivial primops only)
-   proc-data      ; Record containing more data for the procedure primops
-   cond-data      ; Record containing more data for conditional primops
-   )
-  (code-data      ; Code generation data
-   ))
-
-(define-record-discloser type/primop
-  (lambda (primop)
-    (list 'primop (object-hash primop) (primop-id primop))))
-
-(define all-primops (make-vector primop-count))
-
-(define (make-primop id trivial? side-effects simplify cost type)
-  (let ((enum (name->enumerand id primop))
-	(primop (primop-maker id trivial? side-effects simplify cost type #f #f)))
-    (if enum
-	(vector-set! all-primops enum primop))
-    primop))
-
-(define (get-primop enum)
-  (vector-ref all-primops enum))
-
-(define-local-syntax (define-primop-method id args)
-  `(define (,id  . ,args)
-     ((,(concatenate-symbol 'primop- id '- 'proc) (call-primop ,(car args)))
-      . ,args)))
-
-(define-primop-method primop-cost (call))
-(define-primop-method simplify-call (call))
-
-(define (trivial-call-return-type call)
-  ((primop-return-type-proc (call-primop call)) call))
-
-;-------------------------------------------------------------------------------
-; procedure primops
-
-(define-subrecord primop primop-proc-data primop-proc-data
-  (call-index              ; index of argument being called
-   )
-  ())
-
-(define (primop-procedure? primop)
-  (if (primop-proc-data primop) #t #f))
-
-; (call <cont> <proc-var> . <args>)
-; (tail-call <cont-var> <proc-var> . <args>)
-; (return <proc-var> . <args>)
-; (jump   <proc-var> . <args>)
-; (throw  <proc-var> . <args>)
-;
-; (unknown-call <cont> <proc-var> . <args>)
-; (unknown-tail-call <cont-var> <proc-var> . <args>)
-; (unknown-return <proc-var> . <args>)
-
-(define (make-proc-primop id side-effects simplify cost index)
-  (let* ((enum (name->enumerand id primop))
-	 (data (primop-proc-data-maker index))
-	 (primop (primop-maker id #f side-effects simplify cost #f data #f)))
-    (vector-set! all-primops enum primop)
-    primop))
-
-;-------------------------------------------------------------------------------
-; conditional primops
-
-(define-subrecord primop primop-cond-data primop-cond-data
-  (expand-to-conditional-proc     ; Expand this call to a conditional
-   simplify-conditional?-proc     ; Can this conditional be simplified
-   )
-  ())
-
-(define-primop-method expand-to-conditional (call))
-(define-primop-method simplify-conditional? (call index value))
-
-(define (primop-conditional? primop)
-  (if (primop-cond-data primop) #t #f))
-
-(define (make-conditional-primop id side-effects simplify cost expand simplify?)
-  (let* ((enum (name->enumerand id primop))
-	 (data (primop-cond-data-maker expand simplify?))
-	 (primop (primop-maker id #f side-effects simplify cost #f #f data)))
-    (if enum (vector-set! all-primops enum primop))
-    primop))
-
-;-------------------------------------------------------------------------------
-; Random constants for location calls:
-
-;  ($CONTENTS     <thing> <type> <offset> <rep>)
-;  ($SET-CONTENTS <cont> <thing> <type> <offset> <rep> <value>)
-;                    0      1       2       3      4 
-
-(define loc/owner    0)
-(define loc/type     1)
-(define loc/rep      2)
-
-(define set/owner    1)
-(define set/type     2)
-(define set/rep      3)
-(define set/value    4)
-
-; For slots that do not contain code pointers:
-;  ($CLOSURE        <cont> <env> <slot>)
-;  ($SET-CLOSURE    <cont> <env> <slot> <value>)
-; For slots that do contain code pointers:
-;  ($MAKE-PROCEDURE <cont> <env> <slot>)
-;  ($SET-CODE       <cont> <env> <slot> <value>)
-; For known calls to slots that contain code pointers:
-;  ($ENV-ADJUST     <cont> <env> <slot>)
-;                     0      1      2
-
-(define env/owner    0)
-(define env/offset   1)
-(define env/value    2)
-
diff --git a/ps-compiler/node/vector.scm b/ps-compiler/node/vector.scm
deleted file mode 100644
index 16ac9eb..0000000
--- a/ps-compiler/node/vector.scm
+++ /dev/null
@@ -1,212 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-
-;----------------------------------------------------------------------------
-; STORING NODE TREES IN VECTORS
-;----------------------------------------------------------------------------
-
-; The use of OTHER and GLOBAL depends on whether NODE->VECTOR or VECTOR->NODE
-
-(define-record-type vec
- (vector    ; an expanding vector (NODE->VECTOR) or just a vector (VECTOR->NODE)
-  (index)   ; the index of the next empty slot or the next thing to read
-  locals    ; vector of local variables (VECTOR->NODE only)
-  )
- ())
-
-(define make-vec vec-maker)
-
-; Add value as the next thing in the VEC.
-
-(define (add-datum vec value)
-  (xvector-set! (vec-vector vec) (vec-index vec) value)
-  (set-vec-index! vec (+ 1 (vec-index vec))))
-
-;   Convert a node into a vector
-;
-; literal       => QUOTE <literal> <rep>
-; reference     => <index of the variable's name in vector> if lexical, or
-;                  GLOBAL <variable> if it isn't
-; lambda        => LAMBDA <stuff> #vars <variable names+reps> <call>
-; call          => CALL <source> <primop> <exits> <number of args> <args>
-
-; Preserve the node as a vector.
-
-(define (node->vector node)
-  (let ((vec (make-vec (make-xvector #f) 0 #f)))
-    (real-node->vector node vec)
-    (xvector->vector (vec-vector vec))))
-  
-; The main dispatch
-
-(define (real-node->vector node vec)
-  (case (node-variant node)
-    ((literal)
-     (literal->vector node vec))
-    ((reference)
-     (reference->vector node vec))
-    ((lambda)
-     (lambda->vector node vec))
-    ((call)
-     (add-datum vec 'call)
-     (call->vector node vec))
-    (else
-     (bug "node->vector got funny node ~S" node))))
-
-; VARIABLE-FLAGs are used to mark variables with their position in the
-; vector.
-
-(define (lambda->vector node vec)
-  (add-datum vec 'lambda)
-  (add-datum vec (lambda-name node))
-  (add-datum vec (lambda-type node))
-  (add-datum vec (lambda-protocol node))
-  (add-datum vec (lambda-source node))
-  (add-datum vec (lambda-variable-count node))
-  (for-each (lambda (var)
-	      (cond ((not var)
-		     (add-datum vec #f))
-		    (else
-		     (set-variable-flag! var (vec-index vec))
-		     (add-datum vec (variable-name var))
-		     (add-datum vec (variable-type var)))))
-	    (lambda-variables node))
-  (call->vector (lambda-body node) vec)
-  (for-each (lambda (var)
-	      (if var
-		  (set-variable-flag! var #f)))
-	    (lambda-variables node)))
-
-; If VAR is bound locally, then put the index of the variable within the vector
-; into the vector.
-
-(define (reference->vector node vec)
-  (let ((var (reference-variable node)))
-    (cond ((not (variable-binder var))
-           (add-datum vec 'global)
-           (add-datum vec var))
-          ((integer? (variable-flag var))
-           (add-datum vec (variable-flag var)))
-          (else
-           (bug "variable ~S has no vector location" var)))))
-
-(define (literal->vector node vec)
-  (let ((value (literal-value node)))
-    (add-datum vec 'quote)
-    (add-datum vec (literal-value node))
-    (add-datum vec (literal-type node))))
-
-; This counts down so that the continuation will be done after the arguments.
-; Why does this matter?
-
-(define (call->vector node vec)
-  (let* ((args (call-args node))
-         (len (vector-length args)))
-    (add-datum vec (call-source node))
-    (add-datum vec (call-primop node))
-    (add-datum vec (call-exits node))
-    (add-datum vec len)
-    (do ((i (- len 1) (- i 1)))
-        ((< i 0))
-      (real-node->vector (vector-ref args i) vec))))
-
-;----------------------------------------------------------------------------
-; TURNING VECTORS BACK INTO NODES
-;----------------------------------------------------------------------------
-
-(define (vector->node vector)
-  (if (not (vector? vector))
-      (bug "VECTOR->NODE got funny value ~S~%" vector)
-      (let ((vec (make-vec vector -1 (make-vector (vector-length vector)))))
-	(real-vector->node vec))))
-
-(define (vector->leaf-node vector)
-  (case (vector-ref vector 0)
-    ((quote global)
-     (vector->node vector))
-    (else #f)))
-
-; Pop the next thing off of the vector (which is really a (<vector> . <index>)
-; pair).
-
-(define (get-datum vec)
-  (let ((i (+ (vec-index vec) 1)))
-    (set-vec-index! vec i)
-    (vector-ref (vec-vector vec) i)))
-
-; This prevents the (unecessary) resimplification of recreated nodes.
-
-(define (real-vector->node vec)
-  (let ((node (totally-real-vector->node vec)))
-    (set-node-simplified?! node #t)
-    node))
-
-; Dispatch on the next thing in VEC.
-
-(define (totally-real-vector->node vec)
-  (let ((exp (get-datum vec)))
-    (cond ((integer? exp)
-           (make-reference-node (vector-ref (vec-locals vec) exp)))
-          (else
-           (case exp
-             ((lambda)
-              (vector->lambda-node vec))
-             ((quote)
-              (let* ((value (get-datum vec))
-                     (rep   (get-datum vec)))
-                (make-literal-node value rep)))
-             ((global)
-	      (make-reference-node (get-datum vec)))
-	     ((call)
-	      (vector->call-node vec))
-	     ((import)  ; global variable from a separate compilation
-	      (make-reference-node (lookup-imported-variable (get-datum vec))))
-             (else
-              (no-op
-               (bug '"real-vector->node got an unknown code ~S" exp))))))))
-
-(define (vector->lambda-node vec)
-  (let* ((name     (get-datum vec))
-         (type     (get-datum vec))
-	 (protocol (get-datum vec))
-	 (source   (get-datum vec))
-         (count    (get-datum vec))
-         (vars (do ((i 0 (+ i 1))
-                    (v '() (cons (vector->variable vec) v)))
-                   ((>= i count) v)))
-         (node (make-lambda-node name type (reverse! vars))))
-    (set-lambda-protocol! node protocol)
-    (set-lambda-source! node source)
-    (attach-body node (vector->call-node vec))
-    (set-node-simplified?! (lambda-body node) #t)
-    node))
-
-; Replace a variable name with a new variable.
-
-(define (vector->variable vec)
-  (let ((name (get-datum vec)))
-    (if name
-        (let ((var (make-variable name (get-datum vec))))
-          (vector-set! (vec-locals vec) (+ -1 (vec-index vec)) var)
-          var)
-        #f)))
-
-(define (vector->call-node vec)
-  (let* ((source (get-datum vec))
-	 (primop (let ((p (get-datum vec)))
-		   (if (primop? p)
-		       p
-		       (lookup-primop p))))
-	 (exits  (get-datum vec))
-         (count  (get-datum vec))
-         (node (make-call-node primop count exits)))
-    (do ((i (- count 1) (- i 1)))
-        ((< i 0))
-      (attach node i (real-vector->node vec)))
-    (set-call-source! node source)
-    node))
-
-
-
-
-
diff --git a/ps-compiler/package-defs.scm b/ps-compiler/package-defs.scm
deleted file mode 100644
index 306dcc1..0000000
--- a/ps-compiler/package-defs.scm
+++ /dev/null
@@ -1,235 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-
-; The intermediate language (node tree)
-; The structures VARIABLE and PRIMOP are contained in NODE.  They are used
-; in client language code where the NODE- names conflict.
-
-(define-structures ((node     node-interface)
-		    (variable variable-interface)
-		    (primop   primop-interface))
-  (open scheme big-scheme comp-util arch parameters
-	defrecord)
-  (for-syntax (open scheme big-scheme let-nodes))
-  (begin 
-    (define-syntax let-nodes
-      (lambda (form rename compare)
-	(expand-let-nodes form rename compare))))
-  (files (node node)         ; variable and node data structures
-	 (node primop)       ; primop data structure
-	 (node node-util)    ; various small utilities
-	 (node node-equal))) ; node equality
-
-;(define node
-;  (let ()
-;    (define-structure let-nodes (export expand-let-nodes)
-;      (open scheme big-scheme arch)
-;      (files (node let-nodes)))
-;    (define-structures ((node     node-interface)
-;                        (variable variable-interface)
-;                        (primop   primop-interface))
-;      (open scheme big-scheme comp-util arch parameters)
-;      (for-syntax (open scheme big-scheme let-nodes))
-;      (begin 
-;        (define-syntax let-nodes
-;          (lambda (form rename compare)
-;            (expand-let-nodes form rename compare))))
-;      (files (node node)         ; variable and node data structures
-;             (node primop)       ; primop data structure
-;             (node node-util)    ; various small utilities
-;             (node node-equal)   ; node equality
-;             (node leftovers)))  ; more node utilities
-;    node))
-
-; Pretty printer
-
-(define-structure pp-cps (export pp-cps)
-  (open scheme big-scheme comp-util node structure-refs)
-  (access i/o)  ; force-output
-  (files (node pp-cps)))
-
-; Expander for LET-NODES, a macro for creating interconnected nodes.
-	 
-(define-structure let-nodes (export expand-let-nodes)
-  (open scheme big-scheme arch)
-  (files (node let-nodes)))
-
-; Compiler Parameters
-; This allows client languages to supply parameters to the compiler
-; without introducing circular module dependencies.
-
-(define-structures ((parameters parameter-interface)
-		    (set-parameters (export set-compiler-parameter!)))
-  (open scheme big-scheme)
-  (files param))
-
-; An enumerated type defining the standard primops.
-
-(define-structure arch (export (primop :syntax) primop-count)
-  (open scheme enumerated)
-  (files (node arch)))
-
-; linearizing node trees for later reuse
-
-(define-structure node-vector (export node->vector
-				      vector->node
-				      vector->leaf-node)
-  (open scheme big-scheme comp-util node parameters
-	defrecord)
-  (files (node vector)))
-
-; Translating the input forms into simplified node trees
-
-(define-structures ((front       front-interface)
-		    (front-debug front-debug-interface))
-  (open scheme big-scheme comp-util node simplify parameters jump
-	remove-cells flow-values)
-  (files (front top)))       ; main entry points and debugging utilities
-
-(define-structure cps-util (export cps-call cps-sequence)
-  (open scheme big-scheme comp-util node
-	define-record-types)
-  (files (front cps)))
-
-; Converting tail-recursive calls to jumps
-
-(define-structure jump (export integrate-jump-procs!
-			       find-jump-procs
-			       procs->jumps)
-  (open scheme big-scheme comp-util node parameters ssa
-	define-record-types)
-  (files (front jump)))
-
-; Program simplification and partial evaluation
-
-(define-structures ((simplify (export simplify-node))
-		    (simplify-internal simplify-internal-interface))
-  (open scheme big-scheme comp-util node parameters node-vector)
-  (for-syntax (open scheme big-scheme simp-patterns))
-  (begin
-    (define-syntax pattern-simplifier
-      (lambda (form rename compare)
-	(make-pattern-simplifier (cdr form))))) ; from SIMP-PATTERNS
-  (files (simp simplify)  ; main entry point and driver
-	 (simp call)))    ; simplifiers for some of the standard primops
-
-; Simplifying calls to lambda nodes
-
-(define-structure simplify-let (export simplify-let)
-  (open scheme big-scheme comp-util node parameters
-	simplify-join simplify-internal)
-  (files (simp let)))
-
-; Substituting lambda nodes that are bound by calls to lambda nodes,
-; trying to maximize the further simplification opportunites while
-; minimizing code expansion.
-
-(define-structure simplify-join (export substitute-join-arguments)
-  (open scheme big-scheme comp-util node)
-  (files (simp join)))
-
-; The expander for PATTERN-SIMPLIFIER, a macro for writing algebraic
-; transformations.
-
-(define-structure simp-patterns (export make-pattern-simplifier)
-  (open scheme big-scheme defrecord)
-  (files (simp pattern)))
-
-; Replacing cells with values passed as parameters, currently empty
-; and unused (the code has not been made compatible with the current
-; version of the compiler).
-
-(define-structure remove-cells (export remove-cells-from-tree)
-  (open scheme big-scheme)
-  (begin
-    (define (remove-cells-from-tree . stuff)
-      (error "REMOVE-CELLS-FROM-TREE is undefined"))))
-
-; Flow analysis, also currently empty and unused for the same reason.
-
-(define-structure flow-values (export flow-values)
-  (open scheme big-scheme)
-  (begin
-    (define (flow-values . stuff)
-      (error "FLOW-VALUES is undefined"))))
-
-; A random collection of utilities.
-
-(define-structure comp-util utilities-interface
-  (open scheme big-scheme structure-refs expanding-vectors)
-  (for-syntax (open scheme big-scheme))
-  (access primitives features)
-  (files (util syntax)        ; macro for defining subrecords
-	 (util util)))        ; random utilities
-
-(define-structure expanding-vectors (export make-xvector
-					    xvector-length
-					    xvector-ref
-					    xvector-set!
-					    xvector-length
-					    xvector->vector)
-  (open scheme define-record-types)
-  (files (util expand-vec)))
-
-(define-interface transitive-interface
-  (export make-graph-from-predecessors
-	  make-graph-from-successors
-	  transitive-or! transitive-or-with-kill! transitive-or-with-pass!
-	  transitive-and! transitive-and-with-kill! transitive-and-with-pass!))
-
-(define-structure transitive transitive-interface
-  (open scheme big-scheme integer-sets defrecord)
-  (optimize auto-integrate)
-  (files (util transitive)))
-
-(define-interface integer-set-interface
-  (export make-empty-integer-set
-	  add-to-integer-set
-	  integer-set-not
-	  integer-set-ior
-	  integer-set-and
-	  integer-set-subtract
-	  integer-set-equal?
-	  map-over-integer-set))
-
-(define-structure integer-sets integer-set-interface
-  (open scheme bitwise bigbit)
-  (optimize auto-integrate)
-  (files (util z-set)))
-
-(define-structure strongly-connected (export strongly-connected-components)
-  (open scheme big-scheme defrecord)
-  (optimize auto-integrate)
-  (files (util strong)))
-
-(define-structure dominators (export find-dominators!)
-  (open scheme big-scheme comp-util
-	define-record-types)
-  (optimize auto-integrate)
-  (files (util dominators)))
-
-(define-structure ssa (export graph->ssa-graph! find-joins)
-  (open scheme big-scheme dominators
-	define-record-types)
-  (optimize auto-integrate)
-  (files (util ssa)))
-
-; Vectors of bytes, a renaming of Scheme 48's code vectors.
-
-(define-structure byte-vectors compiler-byte-vector-interface
-  (open scheme code-vectors bitwise signals)
-  (optimize auto-integrate)
-  (files (util byte-vector)))
-
-; A version of READ that annotates pairs with source file, line, and
-; column information.
-
-(define-structure annotated-read annotated-read-interface
-  ; this is correct for linking, but doesn't work when loading
-  ;(open defrecord extended-ports primitives scheme assembler)
-  (open scheme big-scheme primitives fluids assembler)
-  (files (prescheme track-read)))
-
-
-
-
diff --git a/ps-compiler/param.scm b/ps-compiler/param.scm
deleted file mode 100644
index 49ecad6..0000000
--- a/ps-compiler/param.scm
+++ /dev/null
@@ -1,42 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-
-; Parameterizing the compiler.
-
-(define lookup-primop 'unset-compiler-parameter)
-(define lookup-imported-variable 'unset-compiler-parameter)
-	  
-(define type/unknown 'unset-compiler-parameter)
-(define type-eq? 'unset-compiler-parameter)
-
-(define lambda-node-type 'unset-compiler-parameter)
-
-(define true-value  'unset-compiler-parameter)
-(define false-value 'unset-compiler-parameter)
-
-(define determine-lambda-protocol       'unset-compiler-parameter)
-(define determine-continuation-protocol 'unset-compiler-parameter)
-
-(define (set-compiler-parameter! name value)
-  (case name
-    ((lookup-primop)
-     (set! lookup-primop value))
-    ((lookup-imported-variable)
-     (set! lookup-imported-variable value))
-    ((type/unknown)
-     (set! type/unknown value))
-    ((type-eq?)
-     (set! type-eq? value))
-    ((lambda-node-type)
-     (set! lambda-node-type value))
-    ((true-value)
-     (set! true-value value))
-    ((false-value)
-     (set! false-value value))
-    ((determine-lambda-protocol)
-     (set! determine-lambda-protocol value))
-    ((determine-continuation-protocol)
-     (set! determine-continuation-protocol value))
-    (else
-     (error "unknown compiler parameter ~S ~S" name value))))
-
diff --git a/ps-compiler/prescheme/c-call.scm b/ps-compiler/prescheme/c-call.scm
deleted file mode 100644
index 3ea44ac..0000000
--- a/ps-compiler/prescheme/c-call.scm
+++ /dev/null
@@ -1,353 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-; Generating C code for a call
-
-(define (call->c node port indent)
-  (let loop ((node node))
-    (if (primop-call->c node port indent)
-	(loop (lambda-body (call-arg node 0))))))
-
-(define (primop-call->c node port indent)
-  (let ((primop (call-primop node)))
-    (if (and (simple-c-primop? primop)
-	     (= 0 (call-exits node)))
-	(generate-simple-assignment primop node port indent)
-	(primop-generate-c primop node port indent))
-    (and (= 1 (call-exits node))
-	 (not (goto-call? node)))))
-
-(define (c-value node port)
-  (cond ((string? node)
-	 (display node port))
-	((not (node? node))
-	 (display node port))
-	((reference-node? node)
-	 (c-variable (reference-variable node) port))
-	((literal-node? node)
-	 (c-literal-value (literal-value node) (literal-type node) port))
-	((call-node? node)        ; must be simple
-	 (let ((parens? (call-needs-parens? node)))
-	   (if parens? (write-char #\( port))
-	   (primop-generate-c (call-primop node) node port 0)
-	   (if parens? (write-char #\) port))))
-	(else
-	 (bug "odd node in C-VALUE ~S" node))))
-
-(define (c-literal-value value type port)
-  (let ((value (cond ((integer? value) value)
-		     ((eq? value #f) 0)
-		     ((eq? value #t) 1)
-		     ((string? value) value)
-		     ((external-value? value) value)
-		     ((external-constant? value) value)
-		     ((char? value) (char->ascii value))
-		     (else
-		      (error "cannot translate literal to C ~A" value)))))
-    (cond ((integer? value)
-	   (format port "~D" value))
-	  ((string? value)
-	   (c-string-constant value port))
-	  ((external-value? value)
-	   (display (external-value-string value) port))
-	  ((external-constant? value)
-	   (display (external-constant-c-string value) port))
-	  (else
-	   (display value port)))))
-
-(define (c-string-constant string port)
-  (write-char #\" port)
-  (do ((i 0 (+ i 1)))
-      ((= i (string-length string)))
-    (let ((char (string-ref string i)))
-      (case char
-	((#\newline)
-	 (write-char #\\ port)
-	 (write-char #\n port))
-	((#\")
-	 (write-char #\\ port)
-	 (write-char #\" port))
-	((#\\)
-	 (write-char #\\ port)
-	 (write-char #\\ port))
-	(else
-	 (write-char char port)))))
-  (write-char #\" port))
-
-;	(case (base-type-size (maybe-follow-uvar type))
-;	  ((1)
-;	   (let ((new-value (if (>= value 0)
-;				(bitwise-and value 255)
-;				(error "can't translate negative character constants to C ~S"
-;				       value))))
-;	     (format port "'\\~D~D~D'"
-;		     (remainder (quotient new-value 64) 8)
-;		     (remainder (quotient new-value 8) 8)
-;		     (remainder new-value 8))))
-;	  ((2)
-;	   (format port "~D" value))
-;	  ((4)
-;	   (format port "~DL" value))
-;	  (else
-;	   (error "cannot translate literal type to C ~S" type)))
-
-; Cut down on the number of unnecessary parentheses.  We don't go so far as
-; to pay attention to C's precedence rules.
-
-(define (call-needs-parens? call)
-  (and (not (and (eq? 'contents (primop-id (call-primop call)))
-		 (eq? 'global (literal-value (call-arg call loc/type)))))
-       (let ((parent (node-parent call)))
-	 (and (node? parent)
-	      (call-node? parent)
-	      (not (eq? 'let
-			(primop-id (call-primop parent))))))))
-
-; Each local variable has a unique integer used to disambiguate in the
-; C code.  Using our own, instead of what variables already have, keeps
-; the numbers smaller and more readable.
-
-(define *c-variable-id* '0)
-
-(define (next-c-variable-id)
-  (let ((id *c-variable-id*))
-    (set! *c-variable-id* (+ *c-variable-id* 1))
-    id))
-
-(define (c-variable-id var)
-  (if (integer? (variable-generate var))
-      (variable-generate var)
-      (let ((id (next-c-variable-id)))
-	(set! *local-vars* (cons var *local-vars*))
-	(set-variable-generate! var id)
-	id)))
-
-(define (c-variable var port)
-  (really-c-variable var port #t))
-
-(define (c-variable-no-shadowing var port)
-  (really-c-variable var port #f))
-
-(define (really-c-variable var port shadow?)
-  (cond ((string? var)
-	 (display var port))
-	((symbol? var)
-	 (display var port))
-	((not (variable? var))
-	 (bug "funny value for C-VARIABLE ~S" var))
-	((not (variable-binder var))
-	 (cond ((and shadow?
-		     (memq? 'shadowed (variable-flags var)))
-		(writec port '#\R))
-	       ((generated-top-variable? var)
-		(writec port '#\H)))
-	 (write-c-identifier (variable-name var) port)
-	 (if (generated-top-variable? var)
-	     (display (c-variable-id var) port)))
-	(else
-	 ;		  (if (= (c-variable-id var) 944)
-	 ;		      (breakpoint "writing 944"))
-	 (write-c-identifier (variable-name var) port)
-	 (write-char '#\_ port)
-	 (display (c-variable-id var) port)
-	 (write-char '#\X port))))
-
-;==============================================================================;
-; Scheme identifiers contain many characters that are not legal in C
-; identifiers.  Luckily C is case-sensitive and Scheme is not.
-
-(define char-translations
-  (let* ((count number-of-char-codes)
-         (string (make-string count)))
-    (do ((i '0 (+ i '1)))
-        ((>= i count))
-      (let ((char (ascii->char i)))
-        (string-set! string i
-		     (cond ((and (char-alphabetic? char)
-				 (char=? char
-					 (string-ref (symbol->string
-						      (string->symbol
-						       (list->string
-							(list char))))
-						     0)))
-			    (char-downcase char))
-			   ((char-numeric? char)
-			    char)
-			   (else
-			    (ascii->char 0))))))
-    (string-set! string (char->ascii '#\+) '#\A)
-    (string-set! string (char->ascii '#\!) '#\B)
-    (string-set! string (char->ascii '#\:) '#\C)
-    (string-set! string (char->ascii '#\.) '#\D)
-    (string-set! string (char->ascii '#\=) '#\E)
-    (string-set! string (char->ascii '#\>) '#\G)
-    ; used for flattened closures             H
-    ; precedes C keywords                     K
-    (string-set! string (char->ascii '#\<) '#\L)
-    (string-set! string (char->ascii '#\?) '#\P)
-    (string-set! string (char->ascii '#\%) '#\Q)
-    (string-set! string (char->ascii '#\*) '#\S)
-    ; used for tail-recursive procedures      T
-    (string-set! string (char->ascii '#\/) '#\U)
-    (string-set! string (char->ascii '#\#) '#\W)
-    ; follows lexical identifiers             X
-    ; used by the multi-procedure block code  Z
-    (string-set! string (char->ascii '#\-) '#\_)
-    string))
-
-; This needs to check for C keywords (just precede with K)
-
-(define (write-c-identifier symbol port)
-  (if (table-ref c-keywords symbol)
-      (writec port '#\K))
-  (let ((string (symbol->string symbol)))
-    (do ((i 0 (+ i 1)))
-	((>= i (string-length string)))
-      (let* ((char (string-ref string i))
-	     (out (string-ref char-translations (char->ascii char))))
-	(if (= 0 (char->ascii out))
-	    (bug "cannot translate ~S from ~A into C" char string)
-	    (writec port out))))
-    (values)))
-
-(define (c-ify symbol)
-  (call-with-string-output-port
-    (lambda (port)
-      (write-c-identifier symbol port))))
-
-(define c-keywords (make-table))
-
-(for-each (lambda (k)
-	    (table-set! c-keywords k #t))
-	  '(
-	    auto     double int      struct
-	    break    else   long     switch
-	    case     enum   register typedef
-	    char     extern return   union
-	    const    float  short    unsigned
-	    continue for    signed   void
-	    default  goto   sizeof   volatile
-	    do       if     static   while
-	    ))
-
-;==============================================================================;
-
-(define (simple-c-primop op call port)
-  (case (call-arg-count call)
-    ((1)
-     (generate-simple-c-monop-call op (call-arg call 0) port))
-    ((2)
-     (destructure ((#(arg1 arg2) (call-args call)))
-       (generate-simple-c-binop-call op arg1 arg2 port)))
-    (else
-     (bug "funny call to SIMPLE-C-PRIMOP ~S" call))))
-
-(define (generate-simple-c-binop-call op arg1 arg2 port)
-  (c-value arg1 port)
-  (writec port '#\space)
-  (display op port)
-  (writec port '#\space)
-  (c-value arg2 port)
-  (values))
-
-(define (generate-simple-c-monop-call op arg1 port)
-  (display op port)
-  (writec port '#\space)
-  (c-value arg1 port)
-  (values))
-
-(define (generate-simple-assignment primop call port indent)
-  (let ((var (car (lambda-variables (call-arg call 0)))))
-    (c-assign-to-variable var port indent)
-    (primop-generate-c primop call port #f)
-    (writec port '#\;)
-    (values)))
-
-(define (c-assignment var value port indent)
-  (c-assign-to-variable var port indent)
-  (c-value value port)
-  (writec port '#\;))
-
-(define (c-assign-to-variable var port indent)
-  (indent-to port indent)
-  (cond ((or (not (variable? var))
-	     (and (or (used? var)
-		      (global-variable? var))
-		  (not (eq? type/unit (final-variable-type var)))))
-	 (c-variable var port)
-	 (display " = " port))))
-
-;==============================================================================;
-
-(define (known-variable-reference node)
-  (cond ((reference-node? node)
-	 (let ((var (reference-variable node)))
-	   (if (global-variable? var) var #f)))
-	(else #f)))
-
-(define (write-value-list args start port)
-  (writec port '#\()
-  (really-write-value-list args start '() port)
-  (writec port '#\)))
-
-(define (write-value-list-with-extras args start extras port)
-  (writec port '#\()
-  (really-write-value-list args start extras port)
-  (writec port '#\)))
-
-(define (really-write-value-list args start extras port)
-  (let ((len (vector-length args)))
-    (cond ((> len start)
-           (c-value (vector-ref args start) port)
-           (do ((i (+ start '1) (+ i '1)))
-               ((>= i len) (values))
-             (writec port '#\,)
-             (writec port '#\space)
-	     (c-value (vector-ref args i) port))
-	   (write-comma-value-list extras port))
-	  ((not (null? extras))
-	   (c-value (car extras) port)
-	   (write-comma-value-list (cdr extras) port)))))
-	   
-(define (write-comma-value-list args port)
-  (for-each (lambda (arg)
-	      (writec port '#\,)
-	      (writec port '#\space)
-	      (c-value arg port))
-	    args))
-
-(define (write-value+result-var-list args start vars port)
-  (writec port '#\()
-  (really-write-value-list args start '() port)
-  (cond ((not (null? vars))
-	 (if (> (vector-length args) start)
-	     (display ", " port))
-	 (writec port #\&)
-	 (c-variable (car vars) port)
-	 (for-each (lambda (var)
-		     (display ", &" port)
-		     (c-variable var port))
-		   (cdr vars))))
-  (writec port #\)))
-
-(define (c-system-call proc args port)
-  (display proc port)
-  (writec port '#\()
-  (if (not (null? args))
-      (let loop ((args args))
-        (c-value (car args) port)
-        (cond ((not (null? (cdr args)))
-               (writec port '#\,)
-               (writec port '#\space)
-               (loop (cdr args))))))
-  (writec port '#\))
-  (values))
-
-(define (indent-to port indent)
-  (if (> (current-column port) indent)
-      (newline port))
-  (do ((c (current-column port) (+ c 1)))
-      ((>= c indent))
-    (write-char #\space port)))
-
-
diff --git a/ps-compiler/prescheme/c-decl.scm b/ps-compiler/prescheme/c-decl.scm
deleted file mode 100644
index 3e13285..0000000
--- a/ps-compiler/prescheme/c-decl.scm
+++ /dev/null
@@ -1,385 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-; C variable declarations.
-; 
-; (write-function-prototypes forms port)
-;
-; (write-variable-declarations vars port indent)
-
-; Writing declarations.
-
-(define (write-function-prototypes forms port)
-  (for-each (lambda (f)
-	      (if (eq? (form-type f) 'lambda)
-		  (if (form-tail-called? f)
-		      (write-function-tail-prototype (form-c-name f)
-						     (form-exported? f)
-						     port)
-		      (write-function-prototype (form-var f)
-						(form-c-name f)
-						(form-exported? f)
-						port))))
-	    forms))
-
-(define (write-function-tail-prototype name exported? port)
-  (if (not exported?)
-      (display "static " port))
-  (display "long T" port)
-  (display name port)
-  (display "(void);" port)
-  (newline port))
-
-(define (write-function-prototype var name exported? port)
-  (if (not exported?)
-      (display "static " port))
-  (receive (result args)
-      (parse-arrow-type (final-variable-type var))
-    (display-c-type result
-		    (lambda (port)
-		      (display name port))
-		    port)
-    (write-char #\( port)
-    (if (null? args)
-	(display "void" port)
-	(begin
-	  (display-c-type (car args) #f port)
-	  (let loop ((args (cdr args)))
-	    (if (not (null? args))
-		(begin
-		  (display ", " port)
-		  (display-c-type (car args) #f port)
-		  (loop (cdr args)))))))
-    (display ");" port)
-    (newline port)))
-
-; Write declarations for global variables.
-
-(define (write-global-variable-declarations forms port)
-  (for-each (lambda (form)
-	      (if (memq (form-type form)
-			'(stob initialize alias))
-		  (let* ((var (form-var form))
-			 (type (final-variable-type var)))
-		    (if (not (or (eq? type type/unit)
-				 (eq? type type/null)))
-			(really-write-variable-declaration
-			   var type (form-exported? form) port 0)))))
-	    forms))
-
-; Write general variable declarations.
-
-(define (write-variable-declarations vars port indent)
-  (for-each (lambda (var)
-	      (let ((type (final-variable-type var)))
-		(if (not (or (eq? type type/unit)
-			     (eq? type type/null)))
-		    (really-write-variable-declaration var type #t port indent))))
-	    vars))
-
-(define (really-write-variable-declaration var type exported? port indent)
-  (indent-to port indent)
-  (if (not exported?)
-      (display "static " port))
-  (display-c-type type
-		  (lambda (port)
-		    (c-variable-no-shadowing var port))
-		  port)
-  (writec port #\;))
-
-;----------------------------------------------------------------
-; Writing C types
-
-(define (display-c-type type name port)
-  (display-c-base-type (type->c-base-type type) port)
-  (if name (display " " port))
-  (display-c-type-modifiers type name port))
-
-(define (write-c-coercion type out)
-  (write-char #\( out)
-  (display-c-type type #f out)
-  (write-char #\) out))
-  
-; Searches through the type modifiers until the base type is found.
-; Unspecified result types are assumed to be `void'.
-
-(define (type->c-base-type type)
-  (let ((type (maybe-follow-uvar type)))
-    (cond ((or (base-type? type)
-	       (record-type? type))
-	   type)
-	  ((pointer-type? type)
-	   (type->c-base-type (pointer-type-to type)))
-	  ((arrow-type? type)
-	   (let ((res (arrow-type-result type)))
- 	     (cond ((and (uvar? res)
- 			 (not (uvar-binding res)))
- 		    type/unit)
- 	           ((not (tuple-type? res))
-		    (type->c-base-type res))
-		   ((null? (tuple-type-types res))
-		    type/unit)
-		   (else
-		    (type->c-base-type (car (tuple-type-types res)))))))
-	  (else
-	   (bug "don't know how to write ~S as a C type" type)))))
-
-; Table of C names for base types.
-
-(define c-decl-table (make-integer-table))
-
-(define (add-c-type-declaration! type decl)
-  (table-set! c-decl-table (base-type-uid type) decl))
-
-(for-each (lambda (p)
-	    (let ((type (lookup-type (car p))))
-	      (add-c-type-declaration! type (cadr p))))
-	  '((boolean "char")
-	    (char    "char")
-	    (integer "long")
-	    (address "char *")
-	    (input-port "FILE *")
-	    (output-port "FILE *")
-	    (unit    "void")
-	    (null    "void")))
-
-(define (display-c-base-type type port)
-  (cond ((record-type? type)
-	 (display "struct " port)
-	 (write-c-identifier (record-type-name type) port))
-	(else
-	 (display (or (table-ref c-decl-table (base-type-uid type))
-		      (bug "no C declaration for ~S" type))
-		  port))))
-
-; Writes out the modifiers of TYPE with NAME used when the base type is reached.
-
-(define (display-c-type-modifiers type name port)
-  (let label ((type type) (name name))
-    (let ((type (maybe-follow-uvar type)))
-      (cond ((or (base-type? type)
-		 (record-type? type))
-	     (if name (name port)))
-	    ((pointer-type? type)
-	     (label (pointer-type-to type)
-		    (lambda (port)
-		      (format port "*")
-		      (if name (name port)))))
-	    ((arrow-type? type)
-	     (format port "(*")
-	     (receive (return-type args)
-		 (parse-arrow-type type)
-	       (label return-type name)
-	       (format port ")(")
-	       (cond ((null? args)
-		      (display "void" port))
-		     (else
-		      (display-c-type (car args) #f port)
-		      (do ((args (cdr args) (cdr args)))
-			  ((null? args))
-			(display ", " port)
-			(display-c-type (car args) #f port))))
-	       (format port ")")))
-	    (else
-	     (bug "don't know how to write ~S as a C type" type))))))
-
-(define (parse-arrow-type type)
-  (receive (first rest)
-      (parse-return-type (arrow-type-result type))
-    (values first
-	    (append (arrow-type-args type)
-		    (map make-pointer-type rest)))))
-
-(define (parse-return-type type)
-  (cond ((not (tuple-type? type))
-	 (values (if (and (uvar? type)
- 			  (not (uvar-binding type)))
- 		     type/unit
- 		     type)
- 		 '()))
-	((null? (tuple-type-types type))
-	 (values type/unit '()))
-	(else
-	 (values (car (tuple-type-types type))
-		 (cdr (tuple-type-types type))))))
-
-;------------------------------------------------------------
-; Collecting local variables.  Each is added to this list when it is first
-; used.
-
-(define *local-vars* '())
-
-(define (declare-local-variables port)
-  (write-variable-declarations *local-vars* port 2))
-
-; Some primops must be given continuations so that calls to them will
-; be translated into separate C statements and so expand into arbitrarily
-; complex chunks of C if necessary.
-
-(define (fixup-nasty-c-primops! call)
-  (let ((top call))
-    (let label ((call call))
-      (cond ((call-node? call)
-	     (if (and (= 0 (call-exits call))
-		      (nasty-c-primop-call? call))
-		 (set! top (expand-nasty-c-primop! call top)))
-	     (walk-vector label (call-args call)))))
-    (do ((i 0 (+ i 1)))
-	((= i (call-arg-count top)))
-      (let ((arg (call-arg top i)))
-	(if (lambda-node? arg)
-	    (fixup-nasty-c-primops! (lambda-body arg)))))))
-
-(define (nasty-c-primop-call? call)
-  (case (primop-id (call-primop call))
-    ((lshl ashl ashr)     ; C does poorly when shifting by large amounts
-     (not (literal-node? (call-arg call 1))))
-    (else #f)))
-
-; Give CALL a continuation and move it above TOP, replacing CALL
-; with the continuation's variable.
-;
-; top = (p1 ... (p2 a1 ...) ...)
-;  =>
-; (p2 (lambda (v) (p1 ... v ...)) a1 ...)
-
-(define (expand-nasty-c-primop! call top)
-  (let* ((var (make-variable 'x (node-type call)))
-	 (cont (make-lambda-node 'c 'cont (list var))))
-    (move call
-	  (lambda (call)
-	    (make-reference-node var)))
-    (insert-body call
-		 cont
-		 (node-parent top))
-    (set-call-exits! call 1)
-    (insert-call-arg call 0 cont)
-    call))
-
-;------------------------------------------------------------
-; Declare the variables used to pass arguments to procedures.
-; This is done in each procedure so that the C compiler doesn't have to contend
-; with the possibility of globally visible side-effects.
-
-(define (write-arg-variable-declarations lambdas merged port)
-  (let ((lambdas (filter (lambda (l)
-			   (eq? 'jump (lambda-type l)))
-			 lambdas))
-	(merged (map form-value merged)))
-    (really-write-arg-variable-declarations lambdas "arg" port 2)
-    (really-write-arg-variable-declarations merged "merged_arg" port 2)))
-
-(define (write-global-arg-variable-declarations forms port)
-  (let ((lambdas (filter-map (lambda (f)
-			       (if (and (form-var f)
-					(memq? 'tail-called
-					       (variable-flags (form-var f))))
-				   (form-value f)
-				   #f))
-			     forms)))
-    (really-write-arg-variable-declarations lambdas "goto_arg" port 0)))
-  
-(define (really-write-arg-variable-declarations lambdas name port indent)
-  (for-each (lambda (data)
-	      (destructure (((uid type . indicies) data))
-		(if (not (eq? type type/unit))
-		    (for-each (lambda (i)
-				(indent-to port indent)
-				(declare-arg-variable type uid i name port))
-			      indicies))))
-	    (get-variable-decl-data lambdas)))
-
-(define (get-variable-decl-data lambdas)
-  (let ((data '()))
-    (for-each (lambda (l)
-		(do ((vars (if (eq? 'jump (lambda-type l))
-			       (lambda-variables l)
-			       (cdr (lambda-variables l)))
-			   (cdr vars))
-		     (i 0 (+ i 1)))
-		    ((null? vars))
-		  (let* ((type (final-variable-type (car vars)))
-			 (uid (type->uid type))
-			 (datum (assq uid data)))
-		    (cond ((not datum)
-			   (set! data (cons (list uid type i) data)))
-			  ((not (memq i (cddr datum)))
-			   (set-cdr! (cdr datum) (cons i (cddr datum))))))))
-	      lambdas)
-    data))
-
-(define (declare-arg-variable type uid i name port)
-  (display-c-type type
-		  (lambda (port)
-		    (format port "~A~DK~D" name uid i))
-		  port)
-  (format port ";~%"))
-
-;------------------------------------------------------------
-
-(define (write-argument-initializers arg-vars port indent)
-  (really-write-argument-initializers arg-vars "arg" #f port indent))
-
-(define (write-merged-argument-initializers arg-vars port indent)
-  (really-write-argument-initializers arg-vars "merged_arg" #f port indent))
-
-(define (write-global-argument-initializers arg-vars port indent)
-  (really-write-argument-initializers arg-vars "goto_arg" #t port indent))
-
-(define (really-write-argument-initializers arg-vars name type? port indent)
-  (do ((i 0 (+ i 1))
-       (vars arg-vars (cdr vars)))
-      ((null? vars) (values))
-    (if (used? (car vars))
-	(let* ((var (car vars))
-	       (type (final-variable-type var)))
-	  (cond ((not (eq? type/unit type))
-		 (indent-to port indent)
-		 (if type?
-		     (display-c-type type
-				     (lambda (port) (c-variable var port))
-				     port)
-		     (c-variable var port))
-		 (display " = " port)
-		 (display (c-argument-var name type i port) port)
-		 (write-char '#\; port)))))))
-
-(define (c-argument-var name type i port)
-  (format #f "~A~DK~D" name (type->uid type) i))
-
-(define *type-uids* '())
-(define *next-type-uid* 0)
-
-(define (type->uid type)
-  (cond ((any (lambda (p)
-		(type-eq? type (car p)))
-	      *type-uids*)
-	 => cdr)
-	(else
-	 (let ((id *next-type-uid*))
-	   (set! *next-type-uid* (+ id 1))
-	   (set! *type-uids* (cons (cons type id) *type-uids*))
-	   id))))
-
-;----------------------------------------------------------------
-; Random utility here for historical reasons.
-
-(define (goto-call? call)
-  (and (calls-this-primop? call 'unknown-tail-call)
-       (goto-protocol? (literal-value (call-arg call 2)))))
-
-;----------------------------------------------------------------
-; random type stuff
-
-(define (reference-type node)
-  (finalize-variable-type (reference-variable node)))
-
-(define (finalize-variable-type var)
-  (let* ((type (finalize-type (variable-type var)))
-	 (type (if (uvar? type)
-		   type/null
-		   type)))
-    (set-variable-type! var type)
-    type))
-
-(define final-variable-type finalize-variable-type)
-
diff --git a/ps-compiler/prescheme/c-stuff b/ps-compiler/prescheme/c-stuff
deleted file mode 100644
index 71b83d1..0000000
--- a/ps-compiler/prescheme/c-stuff
+++ /dev/null
@@ -1,131 +0,0 @@
-Put the case defn and the system-status enumeration in a file and load
-it into the base package.
-
-Have system status be a enumeration macro that doesn't give numbers
-but instead calls to (named-c-constant "FOO") with the obvious translation.
-Need a normal enumerated definition for running with Scheme.
-Of course, if there is no overlap we can just use negative numbers for
-the error numbers visible in Pre-Scheme.
-
-  PS_READ_CHAR(port_10X, Kchar_27X, eofP_15X, status_16X)
-
-
-#define PS_PEEK_CHAR(PORT,RESULT,EOFP,STATUS)
-{
-  FILE * TTport = PORT;
-  
-  if (EOF == (RESULT = getc(TTport)))
-    RESULT = ps_read_char(TTport, &EOFP, &STATUS);
-  else {
-    EOFP = 0;
-    STATUS = 0; }
-}
-
-#define PS_GETC(PORT,RESULT)      /* RESULT = getc(PORT); */ \
-
-{                                          \
-  FILE * TTport = PORT;			   \
-  int errorp;				   \
-  while (EOF == (RESULT = getc(TTport))	   \
-	 && (errorp = ferror(TTport),	   \
-	     clearerr(TTport),		   \
-	     (errorp && errno == EINTR)))  \
-    ;					   \
-}
-
-char
-ps_read_char( FILE *filep, int *eofp )
-{
-  int value;
-
-  while (TRUE) {
-    value = getc(filep);
-    if (EOF != value) {
-      *eofp = FALSE;
-      return value; }
-    if (ferror(filep)) {
-      clearerr(filep);
-      if (errno != EINTR) {
-        ps_status_errno = errno;
-	*eofp = FALSE;
-        return 0; } }
-    else {
-      *eofp = TRUE;
-      return 0; }}
-}
- 
-/* Identical to ps_read_char except that we give the character back. */
-
-char
-ps_peek_char( FILE *filep )
-{
-  int value;
-
-  while (TRUE) {
-    value = getc(filep);
-    if (EOF != value) {
-      ungetc(value);
-      return value;
-    }
-    if (ferror(filep)) {
-      clearerr(filep);
-      if (errno != EINTR) {
-        ps_status_errno = errno;
-        return 0;
-      }
-    }
-    else {
-      ps_status_errno = EOF_ERRNO;
-      return 0;
-    }
-  }
-}
-
-void
-ps_write_char( char c; FILE *filep )
-{
-  while (TRUE) {
-    if (EOF != putc(c, filep);
-      return;
-    if (ferror(filep)) {
-      clearerr(filep);
-      if (errno != EINTR) {
-        ps_status_errno = errno;
-        return;
-      }
-    }
-    else {
-      ps_status_errno = EOF_ERRNO;
-      return;
-    }
-  }
-}
- 
- 
-; no status
-current-input-port current-output-port current-error-port
-
-; -> port status
-open-input-file open-output-file
-
-; -> status
-close-output-port close-input-port
-
-; -> value eof? status
-read-char peek-char read-integer
-
-; -> status
-write-char newline write-string write-integer force-output
-
-
-Error status:
-
-   no-errors         0
-   parse-error       EINVAL   invalid argument
-   pending-i/o       EAGAIN?  resource temporarily unavailable
-   file-not-found    ENOENT   no such
-                     EISDIR   is a directory
-   out-of-memory     ENOMEM   not enough space
-   out-of-channels   EMFILE   too many open files
-   channel-closed    EBADF    bad file descriptor
-   no-such-channel   EBADF    bad file descriptor
diff --git a/ps-compiler/prescheme/c.scm b/ps-compiler/prescheme/c.scm
deleted file mode 100644
index ed07a4a..0000000
--- a/ps-compiler/prescheme/c.scm
+++ /dev/null
@@ -1,467 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-; Translating the node tree into C
-
-(define (write-c-file init-name file header forms)
-  (set! *c-variable-id* 0)
-  (set! *type-uids* '())
-  (set! *next-type-uid* 0)
-  (let* ((real-out (open-output-file file))
-	 (out (make-tracking-output-port real-out)))
-    (merge-forms forms)
-    (check-hoisting forms)
-    (format #t "Translating~%")
-    (write-c-header header out)
-    (write-function-prototypes forms out)
-    (write-global-arg-variable-declarations forms out)
-    (write-global-variable-declarations forms out)
-    (newline out)
-    (for-each (lambda (f)
-		(case (form-type f)
-		  ((lambda)
-		   (compile-proc-to-c f out))
-		  ((alias constant integrate merged stob initialize unused)
-		   (values))
-		  (else
-		   (bug "unknown type of form ~S" f))))
-	      forms)
-    (write-c-main init-name out forms)
-    (newline out)
-    (set! *type-uids* '())
-    (close-output-port out)
-    (close-output-port real-out)))
-    
-
-(define (write-c-main init-name out forms)
-  (set! *doing-tail-called-procedure?* #f)
-  (set! *current-merged-procedure* #f)
-  (cond ((any? (lambda (f)
-		 (or (eq? (form-type f) 'initialize)
-		     (eq? (form-type f) 'stob)
-		     (eq? (form-type f) 'alias)))
-	       forms)
-	 (write-c-main-header (if init-name init-name 'main) out)
-	 (for-each (lambda (f)
-		     (case (form-type f)
-		       ((initialize alias)
-			(write-initialize (form-var f) (form-value f) out))
-		       ((stob)
-			(write-stob (form-var f)
-				    (form-value-type f)
-				    (lambda-body (form-value f))
-				    out))))
-		   forms)
-	 (write-c-main-end out))))
-
-(define (write-c-header header out)
-  (format out "#include <stdio.h>~%")
-  (format out "#include \"prescheme.h\"~%")
-  (for-each (lambda (s)
-	      (display s out)
-	      (newline out))
-	    header)
-  (for-each (lambda (rtype)
-	      (declare-record-type rtype out))
-	    (all-record-types))
-  (newline out)
-  (values))
-
-(define (declare-record-type rtype out)
-  (format out "~%struct ")
-  (write-c-identifier (record-type-name rtype) out)
-  (format out " {~%")
-  (for-each (lambda (field)
-	      (format out "  ")
-	      (display-c-type (record-field-type field)
-			      (lambda (port)
-				(write-c-identifier (record-field-name field)
-						    out))
-			      out)
-	      (format out ";~%"))
-	    (record-type-fields rtype))
-  (format out "};"))
-
-; Even when finished we need to keep the lambda around for help with
-; calls to it.
-
-(define (compile-proc-to-c form out)
-  (format #t " ~A~%" (form-c-name form))
-  (let ((name (form-c-name form)))
-    (proc->c name form (form-shadowed form) out #f)
-    (for-each make-form-unused! (form-merged form))
-    (erase (detach-body (lambda-body (form-value form))))
-    (suspend-form-use! form)))
-
-(define (form-c-name form)
-  (let* ((var (form-var form))
-	 (name (c-ify (variable-name var))))
-    (if (generated-top-variable? var)
-	(string-append "H" name (number->string (c-variable-id var)))
-	name)))
-
-(define (no-value-node? node)
-  (or (undefined-value-node? node)
-      (and (reference-node? node)
-	   (let ((type (final-variable-type (reference-variable node))))
-	     (or (eq? type type/unit)
-		 (eq? type type/null))))))
-
-;------------------------------------------------------------
-; Initialization procedure at the end of the file (often called `main').
-
-; Header for initialization code
-
-(define (write-c-main-header initname out)
-  (format out "void~%")
-  (write-c-identifier initname out)
-  (format out "(void)~%{"))
-
-; Write the end of the initialization code
-
-(define (write-c-main-end out)
-  (format out "~&}"))
-
-(define (write-initialize var value out)
-  (let ((wants (maybe-follow-uvar (variable-type var))))
-    (receive (value has)
-	(cond ((variable? value)
-	       (values value (final-variable-type value)))
-	      ((literal-node? value)
-	       (values (literal-value value) (literal-type value)))
-	      ((reference-node? value)
-	       (let ((var (reference-variable value)))
-		 (values var (final-variable-type var))))
-	      (else
-	       (error "unknown kind of initial value ~S" value)))
-      (cond ((not (unspecific? value))
-	     (c-assign-to-variable var out 0)
-	     (if (not (type-eq? wants has))
-		 (write-c-coercion wants out))
-	     (cond ((input-port? value)
-		    (display "0" out))
-		   ((output-port? value)
-		    (display "1" out))
-		   ((variable? value)
-		    (c-variable value out))
-		   (else
-		    (c-literal-value value has out)))
-	     (writec out '#\;))))))
-
-(define (write-stob var type call out)
-  (let ((value (literal-value (call-arg call 0)))
-	(wants (final-variable-type var)))
-    (c-assign-to-variable var out 0)
-    (cond ((vector? value)
-	   (if (not (type-eq? type wants))
-	       (write-c-coercion wants out))
-	   (format out "malloc(~D * sizeof(" (vector-length value))
-	   (display-c-type (pointer-type-to type) #f out)
-	   (format out "));")
-	   (do ((i 0 (+ i 1)))
-	       ((>= i (vector-length value)))
-	     (let* ((elt (call-arg call (+ i 1)))
-		    (has (finalize-type
-			  (if (reference-node? elt)
-			      (variable-type (reference-variable elt))
-			      (literal-value-type (literal-value elt))))))
-	       (newline out)
-	       (c-variable var out)
-	       (format out "[~D] = " i)
-	       (if (not (type-eq? (pointer-type-to type) has))
-		   (write-c-coercion (pointer-type-to type) out))
-	       (c-value elt out)
-	       (write-char #\; out))))
-	  (else
-	   (error "don't know how to generate stob value ~S" value)))))
-
-;------------------------------------------------------------
-; Writing out a procedure.
-
-(define (proc->c name form rename-vars port maybe-merged-count)
-  (let ((top       (form-value form))
-	(merged    (form-merged form))
-	(tail?     (form-tail-called? form))
-	(exported? (form-exported? form))
-	(lambda-kids lambda-block))        ; filled in by the hoist code
-    (let ((lambdas (filter (lambda (l)
-			     (not (proc-lambda? l)))
-			   (lambda-kids top))))
-      (if maybe-merged-count
-	  (merged-proc->c name top lambdas merged maybe-merged-count port tail?)
-	  (real-proc->c name (form-var form) top lambdas
-			merged rename-vars port tail? exported?))
-      (values))))
-
-(define (write-merged-form form port)
-  (format #t "  ~A~%" (form-c-name form))
-  (proc->c (form-c-name form)
-	   form
-	   '()
-	   port
-	   (length (variable-refs (form-var form)))))
-
-;------------------------------------------------------------
-
-; 1. write the header
-; 2. declare the local variables
-; 3. write out the body
-; 4. write out all of the label lambdas
-
-(define (real-proc->c id var top lambdas merged rename-vars port tail? exported?)
-  (let ((vars (cdr (lambda-variables top)))
-	(return-type (final-variable-type (car (lambda-variables top))))
-	(all-lambdas (append lambdas (gather-merged-lambdas merged)))
-	(merged-procs (gather-merged-procs merged)))
-    (set! *doing-tail-called-procedure?* tail?)
-    (set! *current-merged-procedure* #f)
-    (receive (first rest)
-	(parse-return-type return-type)
-      (set! *extra-tail-call-args*
-	    (do ((i (length rest) (- i 1))
-		 (args '() (cons (format #f "TT~D" (- i 1)) args)))
-		((= i 0)
-		 args))))
-    (set! *jumps-to-do* '())
-    (write-procedure-header id return-type vars port tail? exported?)
-    (write-char '#\{ port)
-    (newline port)
-    (for-each (lambda (v)
-		(set-variable-flags! v (cons 'shadowed (variable-flags v))))
-	      rename-vars)
-    (write-arg-variable-declarations all-lambdas merged port)      
-    (write-rename-variable-declarations rename-vars port)
-    (write-merged-declarations merged port)
-    (fixup-nasty-c-primops! (lambda-body top))
-    (for-each (lambda (form)
-		(write-merged-decls form port))
-	      merged)
-    (clear-lambda-generated?-flags lambdas)
-    (set! *local-vars* '())
-    (let ((body (call-with-string-output-port
-		 (lambda (temp-port)
-		   (let ((temp-port (make-tracking-output-port temp-port)))
-		     (write-c-block (lambda-body top) temp-port 2)
-		     (write-jump-lambdas temp-port 0)
-		     (for-each (lambda (f)
-				 (write-merged-form f temp-port))
-			       (reverse merged))  ; makes for more readable output
-		     (newline temp-port)
-		     (force-output temp-port))))))
-      (declare-local-variables port)
-      (if tail? 
-	  (write-global-argument-initializers (cdr (lambda-variables top))
-					      port 2))
-      (format port "~% {")
-      (display body port)
-      (write-char '#\} port))
-    (for-each (lambda (v)
-		(set-variable-flags! v (delq! 'shadowed (variable-flags v))))
-	      rename-vars)
-    (values)))
-
-; These global variables should be replaced with fluids.
-
-(define *doing-tail-called-procedure?* #f)
-(define *current-merged-procedure* #f)
-(define *extra-tail-call-args* '())
-
-(define (gather-merged-lambdas merged)
-  (let loop ((merged merged) (lambdas '()))
-    (if (null? merged)
-	lambdas
-	(loop (append (form-merged (car merged)) (cdr merged))
-	      (append (form-lambdas (car merged)) lambdas)))))
-
-(define (gather-merged-procs merged)
-  (let loop ((merged merged) (procs '()))
-    (if (null? merged)
-	procs
-	(loop (append (form-merged (car merged)) (cdr merged))
-	      (cons (form-value (car merged)) procs)))))
-
-(define (write-merged-decls form port)
-  (let ((top (form-value form))
-	(merged (form-merged form)))
-    (let ((vars (filter (lambda (var)
-			  (and (used? var)
-			       (not (eq? type/unit (final-variable-type var)))))
-			(cdr (lambda-variables top)))))
-      (write-variable-declarations vars port 2))
-    (write-merged-declarations merged port)))
-
-(define (merged-proc->c name top lambdas merged return-count port tail?)
-  (let ((vars (cdr (lambda-variables top)))
-	(body (lambda-body top)))
-    (set! *doing-tail-called-procedure?* tail?)
-    (set! *current-merged-procedure* name)
-    (write-merged-header name top port)
-    (write-char '#\{ port)
-    (clear-lambda-generated?-flags lambdas)
-    (write-c-block body port 2)
-    (write-jump-lambdas port 0)
-    (if (not tail?)
-	(write-merged-return name return-count port))
-    (for-each (lambda (f)
-		(write-merged-form f port))
-	      (reverse merged))  ; makes for more readable output
-    (write-char '#\} port)
-    (newline port)
-    (values)))
-
-(define (write-merged-header name top port)
-  (format port "~% ~A: {~%" name)
-  (if (not (null? (cdr (lambda-variables top))))
-      (write-merged-argument-initializers (cdr (lambda-variables top)) port 2)))
-
-; We use `default:' for the last tag so that the C compiler will
-; know that the code following the switch is unreachable (to avoid
-; a spurious warning if this is the end of the procedure).
-
-(define (write-merged-return name return-count port)
-  (format port "~% ~A_return:~%  switch (~A_return_tag) {~%" name name)
-  (do ((i 0 (+ i 1)))
-      ((>= i (- return-count 1)))
-    (format port "  case ~S: goto ~A_return_~S;~%" i name i))
-  (format port "  default: goto ~A_return_~S;~%" name (- return-count 1))
-  (format port "  }"))
-
-(define (write-merged-declarations forms port)
-  (for-each (lambda (f)
-	      (if (not (form-tail-called? f))
-		  (write-merged-declaration f port)))
-	    forms))
-
-(define (write-merged-declaration form port)
-  (let ((name (form-c-name form))
-	(types (lambda-return-types (form-value form))))
-    (format port "~%  int ~A_return_tag;" name)
-    (do ((i 0 (+ i 1))
-	 (types types (cdr types)))
-	((null? types))
-      (let ((type (car types)))
-	(cond ((not (or (eq? type type/unit)
-			(eq? type type/null)))
-	       (format port "~%  ")
-	       (display-c-type type
-			       (lambda (port)
-				 (format port "~A~D_return_value" name i))
-			       port)
-	       (writec port #\;)))))))
-
-(define (lambda-return-types node)
-  (let ((type (final-variable-type (car (lambda-variables node)))))
-    (if (tuple-type? type)
-	(tuple-type-types type)
-	(list type))))
-
-(define (write-procedure-header id return-type vars port tail? exported?)
-  (newline port)
-  (if (not exported?)
-      (display "static " port))
-  (receive (first rest)
-      (parse-return-type return-type)
-    (display-c-type (if tail? type/integer first)
-		    (lambda (port)
-		      (if tail? (write-char #\T port))
-		      (display id port))
-		    port)
-    (write-char '#\( port)
-    (if (not tail?)
-	(let ((args (append vars
-			    (do ((i 0 (+ i 1))
-				 (rest rest (cdr rest))
-				 (res '() (cons (cons i (car rest)) res)))
-				((null? rest)
-				 (reverse res))))))
-	  (if (null? args)
-	      (display "void" port)
-	      (write-variables args port))))
-    (write-char '#\) port)
-    (newline port)))
-
-; Write the names of VARS out to the port.  VARS may contain pairs of the
-; form (<integer> . <type>) as well as variables.
-
-(define (write-variables vars port)
-  (let ((do-one (lambda (var)
-		  (display-c-type (if (pair? var)
-				      (make-pointer-type (cdr var))
-				      (final-variable-type var))
-				  (lambda (port)
-				    (if (pair? var)
-					(format port "TT~D" (car var))
-					(c-variable var port)))
-				  port))))
-    (cond ((null? vars)
-	   (values))
-	  ((null? (cdr vars))
-	   (do-one (car vars)))
-	  (else
-	   (do-one (car vars))
-	   (do ((vars (cdr vars) (cdr vars)))
-	       ((null? vars)
-		(values))
-	     (write-char '#\, port)
-	     (write-char '#\space port)
-	     (do-one (car vars)))))))
-  
-(define (write-rename-variable-declarations vars port)
-  (for-each (lambda (var)
-	      (indent-to port 2)
-	      (display-c-type (final-variable-type var)
-			      (lambda (port)
-				(writec port #\R)
-				(write-c-identifier (variable-name var) port))
-			      port)
-	      (display " = " port)
-	      (write-c-identifier (variable-name var) port)
-	      (format port ";~%"))
-	    vars))
-
-(define (write-c-block body port indent)
-  (write-c-block-with-args body '() port indent))
-
-(define (write-c-block-with-args body arg-vars port indent)
-  (if (not (null? arg-vars))
-      (write-argument-initializers arg-vars port indent))
-  (call->c body port indent)
-  (write-char '#\} port))
-
-; Jump lambdas.  These are generated more-or-less in the order they are
-; referenced.
-
-(define (clear-lambda-generated?-flags lambdas)
-  (for-each (lambda (l)
-	      (set-lambda-block! l #f))
-	    lambdas))
-
-(define *jumps-to-do* '())
-
-(define (note-jump-generated! proc)
-  (if (not (lambda-block proc))
-      (begin
-	(set! *jumps-to-do* (cons proc *jumps-to-do*))
-	(set-lambda-block! proc #t))))
-
-(define (write-jump-lambdas port indent)
-  (let loop ()
-    (let ((jumps (reverse *jumps-to-do*)))
-      (set! *jumps-to-do* '())
-      (for-each (lambda (jump)
-		  (jump-lambda->c jump port indent))
-		jumps)
-      (if (not (null? *jumps-to-do*))
-	  (loop)))))
-      
-(define (jump-lambda->c node port indent)
-  (newline port)
-  (indent-to port indent)
-  (display " L" port)
-  (display (lambda-id node) port)
-  (display ": {" port)
-  (newline port)
-  (write-c-block-with-args (lambda-body node)
-			   (lambda-variables node)
-			   port
-			   (+ '2 indent)))
-
diff --git a/ps-compiler/prescheme/display.scm b/ps-compiler/prescheme/display.scm
deleted file mode 100644
index 677a63b..0000000
--- a/ps-compiler/prescheme/display.scm
+++ /dev/null
@@ -1,224 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-; Data must be done last as it may contain references to the other stuff.
-
-(define (display-forms-as-scheme forms out)
-  (receive (data other)
-      (partition-list (lambda (f)
-			(and (node? (form-value f))
-			     (literal-node? (form-value f))))
-		      forms)
-    (for-each (lambda (f)
-		(display-form-as-scheme f (schemify (form-value f)) out))
-	      other)
-    (for-each (lambda (f)
-		(display-data-form-as-scheme f out))
-	      data)))
-
-(define form-value (structure-ref forms form-value))
-(define form-var   (structure-ref forms form-var))
-
-(define literal-node? (node-predicate 'literal #f))
-
-(define (display-form-as-scheme f value out)
-  (cond ((unspecific? value)
-	 (p `(define ,(get-form-name f)) out)
-	 (newline out))
-	((or (external-value? value)
-	     (memq 'closed-compiled-primitive (variable-flags (form-var f))))
-	 (values))
-	(else
-	 (p `(define ,(get-form-name f) ,value)
-	    out)
-	 (newline out))))
-
-(define (display-data-form-as-scheme f out)
-  (let* ((value (clean-literal (node-form (form-value f))))
-	 (value (if (and (quoted? value)
-			 (not (or (list? (cadr value))
-				  (vector? (cadr value)))))
-		    (cadr value)
-		    value)))
-    (display-form-as-scheme f value out)))
-
-(define (get-form-name form)
-  (name->symbol (get-variable-name (form-var form))))
-
-(define (schemify node)
-  (if (node? node)
-      ((operator-table-ref schemifiers (node-operator-id node))
-       node)
-      (schemify-sexp node)))
-
-(define unspecific?
-  (let ((x (if #f #t)))
-    (lambda (y)
-      (eq? x y))))
-
-(define schemifiers
-  (make-operator-table (lambda (node)
-			 (let ((form (node-form node)))
-			   (if (list? form)
-			       (map schemify form)
-			       form)))))
-
-(define (define-schemifier name type proc)
-  (operator-define! schemifiers name type proc))
-
-(define-schemifier 'name 'leaf
-  (lambda (node)
-    (cond ((node-ref node 'binding)
-	   => (lambda (binding)
-		(let ((var (binding-place binding)))
-		  (if (variable? var)
-		      (get-variable-name var)
-		      (desyntaxify (node-form node))))))
-	  (else
-	   (name->symbol (node-form node))))))
-
-; Rename things that have differ in Scheme and Pre-Scheme
-
-(define aliases
-  (map (lambda (s)
-	 (cons s (string->symbol (string-append "ps-" (symbol->string s)))))
-       '(read-char peek-char write-char newline
-	 open-input-file open-output-file
-	 close-input-port close-output-port)))
-
-(define (get-variable-name var)
-  (cond ((and (generated-top-variable? var)
-	      (not (memq 'closed-compiled-primitive (variable-flags var))))
-	 (string->symbol (string-append (symbol->string
-					 (name->symbol (variable-name var)))
-					"."
-					(number->string (variable-id var)))))
-	((assq (variable-name var) aliases)
-	 => cdr)
-	(else
-	 (variable-name var))))
-
-(define (name->symbol name)
-  (if (symbol? name)
-      name
-      (string->symbol (string-append (symbol->string (generated-symbol name))
-				     "."
-				     (number->string (generated-uid name))))))
-
-(define-schemifier 'quote #f
-  (lambda (node)
-    (list 'quote (cadr (node-form node)))))
-
-(define-schemifier 'literal #f
-  (lambda (node)
-    (let ((form (node-form node)))
-      (cond ((primop? form)
-	     (primop-id form))
-	    ((external-value? form)
-	     (let ((string (external-value-string form)))
-	       (if (string=? string "(long(*)())")
-		   'integer->procedure
-		   (string->symbol (external-value-string form)))))
-	    ((external-constant? form)
-	     `(enum ,(external-constant-enum-name form)
-		    ,(external-constant-name form)))
-	    (else
-	     (schemify-sexp form))))))
-
-(define-schemifier 'unspecific #f
-  (lambda (node)
-    ''unspecific))
-
-; Used for primitives in non-call position.  The CDR of the form is a
-; variable that will be bound to the primitive's closed-compiled value.
-
-(define-schemifier 'primitive #f
-  (lambda (node)
-    (let ((form (node-form node)))
-      (cond ((pair? form)
-	     (get-variable-name (cdr form))) ; non-call position
-	    ((assq (primitive-id form) aliases)
-	     => cdr)
-	    (else
-	     (primitive-id form))))))
-
-; lambda, let-syntax, letrec-syntax...
-
-(define-schemifier 'letrec #f
-  (lambda (node)
-    (let ((form (node-form node)))
-      `(letrec ,(map (lambda (spec)
-                       `(,(schemify (car spec)) ,(schemify (cadr spec))))
-                     (cadr form))
-         ,@(map (lambda (f) (schemify f))
-                (cddr form))))))
-
-(define-schemifier 'lambda #f
-  (lambda (node)
-    (let ((form (node-form node)))
-      `(lambda ,(let label ((vars (cadr form)))
-		  (cond ((pair? vars)
-			 (cons (schemify (car vars))
-			       (label (cdr vars))))
-			((null? vars)
-			 '())
-			(else
-			 (schemify vars))))
-	 ,@(map schemify (cddr form))))))
-
-(define-schemifier 'goto #f
-  (lambda (node)
-    (map schemify (cdr (node-form node)))))
-
-(define (schemify-sexp thing)
-  (cond ((name? thing)
-	 (desyntaxify thing))
-	((primop? thing)
-	 (primop-id thing))
-	((primitive? thing)
-	 (primitive-id thing))
-	((variable? thing)
-	 (get-variable-name thing))
-	((pair? thing)
-	 (let ((x (schemify-sexp (car thing)))
-	       (y (schemify-sexp (cdr thing))))
-	   (if (and (eq? x (car thing))
-		    (eq? y (cdr thing)))
-	       thing			;+++
-	       (cons x y))))
-	((vector? thing)
-	 (let ((new (make-vector (vector-length thing) #f)))
-	   (let loop ((i 0) (same? #t))
-	     (if (>= i (vector-length thing))
-		 (if same? thing new)	;+++
-		 (let ((x (schemify-sexp (vector-ref thing i))))
-		   (vector-set! new i x)
-		   (loop (+ i 1)
-			 (and same? (eq? x (vector-ref thing i)))))))))
-	(else thing)))
-
-(define (clean-literal thing)
-  (cond ((name? thing)
-	 (desyntaxify thing))
-	((variable? thing)
-	 (get-variable-name thing))
-	((external-constant? thing)
-	 `(enum ,(external-constant-enum-name thing)
-		,(external-constant-name thing)))
-	((pair? thing)
-	 (let ((x (clean-literal (car thing)))
-	       (y (clean-literal (cdr thing))))
-	   (if (and (quoted? x) (quoted? y))
-	       `(quote (,(cadr x) . ,(cadr y)))
-	       `(cons ,x ,y))))
-	((vector? thing)
-	 (let ((elts (map clean-literal (vector->list thing))))
-	   (if (every? quoted? elts)
-	       `(quote ,(list->vector (map cadr elts)))
-	       `(vector . ,elts))))
-	(else
-	 `(quote ,thing))))
-
-(define (quoted? x)
-  (and (pair? x)
-       (eq? (car x) 'quote)))
\ No newline at end of file
diff --git a/ps-compiler/prescheme/eval.scm b/ps-compiler/prescheme/eval.scm
deleted file mode 100644
index db0a79d..0000000
--- a/ps-compiler/prescheme/eval.scm
+++ /dev/null
@@ -1,214 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-; Evaluator for nodes.
-
-; This doesn't handle n-ary procedures.
-
-; (NAME-NODE-BINDING name-node) is used as an EQ? key in local environments,
-; and passed as-is to the global-environment arguments.
-
-; Exports:
-; (EVAL-NODE node global-ref global-set! eval-primitive)
-; CLOSURE? (CLOSURE-NODE closure) (CLOSURE-ENV closure)
-; (UNSPECIFIC? thing)
-
-(define (eval-node node global-ref global-set! eval-primitive)
-  (eval node (make-env '()
-		       (make-eval-data global-ref
-				       global-set!
-				       eval-primitive))))
-
-(define-record-type eval-data :eval-data
-  (make-eval-data global-ref global-set! eval-primitive)
-  eval-data?
-  (global-ref     eval-data-global-ref)
-  (global-set!    eval-data-global-set!)
-  (eval-primitive eval-data-eval-primitive))
-
-; Environments
-
-(define-record-type env :env
-  (make-env alist eval-data)
-  env?
-  (alist env-alist)
-  (eval-data env-eval-data))
-
-(define (env-ref env name-node)
-  (let ((cell (assq name-node (env-alist env))))
-    (if cell
-	(cdr cell)
-	((eval-data-global-ref (env-eval-data env)) name-node))))
-
-(define (env-set! env name-node value)
-  (let ((cell (assq name-node (env-alist env))))
-    (if cell
-	(set-cdr! cell value)
-	((eval-data-global-set! (env-eval-data env))
-	 name-node
-	 value))))
-
-(define (extend-env env ids vals)
-  (make-env (append (map cons ids vals)
-		    (env-alist env))
-	    (env-eval-data env)))
-
-(define (eval-primitive primitive args env)
-  ((eval-data-eval-primitive (env-eval-data env)) primitive args))
-
-; Closures
-
-(define-record-type closure :closure
-  (make-closure node env)
-  closure?
-  (node closure-node)
-  (env real-closure-env)
-  (temp closure-temp set-closure-temp!))
-
-(define (closure-env closure)                   ; exported
-  (env-alist (real-closure-env closure)))
-
-(define (make-top-level-closure exp)
-  (make-closure exp the-empty-env))
-
-(define the-empty-env (make-env '() #f))
-
-; Main dispatch
-
-(define (eval node env)
-  ((operator-table-ref evaluators (node-operator-id node))
-   node
-   env))
-
-; Particular operators
-
-(define evaluators
-  (make-operator-table
-   (lambda (node env)
-     (error "no evaluator for node ~S" node))))
-
-(define (define-evaluator name proc)
-  (operator-define! evaluators name #f proc))
-
-(define (eval-list nodes env)
-  (map (lambda (node)
-	 (eval node env))
-       nodes))
-
-(define-evaluator 'literal
-  (lambda (node env)
-    (node-form node)))
-
-(define-evaluator 'unspecific
-  (lambda (node env)
-    (unspecific)))
-
-(define-evaluator 'unassigned
-  (lambda (node env)
-    (unspecific)))
-
-(define-evaluator 'real-external
-  (lambda (node env)
-    (let* ((exp (node-form node))
-	   (type (expand-type-spec (cadr (node-form (caddr exp))))))
-      (make-external-value (node-form (cadr exp))
-			   type))))
-
-(define-evaluator 'quote
-  (lambda (node env)
-    (cadr (node-form node))))
-
-(define-evaluator 'lambda
-  (lambda (node env)
-    (make-closure node env)))
-
-(define (apply-closure closure args)
-  (let ((node (closure-node closure))
-	(env (real-closure-env closure)))
-    (eval (caddr (node-form node))
-	  (extend-env env (cadr (node-form node)) args))))
-
-(define-evaluator 'name
-  (lambda (node env)
-    (env-ref env node)))
-
-(define-evaluator 'set!
-  (lambda (node env)
-    (let ((exp (node-form node)))
-      (env-set! env (cadr exp) (eval (caddr exp) env))
-      (unspecific))))
-
-(define-evaluator 'call
-  (lambda (node env)
-    (eval-call (car (node-form node))
-	       (cdr (node-form node))
-	       env)))
-
-(define-evaluator 'goto
-  (lambda (node env)
-    (eval-call (cadr (node-form node))
-	       (cddr (node-form node))
-	       env)))
-
-(define (eval-call proc args env)
-  (let ((proc (eval proc env))
-	(args (eval-list args env)))
-    (if (closure? proc)
-	(apply-closure proc args)
-	(eval-primitive proc args env))))
-
-(define-evaluator 'begin
-  (lambda (node env)
-    (let ((exps (cdr (node-form node)))) 
-      (if (null? exps)
-	  (unspecific)
-	  (let loop ((exps exps))
-	    (cond ((null? (cdr exps))
-		   (eval (car exps) env))
-		  (else
-		   (eval (car exps) env)
-		   (loop (cdr exps)))))))))
-
-(define-evaluator 'if 
-  (lambda (node env)
-    (let* ((form (node-form node))
-	   (test (cadr form))
-	   (arms (cddr form)))
-      (cond ((eval test env)
-	     (eval (car arms) env))
-	    ((null? (cdr arms))
-	     (unspecific))
-	    (else
-	     (eval (cadr arms) env))))))
-
-(define-evaluator 'loophole
-  (lambda (node env)
-    (eval (caddr (node-form node)) env)))
-
-(define-evaluator 'letrec
-  (lambda (node env)
-    (let ((form (node-form node)))
-      (let ((vars (map car (cadr form)))
-	    (vals (map cadr (cadr form)))
-	    (body (caddr form)))
-	(let ((env (extend-env env
-			       vars
-			       (map (lambda (ignore)
-				      (unspecific))
-				    vars))))
-	  (for-each (lambda (var val)
-		      (env-set! env var (eval val env)))
-		    vars
-		    vals)
-	  (eval body env))))))
-
-(define (unspecific? x)
-  (eq? x (unspecific)))
-
-; Used by our clients but not by us.
-
-(define (constant? x)
-  (or (number? x)
-      (symbol? x)
-      (external-constant? x)
-      (external-value? x)
-      (boolean? x)))
diff --git a/ps-compiler/prescheme/expand.scm b/ps-compiler/prescheme/expand.scm
deleted file mode 100644
index 3cd44b2..0000000
--- a/ps-compiler/prescheme/expand.scm
+++ /dev/null
@@ -1,77 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-; Expanding using the Scheme 48 expander.
-
-(define (scan-packages packages)
-  (let ((definitions
-	  (fold (lambda (package definitions)
-		  (let ((cenv (package->environment package)))
-		    (fold (lambda (form definitions)
-			    (let ((node (expand-form form cenv)))
-			      (cond ((define-node? node)
-				     (cons (eval-define (expand node cenv)
-							cenv)
-					   definitions))
-				    (else
-				     (eval-node (expand node cenv)
-						global-ref
-						global-set!
-						eval-primitive)
-				     definitions))))
-			  (call-with-values
-			   (lambda ()
-			     (package-source package))
-			   (lambda (files.forms usual-transforms primitives?)
-			     (scan-forms (apply append (map cdr files.forms))
-					 cenv)))
-			  definitions)))
-		packages
-		'())))
-    (reverse (map (lambda (var)
-		    (let ((value (variable-flag var)))
-		      (set-variable-flag! var #f)
-		      (cons var value)))
-		  definitions))))
-
-(define package->environment (structure-ref packages package->environment))
-
-(define define-node? (node-predicate 'define))
-
-(define (eval-define node cenv)
-  (let* ((form (node-form node))
-	 (value (eval-node (caddr form)
-			   global-ref
-			   global-set!
-			   eval-primitive))
-	 (lhs (cadr form)))
-    (global-set! lhs value)
-    (name->variable-or-value lhs)))
-
-(define (global-ref name)
-  (let ((thing (name->variable-or-value name)))
-    (if (variable? thing)
-	(variable-flag thing)
-	thing)))
-
-(define (global-set! name value)
-  (let ((thing (name->variable-or-value name)))
-    (if (primitive? thing)
-	(bug "trying to set the value of primitive ~S" thing)
-	(set-variable-flag! thing value))))
-
-(define (name->variable-or-value name)
-  (let ((binding (node-ref name 'binding)))
-    (if (binding? binding)
-	(let ((value (binding-place binding))
-	      (static (binding-static binding)))
-	  (cond ((primitive? static)
-		 static)
-		((variable? value)
-		 value)
-		((and (location? value)
-		      (constant? (contents value)))
-		 (contents value))
-		(else
-		 (bug "global binding is not a variable, primitive or constant ~S" name))))
-	(user-error "unbound variable ~S" (node-form name)))))
-
diff --git a/ps-compiler/prescheme/flatten.scm b/ps-compiler/prescheme/flatten.scm
deleted file mode 100644
index 13b5a4e..0000000
--- a/ps-compiler/prescheme/flatten.scm
+++ /dev/null
@@ -1,406 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-; Definitions are (<variable> . <value>) pairs, where <value> can be any
-; Scheme value.  This code walks the values looking for sharing and for
-; closures.  Shared values are collected in a list and additional definitions
-; are introduced for the bindings in the environments of closures and for
-; close-compiled versions of any primitives in non-call position.  References
-; to closure-bound variables are replaced with references to the newly-created
-; package variables.
-
-(define (flatten-definitions definitions)
-  (set! *shared* '())
-  (set! *definitions* '())
-  (set! *immutable-value-table* (make-value-table))
-  (set! *closed-compiled-primitives* (make-symbol-table))
-  (let loop ((defs definitions) (flat '()))
-    (cond ((not (null? defs))
-	   (let ((var (caar defs))
-		 (value (cdar defs)))
-	     (if (and (variable-set!? var)
-		      (closure? value))
-		 (let ((new (generate-top-variable (variable-name var))))
-		   (loop `((,var . ,new)
-			   (,new . ,value)
-			   . ,defs)
-			 flat))
-		 (loop (cdr defs)
-		       (cons (cons var (flatten-value value))
-			     flat)))))
-	  ((null? *definitions*)
-	   (let ((forms (really-make-forms flat *shared*)))
-	     (set! *shared* #f)       ; safety
-	     (set! *closed-compiled-primitives* #f)
-	     (set! *immutable-value-table* #f)
-	     forms))
-	  (else
-	   (let ((defs *definitions*))
-	     (set! *definitions* '())
-	     (loop defs flat))))))
-
-; <Definitions> is a list of (<variable> . <value>) pairs.
-; <Shared> is a list of all shared objects, each of which must end up being
-; bound to a variable.
-
-(define (really-make-forms definitions shared)
-  (for-each (lambda (defn)
-	      (let ((var (car defn))
-		    (shared (value-shared (cdr defn))))
-		(if (and (not (variable-set!? var))
-			 shared
-			 (not (shared-variable shared)))
-		    (set-shared-variable! shared var))))
-	    definitions)
-  (map definition->form
-       (append definitions
-	       (shared-values->definitions shared))))
-
-(define variable-set!? (structure-ref forms variable-set!?))
-
-(define (shared-values->definitions shared)
-  (do ((shared shared (cdr shared))
-       (defns '() (if (shared-variable (value-shared (car shared)))
-		      defns
-		      (let ((var (generate-top-variable #f)))
-			(set-shared-variable! (value-shared (car shared)) var)
-			(cons (cons var (car shared)) defns)))))
-      ((null? shared)
-       defns)))
-
-(define (definition->form definition)
-  (let* ((var (car definition))
-	 (value (cdr definition))
-	 (shared (value-shared value))
-	 (value (if (or (not shared)
-			(eq? var (shared-variable shared)))
-		    value
-		    (shared-variable shared)))
-	 (clean (clean-value! value)))
-    ((structure-ref forms make-form)
-       var
-       (if (or (node? clean)
-	       (variable? clean))
-	   clean
-	   (make-literal-node clean))
-       (if (closure? value)              
-	   (cdr (shared-saved (closure-temp value))) ; free vars
-	   (stored-value-free-vars clean)))))
-
-(define (make-literal-node value)
-  (make-node op/literal value))
-
-(define (make-name-node value)
-  (make-node op/name value))
-
-(define *shared* '())
-
-(define (add-shared! value)
-  (set! *shared* (cons value *shared*)))
-
-(define *definitions* '())
-
-(define (add-package-definition! value id)
-  (let ((var (generate-top-variable id)))
-    (set! *definitions*
-	  (cons (cons var value)
-		*definitions*))
-    var))
-
-(define (generate-top-variable maybe-id)
-  (let ((var (make-global-variable (concatenate-symbol
-				      (if maybe-id
-					  (schemify maybe-id)
-					  'top.)
-				      (next-top-id))
-				   type/undetermined)))
-    (set-variable-flags! var
-			 (cons 'generated-top-variable
-			       (variable-flags var)))
-    var))
-
-(define *next-top-id* 0)
-
-(define (next-top-id)
-  (let ((id *next-top-id*))
-    (set! *next-top-id* (+ 1 *next-top-id*))
-    id))
-
-(define (generated-top-variable? var)
-  (memq? 'generated-top-variable (variable-flags var)))
-
-(define (stored-value-free-vars value)
-  (let ((vars '()))
-    (let label ((value value))
-      (cond ((variable? value)
-	     (cond ((not (variable-flag value))
-		    (set-variable-flag! value #t)
-		    (set! vars (cons value vars)))
-		   (else
-		    ;(breakpoint "marked variable")  ; why did I care?
-		    (values))))
-	    ((vector? value)
-	     (do ((i 0 (+ i 1)))
-		 ((= i (vector-length value)))
-	       (label (vector-ref value i))))
-	    ((pair? value)
-	     (label (car value))
-	     (label (cdr value)))))
-    (for-each (lambda (var)
-		(set-variable-flag! var #f))
-	      vars)
-    vars))
-
-;----------------------------------------------------------------
-; Finding shared data structures.
-
-(define-record-type shared
-  ()
-  (saved
-   (shared? #f)
-   (variable #f)))
-
-(define make-shared shared-maker)
-
-(define (value-shared value)
-  (cond ((pair? value)
-	 (car value))
-	((vector? value)
-	 (if (= 0 (vector-length value))
-	     #f
-	     (vector-ref value 0)))
-	((closure? value)
-	 (closure-temp value))
-	(else
-	 #f)))
-
-(define (clean-value! value)
-  (cond ((pair? value)
-	 (cons (clean-sub-value! (shared-saved (car value)))
-	       (clean-sub-value! (cdr value))))
-	((vector? value)
-	 (if (= 0 (vector-length value))
-	     value
-	     (let ((new (make-vector (vector-length value))))
-	       (vector-set! new 0 (clean-sub-value!
-				   (shared-saved (vector-ref value 0))))
-	       (do ((i 1 (+ i 1)))
-		   ((= i (vector-length value)))
-		 (vector-set! new i (clean-sub-value! (vector-ref value i))))
-	       new)))
-	((closure? value)
-	 (car (shared-saved (closure-temp value)))) ; flattened version of node
-	((node? value)
-	 (if (name-node? value)
-	     (name-node->variable value)
-	     (bug "bad definition value: ~S" value)))
-	(else
-	 value)))
-
-(define name-node? (node-predicate 'name))
-
-(define (clean-sub-value! value)
-  (cond ((pair? value)
-	 (let ((shared (car value)))
-	   (cond ((shared-shared? shared)
-		  (shared-variable shared))
-		 (else
-		  (set-car! value (clean-sub-value! (shared-saved shared)))
-		  (set-cdr! value (clean-sub-value! (cdr value)))
-		  value))))
-	((vector? value)
-	 (cond ((= 0 (vector-length value))
-		value)
-	       ((shared-shared? (vector-ref value 0))
-		(shared-variable (vector-ref value 0)))
-	       (else
-		(vector-set! value 0 (clean-sub-value!
-				      (shared-saved (vector-ref value 0))))
-		(do ((i 1 (+ i 1)))
-		    ((= i (vector-length value)))
-		  (vector-set! value i (clean-sub-value! (vector-ref value i))))
-		value)))
-	((closure? value)
-	 (shared-variable (closure-temp value)))
-	(else
-	 value)))
-
-(define (flatten-value value)
-  (cond ((immutable? value)
-	 (flatten-immutable-value value))
-	((primitive? value)
-	 (primitive->name-node value))
-	(else
-	 (flatten-value! value)
-	 value)))
-
-(define (flatten-value! value)
-  (cond ((pair? value)
-	 (check-shared! (car value) flatten-pair! value))
-	((vector? value)
-	 (if (not (= 0 (vector-length value)))
-	     (check-shared! (vector-ref value 0) flatten-vector! value)))
-	((closure? value)
-	 (check-shared! (closure-temp value) flatten-closure! value))))
-
-(define (check-shared! shared flatten! value)
-  (cond ((not (shared? shared))
-	 (flatten! value))
-	((not (shared-shared? shared))
-	 (set-shared-shared?! shared #t)
-	 (add-shared! value))))
-
-(define *immutable-value-table* #f)
-
-(define (flatten-immutable-value value)
-  (cond ((pair? value)
-	 (or (shared-immutable-value value car)
-	     (let ((p (cons (car value) (cdr value))))
-	       (table-set! *immutable-value-table* value p)
-	       (flatten-pair! p)
-	       p)))
-	((vector? value)
-	 (if (= 0 (vector-length value))
-	     value
-	     (or (shared-immutable-value value (lambda (x) (vector-ref x 0)))
-		 (let ((v (copy-vector value)))
-		   (table-set! *immutable-value-table* value v)
-		   (flatten-vector! v)
-		   v))))
-	; no immutable closures
-	(else
-	 value)))  ; no sub-values
-
-(define (shared-immutable-value value accessor)
-  (cond ((table-ref *immutable-value-table* value)
-	 => (lambda (copy)
-	      (cond ((not (shared-shared? (accessor copy)))
-		     (set-shared-shared?! (accessor copy) #t)
-		     (add-shared! copy)
-		     copy))))
-	(else
-	 #f)))
-
-(define (flatten-pair! pair)
-  (let ((temp (car pair))
-	(shared (make-shared)))
-    (set-car! pair shared)
-    (set-shared-saved! shared (flatten-value temp))
-    (set-cdr! pair (flatten-value (cdr pair)))))
-
-(define (flatten-vector! vector)
-  (let ((temp (vector-ref vector 0))
-	(shared (make-shared)))
-    (vector-set! vector 0 shared)
-    (set-shared-saved! shared (flatten-value temp))
-    (do ((i 1 (+ i 1)))
-	((= i (vector-length vector)))
-      (vector-set! vector i (flatten-value (vector-ref vector i))))))
-
-; Make top-level definitions for the bindings in the closure and then substitute
-; the defined variables within the closure's code.  The define variables are
-; saved in the bindings in case they are shared with other closures (both for
-; efficiency and because SET! requires it).
-
-(define (flatten-closure! closure)
-  (let ((shared (make-shared)))
-    (for-each flatten-closure-binding! (closure-env closure))
-    (set-closure-temp! closure shared)
-    (set-shared-shared?! shared #t)     ; closures always need definitions
-    (add-shared! closure)
-    (receive (exp free)
-	(substitute-in-expression (closure-node closure))
-      (set-shared-saved! shared (cons exp free))
-      (for-each clear-closure-binding! (closure-env closure)))))
-
-(define (clear-closure-binding! pair)
-  (node-set! (car pair) 'substitute #f))
-
-; PAIR is (<name-node> . <value>) if it hasn't been seen before and
-; (<name-node> . <substitute-name-node>) if it has.
-
-(define (flatten-closure-binding! pair)
-  (let* ((name (car pair))
-	 (subst (if (node? (cdr pair))
-		    (cdr pair)
-		    (let ((subst (make-name-node-subst name (cdr pair))))
-		      (set-cdr! pair subst)
-		      subst))))
-    (node-set! name 'substitute subst)))
-
-(define (make-name-node-subst name value)		      
-  (let ((var (add-package-definition! value (node-form name)))
-	(subst (make-similar-node name (node-form name))))
-    (node-set! subst 'binding (make-binding #f var #f))
-    subst))
-
-(define op/literal (get-operator 'literal))
-(define op/name    (get-operator 'name))
-
-;----------------------------------------------------------------
-(define *closed-compiled-primitives* #f)
-
-(define (make-primitive-node primitive call?)
-  (if (and call?
-	   (primitive-expands-in-place? primitive))
-      (make-node op/primitive primitive)
-      (let ((name-node (primitive->name-node primitive)))
-	(note-variable-use! (name-node->variable name-node))
-	name-node)))
-
-(define (name-node->variable name-node)
-  (let ((binding (node-ref name-node 'binding)))
-    (cond ((not (binding? binding))
-	   (bug "unbound variable ~S" (node-form name-node)))
-	  ((primitive? (binding-static binding))
-	   (primitive->name-node (binding-static binding)))
-	  (else
-	   (binding-place binding)))))
-
-(define (primitive->name-node primitive)
-  (let ((id (primitive-id primitive)))
-    (or (table-ref *closed-compiled-primitives* id)
-	(let* ((var (add-package-definition!
-		     (make-top-level-closure
-		      (expand (primitive-source primitive)
-			      prescheme-compiler-env))
-		     id))
-	       (binding (make-binding #f var #f))
-	       (node (make-node op/name id)))
-	  (node-set! node 'binding (make-binding #f var #f))
-	  (table-set! *closed-compiled-primitives* id node)
-	  (set-variable-flags! var (cons 'closed-compiled-primitive
-					 (variable-flags var)))
-	  node))))
-
-(define op/primitive (get-operator 'primitive))
-
-;----------------------------------------------------------------
-
-(define max-key-depth 5)
-
-(define (value-table-hash-function obj)
-  (let recur ((obj obj) (depth 0))
-    (cond ((= depth max-key-depth)
-	   0)
-	  ((symbol? obj) (string-hash (symbol->string obj)))
-	  ((integer? obj)
-	   (if (< obj 0) (- -1 obj) obj))
-	  ((char? obj) (+ 333 (char->integer obj)))
-	  ((eq? obj #f) 3001)
-	  ((eq? obj #t) 3003)
-	  ((null? obj) 3005)
-	  ((pair? obj)
-	   (+ 3007
-	      (recur (car obj) (- depth 1))
-	      (* 3 (recur (cdr obj) (- depth 1)))))
-	  ((vector? obj)
-	   (let loop ((i 0) (hash (+ 3009 (vector-length obj))))
-	     (if (or (= i (vector-length obj))
-		     (= 0 (- depth i)))
-		 hash
-		 (loop (+ i 1) (+ hash (* i (recur (vector-ref obj i)
-						   (- depth i))))))))
-	  (else (error "value cannot be used as a table key" obj)))))
-
-(define make-value-table
-  (make-table-maker eq? value-table-hash-function))
diff --git a/ps-compiler/prescheme/form.scm b/ps-compiler/prescheme/form.scm
deleted file mode 100644
index 094f80a..0000000
--- a/ps-compiler/prescheme/form.scm
+++ /dev/null
@@ -1,666 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-; temporary hack
-;(define enqueue! enqueue)
-;(define dequeue! dequeue)
-
-(define-record-type form
-  (var              ; variable being defined (if any)
-   (value)          ; current value
-   ;source           ; one line of source code
-   (free)           ; variables free in this form
-   )
-
-  (used?            ; is the value used in the program
-   (exported? #f)   ; true if the definition in this form is exported
-   (integrate 'okay) ; one of OKAY, YES, NO, PARTIAL
-   (aliases   '())  ; variables that are aliases for this one
-   (shadowed  '())  ; package variables that should be shadowed here
-
-   value-type       ; value's type
-
-   (dependency-index #f) ; index of this form in the data dependent order
-
-   lambdas          ; list of all non-cont lambdas in this form
-
-   (clients '())    ; forms that use this one's variable
-   (providers '())  ; forms that define a variable used by this one
-   
-   (type #f)        ; one of LAMBDA, INTEGRATE, INITIALIZE or
-                    ;  #F for unfinished forms
-   merge            ; slot used by form-merging code
-   temp             ; handy slot
-   ))
-
-(define-record-discloser type/form
-  (lambda (form)
-    `(form ,(variable-name (form-var form)))))
-
-(define (make-form var value free)
-  (let ((form (form-maker var value free)))
-    (if (maybe-variable->form var)
-	(error "more than one definition of ~S" (variable-name var)))
-    (set-variable-flags! var `((form . ,form) . ,(variable-flags var)))
-    form))
-
-(define (pp-one-line x)
-  (call-with-string-output-port
-   (lambda (p)
-     (write-one-line p 70 (lambda (p) (write x p))))))
-
-(define (form-node form)
-  (let ((value (form-value form)))
-    (if (node? value)
-	value
-	(bug "form's value is not a node ~S ~S" form value))))
-
-(define (set-form-node! form node lambdas)
-  (set-node-flag! node form)
-  (set-form-value! form node)
-  (set-form-lambdas! form lambdas))
-
-(define (node-form node)
-  (let ((form (node-flag (node-base node))))
-    (if (form? form)
-	form
-	(bug "node ~S (~S) not in any form" node (node-base node)))))
-
-(define (suspend-form-use! form)
-  (set-form-lambdas! form (make-lambda-list))
-  (set-node-flag! (form-node form) form))
-
-(define (use-this-form! form)
-  (initialize-lambdas)
-  (also-use-this-form! form))
-
-(define (also-use-this-form! form)
-  (add-lambdas (form-lambdas form))
-  (set-node-flag! (form-node form) #f))
-
-(define (form-name form)
-  (variable-name (form-var form)))
-
-(define (make-form-unused! form)
-  (set-form-type! form 'unused)
-  (cond ((node? (form-value form))
-	 (erase (form-value form))
-	 (set-form-value! form #f)
-	 (set-form-lambdas! form #f))))
-
-; notes on writing and reading forms
-; What we really need here are forms.
-; What to do?  Can read until there are no missing lambdas = end of form
-; Need the variables as well.
-
-; (form index type var source? clients providers integrate?)
-; clients and providers are lists of indicies
-; can get lambdas automatically
-
-;(define (write-cps-file file forms)
-;  (let ((port (make-tracking-output-port (open-output-file file))))
-;    (reset-pp-cps)
-;    (walk (lambda (f)
-;	    (write-form f port))
-;	  (sort-list forms
-;		     (lambda (f1 f2)
-;		       (< (form-index f1) (form-index f2)))))
-;    (close-output-port port)))
-
-;(define (write-form form port)
-;  (format port "(FORM ~D ~S ~S "
-;	  (form-index form)
-;	  (form-type form)
-;	  (form-integrate form))
-;  (if (form-var form)
-;      (print-variable-name (form-var form) port)
-;      (format port "#f"))
-;  (format port "~%  ~S" (map form-index (form-clients form)))
-;  (rereadable-pp-cps (form-value form) port)
-;  (format port ")~%~%"))
-
-;------------------------------------------------------------------------------
-; Put the forms that do not reference any other forms' variables in a queue.
-; Every form gets a list of forms that use its variable and a list of forms
-; whose variables it uses.
-
-(define (sort-forms forms)
-  (let ((queue (make-queue)))
-    (for-each (lambda (f)
-		(set-variable-flag! (form-var f) f))
-	      forms)
-    (let ((forms (really-remove-unreferenced-forms
-		  forms
-		  set-providers-using-free)))
-      (for-each (lambda (f)
-		  (if (null? (form-providers f))
-		      (enqueue! queue f)))
-		(reverse forms))
-      (for-each (lambda (f)
-		  (set-variable-flag! (form-var f) #f))
-		forms)
-      (values forms (make-form-queue queue forms)))))
-
-(define (set-providers-using-free form)
-  (let loop ((vars (form-free form)) (provs '()))
-    (cond ((null? vars)
-	   (set-form-providers! form provs))
-	  ((variable-flag (car vars))
-	   => (lambda (prov)
-		(set-form-clients! prov (cons form (form-clients prov)))
-		(loop (cdr vars) (cons prov provs))))
-	  (else
-	   (loop (cdr vars) provs)))))
-
-(define (make-form-queue ready forms)
-  (let ((index 0))
-    (lambda ()
-      (let loop ()
-	(cond ((not (queue-empty? ready))
-	       (let ((form (dequeue! ready)))
-		 (set-form-dependency-index! form index)
-		 (for-each (lambda (f)
-			     (set-form-providers! f (delq! form (form-providers f)))
-			     (if (and (null? (form-providers f))
-				      (not (form-dependency-index f))
-				      (form-used? f))
-				 (enqueue! ready f)))
-			   (form-clients form))
-		 (set! index (+ index 1))
-		 form))
-	      ((find-dependency-loop ready forms)
-	       => (lambda (rest)
-		    (set! forms rest)
-		    (loop)))
-	      (else #f))))))
-
-; Find a circular dependence between the remaining forms.
-
-(define (find-dependency-loop queue forms)
-  (let ((forms (do ((forms forms (cdr forms)))
-                   ((or (null? forms)
-			(not (form-dependency-index (car forms))))
-                    forms))))
-    (cond ((null? forms)
-           #f)
-          (else
-           ;;(format #t "Dependency loop!~%")
-           (let ((form (really-find-dependency-loop forms)))
-	     (if (not (every? (lambda (f) (eq? 'no (form-integrate f)))
-			      (form-providers form)))
-		 (set-form-integrate! form 'no))
-             (set-form-providers! form '())
-             (enqueue! queue form)
-             forms)))))
-
-(define (really-find-dependency-loop forms)
-  (for-each (lambda (f) (set-form-temp! f #f))
-	    forms)
-  (let label ((form (car forms)))
-    (cond ((form-temp form)
-           (break-dependency-loop (filter (lambda (f)
-					    (and (form-temp f) (form-var f)))
-					  forms)))
-          (else
-           (set-form-temp! form #t)
-           (cond ((any-map label (form-providers form))
-                  => (lambda (res)
-                       (set-form-temp! form #f)
-                       res))
-                 (else
-                  (set-form-temp! form #f)
-                  #f))))))
-
-(define (any-map proc list)
-  (let loop ((list list))
-    (cond ((null? list)
-	   #f)
-	  ((proc (car list))
-	   => identity)
-	  (else
-	   (loop (cdr list))))))
-
-(define *loop-forms* #f)
-
-(define (break-dependency-loop forms)
-  (or (first (lambda (f)
-               (or (every? (lambda (f)
-                             (eq? 'no (form-integrate f)))
-                           (form-providers f))
-                   (memq? f (form-providers f))
-		   (and (scheme-node? (form-value f))
-			(scheme-literal-node? (form-value f)))))
-             forms)
-      (begin (set! *loop-forms* forms)
-	     (let ((f (breakpoint "Break dependency loop: *loop-forms* = ~S" forms)))
-	       (set! *loop-forms* #f)
-	       f))))
-
-(define scheme-literal-node? 
-  ((structure-ref nodes node-predicate) 'literal))
-
-(define scheme-node? 
-  (structure-ref nodes node?))
-
-;----------------------------------------------------------------
-
-(define (variable-set!? var)
-  (memq 'set! (variable-flags var)))
-
-(define (note-variable-set!! var)
-  (if (not (variable-set!? var))
-      (set-variable-flags! var (cons 'set! (variable-flags var)))))
-
-;------------------------------------------------------------------------------
-; Turn expression into nodes and simplify it.
-
-; Still to do:
-;  Get representations of data values
-;  Need to constant fold vector slots, including detection of modifications
-;    and single uses.
-
-(define (expand-and-simplify-form form)
-  (initialize-lambdas)
-  (let* ((value (form-value form))
-	 (node (if (variable? value)
-		   (make-reference-node value)
-		   (x->cps (form-value form) (form-name form)))))
-    (cond ((variable-set!? (form-var form))
-	   (set-form-type! form 'initialize)
-	   (set-form-node! form node '())
-	   "settable")
-         ((reference-node? node)
-	  (let ((var (reference-variable node)))
-	    (add-known-form-value! form node)
-	    (cond ((maybe-variable->form var)
-		   => (lambda (f)
-			(set-form-aliases! f
-					   `(,(form-var form)
-					     ,@(form-aliases form)
-					     . ,(form-aliases f))))))
-	    (set-form-type! form 'alias)
-	    (erase node)
-	    (set-form-value! form var)
-	    "alias"))
-	 ((literal-node? node)
-	  (expand-and-simplify-literal node form))
-	 ((lambda-node? node)
-	  (expand-and-simplify-lambda node form))
-	 (else
-	  (bug "funny form value ~S" node)))))
-
-; This could pay attention to immutability.
-
-(define (atomic? value)
-  (not (or (vector? value)
-	   (pair? value))))
-
-(define (expand-and-simplify-literal node form)
-  (let ((value (literal-value node)))
-    (cond ((unspecific? value)
-	   (format #t "~%Warning: variable `~S' has no value and is not SET!~%"
-		   (form-name form))
-	   (set-form-value! form node)
-	   (set-form-lambdas! form '())
-	   (set-form-integrate! form 'no)
-	   (set-form-type! form 'unused)
-           "constant")
-	  ((atomic? value)
-	   (add-known-form-value! form node)
-	   (set-form-value! form node)
-	   (set-form-lambdas! form '())
-	   "constant")
-	  (else
-	   (set-form-node! form (stob->node value) '())
-	   (set-form-type! form 'stob)
-	   "consed"))))
-
-; Make a call node containing the contents of the stob so that any
-; variables will be seen as referenced and any integrable values will
-; be integrated.
-
-; Only works for vectors at this point.
-; MAKE-VECTOR is a randomly chosen primop, almost anything could be used.
-
-(define (stob->node value)
-  (let* ((contents '())
-	 (add! (lambda (x) (set! contents (cons x contents)))))
-    (cond ((vector? value)
-	   (do ((i 0 (+ i 1)))
-	       ((>= i (vector-length value)))
-	     (add! (vector-ref value i))))
-	  (else
-	   (error "unknown kind of stob value ~S" value)))
-    (let ((call (make-call-node (get-prescheme-primop 'make-vector)
-				(+ 1 (length contents))
-				0))
-	  (node (make-lambda-node 'stob 'init '())))
-      (attach call 0 (make-literal-node value #f)) ; save for future use
-      (do ((i 1 (+ i 1))
-	   (cs (reverse contents) (cdr cs)))
-	  ((null? cs))
-	(let ((x (car cs)))
-	  (attach call i (if (variable? x)
-			     (make-reference-node x)
-			     (make-literal-node x type/unknown)))))
-      (attach-body node call)
-      (simplify-args call 1)
-      node)))
-
-(define (add-known-form-value! form value)
-  (let ((node (if (variable? value)
-		  (make-reference-node value)
-		  value))
-	(var (form-var form)))
-    (set-form-type! form 'integrate)
-    (cond ((or (literal-node? node)
-	       (reference-node? node)
-	       (and (call-node? node)
-		    (trivial? node)))
-	   (add-variable-known-value! var (node->vector node))
-	   (if (variable? value)
-	       (erase node)))
-	  ((lambda-node? node)
-	   (add-variable-simplifier! var (make-inliner (node->vector node))))
-	  (else
-	   (bug "form's value ~S is not a value" value)))))
-
-(define (make-inliner vector)
-  (lambda (call)
-    (let ((proc (call-arg call 1)))
-      (replace proc (reconstruct-value vector proc call)))))
-
-(define (reconstruct-value value proc call)
-  (let ((has-type (maybe-follow-uvar (variable-type (reference-variable proc))))
-	(node (vector->node value)))
-    (if (type-scheme? has-type)
-	(instantiate-type&value has-type node proc))
-    node))
-
-(define (expand-and-simplify-lambda node form)
-  (simplify-all node (form-name form))
-  (let ((lambdas (make-lambda-list))
-	(status (duplicate-form? form node)))
-    (if status
-	(add-known-form-value! form node))
-    (set-form-node! form node lambdas)
-    (set-form-type! form 'lambda)
-    (set-form-free! form #f)   ; old value no longer valid
-    status))
-
-(define *duplicate-lambda-size* 10)
-
-(define (set-duplicate-lambda-size! n)
-  (set! *duplicate-lambda-size* n))
-
-(define (duplicate-form? form node)
-  (cond ((or (variable-set!? (form-var form))
-	     (eq? 'no (form-integrate form)))
-         #f)
-        ((small-node? node *duplicate-lambda-size*)
-	 "small")
-	((eq? 'yes (form-integrate form))
-	 "by request")
-;        ((called-arguments? node)
-;         "called arguments")
-        (else
-         #f)))
-
-(define (called-arguments? node)
-  (any? (lambda (v)
-	  (any? (lambda (n)
-		  (eq? n (called-node (node-parent n))))
-		(variable-refs v)))
-	(cdr (lambda-variables node))))
-
-;------------------------------------------------------------------------------
-
-(define (integrate-stob-form form)
-  (if (and (eq? 'stob (form-type form))
-	   (elide-aliases! form)
-	   (not (form-exported? form))
-	   (every? cell-use (variable-refs (form-var form))))
-      (let* ((var (form-var form))
-	     (ref (car (variable-refs var)))
-	     (call (lambda-body (form-value form))))
-	; could fold any fixed references - do it later
-	(cond ((and (null? (cdr (variable-refs var)))
-		    (called-node? (cell-use ref)))
-	       (format #t "computed-goto: ~S~%" (variable-name var)) 
-	       (make-computed-goto form))))))
-
-(define (cell-use node)
-  (let ((parent (node-parent node)))
-    (if (and (call-node? parent)
-	     (eq? 'vector-ref (primop-id (call-primop parent))))
-	parent
-	#f)))
-
-(define (elide-aliases! form)
-  (not (or-map (lambda (f)
-		 (switch-references! (form-var f) (form-var form))
-		 (form-exported? f))
-	       (form-aliases form))))
-
-(define (switch-references! from to)
-  (for-each (lambda (r)
-	      (set-reference-variable! r to))
-	    (variable-refs from))
-  (set-variable-refs! to (append (variable-refs from) (variable-refs to))))
-
-;------------------------------------------------------------------------------
-
-(define (resimplify-form form)
-  (let ((node (form-value form)))
-    (cond ((and (node? node)
-		(not (eq? 'stob (form-type form)))
-		(not (node-simplified? node)))
-	   (use-this-form! form)
-	   (simplify-node node)
-	   (suspend-form-use! form)))))
-
-;------------------------------------------------------------------------------
-; This is removes all forms that are not ultimately referenced from some
-; exported form.
-
-(define (add-form-provider! form provider)
-  (if (not (memq? provider (form-providers form)))
-      (set-form-providers!
-       form
-       (cons provider (form-providers form)))))
-
-(define (variable->form var)
-  (or (maybe-variable->form var)
-      (bug "variable ~S has no form" var)))
-
-(define (maybe-variable->form var)
-  (cond ((flag-assq 'form (variable-flags var))
-	 => cdr)
-	(else
-	 #f)))
-
-(define (remove-unreferenced-forms forms)
-  (really-remove-unreferenced-forms forms set-form-providers))
-
-(define (really-remove-unreferenced-forms forms set-form-providers)
-  (receive (exported others)
-      (partition-list form-exported? forms)
-    (for-each (lambda (f)
-		(set-form-providers! f '())
-		(set-form-clients!   f '())
-		(set-form-used?!     f (form-exported? f)))
-	      forms)
-    (for-each set-form-providers forms)
-    (propogate-used?! exported)
-    (append (remove-unused-forms others) exported)))
-
-(define (set-form-providers form)
-  (for-each (lambda (n)
-	      (add-form-provider! (node-form n) form))
-	    (variable-refs (form-var form)))
-  (if (eq? (form-type form) 'alias)
-      (add-form-provider! form (variable->form (form-value form)))))
-
-(define (propogate-used?! forms)
-  (let loop ((to-do forms))
-    (if (not (null? to-do))
-	(let loop2 ((providers (form-providers (car to-do)))
-		    (to-do (cdr to-do)))
-	  (if (null? providers)
-	      (loop to-do)
-	      (loop2 (cdr providers)
-		     (let ((p (car providers)))
-		       (cond ((form-used? p)
-			      to-do)
-			     (else
-			      (set-form-used?! p #t)
-			      (cons p to-do))))))))))
-
-; Actually remove forms that are not referenced.
-
-(define (remove-unused-forms forms)
-;  (format #t "Removing unused forms~%")
-  (filter (lambda (f)
-	    (cond ((or (not (form-used? f))
-		       )
-		       ;(let ((value (form-value f)))
-			; (and (quote-exp? value)
-			 ;     (external-value? (quote-exp-value value))))
-;		   (format #t " ~S~%" (variable-name (form-var f)))
-		   (erase-variable (form-var f))
-		   (cond ((node? (form-value f))
-			  (erase (form-value f))
-			  (set-form-value! f #f)
-			  (set-form-lambdas! f '())))
-		   #f)
-		  (else #t)))
-	  forms))
-
-;------------------------------------------------------------
-; Total yucko.
-
-; (unknown-call (lambda e-vars e-body)
-;               protocol
-;               (vector-ref x offset)
-;               . args)
-; =>
-; (let (lambda ,vars
-;        (computed-goto
-;          ...
-;          (lambda ()
-;            (unknown-call (lambda ,copied-evars
-;                            (jump ,(car vars) ,copied-evars))
-;                          ,(vector-ref proc-vector i)
-;                          . ,(cdr vars)))
-;          ...
-;          '((offsets ...) ...)    ; offsets for each continuation
-;          ,offset))
-;      ,exit
-;      . ,args)
-
-(define (make-computed-goto form)
-  (let* ((ref (car (variable-refs (form-var form))))
-	 (in-form (node-form ref))
-	 (entries (vector->offset-map (call-args (lambda-body (form-node form))))))
-    (use-this-form! in-form)
-    (also-use-this-form! form)
-    (really-make-computed-goto (node-parent ref) entries)
-    (erase (form-node form))
-    (set-form-value! form #f)
-    (set-form-lambdas! form #f)
-    (simplify-node (form-node in-form))
-    (suspend-form-use! in-form)))
-
-; Returns a list ((<node> . <offsets>) ...) where <offsets> are where <node>
-; was found in VECTOR.  The first element of VECTOR is a marker which we
-; pretend isn't there.
-;
-; This would be more effective if done by a simplifier after the continuations
-; had been simplified.
-
-(define (vector->offset-map vector)
-  (let loop ((i 0) (res '()))
-    (if (= (+ i 1) (vector-length vector))
-	(reverse (map (lambda (p)
-			(cons (car p) (reverse (cdr p))))
-		      res))
-	(let ((n (vector-ref vector (+ i 1))))
-	  (loop (+ i 1)
-		(cond ((first (lambda (p)
-				(node-equal? n (car p)))
-			      res)
-		       => (lambda (p)
-			    (set-cdr! p (cons i (cdr p)))
-			    res))
-		      (else
-		       (cons (list n i) res))))))))
-
-
-(define (really-make-computed-goto vec-ref entries)
-  (let* ((exits (length entries))
-	 (offset (call-arg vec-ref 1))
-	 (vector-call (node-parent vec-ref))
-	 (args (sub-vector->list (call-args vector-call) 3))
-	 (call (make-call-node (get-prescheme-primop 'computed-goto)
-			       (+ 2 exits)
-			       exits))
-	 (arg-vars (map (lambda (arg) (make-variable 't (node-type arg)))
-			args))
-	 (protocol (literal-value (call-arg vector-call 2)))
-	 (cont (call-arg vector-call 0)))
-    (for-each detach args)
-    (attach call exits (make-literal-node (map cdr entries) #f))
-    (attach call (+ exits 1) (detach offset))
-    (receive (top continuations)
-	(if (reference-node? cont)
-	    (make-computed-goto-tail-conts call args arg-vars entries cont protocol)
-	    (make-computed-goto-conts call args arg-vars entries cont protocol))
-      (do ((i 0 (+ i 1))
-	   (l continuations (cdr l)))
-	  ((= i exits))
-	(attach call i (car l)))
-      (replace-body vector-call top))))
-    
-(define (make-computed-goto-tail-conts call args arg-vars entries cont protocol)
-  (let-nodes ((top (let 1 l1 . args))
-	      (l1 arg-vars call))
-    (values top (map (lambda (p)
-		       (computed-goto-tail-exit
-			(detach (car p))
-			protocol
-			(reference-variable cont)
-			arg-vars))
-		     entries))))
-
-(define (computed-goto-tail-exit node protocol cont-var arg-vars)
-  (let ((args (map make-reference-node arg-vars)))
-    (let-nodes ((l1 () (unknown-tail-call 0 (* cont-var)
-					  node
-					  '(protocol #f) . args)))
-      l1)))
-
-(define (make-computed-goto-conts call args arg-vars entries cont protocol)
-  (let ((cont-vars (lambda-variables cont))
-	(cont-type (make-arrow-type (map variable-type
-					 (lambda-variables cont))
-				    type/null)))
-    (detach cont)
-    (change-lambda-type cont 'jump)
-    (let-nodes ((top (let 1 l1 cont . args))
-		(l1 ((j cont-type) . arg-vars) call))
-      (values top
-	      (map (lambda (p)
-		     (computed-goto-exit (detach (car p))
-					 protocol
-					 arg-vars
-					 j
-					 cont-vars))
-		   entries)))))
-
-(define (computed-goto-exit node protocol arg-vars cont-var cont-vars)
-  (let* ((cont-vars (map copy-variable cont-vars))
-	 (cont-args (map make-reference-node cont-vars))
-	 (args (map make-reference-node arg-vars)))
-    (let-nodes ((l1 () (unknown-call 1 l2 node '(protocol #f) . args))
-		(l2 cont-vars (jump 0 (* cont-var) . cont-args)))
-      l1)))
-
diff --git a/ps-compiler/prescheme/front-end.scm b/ps-compiler/prescheme/front-end.scm
deleted file mode 100644
index 252d3a0..0000000
--- a/ps-compiler/prescheme/front-end.scm
+++ /dev/null
@@ -1,133 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-(define (prescheme-front-end package-ids spec-files copy no-copy shadow)
-  (receive (packages exports lookup)
-      (package-specs->packages+exports package-ids spec-files)
-    (let ((forms (flatten-definitions (scan-packages packages))))
-      (annotate-forms! (car package-ids) lookup exports copy no-copy shadow)
-      (receive (forms producer)
-	  (sort-forms forms)
-	(format #t "Checking types~%")
-	(let ((sorted (let loop ((forms '()))
-			(cond ((producer)
-			       => (lambda (f)
-				    (type-check-form f)
-				    (loop (cons f forms))))
-			      (else
-			       (reverse forms))))))
-;	  (format #t "Adding coercions~%")
-;	  (add-type-coercions (form-reducer forms))
-	  sorted)))))
-
-(define (form-reducer forms)
-  (lambda (proc init)
-    (let loop ((forms forms) (value init))
-      (if (null? forms)
-	  value
-	  (loop (cdr forms)
-		(proc (form-name (car forms))
-		      (form-value (car forms))
-		      value))))))
-
-(define (test id files)
-  ((structure-ref node reset-node-id))
-  ((structure-ref record-types reset-record-data!))
-  (prescheme-front-end id files '() '() '()))
-
-(define (annotate-forms! package-id lookup exports copy no-copy shadow)
-  (mark-forms! exports
-	       lookup
-	       (lambda (f) (set-form-exported?! f #t))
-	       "exported")
-  (mark-forms! copy
-	       lookup
-	       (lambda (f) (set-form-integrate! f 'yes))
-	       "to be copied")
-  (mark-forms! no-copy
-	       lookup
-	       (lambda (f) (set-form-integrate! f 'no))
-	       "not to be copied")
-  (for-each (lambda (data)
-	      (let ((owner (package-lookup lookup (caar data) (cadar data))))
-		(if owner
-		    (mark-forms! (cdr data)
-				 lookup
-				 (lambda (f)
-				   (set-form-shadowed! owner
-						       (cons (form-var f)
-							     (form-shadowed owner))))
-				 (format #f "shadowed in ~S" (car data)))
-		    (format #t "Warning: no definition for ~S, cannot shadow ~S~%"
-			    (car data) (cdr data)))))
-	    shadow))
-
-(define (mark-forms! specs lookup marker mark)
-  (let ((lose (lambda (p n)
-		(format #t "Warning: no definition for ~S, cannot mark as ~A~%"
-			(list p n) mark))))
-    (for-each (lambda (spec)
-		(let ((package-id (car spec))
-		      (ids (cdr spec)))
-		  (for-each (lambda (id)
-			      (cond ((package-lookup lookup package-id id)
-				     => marker)
-				    (else
-				     (lose package-id id))))
-			    ids)))
-	      specs)))
-
-(define (package-lookup lookup package-id id)
-  (let ((var (lookup package-id id)))
-    (and (variable? var)
-	 (maybe-variable->form var))))
-
-; Two possibilities:
-; 1. The variable is settable but the thunk gives it no particular value.
-; 2. A real value is or needs to be present, so we relate the type of
-; the variable with the type of the value.
-
-; thunk's value may be a STOB and not a lambda.
-
-(define (type-check-form form)
-  ;; (format #t "  ~S: " (variable-name (form-var form)))
-  (let* ((value (form-value form))
-	 (var (form-var form))
-	 (name (form-name form))
-	 (value-type (cond (((structure-ref nodes node?) value)
-			    (infer-definition-type value (source-proc form)))
-			   ((variable? value)
-			    (get-package-variable-type value))
-			   (else
-			    (bug "unknown kind of form value ~S" value)))))
-    (set-form-value-type! form value-type)
-    (cond ((not (variable-set!? var))
-	   (let ((type (cond ((eq? type/unknown (variable-type var))
-			      (let ((type (schemify-type value-type 0)))
-				(set-variable-type! var type)
-				type))
-			     (else
-			      (unify! value-type (get-package-variable-type var) form)
-			      value-type))))
-	     (if (not (type-scheme? type))
-		 (make-nonpolymorphic! type)) ; lock down any related uvars
-	     ;;(format #t "~S~%" (instantiate type))
-	     ))
-	  ((not (or (eq? type/unit value-type)
-		    (eq? type/null value-type)))
-	   (make-nonpolymorphic! value-type) ; no polymorphism allowed (so it
-	   ;; is not checked for, so there may be depth 0 uvars in the type)
-	   ;; (format #t " ~S~%" (instantiate value-type))
-	   (unify! value-type (get-package-variable-type var) form))
-	  ((eq? type/unknown (variable-type var))
-	   (get-package-variable-type var)))))
-
-(define (source-proc form)
-  (lambda (port)
-    (write-one-line port
-		    70
-		    (lambda (port)
-		      (format port "~S = ~S"
-			      (form-name form)
-			      ((structure-ref nodes schemify)
-			         (form-value form)))))))
diff --git a/ps-compiler/prescheme/hoist.scm b/ps-compiler/prescheme/hoist.scm
deleted file mode 100644
index c23de3c..0000000
--- a/ps-compiler/prescheme/hoist.scm
+++ /dev/null
@@ -1,162 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-; Move nested procedures out to top level.  We move them all out, then merge
-; as many as possible back together (see merge.scm), and finally check to
-; see if there are any out-of-scope references.
-
-(define (hoist-nested-procedures forms)
-  (set! *hoist-index* 0)
-  (let loop ((forms forms) (done '()))
-    (if (null? forms)
-	(reverse done)
-	(loop (cdr forms)
-	      (let ((form (car forms)))
-		(if (eq? 'lambda (form-type form))
-		    (append (really-hoist-nested-procedures form)
-			    (cons form done))
-		    (cons form done)))))))
-
-(define (really-hoist-nested-procedures form)
-  (let ((top     (form-value form))
-	(lambdas (form-lambdas form))
-	(lambda-parent lambda-env)	; Rename a couple of handy fields
-	(lambda-kids lambda-block)
-	(new-forms '()))
-;    (format #t " ~S: ~S~%" (form-name form) lambdas)
-;    (if (eq? 'read-list (form-name form))
-;	(breakpoint "read-list"))
-    (receive (procs others)
-	(find-scoping lambdas
-		      lambda-env set-lambda-env!
-		      lambda-block set-lambda-block!)
-      (set-form-lambdas! form (cons top (non-proc-lambdas (lambda-kids top))))
-      (map (lambda (proc)
-	     (let ((var (replace-with-variable proc)))
-	       (make-hoist-form proc
-				var
-				(form-name form)
-				(non-proc-lambdas (lambda-kids proc)))))
-	   (filter (lambda (p)
-		     (not (eq? p top)))
-		   procs)))))
-
-(define (non-proc-lambdas lambdas)
-  (filter (lambda (l)
-	    (not (or (eq? 'proc (lambda-type l))
-		     (eq? 'known-proc (lambda-type l)))))
-	  lambdas))
-
-(define (make-hoist-form value var hoisted-from lambdas)
-  (let ((form (make-form var #f #f)))
-    (set-form-node! form value (cons value lambdas))
-    (set-form-type! form 'lambda)
-    (set-variable-flags! var
-			 (cons (cons 'hoisted hoisted-from)
-			       (variable-flags var)))
-    form))
-
-(define (replace-with-variable node)
-  (let ((var (make-hoist-variable node)))
-    (case (primop-id (call-primop (node-parent node)))
-      ((let)
-       (substitute-var-for-proc (node-parent node) node var))
-      ((letrec2)
-       (substitute-var-for-proc-in-letrec (node-parent node) node var))
-      (else
-       (move node
-	     (lambda (node)
-	       (make-reference-node var)))))
-    var))
-
-(define (make-hoist-variable node)
-  (cond ((bound-to-variable node)
-	 => (lambda (var)
-	      (make-global-variable (generate-hoist-name (variable-name var))
-				    (variable-type var))))
-	(else
-	 (let* ((vars (lambda-variables node))
-		(type (make-arrow-type (map variable-type (cdr vars))
-				       (variable-type (car vars))))
-		(id (generate-hoist-name (or (lambda-name node) 'hoist))))
-	   (make-global-variable id type)))))
-    
-(define (substitute-var-for-proc call node value-var)
-  (let ((proc (call-arg call 0)))
-    (really-substitute-var-for-proc proc call node value-var)
-    (if (null? (lambda-variables proc))
-        (replace-body call (detach-body (lambda-body proc))))))
-
-(define (substitute-var-for-proc-in-letrec call node value-var)
-  (let ((proc (node-parent call)))
-    (really-substitute-var-for-proc proc call node value-var)
-    (if (null? (cdr (lambda-variables proc)))
-        (replace-body (node-parent proc)
-		      (detach-body (lambda-body (call-arg call 0)))))))
-
-(define (really-substitute-var-for-proc binder call node value-var)
-  (let* ((index (node-index node))
-         (var (list-ref (lambda-variables binder)
-			(- (node-index node) 1))))
-    (walk-refs-safely
-     (lambda (ref)
-       (replace ref (make-reference-node value-var)))
-     var)
-    (remove-variable binder var)
-    (detach node)
-    (remove-call-arg call index)))
-
-(define *hoist-index* 0)
-
-(define (generate-hoist-name sym)
-  (let ((i *hoist-index*))
-    (set! *hoist-index* (+ i 1))
-    (concatenate-symbol sym "." i)))
-
-;----------------------------------------------------------------
-; Part 2: checking for variables moved out of scope.
-
-(define (check-hoisting forms)
-  (let ((forms (filter (lambda (form)
-			 (or (eq? 'merged (form-type form))
-			     (eq? 'lambda (form-type form))))
-		       forms)))
-    (for-each (lambda (form)
-		(cond ((flag-assq 'hoisted (variable-flags (form-var form)))
-		       => (lambda (p)
-			    (check-hoisted-form form (cdr p))))))
-	      forms)))
-
-(define (check-hoisted-form form hoisted-from)
-  (let ((vars (find-unbound-variables (form-value form) (form-head form))))
-    (if (not (null? vars))
-	(user-error "Procedure ~S in ~S is closed over: ~S~%"
-		    (form-name form)
-		    hoisted-from
-		    (map variable-name vars)))))
-
-(define (find-unbound-variables node form)
-  (let ((unbound '())
-	(mark (cons 0 0)))
-    (let label ((n node))
-      (cond ((lambda-node? n)
-	     (let ((flag (node-flag n)))
-	       (set-node-flag! n mark)
-	       (label (lambda-body n))
-	       (set-node-flag! n flag)))
-	    ((call-node? n)
-	     (let ((vec (call-args n)))
-	       (do ((i 0 (+ i 1)))
-		   ((= i (vector-length vec)))
-		 (label (vector-ref vec i)))))
-	    ((reference-node? n)
-	     (let* ((v (reference-variable n))
-		    (b (variable-binder v)))
-	       (cond ((and b
-			   (not (eq? mark (node-flag b)))
-			   (not (variable-flag v)))
-		      (set-variable-flag! v #t)
-		      (set! unbound (cons v unbound))))))))
-    (filter (lambda (v)
-	      (set-variable-flag! v #f)
-	      (not (eq? form (form-head (node-form (variable-binder v))))))
-	    unbound)))
diff --git a/ps-compiler/prescheme/infer-early.scm b/ps-compiler/prescheme/infer-early.scm
deleted file mode 100644
index 0d283a8..0000000
--- a/ps-compiler/prescheme/infer-early.scm
+++ /dev/null
@@ -1,341 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-; Type checking nodes.
-
-; Entry point
-
-; Because NODE is not the car of a pair, this depends on lambdas not being
-; coerceable and literal nodes being coerced in place (instead of having a
-; call inserted).
-
-(define (infer-definition-type node name)
-  (set! *currently-checking* name)
-  (let ((res (cond ((literal-node? node)
-		    (infer-literal-type node name))
-		   ((lambda-node? node)
-		    (infer-type node 0))
-		   ((name-node? node)
-		    (get-global-type (binding-place (node-ref node 'binding))))
-		   (else
-		    (bug "definition value is not a value node ~S" node)))))
-    (set! *currently-checking* #f)
-    res))
-
-(define (infer-literal-type node name)
-  (let ((value (node-form node)))
-    (cond ((vector? value)
-	   (let ((uvar (make-uvar name -1)))
-	     (do ((i 0 (+ i 1)))
-		 ((>= i (vector-length value)))
-	       (unify! uvar (type-check-thing (vector-ref value i)) value))
-	     (make-pointer-type (maybe-follow-uvar uvar))))
-	  (else
-	   (infer-type node 0)))))
-
-(define (type-check-thing thing)
-  (if (variable? thing)
-      (get-package-variable-type thing)
-      (literal-value-type thing)))
-
-(define literal-operator (get-operator 'literal))
-
-(define (make-literal-node value)
-  (make-node literal-operator value))
-
-; Get the type of the variable - if it is a type-variable, then create a new
-; one and relate the two; if it is a polymorphic pattern, instantiate it.
-
-(define (get-package-variable-type var)
-  (let ((rep (variable-type var)))
-    (cond ((eq? rep type/undetermined)
-	   (let ((type (make-uvar (variable-name var) -1)))
-	     (set-variable-type! var type)
-	     (set-uvar-source! type var)
-	     type))
-	  ((type-scheme? rep)
-	   (instantiate-type-scheme rep -1))
-	  (else
-	   rep))))
-
-; Exported
-
-(define (get-variable-type var)
-  (let ((rep (variable-type var)))
-    (cond ((eq? rep type/undetermined)
-	   (bug "lexically bound variable ~S has no type" var))
-	  ((type-scheme? rep)
-	   (instantiate-type-scheme rep -1))
-	  (else
-	   rep))))
-
-;----------------------------------------------------------------
-
-(define (infer-type node depth)
-  (infer-any-type node depth #f))
-
-(define (infer-any-type node depth return?)
-  (let ((type ((operator-table-ref inference-rules (node-operator-id node))
-	       node
-	       depth
-	       return?)))
-    (set-node-type! node type)
-    (maybe-follow-uvar type)))
-
-(define inference-rules
-  (make-operator-table
-   (lambda (node depth return?)
-     (error "no type inference for node ~S" node))))
-
-(define (define-inference-rule name proc)
-  (operator-define! inference-rules name #f proc))
-
-(define-inference-rule 'literal
-  (lambda (node depth return?)
-    (infer-literal (node-form node) node)))
-
-(define-inference-rule 'quote
-  (lambda (node depth return?)
-    (infer-literal (cadr (node-form node)) node)))
-
-(define (infer-literal value node)
-  (literal-value-type value))
-
-(define (literal-value-type value)
-  (or (maybe-literal-value-type value)
-      (error "don't know type of literal ~S" value)))
-      
-(define (maybe-literal-value-type value)
-  (cond ((boolean? value)
-	 type/boolean)
-	((char? value)
-	 type/char)
-	((integer? value)
-	 type/integer)
-	((string? value)
-	 type/string)
-	(((structure-ref eval-node unspecific?) value)
-	 type/null)
-	((input-port? value)
-	 type/input-port)
-	((output-port? value)
-	 type/output-port)
-	((external-value? value)
-	 (external-value-type value))
-	((external-constant? value)
-         type/integer)
-	(else
-	 #f)))
-
-(define-inference-rule 'unspecific
-  (lambda (node depth return?)
-    type/null))
-
-(define-inference-rule 'lambda
-  (lambda (node depth return?)
-    (let* ((uid (unique-id))
-	   (exp (node-form node))
-	   (var-types (map (lambda (name-node)
-			     (initialize-name-node-type name-node uid depth))
-			   (cadr exp)))
-	   (result (infer-any-type (caddr exp) depth #t)))
-      ; stash the return type
-      (set-lambda-node-return-type! node result)
-      (make-arrow-type var-types result))))
-	
-; Create a new type variable for VAR.
-
-(define (initialize-name-node-type node uid depth)
-  (let ((uvar (make-uvar (node-form node) depth uid)))
-    (set-node-type! node uvar)
-    (set-uvar-source! uvar node)
-    uvar))
-
-; Get the type of the variable - if it is a type-variable, then create a new
-; one and relate the two; if it is a polymorphic pattern, instantiate it.
-; How to pass the source?
-
-(define-inference-rule 'name
-  (lambda (node depth return?)
-    (let ((type (if (node-ref node 'binding)
-		    (get-global-type (binding-place (node-ref node 'binding)))
-		    (node-type node))))
-      (if (not type)
-	  (bug "name node ~S has no type" node))
-      (if (type-scheme? type)
-	  (instantiate-type-scheme type depth)
-	  type))))
-
-(define-inference-rule 'primitive
-  (lambda (node depth return?)
-    (let ((type (get-global-type (cdr (node-form node)))))
-      (if (type-scheme? type)
-	  (instantiate-type-scheme type depth)
-	  type))))
-
-; If no type is present, create a type variable.
-
-(define (get-global-type value)
-  (if (location? value)
-      (literal-value-type (contents value))
-      (let ((has (maybe-follow-uvar (variable-type value))))
-	(cond ((not (eq? has type/undetermined))
-	       has)
-	      (else
-	       (let ((type (make-uvar (variable-name value) -1)))
-		 (set-variable-type! value type)
-		 (set-uvar-source! type value)
-		 type))))))
-
-(define-inference-rule 'set!
-  (lambda (node depth return?)
-    (let* ((exp (node-form node))
-	   (type (infer-type (caddr exp) depth))
-	   (binding (node-ref (cadr exp) 'binding)))
-      (if (not binding)
-	  (error "SET! on a local variable ~S" (schemify node)))
-      (unify! type (variable-type (binding-place binding)) node)
-      type/null)))
-
-(define-inference-rule 'call
-  (lambda (node depth return?)
-    (rule-for-calls (node-form node) node depth return?)))
-
-(define-inference-rule 'goto
-  (lambda (node depth return?)
-    (rule-for-calls (cdr (node-form node)) node depth return?)))
-
-(define (rule-for-calls proc+args node depth return?)
-  (let ((proc (car proc+args))
-	(args (cdr proc+args)))
-    (cond ((lambda-node? proc)
-	   (rule-for-let node depth proc args return?))
-	  ((primitive-node? proc)
-	   (rule-for-primitives node depth (node-form proc) args return?))
-	  (else
-	   (rule-for-unknown-calls node depth proc+args return?)))))
-
-(define name-node? (node-predicate 'name))
-(define lambda-node? (node-predicate 'lambda))
-(define literal-node? (node-predicate 'literal))
-(define primitive-node? (node-predicate 'primitive))
-
-(define (rule-for-let node depth proc args return?)
-  (let ((depth (+ depth 1))
-	(uid (unique-id))
-	(proc (node-form proc)))
-    (do ((names (cadr proc) (cdr names))
-	 (vals args (cdr vals)))
-	((null? names))
-      (let ((type (schemify-type (infer-type (car vals) depth) depth)))
-	(if (type-scheme? type)
-	    (set-node-type! (car names) type)
-	    (unify! (initialize-name-node-type (car names) uid depth)
-		    type
-		    node))))
-    (infer-any-type (caddr proc) depth return?)))
-
-(define (rule-for-primitives node depth primitive args return?)
-  ((primitive-inference-rule primitive)
-     args node depth return?))
-
-(define (rule-for-unknown-calls node depth proc+args return?)
-  (let ((proc-type (infer-type (car proc+args) depth))
-	(arg-types (infer-types (cdr proc+args) depth))
-	(return-type (if return?
-			 (make-tuple-uvar 'result depth)
-			 (make-uvar 'result depth))))
-    (unify! proc-type
-	    (make-arrow-type arg-types return-type)
-	    node)
-;    (if (= 244 (uvar-id return-type))
-;	(breakpoint "rule-for-unknown-calls"))
-    (maybe-follow-uvar return-type)))
-  
-(define (infer-types nodes depth)
-  (map (lambda (node)
-	 (infer-type node depth))
-       nodes))
-
-(define-inference-rule 'begin
-  (lambda (node depth return?)
-    (let loop ((exps (cdr (node-form node))) (type type/unit))
-      (if (null? exps)
-	  type
-	  (loop (cdr exps)
-		(infer-any-type (car exps)
-				depth
-				(or (not (null? (cdr exps)))
-				    return?)))))))
-
-; It would be nice if we could just try to unify the two arms and return
-; type/unit if we lost, but unification has side-effects.
-
-(define-inference-rule 'if
-  (lambda (node depth return?)
-    (let* ((args (cdr (node-form node)))
-	   (true-type (infer-any-type (cadr args) depth return?))
-	   (false-type (infer-any-type (caddr args) depth return?)))
-      (unify! (infer-type (car args) depth) type/boolean node)
-      (cond ((eq? true-type type/null)
-	     false-type)
-	    ((eq? false-type type/null)
-	     true-type)
-	    (else
-	     (unify! true-type false-type node)
-	     true-type)))))
-
-(define-inference-rule 'letrec
-  (lambda (node depth return?)
-    (let ((form (node-form node))
-	  (depth (+ depth 1))
-	  (uid (unique-id)))
-      (let ((names (map car (cadr form)))
-	    (vals (map cadr (cadr form))))
-	(for-each (lambda (name)
-		    (initialize-name-node-type name uid depth))
-		  names)
-	(do ((names names (cdr names))
-	     (vals vals (cdr vals)))
-	    ((null? names))
-	  (if (not (lambda-node? (car vals)))
-	      (error "LETREC value is not a LAMBDA: ~S" (schemify node)))
-	  (unify! (infer-type (car vals) depth)
-		  (node-type (car names))
-		  node))
-	(for-each (lambda (name)
-		    (let ((type (schemify-type (node-type name) depth)))
-		      (if (type-scheme? type)
-			  (set-node-type! name type))))
-		  names)
-	(infer-any-type (caddr form) depth return?)))))
-
-;--------------------------------------------------
-
-(define (node-type node)
-  (maybe-follow-uvar (node-ref node 'type)))
-
-(define (set-node-type! node type)
-  (node-set! node 'type type))
-
-(define (lambda-node-return-type node)
-  (node-ref node 'return-type))
-
-(define (set-lambda-node-return-type! node type)
-  (node-set! node 'return-type type))
-
-;--------------------------------------------------
-; Utility procedures used by the inferencers of the various primops.
-
-; Check that the INDEX'th argument of CALL has type TYPE.
-
-(define (check-arg-type args index type depth exp)
-  (if (null? args)
-      (begin
-	(format #t "Wrong number of arguments in ~S~% " (schemify exp))
-	(if *currently-checking*
-	    (format #t "~% while reconstructing the type of '~S'" *currently-checking*))
-	(error "type problem")))
-  (unify! (infer-type (list-ref args index) depth)
-	  type
-	  exp))
-
diff --git a/ps-compiler/prescheme/inference.scm b/ps-compiler/prescheme/inference.scm
deleted file mode 100644
index bf76912..0000000
--- a/ps-compiler/prescheme/inference.scm
+++ /dev/null
@@ -1,94 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-; Type Inference
-;
-; The entry points to the inferencer are:
-;
-; (unify! type1 type2 context)
-;   Unify TYPE1 and TYPE2.  CONTEXT is used to provide user feedback when type
-;   errors are detected.
-;
-; (make-uvar prefix depth . maybe-id)
-;   Makes a new type variable.  PREFIX is a symbol, DEPTH is the current type
-;   depth (used for polymorphism), and MAYBE-ID is an optional unique
-;   integer.
-;
-; (schemify-type type depth)
-;   Make TYPE polymorphic in any variables bound at DEPTH.
-;
-; (instantiate-type-scheme scheme depth)
-;   Return an instantiation of SCHEME at DEPTH.
-;
-; (reset-inference!)
-;   Clear various global variables (to be replaced with fluids at some point)
-
-
-(define (unify! type1 type2 context)
-  (cond ((really-unify! type1 type2)
-	 => (lambda (error-thunk)
-	      (unify-lost error-thunk type1 type2 context)))))
-
-(define *currently-checking* #f)
-(define *current-top-exp* #f)
-
-(define (unify-lost error-thunk type1 type2 context)
-  (cond ((eq? context 'simplifying)
-	 (bug "unification error while instantiating an integrable procedure"))
-	((eq? context 'make-monomorphic)
-	 #f)
-	(else
-	 (user-type-error-message error-thunk type1 type2 context))))
-
-(define (user-type-error-message error-thunk type1 type2 context)
-  (format #t "Type error in ~S~% " (schemify context))
-  (error-thunk)
-  (if *currently-checking*
-      (begin
-	(format #t "~% while reconstructing the type of~%  ")
-	(*currently-checking* (current-output-port))))
-  (error "type problem"))
-
-(define (really-unify! p1 p2)
-  (let ((p1 (maybe-follow-uvar p1))    ; get the current value of P1
-	(p2 (maybe-follow-uvar p2)))   ; get the current value of P2
-    (cond ((or (eq? p1 p2)
-	       (eq? p1 type/null)
-	       (eq? p2 type/null))
-	   #f)
-	  ((uvar? p1)
-	   (bind-uvar! p1 p2))
-	  ((uvar? p2)
-	   (bind-uvar! p2 p1))
-	  ((other-type? p1)
-	   (if (and (other-type? p2)
-		    (eq? (other-type-kind p1) (other-type-kind p2))
-		    (= (length (other-type-subtypes p1))
-		       (length (other-type-subtypes p2))))
-	       (unify-lists! (other-type-subtypes p1)
-			     (other-type-subtypes p2))
-	       (mismatch-failure p1 p2)))
-	  (else
-	   (mismatch-failure p1 p2)))))
-
-(define (mismatch-failure t1 t2)
-  (lambda ()
-    (format #t "type mismatch~% ")
-    (display-type t1 (current-output-port))
-    (format #t "~% ")
-    (display-type t2 (current-output-port))))
-
-(define (unify-lists! l1 l2)
-  (let loop ((l1 l1) (l2 l2))
-    (if (null? l1)
-	#f
-	(or (really-unify! (car l1) (car l2))
-	    (loop (cdr l1) (cdr l2))))))
-
-(define (type-conflict message . stuff)
-  (apply breakpoint message stuff))
-
-; For debugging
-(define (uvar-name uvar)
-  (concatenate-symbol (uvar-prefix uvar) "." (uvar-id uvar)))
-
diff --git a/ps-compiler/prescheme/interfaces.scm b/ps-compiler/prescheme/interfaces.scm
deleted file mode 100644
index 0a91a57..0000000
--- a/ps-compiler/prescheme/interfaces.scm
+++ /dev/null
@@ -1,215 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-(define-interface ps-primop-interface
-  (export get-prescheme-primop
-          (define-scheme-primop :syntax)
-          (define-polymorphic-scheme-primop :syntax)
-          (define-nonsimple-scheme-primop :syntax)
-          (define-scheme-cond-primop :syntax)
-
-	  prescheme-integer-size
-	  lshr))
-
-(define-interface ps-c-primop-interface
-  (export simple-c-primop?
-          primop-generate-c
-          (define-c-generator :syntax)))
-
-(define-interface ps-type-interface
-  (export ;type/int7u
-          ;type/int8
-          ;type/int8u
-          type/integer
-          type/float
-	  type/char
-	  type/address
-
-          type/null
-          type/unit
-          type/boolean
-          type/undetermined
-          type/input-port
-          type/output-port
-
-          type/unknown
-          type/string
-
-          other-type?
-          other-type-kind
-          other-type-subtypes
-          make-other-type
-
-          base-type?
-          base-type-name
-	  base-type-uid
-	  make-atomic-type
-
-          make-arrow-type
-          arrow-type?
-          arrow-type-result
-          arrow-type-args
-
-          make-pointer-type
-          pointer-type?
-          pointer-type-to
-
-	  make-tuple-type
-	  tuple-type?
-	  tuple-type-types
-
-	  record-type?
-
-          lookup-type
-
-          type-scheme?
-          schemify-type
-          instantiate-type-scheme
-          copy-type
-          type-scheme-type
-          make-nonpolymorphic!
-
-          type-scheme-free-uvars           ; for error messages
-;          type-scheme-lattice-uvars
-;          type-scheme-type
-
-          type-eq?
-;          type>
-;          type>=
-
-;          lattice-type?
-
-	  expand-type-spec
-
-          finalize-type
-
-          display-type
-
-	  make-base-type-table
-          ))
-
-(define-interface type-variable-interface
-  (export make-uvar
-	  make-tuple-uvar
-          uvar?
-          maybe-follow-uvar
-          uvar-source set-uvar-source!
-
-          reset-type-vars!
-
-          uvar-binding set-uvar-binding!
-          uvar-prefix
-          uvar-id
-	  uvar-temp set-uvar-temp!
-
-          bind-uvar!
-
-          unique-id
-          ))
-
-(define-interface record-type-interface
-  (export reset-record-data!
-	  all-record-types
-	  get-record-type
-	  record-type-name
-	  record-type-fields
-	  get-record-type-field
-	  record-field-record-type
-	  record-field-name
-	  record-field-type))
-
-(define-interface inference-interface
-  (export infer-definition-type
-	  get-package-variable-type
-	  get-variable-type
-          ;add-type-coercions
-	  node-type
-	  lambda-node-return-type))
-
-(define-interface inference-internal-interface
-  (export unify!
-	  infer-type infer-types
-          check-arg-type
-          literal-value-type
-          ))
-
-(define-interface form-interface
-  (export make-form
-          form?
-          form-value
-          set-form-value!
-	  form-value-type
-	  set-form-value-type!
-	  node-form
-          set-form-node!
-          set-form-integrate!
-          set-form-exported?!
-	  form-node
-          form-var
-          form-exported?
-          form-type
-          set-form-type!
-          form-free set-form-free!
-	  suspend-form-use!
-	  use-this-form!
-	  also-use-this-form!
-	  set-form-lambdas!
-          form-lambdas
-          form-name
-          form-merge set-form-merge!
-          form-providers set-form-providers!
-          form-clients set-form-clients!
-	  form-shadowed set-form-shadowed!
-            
-	  variable-set!? note-variable-set!!
-	  make-form-unused!
-          variable->form
-          maybe-variable->form
-            
-          ; high level stuff
-          sort-forms
-          expand-and-simplify-form
-          remove-unreferenced-forms
-          integrate-stob-form
-          resimplify-form
-          ))
-
-(define-interface linking-interface
-  (export package-specs->packages+exports
-	  package-source
-          define-prescheme!
-	  prescheme-compiler-env
-          ))
-
-(define-interface c-internal-interface
-  (export c-assignment
-          indent-to
-          c-argument-var
-          form-tail-called?
-          *doing-tail-called-procedure?*
-          merged-procedure-reference
-          goto-protocol?
-          c-ify
-          c-value
-          form-value
-          form-name
-          form-c-name
-          form-type
-          c-assign-to-variable
-          write-c-identifier
-          write-value-list
-	  write-value-list-with-extras
-          write-value+result-var-list
-          form-return-count
-          set-form-return-count!
-          simple-c-primop
-          c-variable
-          *current-merged-procedure*
-          *extra-tail-call-args*
-          write-c-block
-          write-c-coercion
-          no-value-node?
-          display-c-type
-	  add-c-type-declaration!
-	  note-jump-generated!
-          ))
-
diff --git a/ps-compiler/prescheme/linking.scm b/ps-compiler/prescheme/linking.scm
deleted file mode 100644
index 677f004..0000000
--- a/ps-compiler/prescheme/linking.scm
+++ /dev/null
@@ -1,236 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-; This file has the Pre-Scheme compiler's code for dealing with the
-; Scheme 48's module system.
-
-; FILES is a list of files that contain structure definitions, including
-; a definition for NAME.  The files are loaded into a config package
-; containing:
-;   - the procedures and macros for defining structures and interfaces
-;   - a Pre-Scheme structure (called PRESCHEME)
-;   - a ps-memory structure
-;   - a ps-receive structure
-;   - the STRUCTURE-REFS structure
-; We then return:
-;   1. a list of the packages required to implement the named structures
-;   2. a list of the names exported by the named structures
-;   3. a procedure that for looking up names defined in packages in the
-;      config package (this is used to map user directives to their targets)
-
-(define (package-specs->packages+exports struct-names files)
-  (let ((config (make-very-simple-package 'config (list defpackage)))
-	(old-config ((structure-ref package-commands-internal config-package))))
-    (environment-define! config 'prescheme prescheme)
-    (environment-define! config 'ps-memory ps-memory)
-    (environment-define! config 'ps-receive ps-receive)
-    (environment-define! config 'ps-record-types ps-record-types)
-    (environment-define! config 'structure-refs structure-refs)
-    (environment-define! config ':syntax (structure-ref meta-types syntax-type))
-    (set-reflective-tower-maker! config (get-reflective-tower-maker old-config))
-    (let-fluids (structure-ref packages-internal $get-location)
-		get-variable
-		(structure-ref reading-forms $note-file-package)
-		(lambda (filename package) (values))
-      (lambda () 
-	(for-each (lambda (file)
-		    (load file config))
-		  files)))
-    (values (collect-packages (map (lambda (name)
-				     (environment-ref config name))
-				   struct-names)
-			      (lambda (package)
-				#t))
-	    (let ((names '()))
-	      (for-each (lambda (struct-name)
-			  (let ((my-names '()))
-			    (for-each-declaration
-			     (lambda (name type)
-			       (set! my-names (cons name my-names)))
-			     (structure-interface (environment-ref config struct-name)))
-			    (set! names (cons (cons struct-name my-names) names))))
-			struct-names)
-	      names)
-	    (make-lookup config))))
-
-; This creates new variables as needed for packages.
-
-(define (get-variable package name)
-  ;(format #t "Making variable ~S for ~S~%" name package)
-  ((structure-ref variable make-global-variable)
-     name
-     (structure-ref ps-types type/unknown)))
-
-; Return something that will find the binding of ID in the package belonging
-; to the structure PACKAGE-ID in the CONFIG package.
-
-(define (make-lookup config)
-  (lambda (package-id id)
-    (let ((binding (package-lookup config package-id)))
-      (if (and (binding? binding)
-	       (location? (binding-place binding))
-	       (structure? (contents (binding-place binding))))
-	  (let* ((package (structure-package
-			   (contents (binding-place binding))))
-		 (binding (package-lookup package id)))
-	    (if (binding? binding)
-		(binding-place binding)
-		#f))
-	  #f))))
-	       
-;----------------------------------------------------------------
-; Handy packages and package making stuff.
-
-(define defpackage     (structure-ref built-in-structures defpackage))
-(define structure-refs (structure-ref built-in-structures structure-refs))
-(define scheme         (structure-ref built-in-structures scheme))
-
-(define (make-env-for-syntax-promise . structures)
-  (make-reflective-tower eval structures 'prescheme-linking))
-
-(define (make-very-simple-package name opens)
-  (make-simple-package opens
-		       eval
-		       (make-env-for-syntax-promise scheme)
-		       name))
-
-(define (get-reflective-tower-maker p)
-  (environment-ref p (string->symbol ".make-reflective-tower.")))
-
-;----------------------------------------------------------------
-; The following stuff is used to define the DEFINE-RECORD-TYPE macro.
-; We produce a structure that exports EXPAND-DEFINE-RECORD-TYPE.  The
-; base package then includes that structure in its FOR-SYNTAX package.
-
-(define defrecord-for-syntax-package
-  (make-very-simple-package 'defrecord-for-syntax-package '()))
-
-(define defrecord-for-syntax-structure
-  (make-structure defrecord-for-syntax-package
-		  (lambda () (export expand-define-record-type))
-		  'defrecord-for-syntax-structure))
-
-(define (define-for-syntax-value id value)
-  (let ((loc (make-new-location defrecord-for-syntax-package id)))
-    (set-contents! loc value)
-    (package-define! defrecord-for-syntax-package
-		     id
-		     (structure-ref meta-types usual-variable-type)
-		     loc
-		     #f)))
-
-(define-for-syntax-value 'expand-define-record-type expand-define-record-type)
-
-;----------------------------------------------------------------
-; BASE-PACKAGE contains all of the primitives, syntax, etc. for Pre-Scheme
-
-(define (prescheme-unbound package name)
-  (bug "~S has no binding in package ~S" name package))
-
-(define base-package
-;  (let-fluid (structure-ref packages-internal $get-location) prescheme-unbound
-;    (lambda () ))
-  (make-simple-package '()
-		       eval
-		       (make-env-for-syntax-promise
-			  scheme
-			  defrecord-for-syntax-structure)
-		       'base-package))
-
-; Add the operators.
-
-(let ((syntax-type (structure-ref meta-types syntax-type)))
-  (for-each (lambda (id)
-	      (package-define! base-package
-			       id
-			       syntax-type
-			       #f
-			       (get-operator id syntax-type)))
-	    '(if begin lambda letrec quote set!
-		 define define-syntax let-syntax
-		 goto real-external)))  ; special for Prescheme
-
-; Add the usual macros.
-
-(let ((syntax-type (structure-ref meta-types syntax-type)))
-  (for-each (lambda (name)
-	      (package-define! base-package
-			       name
-			       syntax-type
-			       #f
-			       (make-transform
-			         (usual-transform name)
-				 base-package
-				 (structure-ref meta-types syntax-type)
-				 `(usual-transform ',name)
-				 name)))
-	    '(and cond do let let* or quasiquote syntax-rules))) ; delay
-
-; Plus whatever primitives are wanted.
-
-(define (define-prescheme! name location static)
-  (package-define! base-package
-		   name
-		   (structure-ref meta-types usual-variable-type)
-		   location
-		   static))
-
-; Copy over the enumeration macros and the ERRORS enumeration.
-
-(define (import-syntax! package-id name)
-  (let ((config ((structure-ref package-commands-internal config-package)))
-	(syntax-type (structure-ref meta-types syntax-type)))
-    (let ((binding (structure-lookup (environment-ref config package-id)
-				     name
-				     #t)))
-      (package-define! base-package
-		       name
-		       syntax-type
-		       (binding-place binding)
-		       (binding-static binding)))))
-
-(import-syntax! 'enumerated 'define-enumeration)
-(import-syntax! 'enumerated 'enum)
-(import-syntax! 'enumerated 'name->enumerand)
-(import-syntax! 'enumerated 'enumerand->name)
-(import-syntax! 'prescheme  'errors)
-(import-syntax! 'prescheme  'define-external-enumeration)
-
-; define still more syntax
-
-(load "prescheme/ps-syntax.scm" base-package)
-
-(eval '(define-syntax define-record-type expand-define-record-type)
-      base-package)
-
-;----------------------------------------------------------------
-; Make the Pre-Scheme structure and related structures
-
-(define (get-interface name)
-  (environment-ref ((structure-ref package-commands-internal config-package))
-		   name))
-
-(define prescheme
-  (make-structure base-package
-		  (lambda () (get-interface 'prescheme-interface))
-		  'prescheme))
-
-(define ps-memory
-  (make-structure base-package
-		  (lambda () (get-interface 'ps-memory-interface)) 
-		  'ps-memory))
-
-(define ps-receive
-  (make-structure base-package
-		  (lambda () (get-interface 'ps-receive-interface)) 
-		  'ps-receive))
-
-(define ps-record-types
-  (make-structure base-package
-                  (lambda () (export (define-record-type :syntax)))
-                  'ps-record-types))
-
-; and a handy environment
-
-(define prescheme-compiler-env
-  (package->environment base-package))
-
diff --git a/ps-compiler/prescheme/merge.scm b/ps-compiler/prescheme/merge.scm
deleted file mode 100644
index 806f71a..0000000
--- a/ps-compiler/prescheme/merge.scm
+++ /dev/null
@@ -1,296 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-; This code determines which procedures are called from one other form, and
-; thus can be compiled as part of that form and called with a `goto' instead
-; of a normal procedure call.  This saves much of the overhead of a normal
-; procedure call.
-;
-; The procedures to be merged are annotated; no code is changed.
-
-(define-subrecord form form-merge form-merge
-  ((head)           ; self or the form into which this one will be merged
-   )
-  (
-   (status #f)      ; one of #F, DO-NOT-MERGE, MERGED
-   tail-clients     ; forms that call this one tail-recursively, this is an
-                    ; a-list of forms and reference nodes
-   (tail-providers '()) ; forms that are used by this one, this is a simple list
-   (merged '())     ; forms merged with this one
-   (return-count 0) ; how many returns have been generated so far
-   temp             ; handy utility field
-   ))
-
-; Two procedures for letting the user know what is going on.
-
-(define (show-merges form)
-  (let ((merges (form-merged form)))
-    (if (not (null? merges))
-	(format #t " ~S: ~S~%" (form-name form) (map form-name merges)))))
-
-(define (show-providers form)
-  (cond ((eq? (form-type form) 'lambda)
-	 (format #t "~S ~A~%"
-		 (form-name form)
-		 (if (form-exported? form) " (exported)" ""))
-	 (cond ((or (not (null? (form-providers form)))
-		    (not (null? (form-tail-providers form))))
-		(format #t "  ~S~%  ~S~%"
-			(map form-name (form-providers form))
-			(map form-name (form-tail-providers form))))))))
-
-; Note that OTHERS should be merged with FORM.
-
-(define (do-merge form others)
-  (let ((form (form-head form))
-	(secondary (apply append (map form-merged others))))
-    (set-form-merged! form (append others
-				   secondary
-				   (form-merged form)))
-    (for-each (lambda (f)
-		(set-form-head! f form))
-	      secondary)
-    (for-each (lambda (f)
-		(set-form-head! f form)
-		(set-form-status! f 'merged)
-		(set-form-type! f 'merged)
-		(set-form-merged! f '()))
-	      others)))
-
-; Returns the merged form, if any, to which NODE is a reference.
-
-(define (merged-procedure-reference node)
-  (cond ((and (reference-node? node)
-	      (maybe-variable->form (reference-variable node)))
-	 => (lambda (form)
-	      (if (eq? 'merged (form-type form))
-		  form
-		  #f)))
-	(else #f)))
-
-; Is FORM ever tail called?
-
-(define (form-tail-called? form)
-  (and (or (eq? 'lambda (form-type form))
-	   (eq? 'merged (form-type form)))
-       (memq? 'tail-called (variable-flags (form-var form)))))
-
-; Annotate FORM if it is in fact called tail-recursively anywhere.
-
-(define (note-tail-called-procedure form)
-  (if (and (eq? 'lambda (form-type form))
-	   (or (any (lambda (r)
-		      (used-as-label? r))
-		    (variable-refs (form-var form)))
-	       (eq? 'tail-called (lambda-protocol (form-value form)))))
-      (set-variable-flags! (form-var form)
-			   (cons 'tail-called
-				 (variable-flags (form-var form))))))
-
-(define (used-as-label? node)
-  (and (node? (node-parent node))
-       (goto-call? (node-parent node))
-       (= 1 (node-index node))))
-
-;------------------------------------------------------------
-; Entry point.
-;
-; First marks the tail-called procedures and adds the MERGE slots to the
-; forms.  The C code generator expects FORM-MERGED to work, even if no
-; actual merging was done.
-;
-; Three steps:
-;  Find the call graph.
-;  Merge the tail-called forms.
-;  Merge the non-tail-called forms. 
-
-(define *merge-forms?* #t)
-
-(define (merge-forms forms)
-  (for-each (lambda (f)
-	      (note-tail-called-procedure f)
-	      (set-form-merge! f (form-merge-maker f))
-	      (set-form-providers! f '()))
-	    forms)
-  (if *merge-forms?*
-      (let ((mergable-forms (filter determine-merger-graph forms)))
-	(format #t "Call Graph:~%<procedure name>~%")
-	(format #t "  <called non-tail-recursively>~%")
-	(format #t "  <called tail-recursively>~%")
-	(for-each show-providers forms)
-	(format #t "Merging forms~%")
-	(receive (tail other)
-	    (partition-list (lambda (f) (null? (form-clients f)))
-			    mergable-forms)
-	  (merge-tail-forms tail)
-	  (for-each merge-non-tail-forms forms)
-	  (for-each show-merges forms)
-	  (values)))))
-
-; The only forms that can be merged are those that:
-;  are lambdas,
-;  all uses are calls,
-;  are not exported, and
-;  every loop containing a non-tail-recursive call must contain a call to
-;  at least one non-merged procedure.
-; 
-; This code doesn't use the last criterion.  Instead it makes sure that each
-; procedure is called exclusively tail-recursively or non-tail-recursively
-; and doesn't allow non-tail-recursion in loops at all.
-
-(define (determine-merger-graph form)
-  (cond ((and (eq? 'lambda (form-type form))
-	      (really-determine-merger-graph form)
-	      (not (form-exported? form))
-	      (or (null? (form-clients form))
-		  (null? (form-tail-clients form))))
-	 #t)
-	(else
-	 (set-form-status! form 'do-not-merge)
-	 #f)))
-
-; Loop down the references to FORM's variable adding FORM to the providers
-; lists of the forms that reference the variable, and adding those forms
-; to FORM's clients lists.  OKAY? is #T if all references are calls.
-
-; The full usage graph is needed, even if there are uses of the form's value
-; that are not calls.
-
-(define (really-determine-merger-graph form)
-  (let loop ((refs (variable-refs (form-var form)))
-	     (clients '()) (tail-clients '()) (okay? #t))
-    (cond ((null? refs)
-	   (set-form-clients! form clients)
-	   (set-form-tail-clients! form tail-clients)
-	   okay?)
-	  (else
-	   (let* ((r (car refs))
-		  (f (node-form (car refs))))
- 	     (if (and (called-node? r)
- 		      (or (calls-this-primop? (node-parent r) 'tail-call)
- 			  (calls-this-primop? (node-parent r) 'unknown-tail-call)))
- 		 (loop (cdr refs)
- 		       clients
- 		       (add-to-client-list tail-clients r form f
- 					   form-tail-providers
- 					   set-form-tail-providers!)
- 		       okay?)
- 		 (loop (cdr refs)
- 		       (add-to-client-list clients r form f
- 					   form-providers
- 					   set-form-providers!)
- 		       tail-clients
- 		       (and okay? (called-node? r)))))))))
-
-(define (add-to-client-list client-list ref form f getter setter)
-  (cond ((assq f client-list)
-	 => (lambda (p)
-	      (set-cdr! p (cons ref (cdr p)))
-	      client-list))
-	(else
-	 (setter f (cons form (getter f)))
-	 (cons (list f ref) client-list))))
-
-; These forms are non-exported procedures that are always tail-called.
-; Strongly connected components of the call graph that have a single
-; entry point, whether in the component or not, are merged.
-; This depends on STRONGLY-CONNECTED-COMPONENTS returning the components
-; in a reverse topologically sorted order (which it does).
-
-(define (merge-tail-forms forms)
-  (for-each merge-tail-loop
-	    (reverse (strongly-connected-components
-		      forms
-		      (lambda (f)
-			(filter (lambda (f) (memq? f forms))
-				(map car (form-tail-clients f))))
-		      form-temp
-		      set-form-temp!))))
-
-; ENTRIES are the forms in the loop that are called from outside.
-; FORMS is used as a unique identifier here.
-
-(define (merge-tail-loop forms)
-  (for-each (lambda (f) (set-form-temp! f forms)) forms)
-  (receive (entries other)
-      (partition-list (lambda (f)
-			(any? (lambda (p)
-				(not (eq? forms
-					  (form-temp (car p)))))
-			      (form-tail-clients f)))
-		      forms)
-    (cond ((single-outside-client (if (null? entries)
-				      other
-				      entries)
-				  forms)
-	   => (lambda (f) (do-merge f forms)))
-	  ((and (not (null? entries))
-		(null? (cdr entries))
-		(not (null? other)))
-	   (do-merge (car entries) other)))
-    (for-each (lambda (f) (set-form-temp! f #f)) forms)))
-
-; This checks to see if all non-FLAGged clients of ENTRIES are in
-; fact a single form, and then returns that form.
-; Forms that have already been merged into another form are treated as that
-; other form (by using FORM-HEAD).
-
-(define (single-outside-client entries flag)
-  (let loop ((entries entries) (form #f))
-    (if (null? entries)
-	form
-	(let loop2 ((clients (form-tail-clients (car entries))) (form form))
-	  (cond ((null? clients)
-		 (loop (cdr entries) form))
-		((eq? (form-temp (caar clients)) flag)
-		 (loop2 (cdr clients) form))
-		((not form)
-		 (loop2 (cdr clients) (form-head (caar clients))))
-		((eq? (form-head (caar clients)) form)
-		 (loop2 (cdr clients) form))
-		(else
-		 #f))))))
-
-; Merge the forms used by FORM into it if possible.
-
-(define (merge-non-tail-forms form)
-  (for-each (lambda (f)
-	      (maybe-merge-non-tail-form f (form-head form)))
-	    (form-providers form)))
-
-; If FORM is not INTO, has not been merged before, and is only used by
-; INTO, then merge FORM into INTO and recursively check the forms used
-; by FORM.
-
-(define (maybe-merge-non-tail-form form into)
-  (cond ((and (not (eq? form into))
-	      (not (form-status form))
-	      (every? (lambda (p)
-			(eq? (form-head (car p)) into))
-		      (form-clients form)))
-	 (do-merge into (list form))
-	 (for-each tail-call->call
-		   (variable-refs (form-var form)))
-	 (for-each tail-call->call
-		   (variable-refs (car (lambda-variables (form-node form)))))
-	 (for-each (lambda (f)
-		     (maybe-merge-non-tail-form f into))
-		   (form-providers form)))))
-
-; Replace tail calls with calls to make the code generator's job easier.
-; The user didn't say that these calls had to be tail-recursive.
-
-(define (tail-call->call ref)
-  (let ((call (node-parent ref)))
-    (if (or (calls-this-primop? call 'tail-call)
-	    (calls-this-primop? call 'unknown-tail-call))
-	(let ((type (arrow-type-result (node-type (call-arg call 1)))))
-	  (move (call-arg call 0)
-		(lambda (cont)
-		  (let-nodes ((new-cont ((v type)) (return 0 cont (* v))))
-		    new-cont)))
-	  (set-call-exits! call 1)
-	  (set-call-primop! call
-			    (get-primop (if (calls-this-primop? call 'tail-call)
-					    (enum primop call)
-					    (enum primop unknown-call))))))))
-  
\ No newline at end of file
diff --git a/ps-compiler/prescheme/node-type.scm b/ps-compiler/prescheme/node-type.scm
deleted file mode 100644
index f5356c3..0000000
--- a/ps-compiler/prescheme/node-type.scm
+++ /dev/null
@@ -1,78 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-; Types and nodes together
-
-; Instantiate TYPE and replace the types in NODE with their corresponding
-; value.  LOCATION is where NODE will be applied, and is used to get the actual
-; types of the arguments.
-
-(define (instantiate-type&value type node location)
-  (let ((has (instantiate-type-scheme type
-				      -1
-				      (lambda () (fix-types node))))
-	(wants (call->proc-type (node-parent location))))
-    (identity (unify! has wants 'simplifying))))
-;	  (format #t "~%Reconstructing ")
-;	  (pp-cps call)
-;	  (format #t " has   ~S~% wants ~S~%"
-;		  (instantiate has)
-;		  (instantiate wants))
-;	  (breakpoint "reconstructing ~S" call)
-;	  (unify! has wants 'simplifying)
-
-; This is used to replace all references in NODE to polymorphic type variables
-; with the current value of the type variable.
-; Youch!  Very inefficient - may make many copies of the same type.
-
-(define (fix-types node)
-  (let label ((node node))
-    (case (node-variant node)
-      ((lambda)
-       (for-each fix-variable (lambda-variables node))
-       (label (lambda-body node)))
-      ((call)
-       (walk-vector label (call-args node)))
-      ((literal)
-       (let ((value (literal-value node)))
-	 (if (or (uvar? value)
-		 (other-type? value))
-	     (set-literal-value! node (copy-type value))))))))
-
-(define (fix-variable var)
-  (set-variable-type! var (copy-type (variable-type var))))
-
-(define (call->proc-type call)
-  (let ((end (if (or (calls-this-primop? call 'call)
-		     (calls-this-primop? call 'tail-call))
-		 2        ; no protocol to ignore
-		 3)))     ; protocol to ignore
-    (make-arrow-type (do ((i (- (vector-length (call-args call)) 1) (- i 1))
-			  (ts '() (cons (maybe-instantiate
-					 (node-type (call-arg call i)))
-					ts)))
-			 ((< i end)
-			  ts))
-		     (let ((cont (call-arg call 0)))
-		       (if (reference-node? cont)
-			   (variable-type (reference-variable cont))
-			   (make-tuple-type (map variable-type
-						 (lambda-variables cont))))))))
-
-(define (maybe-instantiate type)
-  (if (type-scheme? type)
-      (instantiate-type-scheme type -1)
-      type))
-
-(define (make-monomorphic! var)
-  (let ((type (type-scheme-type (variable-type var))))
-    (for-each (lambda (ref)
-		(if (not (called-node? ref))
-		    (error
-		     "polymorphic procedure ~S used as value, cannot be made monomorphic"
-		     (variable-name var))
-		    (unify! type
-			    (call->proc-type (node-parent ref))
-			    'make-monomorphic!)))
-	      (variable-refs var))
-    (set-variable-type! var type)))
\ No newline at end of file
diff --git a/ps-compiler/prescheme/package-defs.scm b/ps-compiler/prescheme/package-defs.scm
deleted file mode 100644
index fbdf27f..0000000
--- a/ps-compiler/prescheme/package-defs.scm
+++ /dev/null
@@ -1,310 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-; Pre-Scheme packages
-
-; Everything else
-
-(define-structures ((prescheme-compiler (export)))
-  (open scheme big-scheme conditions comp-util structure-refs
-	prescheme-front-end prescheme-display
-	parameters
-	node
-	front-debug forms
-	ps-types
-	type-variables
-	c
-	structure-refs
-	primop-data
-	c-primop-data
-	jump                 ;find-jump-procs procs->jumps 
-	record-types         ;reset-record-data!
-	node-types
-	front                ;simplify-all
-	simplify)            ;simplify-node
-  (files top))
-
-(define-structures ((prescheme-display (export display-forms-as-scheme)))
-  (open scheme big-scheme
-	structure-refs
-	names
-	bindings		;binding-place
-	nodes
-	variable primop external-values ps-primitives
-	flatten-internal	;generated-top-variable?
-	external-constants)
-  (access forms)		;form-value form-var
-  (files display))
-
-(define-structures ((protocol (export normal-protocol
-				      goto-protocol
-				      goto-protocol?)))
-  (open scheme big-scheme comp-util set-parameters ps-primops ps-types node)
-  (files spec))
-
-(define-structures ((prescheme-front-end (export prescheme-front-end)))
-  (open scheme big-scheme comp-util structure-refs
-	linking expand flatten forms
-	ps-types inference
-	variable
-	primitive-data
-	primop-data
-	inference-internal  ; unify!
-	type-variables)     ; reset-type-vars!
-  (access nodes		    ; node? schemify
-	  node              ; reset-node-id
-	  record-types)     ; reset-record-types!    
-  (files front-end))
-
-(define-structures ((forms form-interface))
-  (open scheme big-scheme comp-util node expand defrecord
-	node-vector queues to-cps
-	structure-refs
-	eval-node         ; closure stuff
-	ps-primops        ; get-prescheme-primop
-	simplify-internal ; simplify-node simplify-args
-	front             ; simplify-all
-	ps-types          ; type/undetermined
-	type-variables    ; maybe-follow-uvar
-	node-types)       ; instantiate-type&value
-  (access nodes)          ; node-predicate
-  (files form))
-
-; Translating Scheme into evaluated nodes
-
-(define-structures ((expand (export scan-packages)))
-  (open scheme big-scheme comp-util structure-refs
-	variable
-	bindings nodes
-	ps-primitives   ;eval-primitive
-	eval-node       ;eval-node
-	scan-package	;package-source
-	locations
-	util		;fold
-	syntactic)
-  (access packages)     ;package->environment
-  (files expand))
-
-; Eval and type information on Pre-Scheme primitives
-
-(define-structures ((ps-primitives (export primitive?
-					   make-primitive
-					   eval-primitive
-					   primitive-id
-					   primitive-source
-					   primitive-expander
-					   primitive-expands-in-place?
-					   primitive-inference-rule)))
-  (open scheme big-scheme comp-util defrecord)
-  (files primitive))
-
-(define-structures ((primitive-data (export)))
-  (open scheme big-scheme comp-util ps-primitives
-	bindings nodes
-	ascii structure-refs
-	ps-primops		;get-prescheme-primop
-	linking			;define-prescheme!
-	inference-internal	;check-arg-type
-	type-variables		;make-arith-op-uvar
-	record-types
-	prescheme ps-memory
-	ps-types external-constants external-values
-	locations
-	eval-node)  ; closure?  (to keep them from being made immutable)
-  (access variable)   ; variable-name
-  (files (primop scm-scheme)
-	 (primop scm-arith)
-	 (primop scm-memory)
-	 (primop scm-record)))
-
-(define-structures ((eval-node (export eval-node
-				       closure? closure-node closure-env
-				       make-top-level-closure
-				       closure-temp set-closure-temp!
-				       apply-closure
-				       unspecific? constant?)))
-  (open scheme define-record-types
-	nodes
-	ps-types		;expand-type-spec
-	external-values
-	external-constants	;external-constant?
-	signals			;error
-	util)			;unspecific
-  (files eval))
-
-; Reducing closures and data structures to simple definitions
-
-(define-structures ((flatten (export flatten-definitions))
-		    (flatten-internal (export generated-top-variable?)))
-  (open scheme big-scheme comp-util defrecord
-	structure-refs
-	bindings nodes
-	variable
-	eval-node 	;closure stuff, constant?
-	ps-primitives	;primitive stuff
-	ps-types	;type/undetermined expand-type-spec
-	linking		;prescheme-compiler-env
-	syntactic	;expand
-	strong
-	external-values
-	locations
-	features)	;immutable?
-  (access forms)	;avoid name conflict with NODE-FORM in nodes
-  (files flatten substitute))
-
-(define-structures ((to-cps (export x->cps)))
-  (open scheme big-scheme comp-util
-	variable
-	names bindings nodes
-	primop
-	structure-refs
-	cps-util enumerated
-	ps-primops 	;get-prescheme-primop
-	ps-types 	;type/unknown
-	inference	;node-type lambda-node-return-type
-	ps-primitives	;primitive-expander
-	protocol)	;goto-protocol normal-protocol
-  (access node)
-  (files to-cps))
-	
-; Processing interface and package definitions
-
-(define-structures ((linking linking-interface))
-  (open scheme big-scheme structure-refs comp-util
-	interfaces packages environments usual-macros
-	defpackage types ;for making interfaces
-        reflective-tower-maker
-	fluids
-	expand-define-record-type
-	scan-package	 ;collect-packages
-	bindings         ;binding? binding-place
-	nodes		 ;get-operator
-	transforms       ;make-transform
-	locations)       ;contents
-  (access meta-types           		;syntax-type usual-variable-type
-	  variable             		;make-global-variable
-	  ps-types             		;type/unknown
-	  reading-forms			;$note-file-package
-	  packages-internal    		;$get-location
-	  package-commands-internal	;config-package
-	  prescheme            		;we need this loaded
-	  built-in-structures) 		;defpackage structure-refs
-  (files linking))
-
-;----------------------------------------------------------------
-; Types and type inference
-
-(define-structures ((ps-types ps-type-interface)
-		    (type-variables type-variable-interface)
-		    (record-types record-type-interface)
-		    (expand-define-record-type
-		     (export expand-define-record-type)))
-  (open scheme big-scheme comp-util defrecord)
-  (files type
-	 type-scheme
-	 type-var
-	 record))
-
-(define-structures ((inference inference-interface)
-		    (inference-internal inference-internal-interface))
-  (open scheme big-scheme front variable comp-util transitive
-	ps-types type-variables
-	bindings nodes
-	structure-refs
-	ps-primitives
-	ps-primops    ; get-prescheme-primop
-	external-values external-constants
-	locations)    ; for imported constants
-  (access eval-node)  ; unspecific?
-  (for-syntax (open scheme big-scheme))
-  (files inference infer-early))
-
-(define-structures ((node-types (export instantiate-type&value
-					make-monomorphic!)))
-  (open scheme big-scheme front node comp-util
-	ps-types type-variables
-	inference-internal)  ; unify!
-  (files node-type))
-
-;----------------------------------------------------------------
-; Primops
-
-(define-structures ((ps-primops ps-primop-interface))
-  (open scheme big-scheme comp-util node simplify-internal
-	linking ps-types front expand)
-  (files (primop primop)))
-
-(define-structures ((ps-c-primops ps-c-primop-interface))
-  (open scheme big-scheme comp-util node simplify-internal
-	define-record-types
-	ps-types ps-primops)
-  (for-syntax (open scheme big-scheme))
-  (files (primop c-primop)))
-
-(define-structures ((primop-data (export)))
-  (open scheme big-scheme comp-util node simplify-internal simplify-let
-	front expand type-variables inference-internal
-	ps-types ps-primops record-types
-	parameters node-vector
-	node-types)   ; instantiate-type&value
-  (files (primop base)
-	 (primop arith)
-	 (primop io)
-	 (primop vector)
-	 ))
-
-(define-structures ((c-primop-data (export)))
-  (open scheme big-scheme comp-util node simplify
-	ps-types ps-primops ps-c-primops
-	front
-	structure-refs
-	c-internal
-	ps-types type-variables inference-internal
-	inference          ; get-variable-type
-	forms byte-vectors
-	record-types
-	eval-node)         ; unspecific?
-  (access ps-primitives prescheme)
-  (files (primop c-base)
-	 (primop c-arith)
-	 (primop c-io)
-	 (primop c-vector)
-	 ))
-
-(define-structures ((external-values (export external-value?
-					     make-external-value
-					     external-value-type
-					     external-value-string)))
-  (open scheme define-record-types)
-  (begin
-    (define-record-type external-value :external-value
-      (make-external-value string type)
-      external-value?
-      (string external-value-string)
-      (type external-value-type))))
-
-;----------------------------------------------------------------
-; Translating to C
-
-(define-structures ((c (export write-c-file hoist-nested-procedures))
-		    (c-internal c-internal-interface))
-  (open scheme big-scheme comp-util strongly-connected node forms
-	defrecord
-	ps-primops ps-c-primops
-	ps-types type-variables
-	flatten-internal   ; generated-top-variable?
-	inference          ; get-variable-type
-	inference-internal ; literal-value-type
-	protocol           ; goto-protocol?
-	i/o		   ; force-output
-	record-types
-	external-values
-	external-constants
-	eval-node)         ; unspecific?
-  (begin (define number-of-char-codes 256))  ; should be somewhere else
-  (files c
-	 c-decl
-	 c-call
-	 hoist
-	 merge))
-
-
diff --git a/ps-compiler/prescheme/primitive.scm b/ps-compiler/prescheme/primitive.scm
deleted file mode 100644
index 418a5bd..0000000
--- a/ps-compiler/prescheme/primitive.scm
+++ /dev/null
@@ -1,46 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-; Eval'ing and type-checking code for primitives.
-
-(define-record-type primitive
-  (id                ; for debugging & making tables
-   arg-predicates    ; predicates for checking argument types
-   eval              ; evaluation function
-   source            ; close-compiled source (if any)
-   expander          ; convert call to one using primops
-   expands-in-place? ; does the expander expand the definition in-line?
-   inference-rule    ; type inference rule
-   )
-  ())
-
-(define make-primitive primitive-maker)
-
-(define-record-discloser type/primitive
-  (lambda (primitive)
-    (list 'primitive (primitive-id primitive))))
-
-(define (eval-primitive primitive args)
-  (cond ((not (primitive? primitive))
-	 (user-error "error while evaluating: ~A is not a procedure" primitive))
-	((args-okay? args (primitive-arg-predicates primitive))
-	 (apply (primitive-eval primitive) args))
-	(else
-	 (user-error "error while evaluating: type error ~A"
-		     (cons (primitive-id primitive) args)))))
-
-; PREDICATES is a (possibly improper) list of predicates that should match
-; ARGS.
-
-(define (args-okay? args predicates)
-  (cond ((atom? predicates)
-	 (if predicates
-	     (every? predicates args)
-	     #t))
-	((null? args)
-	 #f)
-	((car predicates)
-	 (and ((car predicates) (car args))
-	      (args-okay? (cdr args) (cdr predicates))))
-	(else
-	 (args-okay? (cdr args) (cdr predicates)))))
-
diff --git a/ps-compiler/prescheme/primop/arith.scm b/ps-compiler/prescheme/primop/arith.scm
deleted file mode 100644
index 0c289d7..0000000
--- a/ps-compiler/prescheme/primop/arith.scm
+++ /dev/null
@@ -1,250 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-(define (put-literal-first call)
-  (if (and (not (literal-node? (call-arg call 0)))
-	   (literal-node? (call-arg call 1)))
-      (let ((arg1 (detach (call-arg call 0)))
-	    (arg0 (detach (call-arg call 1))))
-	(attach call 0 arg0)
-	(attach call 1 arg1))))
-
-(define (simplify-add call)
-  (simplify-args call 0)
-  (put-literal-first call)
-  ((pattern-simplifier
-    ((+ '0 x) x)
-    ((+ 'a 'b) '(+ a b))
-    ((+ 'a (+ 'b x)) (+ x '(+ a b)))
-    ((+ 'a (- x 'b)) (+ x '(- a b)))  ; no overflow in Scheme, but what
-    ((+ 'a (- 'b x)) (- '(+ a b) x))  ; about PreScheme?  Could check the
-    ((+ (+ 'a x) (+ 'b y)) (+ '(+ a b) (+ x y)))
-    ((+ x (+ 'a y)) (+ 'a (+ x y))))
-   call))                             ; result of the literal.  Maybe these
-                                      ; should be left out. 
-
-(define-scheme-primop + #f type/integer simplify-add)
-
-(define (simplify-subtract call)
-  (simplify-args call 0)
-  ((pattern-simplifier
-    ((- 'a 'b) '(- a b))
-    ((- x 'a) (+ '(- 0 a) x))
-    ((- 'a (+ 'b x)) (- '(- a b) x))   ; more overflow problems
-    ((- 'a (- 'b x)) (+ x '(- a b)))
-    ((- x (+ 'a y)) (+ '(- 0 a) (- x y)))
-;    ((- (+ 'a x) y) (+ 'a (- x y)))  hmm - need to come up with a normal form
-    ((- (+ 'a x) (+ 'b y)) (- (+ '(- a b) x) y)))
-   call))
-
-(define-scheme-primop - #f type/integer simplify-subtract)
-
-; This should check for multiply by powers of 2 (other constants can be
-; done later).
-
-(define (simplify-multiply call)
-  (simplify-args call 0)
-  (put-literal-first call)
-  (cond ((power-of-two-literal (call-arg call 0))
-	 => (lambda (i)
-	      (set-call-primop! call (get-prescheme-primop 'ashl))
-	      (replace (call-arg call 0) (detach (call-arg call 1)))
-	      (attach call 1 (make-literal-node i type/unknown))))
-	(else
-	 ((pattern-simplifier
-	   ((* '0 x) '0)
-	   ((* '1 x) x)
-	   ((* 'a 'b) '(* a b))
-	   ((* 'a (* x 'b)) (* x '(* a b)))
-	   ((* 'a (* 'b x)) (* x '(* a b))))
-	  call))))
-
-(define-scheme-primop *      #f type/integer simplify-multiply)
-(define-scheme-primop small* #f type/integer simplify-multiply)
-
-(define (simplify-quotient call)
-  (simplify-args call 0)
-  (cond ;((power-of-two-literal (call-arg call 1))
-	; => (lambda (i)
-	;      (set-call-primop! call (get-prescheme-primop 'ashr))
-	;      (replace (call-arg call 1) (make-literal-node i type/unknown))))
-	(else
-	 ((pattern-simplifier
-	   ((quotient x '0) '((lambda ()
-				(error "program divides by zero"))))
-	   ((quotient x '1) x)
-	   ((quotient '0 x) '0)
-	   ((quotient 'a 'b) '(quotient a b)))
-	  call))))
-
-(define (power-of-two-literal node)
-  (if (not (literal-node? node))
-      #f
-      (let ((value (literal-value node)))
-	(if (not (and (integer? value)
-		      (<= 1 value)))
-	    #f
-	    (do ((v value (arithmetic-shift v -1))
-		 (i 0 (+ i 1)))
-		((odd? v)
-		 (if (= v 1) i #f)))))))
-
-(define-scheme-primop quotient  exception type/integer simplify-quotient)
-(define-scheme-primop remainder exception type/integer)
-
-(define (simplify-ashl call)
-  (simplify-args call 0)
-  ((pattern-simplifier
-    ((ashl '0 x) '0)
-    ((ashl x '0) x)
-    ((ashl 'a 'b) '(arithmetic-shift a b))
-    ((ashl (ashl x 'a) 'b) (ashl x '(+ a b)))
-    ((ashl (ashr x 'a) 'b)
-     (<= a b)    ; condition
-     (ashl (bitwise-and x '(bitwise-not (- (expt 2 a) 1))) '(- b a)))
-    ((ashl (ashr x 'a) 'b)
-     (>= a b)    ; condition
-     (bitwise-and (ashr x '(- a b)) '(bitwise-not (- (expt 2 b) 1))))
-    ((ashl (+ 'a x) 'b) (+ (ashl x 'b) '(arithmetic-shift a b))))
-   call))
-
-(define (simplify-ashr call)
-  (simplify-args call 0)
-  ((pattern-simplifier
-    ((ashr '0 x) '0)
-    ((ashr x '0) x)
-    ((ashr 'a 'b) '(arithmetic-shift a (- b)))
-    ((ashr (ashr x 'a) 'b) (ashr x '(+ a b))))
-   call))
-
-(define (simplify-lshr call)
-  (simplify-args call 0)
-  ((pattern-simplifier
-    ((lshr '0 x) '0)
-    ((lshr x '0) x)
-    ((lshr 'a 'b) '(lshr a (- b)))
-    ((lshr (lshr x 'a) 'b) (lshr x '(+ a b)))
-    ((ashr (lshr x 'a) 'b) (lshr x '(+ a b)))) ; depends on shifts by zero
-                                               ; having been constant folded
-   call))
-
-(define-scheme-primop ashl #f type/integer simplify-ashl)
-(define-scheme-primop ashr #f type/integer simplify-ashr)
-(define-scheme-primop lshr #f type/integer simplify-lshr)
-
-(define (simplify-bitwise-and call)
-  (simplify-args call 0)
-  (put-literal-first call)
-  ((pattern-simplifier
-    ((bitwise-and '0 x) '0)
-    ((bitwise-and '-1 x) x)
-    ((bitwise-and 'a 'b) '(bitwise-and a b)))
-   call))
-
-(define (simplify-bitwise-ior call)
-  (simplify-args call 0)
-  (put-literal-first call)
-  ((pattern-simplifier
-    ((bitwise-ior '0 x) x)
-    ((bitwise-ior '-1 x) '-1)
-    ((bitwise-ior 'a 'b) '(bitwise-ior a b)))
-   call))
-
-(define (simplify-bitwise-xor call)
-  (simplify-args call 0)
-  (put-literal-first call)
-  ((pattern-simplifier
-    ((bitwise-xor '0 x) x)
-    ((bitwise-xor 'a 'b) '(bitwise-xor a b)))
-   call))
-
-(define (simplify-bitwise-not call)
-  (simplify-args call 0)
-  ((pattern-simplifier
-    ((bitwise-not 'a) '(bitwise-not a)))
-   call))
-
-(define-scheme-primop bitwise-and #f type/integer simplify-bitwise-and)
-(define-scheme-primop bitwise-ior #f type/integer simplify-bitwise-ior)
-(define-scheme-primop bitwise-xor #f type/integer simplify-bitwise-xor)
-(define-scheme-primop bitwise-not #f type/integer simplify-bitwise-not)
-
-(define (simplify-= call)
-  (simplify-args call 0)
-  (put-literal-first call)
-  ((pattern-simplifier
-    ((= 'a 'b) '(= a b))
-    ((= 'a (+ 'b c)) (= '(- a b) c))   ; will these ever be used?
-    ((= 'a (- 'b c)) (= '(- b a) c)))
-   call))
-
-(define (simplify-< call)
-  (simplify-args call 0)
-  ((pattern-simplifier
-    ((< 'a 'b) '(< a b))
-    ((< 'a (+ 'b c)) (< '(- a b) c))   ; will these ever be used?
-    ((< (+ 'b c) 'a) (< c '(- a b)))
-    ((< 'a (- 'b c)) (< c '(- b a)))
-    ((< (- 'b c) 'a) (< '(- b a) c)))
-   call))
-
-(define (simplify-char=? call)
-  (simplify-args call 0)
-  (put-literal-first call)
-  ((pattern-simplifier
-    ((char=? 'a 'b) '(char=? a b))
-    ((char=? 'a (+ 'b c)) (char=? '(- a b) c))
-    ((char=? 'a (- 'b c)) (char=? '(- b a) c)))
-   call))
-
-(define (simplify-char<? call)
-  (simplify-args call 0)
-  ((pattern-simplifier
-    ((char<? 'a 'b) '(char<? a b))
-    ((char<? 'a (+ 'b c)) (char<? '(- a b) c))
-    ((char<? (+ 'b c) 'a) (char<? c '(- a b)))
-    ((char<? 'a (- 'b c)) (char<? c '(- b a)))
-    ((char<? (- 'b c) 'a) (char<? '(- b a) c)))
-   call))
-
-(define bool-type
-  (lambda (call)
-    type/boolean))
-
-(define-scheme-primop =      #f bool-type simplify-=)
-(define-scheme-primop <      #f bool-type simplify-<)
-(define-scheme-primop char=? #f bool-type simplify-char=?)
-(define-scheme-primop char<? #f bool-type simplify-char<?)
-
-(define (simplify-char->ascii call)
-  (simplify-args call 0)
-  (let ((arg (call-arg call 0)))
-    (if (literal-node? arg)
-	(let ((value (literal-value arg)))
-	  (if (char? value)
-	      (replace call (make-literal-node (char->ascii value) #f))
-	      (breakpoint "char->ascii is applied to a non-character literal ~S"
-			  value))))))
-			  
-(define (simplify-ascii->char call)
-  (simplify-args call 0)
-  (let ((arg (call-arg call 0)))
-    (if (literal-node? arg)
-	(let ((value (literal-value arg)))
-	  (if (integer? value)
-	      (replace call (make-literal-node (ascii->char value) #f))
-	      (breakpoint "ascii->char is applied to a non-integer literal ~S"
-			  value))))))
-
-(define-scheme-primop char->ascii #f type/integer simplify-char->ascii)
-(define-scheme-primop ascii->char #f type/integer simplify-ascii->char)
-
-;(define (simplify-sign-extend call)
-;  (simplify-args call 0)
-;  (let ((value (call-arg call 0)))
-;    (cond ((literal-node? value)
-;           (set-literal-type! value type/integer)
-;           (replace call (detach value))))))
-;
-;(define-scheme-primop sign-extend #f type/integer simplify-sign-extend)
-;(define-scheme-primop zero-extend #f type/integer simplify-sign-extend)
diff --git a/ps-compiler/prescheme/primop/base.scm b/ps-compiler/prescheme/primop/base.scm
deleted file mode 100644
index 5843d0f..0000000
--- a/ps-compiler/prescheme/primop/base.scm
+++ /dev/null
@@ -1,159 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-(define (simplify-letrec1 call)
-  (let* ((cont (call-arg call 0))
-	 (next (lambda-body cont))
-	 (var (car (lambda-variables cont))))
-    (if (not (and (calls-this-primop? next 'letrec2)
-		  (= 1 (length (variable-refs var)))
-		  (eq? next (node-parent (car (variable-refs var))))
-		  (= 1 (node-index (car (variable-refs var))))))
-	(error "badly formed LETREC ~S ~S" call (node-parent call)))
-    (simplify-args call 0)
-    (check-letrec-scoping call cont next)
-    (if (every? unused? (cdr (lambda-variables cont)))
-	(replace-body call (detach-body (lambda-body (call-arg next 0)))))))
-
-(define (check-letrec-scoping letrec1 binder letrec2)
-  (let ((values (sub-vector->list (call-args letrec2) 2))
-	(body (call-arg letrec2 0)))
-    (for-each (lambda (n) (set-node-flag! n 'okay)) values)
-    (set-node-flag! body 'okay)
-    (for-each (lambda (var)
-		(for-each (lambda (ref)
-			    (set-node-flag! (marked-ancestor ref) 'lose))
-			  (variable-refs var)))
-	      (cdr (lambda-variables binder)))
-    (let ((non-recur (filter (lambda (p)
-			       (eq? (node-flag (car p)) 'okay))
-			     (map cons values (cdr (lambda-variables binder))))))
-      (for-each (lambda (n) (set-node-flag! n #f)) values)
-      (set-node-flag! body #f)
-      (if (not (null? non-recur))
-	  (letrec->let (map car non-recur)
-		       (map cdr non-recur)
-		       letrec1 binder letrec2)))))
-
-(define (letrec->let vals vars letrec1 binder letrec2)
-  (for-each detach vals)
-  (remove-null-arguments letrec2
-			 (- (vector-length (call-args letrec2))
-			    (length vals)))
-  (set-lambda-variables!
-   binder
-   (filter (lambda (v) (not (memq v vars)))
-	   (lambda-variables binder)))
-  (move-body letrec1
-	     (lambda (letrec1)
-	       (let-nodes ((call (let 1 l1 . vals))
-			   (l1 vars letrec1))
-		 call))))
-
-; (return (lambda (a) ...) x)
-;  =>
-; (let (lambda (a) ...) x)
-
-(define (simplify-ps-return call)
-  (let ((cont (call-arg call 0))
-	(value (call-arg call 1)))
-    (cond ((not (lambda-node? cont))
-	   (default-simplifier call))
-	  (else
-	   (set-call-primop! call (get-primop (enum primop let)))
-	   (set-call-exits! call 1)
-	   (set-node-simplified?! call #f)))))
-
-(make-primop 'dispatch         #f #f default-simplifier (lambda (call) 1) #f)
-(make-primop 'let              #f #f simplify-let       (lambda (call) 1) #f)
-(make-primop 'letrec1          #f #f (lambda (call)
-				       (simplify-letrec1 call))  (lambda (call) 1) #f)
-(make-primop 'letrec2          #f #f default-simplifier (lambda (call) 1) #f)
-(make-primop 'undefined-value  #t #f default-simplifier
-	     (lambda (call) 1)
-	     (lambda (call) type/null))
-(make-primop 'undefined-effect #t #f default-simplifier
-	     (lambda (call) 1)
-	     (lambda (call) type/null))
-(make-primop 'global-ref       #t 'read default-simplifier
-	     (lambda (call) 1)
-	     (lambda (call)
-	       (variable-type (reference-variable (call-arg call 0)))))
-
-;(make-primop 'allocate         #f #f 'allocate simplify-allocation (lambda (call) 1))
-
-(make-primop 'global-set!      #f 'write default-simplifier
-	     (lambda (call) 1) #f)
-
-(make-proc-primop 'call 'write simplify-known-call
-		  (lambda (call) 1) 1)
-(make-proc-primop 'tail-call 'write simplify-known-tail-call
-		  (lambda (call) 1) 1)
-(make-proc-primop 'return #f   simplify-ps-return  (lambda (call) 1) 0)
-(make-proc-primop 'jump   #f   simplify-jump       (lambda (call) 1) 0)
-(make-proc-primop 'throw  #f   default-simplifier  (lambda (call) 1) 0)
-
-; This delays simplifying the arguments until we see if the procedure
-; is a lambda-node.
-
-(define (simplify-unknown-call call)
-  (simplify-arg call 1)   ; simplify the procedure
-  (let ((proc (call-arg call 1)))
-    (cond ((lambda-node? proc)
-	   (determine-lambda-protocol proc (list proc))
-	   (mark-changed proc))
-	  ((and (reference-node? proc)
-		(variable-simplifier (reference-variable proc)))
-           => (lambda (proc)
-		(proc call)))
-	  (else
-	   (simplify-args call 0)))))  ; simplify all arguments
-
-(make-proc-primop 'unknown-call 'write simplify-unknown-call
-		  (lambda (call) 1) 1)
-(make-proc-primop 'unknown-tail-call 'write simplify-unknown-call
-		  (lambda (call) 1) 1)
-(make-proc-primop 'unknown-return #f default-simplifier
-		  (lambda (call) 1) 0)
-
-(define (simplify-unspecific call)
-  (let ((node (make-undefined-literal)))
-    (set-literal-type! node type/null)
-    (replace call node)))
-
-(define-scheme-primop unspecific #f type/null simplify-unspecific)
-
-(define-scheme-primop uninitialized-value type/null)
-(define-scheme-primop null-pointer?       type/boolean)
-(define-scheme-primop null-pointer        type/boolean) ; type can't be right
-
-(define-scheme-primop eq? type/boolean)  ; should have a simplifier
-
-;(define (exp->type exp)
-;  (if (quote-exp? exp)
-;      (real-exp->type (quote-exp-value exp))
-;      (error "can't turn ~S into a type" exp)))
-;
-;(define (real-exp->type exp)
-;  (let ((lose (lambda () (error "can't turn ~S into a type" exp))))
-;    (let label ((exp exp))
-;      (cond ((pair? exp)
-;             (case (car exp)
-;               ((pointer)
-;                (make-pointer-type (label (cadr exp))))
-;               ((arrow)
-;                (make-arrow-type (map label (cadr exp)) (caddr exp)))
-;               (else
-;                (lose))))
-;            ((and (symbol? exp)
-;                  (lookup-type exp))
-;             => identity)
-;            (else
-;             (lose))))))
-
-(define-scheme-cond-primop test simplify-test expand-test simplify-test?)
-
-;(define-primitive-expander 'unspecific 0
-;  (lambda (source args cenv)
-;    (make-quote-exp the-undefined-value type/unknown)))
-
-
diff --git a/ps-compiler/prescheme/primop/c-arith.scm b/ps-compiler/prescheme/primop/c-arith.scm
deleted file mode 100644
index 5073f01..0000000
--- a/ps-compiler/prescheme/primop/c-arith.scm
+++ /dev/null
@@ -1,93 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-(define-local-syntax (define-c-arith-binop-generator id c-op)
-  `(define-c-generator ,id #t
-     (lambda (call port indent)
-       (simple-c-primop ,c-op call port))))
-
-(define-c-arith-binop-generator + "+")
-(define-c-arith-binop-generator - "-")
-(define-c-arith-binop-generator * "*")
-(define-c-arith-binop-generator quotient  "/")
-
-(define-c-generator small* #t
-  (lambda (call port indent)
-    (format port "PS_SMALL_MULTIPLY(")
-    (c-value (call-arg call 0) port)
-    (format port ", ")
-    (c-value (call-arg call 1) port)
-    (format port ")")))
-
-(define-c-arith-binop-generator remainder "%")
-(define-c-arith-binop-generator bitwise-and "&")
-(define-c-arith-binop-generator bitwise-ior "|")
-(define-c-arith-binop-generator bitwise-xor "^")
-
-(define-c-generator ashl #t
-  (lambda (call port indent)
-    (generate-shift call port indent "LEFT" "<<" #f)))
-
-(define-c-generator ashr #t
-  (lambda (call port indent)
-    (generate-shift call port indent "RIGHT" ">>" #f)))
-
-(define-c-generator lshr #t
-  (lambda (call port indent)
-    (generate-shift call port indent "RIGHT_LOGICAL" ">>" #t)))
-
-(define (generate-shift call port indent macro c-op logical?)
-  (cond ((= 1 (call-exits call))
-	 ; PS_SHIFT_??? is a C macro that handles overshifting even if C doesn't
-	 (indent-to port indent)
-	 (format port "PS_SHIFT_~A(" macro)
-	 (if logical? (format port "(unsigned long)"))
-	 (c-value (call-arg call 1) port)
-	 (format port ", ")
-	 (c-value (call-arg call 2) port)
-	 (format port ", ")
-	 (c-variable (car (lambda-variables (call-arg call 0))) port)
-	 (format port ")"))
-	((>= (literal-value (call-arg call 1)) prescheme-integer-size)
-	 (format port "0L"))
-	(else
-	 (if logical?
-	     (format port "(long)(((unsigned long)")
-	     (format port "(("))
-	 (c-value (call-arg call 0) port)
-	 (format port ")~A" c-op)
-	 (c-value (call-arg call 1) port)
-	 (format port ")"))))
-    
-(define-c-generator bitwise-not #t
-  (lambda (call port indent)
-    (simple-c-primop "~" call port)))
-
-(define-local-syntax (define-c-comp-binop-generator id c-op)
-  `(define-c-generator ,id #t
-     (lambda (call port indent)
-       (simple-c-primop ,c-op call port))))
-
-(define-c-comp-binop-generator =      "==")
-(define-c-comp-binop-generator <      "<" )
-(define-c-comp-binop-generator char=? "==")
-(define-c-comp-binop-generator char<? "<" )
-
-(define-c-generator ascii->char #t
-  (lambda (call port indent)
-    (c-value (call-arg call 0) port)))
-    
-(define-c-generator char->ascii #t
-  (lambda (call port indent)
-    (c-value (call-arg call 0) port)))
-    
-;(define-c-generator sign-extend #t
-;  (lambda (call port indent)
-;    (display "((long) " port)
-;    (c-value (call-arg call 0) port)
-;    (display ")" port)))
-;
-;(define-c-generator zero-extend #t
-;  (lambda (call port indent)
-;    (display "((unsigned long) " port)
-;    (c-value (call-arg call 0) port)
-;    (display ")" port)))
diff --git a/ps-compiler/prescheme/primop/c-base.scm b/ps-compiler/prescheme/primop/c-base.scm
deleted file mode 100644
index ff6b885..0000000
--- a/ps-compiler/prescheme/primop/c-base.scm
+++ /dev/null
@@ -1,343 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-(define-c-generator let #f
-  (lambda (call port indent)
-    (let ((args (call-args call))
-	  (vars (lambda-variables (call-arg call 0))))
-      (do ((i 1 (+ i 1))
-	   (vars vars (cdr vars)))
-	  ((null? vars))
-	(let ((val (vector-ref args i)))
-	  (if (not (lambda-node? val))
-	      (c-assignment (car vars) val port indent)))))))
-
-(define-c-generator letrec1 #f
-  (lambda (call port indent)
-    (values)))
-
-(define-c-generator letrec2 #f
-  (lambda (call port indent)
-    (values)))
-
-(define-c-generator jump #f
-  (lambda (call port indent)
-    (let ((proc (called-lambda call)))
-      (assign-argument-vars (lambda-variables proc) call 1 port indent)
-      (indent-to port indent)
-      (display "goto " port)
-      (writec port #\L)
-      (display (lambda-id proc) port)
-      (write-char #\; port)
-      (note-jump-generated! proc)
-      (values))))
-  
-(define (assign-argument-vars vars call start port indent)
-  (really-assign-argument-vars vars call start "arg" port indent))
-
-(define (assign-merged-argument-vars vars call start port indent)
-  (really-assign-argument-vars vars call start "merged_arg" port indent))
-
-(define (assign-global-argument-vars vars call start port indent)
-  (really-assign-argument-vars vars call start "goto_arg" port indent))
-
-(define (really-assign-argument-vars vars call start name port indent)
-  (let ((args (call-args call)))
-    (do ((i start (+ i 1))
-	 (vars vars (cdr vars)))
-	((>= i (vector-length args)))
-      (if (not (or (undefined-value-node? (vector-ref args i))
-		   (eq? type/unit (get-variable-type (car vars)))))
-	  (c-assignment (c-argument-var name
-					(get-variable-type (car vars))
-					(- i start)
-					port)
-			(vector-ref args i)
-			port indent)))))
-
-; Calls
-
-; Unknown calls have a first argument of 'goto if they are supposed to be
-; tail-recursive.  For known calls the protocol field of the lambda node
-; is set to 'tail-called if any of the calls are supposed to be tail-recursive.
-;
-; Calls to non-tail-called procedures are just regular C calls.  For tail-
-; called procedures there are two kinds of calls:
-;  Tail-call from a tail-called procedure: proceed through the driver loop
-;  All others: start a driver loop
-;
-; Known and unknown calls are handled identically, except that known calls
-; may be to merged procedures.
-;
-; Merged procedures with GOTO calls:
-;  This works if we merge the return points as well.  Possibly there should be
-; one return switch per C procedure.  There do have to be separate return point
-; variables (and one global one for the switch).
-
-(define-c-generator call #f
-  (lambda (call port indent)
-    (cond ((merged-procedure-reference (call-arg call 1))
-	   => (lambda (form)
-		(generate-merged-call call 2 form port indent)))
-	  (else
-           (generate-c-call call 2 port indent)))))
-
-(define-c-generator tail-call #f
-  (lambda (call port indent)
-    (cond ((merged-procedure-reference (call-arg call 1))
-	   => (lambda (form)
-		(generate-merged-goto-call call 2 form port indent)))
-	  (else
-           (generate-c-tail-call call 2 port indent)))))
-
-(define-c-generator unknown-call #f
-  (lambda (call port indent)
-    (if (goto-protocol? (literal-value (call-arg call 2)))
-	(user-warning "ignoring GOTO declaration for non-tail-recursive call to"
-		      (variable-name (reference-variable
-				      (call-arg call 1)))))
-    (generate-c-call call 3 port indent)))
-
-(define-c-generator unknown-tail-call #f
-  (lambda (call port indent)
-    (generate-c-tail-call call 3 port indent)))
-
-(define (generate-merged-goto-call call start form port indent)
-  (let ((proc (form-value form)))
-    (assign-merged-argument-vars (cdr (lambda-variables proc))
-				 call start
-				 port indent)
-    (indent-to port indent)
-    (display "goto " port)
-    (display (form-c-name form) port)
-    (write-char #\; port)
-    (values)))
-
-(define (generate-goto-call call start port indent)
-  (let ((proc (call-arg call 1)))
-    (if (not (global-reference? proc))
-	(bug "incorrect procedure in goto call ~S" call))
-    (assign-global-argument-vars (cdr (lambda-variables
-				       (global-lambda
-					(reference-variable proc))))
-				 call start
-				 port indent)
-    ; T is the marker for the tail-call version of the procedure
-    (indent-to port indent)
-    (display "return((long)T" port)
-    (c-value proc port)
-    (display ");" port)))
-
-(define (global-lambda var)
-  (let ((form (maybe-variable->form var)))
-    (if (and form
-	     (or (eq? 'lambda (form-type form))
-		 (eq? 'merged (form-type form))))
-	(form-value form)
-	(bug "value of ~S, called using goto, is not a known procedure"
-	       var))))
-
-; C requires that we dereference all but calls to global functions.
-; Calls to literals are macros that must take care of themselves.
-
-(define (generate-c-call call start port indent)
-  (let ((vars (lambda-variables (call-arg call 0)))
-        (args (call-args call))
-        (proc (call-arg call 1)))
-    (if (and (global-reference? proc)
-	     (memq? 'tail-called (variable-flags (reference-variable proc))))
-	(call-with-driver-loop call start port indent (car vars))
-	(let ((deref? (or (and (reference-node? proc)
-			       (variable-binder (reference-variable proc)))
-			  (call-node? proc))))
-	   (c-assign-to-variable (car vars) port indent)
-	   (if deref?
-	       (display "(*" port))
-	   (c-value proc port)
-	   (if deref?
-	       (writec port #\)))
-	   (write-value+result-var-list args start (cdr vars) port)))
-    (writec port #\;)
-    (values)))
-
-(define (generate-c-tail-call call start port indent)
-  (let ((proc (call-arg call 1))
-	(args (call-args call)))
-    (cond ((not (and (global-reference? proc)
-		     (memq? 'tail-called
-			    (variable-flags (reference-variable proc)))))
-	   (indent-to port indent)
-	   (display "return " port)
-	   (c-value proc port)
-	   (write-value-list-with-extras args start *extra-tail-call-args* port))
-	  (*doing-tail-called-procedure?*
-	   (generate-goto-call call start port indent))
-	  (else
-	   (call-with-driver-loop call start port indent #f)))
-    (writec port #\;)
-    (values)))
-
-(define (global-reference? node)
-  (and (reference-node? node)
-       (global-variable? (reference-variable node))))
-
-(define (call-with-driver-loop call start port indent result-var)	   
-  (let* ((proc-var (reference-variable (call-arg call 1)))
-	 (vars (lambda-variables (global-lambda proc-var))))
-    (assign-global-argument-vars (cdr vars) call start port indent)
-    (if result-var
-	(c-assign-to-variable result-var port indent)
-	(begin
-	  (indent-to port indent)
-	  (display "return " port)))
-    (display "TTrun_machine((long)" port)
-    (display "T" port)
-    (write-c-identifier (variable-name proc-var) port)
-    (display ")" port)))
-
-(define (generate-merged-call call start form port indent)
-  (let ((return-index (form-return-count form))
-	(name (form-c-name form))
-	(res (lambda-variables (call-arg call 0))))
-    (set-form-return-count! form (+ 1 return-index))
-    (assign-merged-argument-vars (cdr (lambda-variables (form-value form)))
-				 call start port indent)
-    (indent-to port indent)
-    (format port "~A_return_tag = ~D;" name return-index)
-    (indent-to port indent)
-    (format port "goto ~A;" name)
-    (indent-to port (- indent 1))
-    (format port "~A_return_~S:" name return-index)
-    (do ((i 0 (+ i 1))
-	 (res res (cdr res)))
-	((null? res))
-      (let ((var (car res)))
-	(cond ((and (used? var)
-		    (let ((type (get-variable-type var)))
-		      (and (not (eq? type type/unit))
-			   (not (eq? type type/null)))))
-	       (c-assign-to-variable var port indent)
-	       (format port "~A~D_return_value;" name i)))))))
-
-; Returns
-
-(define-c-generator return #f
-  (lambda (call port indent)
-    (if *current-merged-procedure*
-	(generate-return-from-merged-call call 1 port indent)
-	(really-generate-c-return call 1 port indent))))
-
-(define-c-generator unknown-return #f
-  (lambda (call port indent)
-    (cond (*doing-tail-called-procedure?*
-	   (generate-return-from-tail-call call port indent))
-	  (*current-merged-procedure*
-	   (generate-return-from-merged-call call 1 port indent))
-	  (else
-	   (really-generate-c-return call 1 port indent)))))
-
-(define (generate-return-from-tail-call call port indent)
-  (if (not (no-value-node? (call-arg call 1)))
-      (c-assignment "TTreturn_value" (call-arg call 1) port indent))
-  (indent-to port indent)
-  (display "return(0L);" port))
-
-(define (generate-return-from-merged-call call start port indent)
-  (let ((name *current-merged-procedure*))
-    (do ((i start (+ i 1)))
-	((= i (call-arg-count call)))
-      (let ((arg (call-arg call i)))
-	(if (not (no-value-node? arg))
-	    (c-assignment (format #f "~A~D_return_value" name (- i start))
-			  arg port indent))))
-    (indent-to port indent)
-    (format port "goto ~A_return;" name)))
-
-(define (really-generate-c-return call start port indent)
-  (do ((i (+ start 1) (+ i 1)))
-      ((= i (call-arg-count call)))
-    (let ((arg (call-arg call i)))
-      (if (not (no-value-node? arg))
-	  (begin
-	    (indent-to port indent)
-	    (format port "*TT~D = " (- (- i start) 1))
-	    (c-value arg port)
-	    (write-char #\; port)))))
-  (indent-to port indent)
-  (display "return" port)
-  (if (not (no-value-node? (call-arg call start)))
-      (begin
-	(write-char #\space port)
-	(c-value (call-arg call start) port)))
-  (display ";" port)
-  (values))
-
-; Allocate
-
-;(define-c-generator allocate #f
-;  (lambda (call port indent)
-;    (let ((cont (call-arg call 0))
-;          (size (call-arg call 1)))
-;      (c-assign-to-variable (car (lambda-variables cont)) port indent)
-;      (display "(long) malloc(" port)
-;      (c-value size port)
-;      (display "* sizeof(char));" port))))
-
-(define-c-generator global-ref #t
-  (lambda (call port indent)
-    (c-value (call-arg call 0) port)))
-  
-(define-c-generator global-set! #f
-  (lambda (call port indent)
-    (let ((value (call-arg call 2)))
-      (if (not (and (literal-node? value)
-		    (unspecific? (literal-value value))))
-	  (c-assignment (reference-variable (call-arg call 1))
-			value
-			port indent)))))
-
-; if (ARG1 OP ARG2) {
-;   cont1 }
-; else {
-;   cont2 }
-
-(define-c-generator test #f
-  (lambda (call port indent)
-    (destructure ((#(cont1 cont2 value) (call-args call)))
-      (generate-c-conditional-prelude port indent)
-      (c-value value port)
-      (generate-c-conditional-jumps cont1 cont2 port indent))))
-
-(define (generate-c-conditional-prelude port indent)
-  (indent-to port indent)
-  (display "if " port)
-  (writec port #\())
-
-(define (generate-c-conditional-jumps cont1 cont2 port indent)
-  (display ") {" port)
-  (write-c-block (lambda-body cont1) port (+ indent 2))
-  (newline port)
-  (indent-to port indent)
-  (display "else {" port)
-  (write-c-block (lambda-body cont2) port (+ indent 2)))
-
-(define-c-generator unspecific #t
-  (lambda (call port indent)
-    (bug "generating code for undefined value ~S" call)))
-
-(define-c-generator uninitialized-value #t
-  (lambda (call port indent)
-    (bug "generating code for uninitialized value ~S" call)))
-
-(define-c-generator null-pointer? #t
-  (lambda (call port indent)
-    (display "NULL == " port)
-    (c-value (call-arg call 0) port)))
-
-(define-c-generator null-pointer #t
-  (lambda (call port indent)
-    (display "NULL" port)))
-
-(define-c-generator eq? #t
-  (lambda (call port indent)
-    (simple-c-primop "==" call port)))
-
diff --git a/ps-compiler/prescheme/primop/c-io.scm b/ps-compiler/prescheme/primop/c-io.scm
deleted file mode 100644
index 7eff01f..0000000
--- a/ps-compiler/prescheme/primop/c-io.scm
+++ /dev/null
@@ -1,169 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-(define (write-c-io-call call port name . args)
-  (format port name)
-  (writec port #\()
-  (for-each (lambda (arg)
-	      (cond ((string? arg)
-		     (format port arg))
-		    ((variable? arg)
-		     (c-variable arg port))
-		    (else
-		     (c-value (call-arg call arg) port))))
-	    args)
-  (writec port #\)))
-
-; stdin, stdout, and stderr cannot be variables because they may be macros in C.
-
-(define-c-generator stdin #t
-  (lambda (call port indent)
-    (format port "stdin")))
-
-(define-c-generator stdout #t
-  (lambda (call port indent)
-    (format port "stdout")))
-
-(define-c-generator stderr #t
-  (lambda (call port indent)
-    (format port "stderr")))
-
-; char eof? status
-
-(define-c-generator read-char #f
-  (lambda (call port indent)
-    (indent-to port indent)
-    (let ((vars (lambda-variables (call-arg call 0))))
-      (write-c-io-call call port "PS_READ_CHAR" 1 ", "
-		       (car vars) ", " (cadr vars) ", " (caddr vars)))))
-
-(define-c-generator peek-char #f
-  (lambda (call port indent)
-    (indent-to port indent)
-    (let ((vars (lambda-variables (call-arg call 0))))
-      (write-c-io-call call port "PS_PEEK_CHAR" 1 ", "
-		       (car vars) ", " (cadr vars) ", " (caddr vars)))))
-
-(define-c-generator read-integer #f
-  (lambda (call port indent)
-    (indent-to port indent)
-    (let ((vars (lambda-variables (call-arg call 0))))
-      (write-c-io-call call port "PS_READ_INTEGER" 1 ", "
-		       (car vars) ", " (cadr vars) ", " (caddr vars)))))
-
-(define-c-generator write-char #f
-  (lambda (call port indent)
-    (indent-to port indent)
-    (let ((vars (lambda-variables (call-arg call 0))))
-      (if (used? (car vars))
-	  (write-c-io-call call port "PS_WRITE_CHAR" 1 ", " 2 ", " (car vars))
-	  (begin
-	    (display "{ long ignoreXX;" port)
-	    (indent-to port indent)
-	    (write-c-io-call call port "PS_WRITE_CHAR" 1 ", " 2 ", ignoreXX")
-	    (display " }" port))))))
-
-(define-c-generator write-string #t
-  (lambda (call port indent)
-    (write-c-io-call call port "ps_write_string" 0 ", " 1)))
-
-(define-c-generator write-integer #t
-  (lambda (call port indent)
-    (write-c-io-call call port "ps_write_integer" 0 ", " 1)))
-
-(define-c-generator force-output #t
-  (lambda (call port indent)
-    (write-c-io-call call port "ps_flush" 0)))
-
-(define-c-generator read-block #f
-  (lambda (call port indent)
-    (let ((vars (lambda-variables (call-arg call 0))))
-      (c-assign-to-variable (car vars) port indent)
-      (write-c-io-call call port "ps_read_block" 1 ", ((char *) " 2 "), " 3
-		       ", &" (cadr vars) ", &" (caddr vars))
-      (write-char #\; port))))
-
-(define-c-generator write-block #t
-  (lambda (call port indent)
-    (write-c-io-call call port "ps_write_block" 0 ", ((char *) " 1 ")"
-		     ", " 2)))
-
-; (read-block (lambda (okay? eof? got) ...) port buffer count)
-;
-;(define-c-generator read-block #f
-;  (lambda (call port indent)
-;    (let* ((cont (call-arg call 0))
-;           (vars (lambda-variables cont)))
-;      ;;  got = ps_read(port, buffer, count, &okay?, &eof?);
-;      (c-assign-to-variable (caddr vars) port indent)
-;      (write-c-io-call call port
-;                       "ps_read" 1 ", (void *)" 2 ", " 3 ", &" (car vars)
-;                       ", &" (cadr vars))
-;      (write-char #\; port))))
-;
-;; (write-block (lambda (okay? sent) ...) port buffer count)
-;
-;(define-c-generator write-block #f
-;  (lambda (call port indent)
-;    (let* ((cont (call-arg call 0))
-;           (vars (lambda-variables cont)))
-;      ;;  sent = ps_write(port, buffer, count, &okay?);
-;      (c-assign-to-variable (cadr vars) port indent)
-;      (write-c-io-call call port
-;                       "ps_write" 1 ", (void *)" 2 ", " 3 ", &" (car vars))
-;      (write-char #\; port))))
-
-(define-c-generator open-input-file #f
-  (lambda (call port indent)
-    (let ((vars (lambda-variables (call-arg call 0))))
-      (c-assign-to-variable (car vars) port indent)
-      (write-c-io-call call port "ps_open_input_file" 1 ", &" (cadr vars))
-      (write-char #\; port))))
-
-(define-c-generator open-output-file #f
-  (lambda (call port indent)
-    (let ((vars (lambda-variables (call-arg call 0))))
-      (c-assign-to-variable (car vars) port indent)
-      (write-c-io-call call port "ps_open_output_file" 1 ", &" (cadr vars))
-      (write-char #\; port))))
-
-(define-c-generator close-input-port #t
-  (lambda (call port indent)
-    (write-c-io-call call port "ps_close" 0)))
-
-(define-c-generator close-output-port #t
-  (lambda (call port indent)
-    (write-c-io-call call port "ps_close" 0)))
-
-(define-c-generator abort #t
-  (lambda (call port indent)
-    (format port "(exit -1)")))
-
-(define-c-generator error #f
-  (lambda (call port indent)
-    (indent-to port indent)
-    (format port "ps_error(")
-    (c-value (call-arg call 1) port)
-    (format port ", ~D" (- (call-arg-count call) 2))
-    (do ((i 2 (+ i 1)))
-	((= i (call-arg-count call)))
-      (format port ", ")
-      (c-value (call-arg call i) port))
-    (format port ");")))
-
-(define-c-generator error-string #t
-  (lambda (call port indent)
-    (write-c-io-call call port "ps_error_string" 0)))
-
-; (c-e-v <proc> <nargs> <pointer-to-args>)
-
-(define-c-generator call-external-value #t
-  (lambda (call port indent)
-    (format port "((long(*)())")
-    (c-value (call-arg call 0) port)
-    (format port ")(")
-    (c-value (call-arg call 1) port)
-    (format port ", ")
-    (c-value (call-arg call 2) port)
-    (writec port #\))))
-
-
diff --git a/ps-compiler/prescheme/primop/c-primop.scm b/ps-compiler/prescheme/primop/c-primop.scm
deleted file mode 100644
index 36090c2..0000000
--- a/ps-compiler/prescheme/primop/c-primop.scm
+++ /dev/null
@@ -1,29 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-; Code generation for primops.
-
-(define-record-type c-primop :c-primop
-  (make-c-primop simple? generate)
-  c-primop?
-  (simple? c-primop-simple?)
-  (generate c-primop-generate))
-
-(define (simple-c-primop? primop)
-  (c-primop-simple? (primop-code-data primop)))
-
-(define (primop-generate-c primop call port indent)
-  ((c-primop-generate (primop-code-data primop))
-   call port indent))
-
-(define-syntax define-c-generator
-  (lambda (exp r$ c$)
-    (destructure (((ignore id simple? generate) exp))
-      `(set-primop-code-data!
-	(,(r$ 'get-prescheme-primop) ',id)
-	(,(r$ 'make-c-primop)
-	 ,simple?
-	 ,generate
-	 )))))
-	 
-
diff --git a/ps-compiler/prescheme/primop/c-record.scm b/ps-compiler/prescheme/primop/c-record.scm
deleted file mode 100644
index ed35565..0000000
--- a/ps-compiler/prescheme/primop/c-record.scm
+++ /dev/null
@@ -1,42 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-(define-c-generator make-record #t
-  (lambda (args)
-    (bug "no eval method for MAKE-RECORD"))
-  (lambda (call depth)
-    (reconstruct-make-record call depth))
-  (lambda (call port indent)
-    (let ((type (node-type call)))
-      (write-c-coercion type port)
-      (format port "malloc(sizeof(")
-      (display-c-type (pointer-type-to type) #f port)
-      (format port ") * ")
-      (c-value (call-arg call 0) port)
-      (format port ")"))))
-      
-(define (reconstruct-make-record call depth)
-  (let* ((args (call-exp-args call))
-	 (arg-types (call-arg-types (cdr args) depth))
-	 (record-type (quote-exp-value (car args)))
-	 (type (record-type-type record-type))
-	 (maker-type (record-type-maker-type record-type)))
-    (unify! maker-type (make-arrow-type arg-types type))
-    type))
-
-(define-c-scheme-primop make-record
-  'allocate
-  (lambda (call)
-    (record-type-type (literal-value (node-ref call 0))))
-  default-simplifier)
-
-(define-scheme-primop record-ref
-  'read
-  (lambda (call)
-    (record-slot-type (literal-value (node-ref call 0))))
-  default-simplifier)
-
-(define-scheme-primop record-set!
-  'write
-  (lambda (call) type/unit)
-  default-simplifier)
diff --git a/ps-compiler/prescheme/primop/c-vector.scm b/ps-compiler/prescheme/primop/c-vector.scm
deleted file mode 100644
index 45959f6..0000000
--- a/ps-compiler/prescheme/primop/c-vector.scm
+++ /dev/null
@@ -1,242 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-; (make-vector size init)
-
-(define-c-generator make-vector #t
-  (lambda (call port indent)
-    (let ((type (node-type call)))
-      (write-c-coercion type port)
-      (format port "malloc(sizeof(")
-      (display-c-type (pointer-type-to type) #f port)
-      (format port ") * ")
-      (c-value (call-arg call 0) port)
-      (format port ")"))))
-
-(define-c-generator vector-ref #t
-  (lambda (call port indent)
-    (generate-c-vector-ref (call-arg call 0) (call-arg call 1) port)))
-
-(define (generate-c-vector-ref vector index port)
-  (display "*(" port)
-  (c-value vector port)
-  (display " + " port)
-  (c-value index port)
-  (writec port #\)))
-
-(define-c-generator vector-set! #t
-  (lambda (call port indent)
-    (generate-c-vector-set (call-arg call 1)
-			   (call-arg call 2)
-			   (call-arg call 3)
-			   port indent)))
-
-(define (generate-c-vector-set vector index value port indent)
-  (indent-to port indent)
-  (generate-c-vector-ref vector index port)
-  (display " = " port)
-  (c-value value port)
-  (writec port #\;))
-
-(define-c-generator make-string #t
-  (lambda (call port indent)
-    ; calloc is used as a hack to get a zero at the end
-    (format port "(char *)calloc( 1, 1 + ")
-    (c-value (call-arg call 0) port)
-    (format port ")")))
-
-(define-c-generator string-length #t
-  (lambda (call port indent)
-    (format port "strlen((char *) ")
-    (c-value (call-arg call 0) port)
-    (format port ")")))
-
-(define-c-generator string-ref #t
-  (lambda (call port indent)
-    (generate-c-vector-ref (call-arg call 0) (call-arg call 1) port)))
-
-(define-c-generator string-set! #f
-  (lambda (call port indent)
-    (generate-c-vector-set (call-arg call 1)
-			   (call-arg call 2)
-			   (call-arg call 3)
-			   port indent)))
-
-(define-c-generator make-record #f
-  (lambda (call port indent)
-    (let ((type (get-record-type (literal-value (call-arg call 0)))))
-      (write-c-coercion type port)
-      (format port "malloc(sizeof(struct ")
-      (write-c-identifier (record-type-name type) port)
-      (format port "))"))))
-
-(define-c-generator record-ref #t
-  (lambda (call port indent)
-    (generate-c-record-ref (call-arg call 0)
-			   (call-arg call 1)
-			   (call-arg call 2)
-			   port)))
-
-(define (generate-c-record-ref record type field port)
-  (let ((field (get-record-type-field (literal-value type)
-				      (literal-value field))))
-    (c-value record port)
-    (display "->" port)
-    (write-c-identifier (record-field-name field) port)))
-
-(define-c-generator record-set! #t
-  (lambda (call port indent)
-    (generate-c-record-set (call-arg call 1)
-			   (call-arg call 2)
-			   (call-arg call 3)
-			   (call-arg call 4)
-			   port indent)))
-
-(define (generate-c-record-set record value type field port indent)
-  (indent-to port indent)
-  (generate-c-record-ref record type field port)
-  (display " = " port)
-  (c-value value port)
-  (writec port #\;))
-
-(define-c-generator allocate-memory #t
-  (lambda (call port indent)
-    (write-c-coercion type/address port)
-    (format port "malloc(") 
-    (c-value (call-arg call 0) port)
-    (format port ")")))
-
-(define-c-generator deallocate #t
-  (lambda (call port indent)
-    (format port "free(") 
-    (c-value (call-arg call 0) port)
-    (format port ")")))
-
-(define-c-generator deallocate-memory #t
-  (lambda (call port indent)
-    (format port "free(") 
-    (c-value (call-arg call 0) port)
-    (format port ")")))
-
-(define-c-generator address+ #t
-  (lambda (call port indent)
-    (simple-c-primop "+" call port)))
-  
-(define-c-generator address-difference #t
-  (lambda (call port indent)
-    (simple-c-primop "-" call port)))
-
-(define-c-generator address= #t
-  (lambda (call port indent)
-    (simple-c-primop "==" call port)))
-
-(define-c-generator address< #t
-  (lambda (call port indent)
-    (simple-c-primop "<" call port)))
-
-(define-c-generator address->integer #t
-  (lambda (call port indent)
-    (format port "((long) ") 
-    (c-value (call-arg call 0) port)
-    (format port ")")))
-
-(define-c-generator integer->address #t
-  (lambda (call port indent)
-    (format port "((char *) ") 
-    (c-value (call-arg call 0) port)
-    (format port ")")))
-
-(define-c-generator copy-memory! #t
-  (lambda (call port indent)
-    (format port "memcpy((void *)") 
-    (c-value (call-arg call 1) port)
-    (format port ", (void *)") 
-    (c-value (call-arg call 0) port)
-    (format port ",") 
-    (c-value (call-arg call 2) port)
-    (format port ")")))
-
-(define-c-generator memory-equal? #t
-  (lambda (call port indent)
-    (format port "(!memcmp((void *)") 
-    (c-value (call-arg call 1) port)
-    (format port ", (void *)") 
-    (c-value (call-arg call 0) port)
-    (format port ",") 
-    (c-value (call-arg call 2) port)
-    (format port "))")))
-
-(define-c-generator byte-ref #t
-  (lambda (call port indent)
-    (generate-c-memory-ref "unsigned char" (call-arg call 0) port)))
-
-(define-c-generator word-ref #t
-  (lambda (call port indent)
-    (generate-c-memory-ref "long" (call-arg call 0) port)))
-
-(define (generate-c-memory-ref type pointer port)
-  (format port "*((~A *) " type)
-  (c-value pointer port)
-  (writec port #\)))
-
-(define-c-generator byte-set! #t
-  (lambda (call port indent)
-    (generate-c-memory-set! "unsigned char"
-			    (call-arg call 1)
-			    (call-arg call 2)
-			    port
-			    indent)))
-
-(define-c-generator word-set! #t
-  (lambda (call port indent)
-    (generate-c-memory-set! "long"
-			    (call-arg call 1)
-			    (call-arg call 2)
-			    port
-			    indent)))
-
-(define (generate-c-memory-set! type pointer value port indent)
-  (indent-to port indent)
-  (generate-c-memory-ref type pointer port)
-  (display " = " port)
-  (c-value value port)
-  (writec port #\;))
-
-(define-c-generator char-pointer->string #t
-  (lambda (call port indent)
-    (format port "((char *)") 
-    (c-value (call-arg call 0) port)
-    (format port ")")))
-
-(define-c-generator char-pointer->nul-terminated-string #t
-  (lambda (call port indent)
-    (format port "((char *)") 
-    (c-value (call-arg call 0) port)
-    (format port ")")))
-
-(define-c-generator computed-goto #f
-  (lambda (call port indent)
-    (generate-c-switch call port indent)))
-
-(define (generate-c-switch call port indent)
-  (let ((size (call-exits call)))
-    (indent-to port indent)
-    (display "switch (" port)
-    (c-value (call-arg call (+ size 1)) port)
-    (display ") {" port)
-    (let ((indent (+ indent 2)))
-      (do ((i 0 (+ i 1))
-	   (labels (literal-value (call-arg call size)) (cdr labels)))
-	  ((>= i size))
-	(for-each (lambda (l)
-		    (indent-to port indent)
-		    (format port "case ~D : " l))
-		  (car labels))
-	(write-c-switch-case (call-arg call i) port indent)))
-    (indent-to port indent)
-    (display "}" port)))
-
-(define (write-c-switch-case node port indent)
-  (writec port #\{)
-  (write-c-block (lambda-body node) port (+ indent 2))
-  (indent-to port (+ indent 2))
-  (display "break;" port))
diff --git a/ps-compiler/prescheme/primop/io.scm b/ps-compiler/prescheme/primop/io.scm
deleted file mode 100644
index a43149d..0000000
--- a/ps-compiler/prescheme/primop/io.scm
+++ /dev/null
@@ -1,38 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-;(define-scheme-primop cast-to-long)
-
-(define-scheme-primop stdin  type/input-port)
-(define-scheme-primop stdout type/output-port)
-(define-scheme-primop stderr type/output-port)
-
-(define-nonsimple-scheme-primop read-char io)
-(define-nonsimple-scheme-primop peek-char io)
-(define-nonsimple-scheme-primop read-integer io)
-
-(define type/status type/integer)
-
-(define-nonsimple-scheme-primop write-char io)
-
-(define-scheme-primop write-string  io type/status)
-(define-scheme-primop write-integer io type/status)
-(define-scheme-primop force-output  io type/status)
-
-(define-nonsimple-scheme-primop open-input-file)
-(define-nonsimple-scheme-primop open-output-file)
-
-(define-scheme-primop close-input-port  io type/status)
-(define-scheme-primop close-output-port io type/status)
-
-(define-scheme-primop abort io type/unit)
-
-(define-nonsimple-scheme-primop error io)
-
-(define-scheme-primop error-string type/string)
-
-(define-scheme-primop call-external-value io type/integer)
-
-(define-nonsimple-scheme-primop read-block io)
-(define-scheme-primop write-block io type/status)
-
diff --git a/ps-compiler/prescheme/primop/primop.scm b/ps-compiler/prescheme/primop/primop.scm
deleted file mode 100644
index 2cd6ec2..0000000
--- a/ps-compiler/prescheme/primop/primop.scm
+++ /dev/null
@@ -1,163 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-(define prescheme-primop-table (make-symbol-table))
-
-(walk-vector (lambda (primop)
-	       (if (primop? primop)
-		   (table-set! prescheme-primop-table
-			       (primop-id primop)
-			       primop)))
-	     all-primops)
-
-(define (get-prescheme-primop id)
-  (cond ((table-ref prescheme-primop-table id)
-	 => identity)
-	((name->enumerand id primop)
-	 => get-primop)
-	(else
-	 (bug "Scheme primop ~A not found" id))))
-
-(define (add-scheme-primop! id primop)
-  (table-set! prescheme-primop-table id primop))
-
-(define-syntax define-scheme-primop
-  (syntax-rules ()
-    ((define-scheme-primop id type)
-     (define-scheme-primop id #f type))
-    ((define-scheme-primop id side-effects type)
-     (define-scheme-primop id side-effects type default-simplifier))
-    ((define-scheme-primop id side-effects type simplifier)
-     (define-polymorphic-scheme-primop
-       id side-effects (lambda (call) type) simplifier))))
-
-(define-syntax define-polymorphic-scheme-primop
-  (syntax-rules ()
-    ((define-polymorphic-scheme-primop id type)
-     (define-polymorphic-scheme-primop id #f type))
-    ((define-polymorphic-scheme-primop id side-effects type)
-     (define-polymorphic-scheme-primop id side-effects type default-simplifier))
-    ((define-scheme-primop id side-effects type simplifier)
-     (add-scheme-primop! 'id
-			 (make-primop 'id #t 'side-effects simplifier
-				      (lambda (call) 1)
-				      type)))))
-
-(define-syntax define-nonsimple-scheme-primop
-  (syntax-rules ()
-    ((define-nonsimple-scheme-primop id)
-     (define-nonsimple-scheme-primop id #f))
-    ((define-nonsimple-scheme-primop id side-effects)
-     (define-nonsimple-scheme-primop id side-effects default-simplifier))
-    ((define-nonsimple-scheme-primop id side-effects simplifier)
-     (add-scheme-primop! 'id
-			 (make-primop 'id #f 'side-effects simplifier
-				      (lambda (call) 1)
-				      'nontrivial-primop)))))
-
-(define-syntax define-scheme-cond-primop
-  (syntax-rules ()
-    ((define-scheme-cond-primop id simplifier expand simplify?)
-     (add-scheme-primop! 'id
-			 (make-conditional-primop 'id
-						  #f
-						  simplifier
-						  (lambda (call) 1)
-						  expand
-						  simplify?)))))
-
-;(define-prescheme! 'error  ; all four args must be present if used as value
-;  (lambda (exp env)
-;    (let ((string (expand (cadr exp) env #f))
-;          (args (map (lambda (arg)
-;                       (expand arg env #f))
-;                     (cddr exp))))
-;      (make-block-exp
-;       (list
-;        (make-call-exp (get-prescheme-primop 'error)
-;                       0
-;                       type/unknown
-;                       `(,string
-;                         ,(make-quote-exp (length args) type/int32)
-;                         . ,(case (length args)
-;                              ((0)
-;                               (list (make-quote-exp 0 type/int32)
-;                                     (make-quote-exp 0 type/int32)
-;                                     (make-quote-exp 0 type/int32)))
-;                              ((1)
-;                               (list (car args)
-;                                     (make-quote-exp 0 type/int32)
-;                                     (make-quote-exp 0 type/int32)))
-;                              ((2)
-;                               (list (car args)
-;                                     (cadr args)
-;                                     (make-quote-exp 0 type/int32)))
-;                              ((3)
-;                               args)
-;                              (else
-;                               (error "too many arguments to ERROR in ~S" exp))))
-;                       exp)
-;        (make-quote-exp the-undefined-value type/unknown))))))
-
-; For the moment VALUES is more or less a macro.
-
-;(define-prescheme! 'values   ; dies if used as a value
-;  (lambda (exp env)
-;    (make-call-exp (get-prescheme-primop 'pack)
-;                   0
-;                   type/unknown
-;                   (map (lambda (arg)
-;                          (expand arg env #f))
-;                        (cdr exp))
-;                   exp)))
-
-; Each arg spec is either #F = non-continuation argument or a list of
-; variable (name . type)s for the continuation.
-
-;(define (define-continuation-expander id primop-id arg-specs)
-;  (define-primitive-expander id (length arg-specs)
-;    (lambda (source args cenv)
-;      (receive (conts other)
-;          (expand-arguments args arg-specs cenv)
-;        (make-call-exp (get-prescheme-primop primop-id)
-;                       (length conts)
-;                       type/unknown
-;                       (append conts other)
-;                       source)))))
-
-;(define (expand-arguments args specs cenv)
-;  (let loop ((args args) (specs specs) (conts '()) (other '()))
-;    (if (null? args)
-;        (values (reverse conts) (reverse other))
-;        (let ((arg (expand (car args) cenv #f)))
-;          (if (not (car specs))
-;              (loop (cdr args) (cdr specs) conts (cons arg other))
-;              (loop (cdr args) (cdr specs)
-;                    (cons (expand-continuation-arg arg (car specs))
-;                          conts)
-;                    other))))))                                            
-;
-;(define (expand-continuation-arg arg var-specs)
-;  (let* ((vars (map (lambda (p)
-;                      (make-variable (car p) (cdr p)))
-;                    var-specs)))
-;    (make-continuation-exp
-;     vars
-;     (make-call-exp (get-primop (enum primop unknown-call))
-;                    0
-;                    type/unknown
-;                    `(,arg
-;                      ,(make-quote-exp (length vars) #f)
-;                      . ,vars)
-;                    #f)))) ; no source
-
-; Randomness needed by both arith.scm and c-arith.scm.
-
-; What we will get in C.
-(define prescheme-integer-size 32)
-
-(define int-mask (- (arithmetic-shift 1 prescheme-integer-size) 1))
-
-(define (lshr i n)
-  (arithmetic-shift (bitwise-and i int-mask) (- 0 n)))
-
diff --git a/ps-compiler/prescheme/primop/scm-arith.scm b/ps-compiler/prescheme/primop/scm-arith.scm
deleted file mode 100644
index ddc565b..0000000
--- a/ps-compiler/prescheme/primop/scm-arith.scm
+++ /dev/null
@@ -1,187 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-; Arithmetic inference rules
-
-(define (arith-op-rule args node depth return?)
-  (for-each (lambda (arg)
-	      (unify! (infer-type arg depth) type/integer node))
-	    args)
-  type/integer)
-
-(define (arith-comparison-rule args node depth return?)
-  (arith-op-rule args node depth return?)
-  type/boolean)
-
-(define (integer-binop-rule args node depth return?)
-  (check-arg-type args 0 type/integer depth node)
-  (check-arg-type args 1 type/integer depth node)
-  type/integer)
-
-(define (integer-monop-rule args node depth return?)
-  (check-arg-type args 0 type/integer depth node)
-  type/integer)
-
-(define (integer-comparison-rule args node depth return?)
-  (check-arg-type args 0 type/integer depth node)
-  type/boolean)
-
-;----------------------------------------------------------------
-; Arithmetic
-
-(define-complex-primitive (+ . integer?) +
-  arith-op-rule
-  (lambda (x y) (+ x y))
-  (lambda (args type)
-    (if (null? args)
-	(make-literal-node 0 type/integer)
-	(n-ary->binary args
-		       (make-literal-node (get-prescheme-primop '+))
-		       type))))
-
-(define-complex-primitive (* . integer?) *
-  arith-op-rule
-  (lambda (x y) (* x y))
-  (lambda (args type)
-    (if (null? args)
-	(make-literal-node 1)
-	(n-ary->binary args
-		       (make-literal-node (get-prescheme-primop '*))
-		       type))))
-
-(define-complex-primitive (- integer? . integer?)
-  (lambda args
-    (if (or (null? (cdr args))
-	    (null? (cddr args)))
-	(apply - args)
-	(user-error "error while evaluating: type error ~A" (cons '- args))))
-  (lambda (args node depth return?)
-    (case (length args)
-      ((1)
-       (check-arg-type args 0 type/integer depth node)
-       type/integer)
-      ((2)
-       (check-arg-type args 0 type/integer depth node)
-       (check-arg-type args 1 type/integer depth node)
-       type/integer)
-      (else
-       (user-error "wrong number of arguments to - in ~S" (schemify node)))))
-  (lambda (x y) (- x y))
-  (lambda (args type)
-    (let ((primop (get-prescheme-primop '-)))
-      (if (null? (cdr args))
-	  (make-primop-call-node primop
-				 (list (make-literal-node 0) (car args))
-				 type)
-	  (make-primop-call-node primop args type)))))
-
-(define (n-ary->binary args proc type)
-  (let loop ((args args))
-    (if (null? (cdr args))
-	(car args)
-	(loop (cons (make-call-node proc
-				    (list (car args) (cadr args))
-				    type)
-		    (cddr args))))))
-
-(define-syntax define-binary-primitive
-  (syntax-rules ()
-    ((define-binary-primitive id type-reconstruct)
-     (define-complex-primitive (id integer? integer?) id
-       type-reconstruct
-       (lambda (x y) (id x y))
-       (lambda (args type)
-	 (make-primop-call-node (get-prescheme-primop 'id) args type))))))
-
-(define-binary-primitive = arith-comparison-rule)
-(define-binary-primitive < arith-comparison-rule)
-
-(define-semi-primitive (>  integer? integer?) >
-  arith-comparison-rule
-  (lambda (x y) (< y x)))
-
-(define-semi-primitive (<= integer? integer?) <=
-  arith-comparison-rule
-  (lambda (x y) (not (< y x))))
-
-(define-semi-primitive (>= integer? integer?) >=
-  arith-comparison-rule
-  (lambda (x y) (not (< x y))))
-
-(define-binary-primitive quotient  integer-binop-rule)
-(define-binary-primitive remainder integer-binop-rule)
-(define-binary-primitive modulo    integer-binop-rule)
-
-(define-primitive bitwise-and
-  ((integer? type/integer) (integer? type/integer))
-  type/integer)
-
-(define-primitive bitwise-ior
-  ((integer? type/integer) (integer? type/integer))
-  type/integer)
-
-(define-primitive bitwise-xor
-  ((integer? type/integer) (integer? type/integer))
-  type/integer)
-
-(define-primitive bitwise-not
-  ((integer? type/integer))
-  type/integer)
-
-(define-primitive shift-left
-  ((integer? type/integer) (integer? type/integer))
-  type/integer
-  ashl)
-
-(define-primitive logical-shift-right
-  ((integer? type/integer) (integer? type/integer))
-  type/integer
-  lshr)
-
-(define-primitive arithmetic-shift-right
-  ((integer? type/integer) (integer? type/integer))
-  type/integer
-  ashr)
-
-(define-semi-primitive (abs integer?) abs
-  arith-op-rule
-  (lambda (n) (if (< n 0) (- 0 n) n)))
-
-(define-semi-primitive (zero? integer?) zero?
-  arith-comparison-rule
-  (lambda (n) (= n 0)))
-
-(define-semi-primitive (positive? integer?) positive?
-  arith-comparison-rule
-  (lambda (n) (< 0 n)))
-
-(define-semi-primitive (negative? integer?) negative?
-  arith-comparison-rule
-  (lambda (n) (< n 0)))
-
-(define-semi-primitive (even? integer?) even?
-  integer-comparison-rule
-  (lambda (n) (= 0 (remainder n 2))))
-
-(define-semi-primitive (odd? integer?) odd?
-  integer-comparison-rule
-  (lambda (n) (not (even? n))))
-  
-(define-semi-primitive (max integer? . integer?) max
-  arith-op-rule
-  (lambda (x y)
-    (if (< x y) y x)))
-  
-(define-semi-primitive (min integer? . integer?) min
-  arith-op-rule
-  (lambda (x y)
-    (if (< x y) x y)))
-
-(define-semi-primitive (expt integer? positive-integer?) expt
-  arith-op-rule
-  (lambda (x y)
-    (do ((r x (* r x))
-	 (y y (- y 1)))
-	((<= y 0)
-	 r))))
-
diff --git a/ps-compiler/prescheme/primop/scm-memory.scm b/ps-compiler/prescheme/primop/scm-memory.scm
deleted file mode 100644
index 18f2eb9..0000000
--- a/ps-compiler/prescheme/primop/scm-memory.scm
+++ /dev/null
@@ -1,122 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-(define-primitive allocate-memory ((positive-integer? type/integer)) type/address)
-(define-primitive deallocate-memory ((address? type/address)) type/unit)
-
-(define-load-time-primitive (address? #f) address?)
-
-(define-primitive address+ 
-  ((address? type/address)
-   (integer? type/integer))
-  type/address)
-
-(define-semi-primitive (address- address? integer?) address-
-  (lambda (args node depth return?)
-    (check-arg-type args 0 type/address depth node)
-    (check-arg-type args 1 type/integer depth node)
-    type/address)
-  (lambda (x y) (address+ x (- 0 y))))
-
-(define-primitive address-difference
-  ((address? type/address)
-   (address? type/address))
-  type/integer)
-
-(define-primitive address=
-  ((address? type/address)
-   (address? type/address))
-  type/boolean)
-
-(define-primitive address<
-  ((address? type/address)
-   (address? type/address))
-  type/boolean)
-
-(define-prescheme! 'null-address
-  (let ((location (make-undefined-location 'null-address)))
-    (set-contents! location (make-external-value "NULL" type/address))
-    location)
-  #f)
-
-(define-semi-primitive (null-address? address?) null-address?
-  (lambda (args node depth return)
-    (check-arg-type args 0 type/address depth node)
-    type/boolean)
-  (lambda (x) (address= x null-address)))
-
-(define (address-comparison-rule args node depth return?)
-  (check-arg-type args 0 type/address depth node)
-  (check-arg-type args 1 type/address depth node)
-  type/boolean)
-
-(define-semi-primitive (address> address? address?) address>
-  address-comparison-rule
-  (lambda (x y) (address< y x)))
-
-(define-semi-primitive (address<= address? address?) address<=
-  address-comparison-rule
-  (lambda (x y) (not (address< y x))))
-
-(define-semi-primitive (address>= address? address?) address>=
-  address-comparison-rule
-  (lambda (x y) (not (address< x y))))
-
-(define-primitive address->integer
-  ((address? type/address))
-  type/integer)
-   
-(define-primitive integer->address
-  ((integer? type/integer))
-  type/address)
-
-(define-primitive copy-memory! 
-  ((address? type/address)
-   (address? type/address)
-   (positive-integer? type/integer))
-  type/unit)
-
-(define-primitive memory-equal? 
-  ((address? type/address)
-   (address? type/address)
-   (positive-integer? type/integer))
-  type/boolean)
-
-(define-primitive unsigned-byte-ref
-  ((address? type/address))
-  type/integer
-  byte-ref)
-
-(define-primitive unsigned-byte-set!
-  ((address? type/address) (unsigned-byte? type/integer))
-  type/unit
-  byte-set!)
-
-(define-primitive word-ref ((address? type/address)) type/integer)
-(define-primitive word-set!
-  ((address? type/address) (positive-integer? type/integer))
-  type/unit)
-
-(define-primitive char-pointer->string
-  ((address? type/address)
-   (positive-integer? type/integer))
-  type/string)
-
-(define-primitive char-pointer->nul-terminated-string
-  ((address? type/address))
-  type/string)
-
-(let ((read-block-return-type
-       (make-tuple-type (list type/integer type/boolean type/status))))
-  (define-primitive read-block
-    ((input-port? type/input-port)
-     (address? type/address)
-     (positive-integer? type/integer))
-    read-block-return-type))
-  
-(define-primitive write-block
-  ((output-port? type/output-port)
-   (address? type/address)
-   (positive-integer? type/integer))
-  type/status)
-
diff --git a/ps-compiler/prescheme/primop/scm-record.scm b/ps-compiler/prescheme/primop/scm-record.scm
deleted file mode 100644
index d6360b0..0000000
--- a/ps-compiler/prescheme/primop/scm-record.scm
+++ /dev/null
@@ -1,46 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-(define-complex-primitive (make-record symbol?)
-  (lambda (type)
-    (bug "no evaluator for MAKE-RECORD"))
-  (lambda (args node depth return?)
-    (let ((type-id (cadr (node-form (car args)))))
-      (make-pointer-type (get-record-type type-id))))
-  #f  ; no closed form
-  (lambda (args type)
-    (make-primop-call-node (get-prescheme-primop 'make-record) args type)))
-
-(define-complex-primitive (record-ref any?  ; no RECORD? available
-				      symbol? symbol?)
-  (lambda (thing type field)
-    (bug "no evaluator for RECORD-REF"))
-  (lambda (args node depth return?)
-    (let ((type-id (cadr (node-form (cadr args))))
-	  (field-id (cadr (node-form (caddr args)))))
-      (let ((record-type (make-pointer-type (get-record-type type-id)))
-	    (field-type (record-field-type
-			 (get-record-type-field type-id field-id))))
-	(check-arg-type args 0 record-type depth node)
-	field-type)))
-  #f  ; no closed form
-  (lambda (args type)
-    (make-primop-call-node (get-prescheme-primop 'record-ref) args type)))
-
-(define-complex-primitive (record-set! any?  ; no RECORD? available
-				       any? symbol? symbol?)
-  (lambda (thing value type field)
-    (bug "no evaluator for RECORD-SET!"))
-  (lambda (args node depth return?)
-    (let ((type-id (cadr (node-form (caddr args))))
-	  (field-id (cadr (node-form (cadddr args)))))
-      (let ((record-type (make-pointer-type (get-record-type type-id)))
-	    (field-type (record-field-type
-			 (get-record-type-field type-id field-id))))
-	(check-arg-type args 0 record-type depth node)
-	(check-arg-type args 1 field-type depth node)
-	type/unit)))
-  #f  ; no closed form
-  (lambda (args type)
-    (make-primop-call-node (get-prescheme-primop 'record-set!) args type)))
-
diff --git a/ps-compiler/prescheme/primop/scm-scheme.scm b/ps-compiler/prescheme/primop/scm-scheme.scm
deleted file mode 100644
index 0db036a..0000000
--- a/ps-compiler/prescheme/primop/scm-scheme.scm
+++ /dev/null
@@ -1,403 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-; Primitives that directly correspond to primops.
-;
-; (define-primitive (id (arg-pred arg-type) ...) result-type . maybe-primop-id)
-;
-; Primitives that are n-ary or have other weirdness.
-;
-; (define-complex-primitive (id . argument-predicates)
-;   eval-fn inference-rule source . maybe-expander)
-;
-; Primitives that have only source but not a primop.
-;
-; (define-semi-primitive (id . argument-predicates)
-;   eval-fn inference-rule source maybe-expander)
-;
-; Primitives available only at load time.
-;
-; (define-load-time-primitive (id . argument-predicates) eval-fn)
-
-; (really-define-primitive (id . argument-predicates)
-;   eval-fn inference-rule source expander expands-in-place?)
-
-(define-syntax really-define-primitive
-  (lambda (exp r c)
-    (let* ((spec (cadr exp))
-	   (id (car spec))
-	   (arg-predicates (cdr spec))
-	   (eval (caddr exp))
-	   (rest (cdddr exp))
-	   (inference-rule (car rest))
-	   (source (cadr rest))
-	   (expander (caddr rest))
-	   (expands-in-place? (cadddr rest)))
-      `(let ((,(r 'predicates) ,(let recur ((preds arg-predicates))
-				  (cond ((pair? preds)
-					 `(cons ,(car preds)
-						,(recur (cdr preds))))
-					((null? preds)
-					 '(quote ()))
-					(else
-					 preds)))))
-	 (define-prescheme! ',id
-	   #f				; location
-	   (make-primitive ',id
-			   ,(r 'predicates)
-			   ,eval
-			   ',source
-			   ,expander
-			   ,expands-in-place?
-			   ,inference-rule))))))
-
-(define-syntax define-complex-primitive
-  (lambda (exp r c)
-    `(really-define-primitive ,@(cdr exp) #t)))
-
-(define-syntax define-primitive
-  (lambda (exp r c)
-    (let* ((id (cadr exp))
-	   (args (caddr exp))
-	   (result (cadddr exp))
-	   (primop (if (null? (cddddr exp)) (cadr exp) (car (cddddr exp))))
-	   (names (map (lambda (a b) b)
-		       args
-		       '(x1 x2 x3 x4 x5 x6 x7 x8 x9))))
-      `(define-complex-primitive (,id . ,(map car args)) ,id
-	 (lambda (args node depth return?)
-	   (if (not (= (length args)
-		       ,(length args)))
-	       (user-error "wrong number of arguments in ~S" (schemify node)))
-	   ,@(do ((i 0 (+ i 1))
-		  (args args (cdr args))
-		  (res '() (cons `(check-arg-type args ,i ,(cadar args) depth node)
-				 res)))
-		 ((null? args)
-		  (reverse res)))
-	   ,result)
-	 (lambda ,names (,id . ,names))
-	 (lambda (args type)
-	   (make-primop-call-node (get-prescheme-primop ',primop) args type))))))
-
-(define-syntax define-semi-primitive
-  (lambda (exp r c)
-    `(really-define-primitive ,@(cdr exp) #f #f)))
-
-(define-syntax define-load-time-primitive
-  (lambda (exp r c)
-    `(define-semi-primitive ,(cadr exp)
-       ,(caddr exp)
-       (make-load-time-only-rule ',(caadr exp))
-       #f)))
-
-(define (make-load-time-only-rule id)
-  (lambda (args node depth return?)
-    (user-error "~S is only available at load time ~S" id (schemify node))))
-   
-;----------------------------------------------------------------
-; Boolean stuff
-
-(define-semi-primitive (not #f) not
-  (lambda (args node depth return?)
-    (check-arg-type args 0 type/boolean depth node)
-    type/boolean)
-  (lambda (x) (if x #f #t)))
-
-(define-load-time-primitive (boolean? #f) boolean?)
-
-(define-complex-primitive (eq? #f #f) eq?
-  (lambda (args node depth return?)
-    (unify! (infer-type (car args) depth)
-	    (infer-type (cadr args) depth)
-	    node)
-    type/boolean)
-  (lambda (x y) (eq? x y))
-  (lambda (args type)
-    (make-primop-call-node (get-prescheme-primop 'eq?) args type)))
-
-(define-load-time-primitive (eqv? #f) eqv?)
-(define-load-time-primitive (equal? #f) equal?)
-
-;----------------------------------------------------------------
-; Characters
-
-(define (ascii-value? n)
-  (and (integer? n)
-       (>= n 0)
-       (< n ascii-limit)))
-
-(define-primitive ascii->char ((ascii-value? type/integer)) type/char)
-(define-primitive char->ascii ((char? type/char)) type/integer)
-    
-(define (char-comparison-rule args node depth return?)
-  (check-arg-type args 0 type/char depth node)
-  (check-arg-type args 1 type/char depth node)
-  type/boolean)
-
-(define-syntax define-char-comparison
-  (lambda (exp r c)
-    (let ((id (cadr exp))
-	  (op (caddr exp)))
-      `(define-complex-primitive (,id char? char?) ,id
-	 char-comparison-rule
-	 (lambda (x y) (,op x y))
-	 (lambda (args type)
-	   (make-primop-call-node (get-prescheme-primop ',op) args type))))))
-
-(define-char-comparison char=? =)
-(define-char-comparison char<? <)
-(define-char-comparison char>? >)
-(define-char-comparison char<=? <=)
-(define-char-comparison char>=? >=)
-
-; Plus lots more...
-
-;----------------------------------------------------------------
-; Data manipulation
-
-(define (any? x) #t)
-
-(define (positive-integer? x)
-  (and (integer? x)
-       (<= 0 x)))
-
-(define (unsigned-byte? x)
-  (and (positive-integer? x)
-       (<= x 256)))
-
-(define-complex-primitive (make-vector positive-integer? . any?) make-vector
-  (lambda (args node depth return?)
-    (let ((uvar (make-uvar 'v depth)))
-      (make-nonpolymorphic! uvar)
-      (check-arg-type args 0 type/integer depth node)
-      (check-arg-type args 1 uvar         depth node)
-      (make-pointer-type uvar)))
-  (lambda (size init)
-    (make-vector size init))
-  (lambda (args type)
-    (make-primop-call-node (get-prescheme-primop 'make-vector) args type)))
-
-(define-load-time-primitive (vector-length vector?) vector-length)
-
-(define-complex-primitive (vector-ref vector? positive-integer?) vector-ref
-  (lambda (args node depth return?)
-    (let ((elt-type (make-uvar 'v depth)))
-      (check-arg-type args 0 (make-pointer-type elt-type) depth node)
-      (check-arg-type args 1 type/integer depth node)
-      elt-type))
-  (lambda (vector index)
-    (vector-ref vector index))
-  (lambda (args type)
-    (make-primop-call-node (get-prescheme-primop 'vector-ref) args type)))
-
-(define-complex-primitive (vector-set! vector? positive-integer? any?)
-  vector-set!
-  (lambda (args node depth return?)
-    (let ((elt-type (make-uvar 'v depth)))
-      (check-arg-type args 0 (make-pointer-type elt-type) depth node)
-      (check-arg-type args 1 type/integer depth node)
-      (check-arg-type args 2 elt-type depth node)
-      type/unit))
-  (lambda (vector index value)
-    (vector-set! vector index value))
-  (lambda (args type)
-    (make-primop-call-node (get-prescheme-primop 'vector-set!) args type)))
-
-(define-primitive make-string ((integer? type/integer)) type/string)
-(define-primitive string-length ((string? type/string)) type/integer)
-
-(define-primitive string-ref
-  ((string? type/string) (integer? type/integer))
-  type/char)
-
-(define-primitive string-set!
-  ((string? type/string) (integer? type/integer) (char? type/char))
-  type/unit)
-
-(define-complex-primitive (deallocate any?) (lambda (x) (values))
-  (lambda (args node depth return?)
-    (let ((type (make-pointer-type (make-uvar 'p depth))))
-      (check-arg-type args 0 type depth node)
-      type/unit))
-  (lambda (thing)
-    (deallocate thing))
-  (lambda (args type)
-    (make-primop-call-node (get-prescheme-primop 'deallocate) args type)))
-
-(define-complex-primitive (null-pointer? any?) (lambda (x) #f)
-  (lambda (args node depth return?)
-    (let ((type (make-pointer-type (make-uvar 'p depth))))
-      (check-arg-type args 0 type depth node)
-      type/boolean))
-  (lambda (thing)
-    (null-pointer? thing))
-  (lambda (args type)
-    (make-primop-call-node (get-prescheme-primop 'null-pointer?) args type)))
-
-(define-complex-primitive (null-pointer) (lambda () #f)
-  (lambda (args node depth return?)
-    (make-pointer-type (make-uvar 'null depth)))
-  (lambda ()
-    (null-pointer))
-  (lambda (args type)
-    (make-primop-call-node (get-prescheme-primop 'null-pointer) args type)))
-
-;----------------------------------------------------------------
-; I/O
-
-(define-primitive current-input-port  () type/input-port  stdin)
-(define-primitive current-output-port () type/output-port stdout)
-(define-primitive current-error-port  () type/output-port stderr)
-
-(define type/status type/integer)
-
-(let ((return (make-tuple-type (list type/input-port type/status))))
-  (define-primitive open-input-file ((string? type/string)) return))
-
-(let ((return (make-tuple-type (list type/output-port type/status))))
-  (define-primitive open-output-file ((string? type/string)) return))
-
-(define-primitive close-input-port ((input-port? type/input-port)) type/status)
-(define-primitive close-output-port ((output-port? type/output-port)) type/status)
-
-(define char-return-type
-  (make-tuple-type (list type/char type/boolean type/status)))
-
-(define-primitive read-char ((input-port? type/input-port)) char-return-type)
-(define-primitive peek-char ((input-port? type/input-port)) char-return-type)
-
-(define integer-return-type
-  (make-tuple-type (list type/integer type/boolean type/status)))
-
-(define-primitive read-integer ((input-port? type/input-port)) integer-return-type)
-
-(define-primitive write-char
-  ((char? type/char) (output-port? type/output-port))
-  type/status)
-
-(define-primitive write-string
-  ((string? type/string) (output-port? type/output-port))
-  type/status)
-
-(define-primitive write-integer
-  ((integer? type/integer) (output-port? type/output-port))
-  type/status)
-
-(define-complex-primitive (newline output-port?) newline
-  (lambda (args node depth return?)
-    (check-arg-type args 0 type/output-port depth node)
-    type/status)
-  (lambda (out)
-    (write-char #\newline out))
-  (lambda (args type)
-    (make-primop-call-node (get-prescheme-primop 'write-char)
-			   (cons (make-literal-node #\newline) args)
-			   type)))
-
-(define-primitive force-output ((output-port? type/output-port)) type/status)
-
-(define-primitive error-string
-  ((positive-integer? type/status))
-  type/string)
-
-;----------------------------------------------------------------
-
-(define-complex-primitive (values . any?) values
-  (lambda (args node depth return?)
-    (make-tuple-type (infer-types args depth)))
-  #f
-  (lambda (args type)
-    (let ((node (make-node values-operator (cons 'values args))))
-      (node-set! node 'type type)
-      node)))
-
-(define values-operator (get-operator 'values))
-
-; CALL-WITH-VALUES that uses closures instead of procedures.
-
-(define (ps-call-with-values producer consumer)
-  (call-with-values
-   (lambda ()
-     (apply-closure producer '()))
-   (lambda args
-     (apply-closure consumer args))))
-
-(define-complex-primitive (call-with-values closure? closure?)
-  ps-call-with-values
-  (lambda (args node depth return?)
-    (if (not (lambda-node? (cadr args)))
-	(user-error
-	 "second argument to CALL-WITH-VALUES must be a lambda node~%  ~S"
-	 (schemify node)))
-    (let* ((consumer-type (infer-type (cadr args) depth))
-	   (arg-types (arrow-type-args consumer-type))
-	   (result-type (arrow-type-result consumer-type)))
-      (unify! (infer-type (car args) depth)
-	      (make-arrow-type '() (make-tuple-type arg-types))
-	      node)
-      (if (not return?)  ; so we cause a check for illegal tuples
-	  (unify! result-type (make-uvar 'temp depth) node))
-      result-type))
-  #f
-  (lambda (args type)
-    (let* ((tuple-type (arrow-type-result
- 			 (maybe-follow-uvar (node-ref (car args) 'type))))
-	   (node (make-node call-with-values-operator
-			    (list 'call-with-values
-				  (make-call-node (car args) '() tuple-type)
-				  (cadr args)))))
-      (node-set! node 'type type)
-      node)))
-
-(define lambda-node? (node-predicate 'lambda))
-
-(define call-with-values-operator (get-operator 'call-with-values))
-
-(define-primitive unspecific () type/unit)
-
-(define-complex-primitive (error string? . integer?) error
-  (lambda (args node depth return?)
-    (check-arg-type args 0 type/string depth node)
-    (do ((args (cdr args) (cdr args)))
-	((null? args))
-      (check-arg-type args 0 type/integer depth node))
-    type/null)
-  (lambda (error string)
-    (error string))
-  (lambda (args type)
-    (make-primop-call-node (get-prescheme-primop 'error) args type)))
-
-; For enumerated types that are shared with C
-
-(define-load-time-primitive (make-external-constant symbol? symbol? string?)
-  make-external-constant)
-
-;----------------------------------------------------------------
-; Utilities for making nodes
-
-(define call-operator (get-operator 'call))
-(define literal-operator (get-operator 'literal))
-(define name-operator (get-operator 'name))
-(define primitive-operator (get-operator 'primitive))
-
-(define (make-call-node proc args type)
-  (let ((node (make-node call-operator (cons proc args))))
-    (node-set! node 'type type)
-    node))
-
-(define (make-literal-node value)
-  (make-node literal-operator value))
-
-(define (make-primop-call-node primop args type)
-  (make-call-node (make-literal-node primop) args type))
-
-(define (make-reference-node id binding)
-  (let ((node (make-node name-operator id)))
-    (node-set! node 'binding binding)
-    node))
-
-(define (var->name-node var)
-  (make-reference-node ((structure-ref variable variable-name) var)
-		       (make-binding #f var #f)))
-
diff --git a/ps-compiler/prescheme/primop/vector.scm b/ps-compiler/prescheme/primop/vector.scm
deleted file mode 100644
index 5edb734..0000000
--- a/ps-compiler/prescheme/primop/vector.scm
+++ /dev/null
@@ -1,82 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-(define-polymorphic-scheme-primop make-vector allocate
-  (lambda (call)
-    (make-pointer-type (node-type (call-arg call 1)))))
-
-(define-polymorphic-scheme-primop vector-ref read
-  (lambda (call)
-    (pointer-type-to (node-type (call-arg call 0)))))
-
-(define-nonsimple-scheme-primop vector-set! write)
-
-(define-scheme-primop make-string   allocate type/string)
-(define-scheme-primop string-length          type/integer)
-(define-scheme-primop string-ref    read     type/char)
-
-(define-nonsimple-scheme-primop string-set! write)
-
-(define-polymorphic-scheme-primop make-record allocate
-  (lambda (call)
-    (literal-value (call-arg call 1))))
-
-(define-polymorphic-scheme-primop record-ref read
-  (lambda (call)
-    (record-field-type (literal-value (call-arg call 1)))))
-
-(define-nonsimple-scheme-primop record-set! write)
-
-(define-scheme-primop deallocate        deallocate type/unit)
-(define-scheme-primop allocate-memory   allocate   type/address)
-(define-scheme-primop deallocate-memory deallocate type/unit)
-
-(define (simplify-address+ call)
-  (simplify-args call 0)
-  ((pattern-simplifier
-    ((address+ a '0) a)
-    ((address+ (address+ a x) y) (address+ a (+ x y))))
-   call))
-
-(define-scheme-primop address+ #f type/address simplify-address+)
-
-(define-scheme-primop address-difference type/address)
-(define-scheme-primop address=           type/boolean)
-(define-scheme-primop address<           type/boolean)
-(define-scheme-primop address->integer   type/integer)
-(define-scheme-primop integer->address   type/address)
-
-(define-scheme-primop copy-memory!  write type/unit)
-(define-scheme-primop memory-equal?       type/boolean)
-(define-scheme-primop byte-ref      read  type/integer)
-(define-scheme-primop word-ref      read  type/integer)
-
-(define-nonsimple-scheme-primop byte-set! write)
-(define-nonsimple-scheme-primop word-set! write)
-
-; We delete the length argument because we don't need it.  This is allowable
-; because trivial calls can't have WRITE side effects.
-
-(define-scheme-primop char-pointer->string #f type/string
-  (lambda (call)
-    (if (= 2 (call-arg-count call))
-	(remove-call-arg call 1))))
-
-(define-scheme-primop char-pointer->nul-terminated-string type/string)
-
-; (COMPUTED-GOTO <exit0> <exit1> ... <exitN> <dispatch-value>)
-
-; Remove an unecessary coercion on the dispatch-value, if possible.
-
-(define (simplify-computed-goto call)
-  (simplify-args call 0)
-  (let ((value (call-arg call (call-exits call))))
-    (cond ((and (call-node? value)
-		(eq? 'coerce (primop-id (call-primop value)))
-		(< (call-exits call) 256)
-		(eq? type/integer (literal-value (call-arg value 1))))
-	   (replace value (detach (call-arg value 0)))))))
-
-(define-nonsimple-scheme-primop computed-goto #f simplify-computed-goto)
-
-
-
diff --git a/ps-compiler/prescheme/ps-syntax.scm b/ps-compiler/prescheme/ps-syntax.scm
deleted file mode 100644
index a7e08ce..0000000
--- a/ps-compiler/prescheme/ps-syntax.scm
+++ /dev/null
@@ -1,116 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-; Redefine CASE so that it doesn't call MEMV
-
-(define-syntax case
-  (lambda (e r c)
-    (let ((x (r 'x))
-	  (xlet (r 'let))
-	  (xcond (r 'cond))
-	  (xif (r 'if))
-	  (xeq? (r 'eq?))
-	  (xquote (r 'quote)))
-      (let ((test (lambda (y)
-		    `(,xeq? ,x (,xquote ,y)))))
-	`(,xlet ((,x ,(cadr e)))
-		(,xcond . ,(map (lambda (clause)
-				  (if (c (car clause) 'else)
-				      clause
-				      `(,(let label ((xs (car clause)))
-					   (cond ((null? xs) #f)
-						 ((null? (cdr xs))
-						  (test (car xs)))
-						 (else
-						  `(,xif ,(test (car xs))
-							 #t
-							 ,(label (cdr xs))))))
-					. ,(cdr clause))))
-				(cddr e))))))))
-
-; RECEIVE (from big-scheme)
-
-(define-syntax receive
-  (syntax-rules ()
-    ((receive ?vars ?producer . ?body)
-     (call-with-values (lambda () ?producer)
-		       (lambda ?vars . ?body)))))
-
-
-(define-syntax external
-  (lambda (e r c)
-    (let ((l (length e)))
-      (if (and (or (= l 3) (= l 4))
-	       (string? (cadr e)))
-	  `(,(r 'real-external) ,(cadr e) ',(caddr e))
-	  e))))
-
-; DEFINE-EXTERNAL-ENUMERATION (from prescheme)
-
-(define-syntax define-external-enumeration
-  (lambda (form rename compare)
-    (let* ((name (cadr form))
-	   (symbol->upcase-string
-	    (lambda (s)
-	      (list->string (map (lambda (c)
-				   (if (char=? c #\-)
-				       #\_
-				       (char-upcase c)))
-				 (string->list (symbol->string s))))))
-	   (constant
-	    (lambda (sym string)
-	      `(,(rename 'make-external-constant) ',name ',sym ,string)))
-	   (conc (lambda things
-		   (string->symbol (apply string-append
-					  (map (lambda (thing)
-						 (if (symbol? thing)
-						     (symbol->string thing)
-						     thing))
-					       things)))))
-	   (var-name
-	    (lambda (sym)
-	      (conc name "/" sym)))
-	   (components
-	    (list->vector
-	     (map (lambda (stuff)
-		    (if (pair? stuff)
-			(cons (car stuff)
-			      (var-name (car stuff)))
-			(cons stuff
-			      (var-name stuff))))
-		  (caddr form))))
-	   (%define (rename 'define))
-	   (%define-syntax (rename 'define-syntax))
-	   (%begin (rename 'begin))
-	   (%quote (rename 'quote))
-	   (%make-external-constant (rename 'make-external-constant))
-	   (e-name (conc name '- 'enumeration))
-	   (count (vector-length components)))
-      `(,%begin
-	(,%define-syntax ,name
-	    (let ((components ',components))
-	      (lambda (e r c)
-		(let ((key (cadr e)))
-		  (cond ((c key 'enum)
-			 (let ((which (caddr e)))
-			   (let loop ((i 0)) ;vector-posq
-			     (if (< i ,count)
-				 (if (c which (car (vector-ref components i)))
-				     (r (cdr (vector-ref components i)))
-				     (loop (+ i 1)))
-				 ;; (syntax-error "unknown enumerand name"
-				 ;;               `(,(cadr e) ,(car e) ,(caddr e)))
-				 e))))
-			(else e))))))
-	(,%define ,(conc name '- 'count) ,count)
-        . ,(map (lambda (stuff)
-		  (if (pair? stuff)
-		      `(,%define ,(var-name (car stuff))
-			   (,%make-external-constant ',name
-						     ',(car stuff)
-						     ,(cadr stuff)))
-		      `(,%define ,(var-name stuff)
-			   (,%make-external-constant ',name
-						     ',stuff
-						     ,(symbol->upcase-string stuff)))))
-		(caddr form)))))
-    (begin define define-syntax quote external make-external-constant))
diff --git a/ps-compiler/prescheme/record.scm b/ps-compiler/prescheme/record.scm
deleted file mode 100644
index 1dbe329..0000000
--- a/ps-compiler/prescheme/record.scm
+++ /dev/null
@@ -1,122 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-; Records that translate into C structs.
-
-; Representation of records types.
-
-(define-record-type record-type
-  (name)
-  (fields              ; filled in later because of circularity
-   constructor-args)   ; fields passed to the constructor
-  )
-
-(define-record-discloser type/record-type
-  (lambda (rtype)
-    (list 'record-type (record-type-name rtype))))
-
-; Fields of record types.
-
-(define-record-type record-field
-  (record-type
-   name
-   type
-   )
-  ())
-
-; Global table of record types.  Since we compile to a single C file the
-; record types used within a single computation must have distinct names.
-; (This should really be a fluid.)
-
-(define *record-type-table* (make-symbol-table))
-
-(define (reset-record-data!)
-  (set! *record-type-table* (make-symbol-table)))
-
-(define (get-record-type id)
-  (cond ((table-ref *record-type-table* id)
-	 => identity)
-	(else
-	 (error "no record type ~S" id))))
-
-(define (lookup-record-type id)
-  (table-ref *record-type-table* id))
-
-(define (all-record-types)
-  (table->entry-list *record-type-table*))
-
-; Construction a record type.  This gets the name, the list of fields whose
-; initial values are passed to the constructor, and the field specifications.
-; Each field specification consists of a name and a type.
-
-(define (make-record-type id constructor-args specs)
-  (let ((rt (record-type-maker id)))
-    (if (table-ref *record-type-table* id)
-	(user-error "multiple definitions of record type ~S" id))
-    (table-set! *record-type-table* id rt)
-    (set-record-type-fields! rt (map (lambda (spec)
-				       (record-field-maker
-					  rt
-					  (car spec)
-					  (expand-type-spec (cadr spec))))
-				     specs))
-    (set-record-type-constructor-args! rt
-				       (map (lambda (name)
-					      (get-record-type-field id name))
-					    constructor-args))
-    rt))
-
-; Return the field record for FIELD-ID in record-type TYPE-ID.
-
-(define (get-record-type-field type-id field-id)
-  (let ((rtype (get-record-type type-id)))
-    (cond ((any (lambda (field)
-		  (eq? field-id (record-field-name field)))
-		(record-type-fields rtype))
-	   => identity)
-	  (else
-	   (user-error "~S is not a field of ~S" field-id rtype)))))
-
-; The macro expander for DEFINE-RECORD-TYPE.
-;
-; (define-record-type <id> <type-id>
-;   (<constructor> . <field-names>)
-;   (<field-name> <type> <accessor-name> [<modifier-name>]) ...)
-; 
-; The <type-id> is used only by Pre-Scheme-in-Scheme.
-
-(define (expand-define-record-type exp r c)
-  (let ((id (cadr exp))
-	(maker (cadddr exp))
-	(fields (cddddr exp)))
-    (let ((rt (make-record-type id (cdr maker) fields)))
-      `(,(r 'begin)
-	(,(r 'define) ,maker
-	   (,(r 'let) ((,(r id) (,(r 'make-record) ',id)))
-	     (,(r 'if) (,(r 'not) (,(r 'null-pointer?) ,(r id)))
-	       (,(r 'begin)
-		 . ,(map (lambda (name)
-			   `(,(r 'record-set!) ,(r id) ,name ',id ',name))
-			 (cdr maker))))
-	     ,(r id)))
-	,@(map (lambda (field)
-		 `(,(r 'define) (,(caddr field) ,(r id))
-				(,(r 'record-ref) ,(r id) ',id ',(car field))))
-	       fields)
-	,@(map (lambda (field)
-		 `(,(r 'define) (,(cadddr field) ,(r id) ,(r 'x))
-			(,(r 'record-set!)
-			 ,(r id) ,(r 'x)',id ',(car field))))
-	       (filter (lambda (spec)
-			 (not (null? (cdddr spec))))
-		       fields))))))
-
-; primitives
-;  (make-record 'type . args)
-;  (record-ref thing 'type 'field)
-;  (record-set! thing value 'type 'field)
-;
-; C record creator
-;  global list of these things
-  
-  
\ No newline at end of file
diff --git a/ps-compiler/prescheme/spec.scm b/ps-compiler/prescheme/spec.scm
deleted file mode 100644
index 4fa3222..0000000
--- a/ps-compiler/prescheme/spec.scm
+++ /dev/null
@@ -1,101 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-; Protocol specifications are lists of representations.
-
-(set-compiler-parameter! 'lambda-node-type
-			 (lambda (node)
-			   (let ((vars (lambda-variables node)))
-			     (case (lambda-type node)
-			       ((cont jump)
-				(make-arrow-type (map variable-type vars)
-						 type/unknown)) ; what to do?
-			       ((proc known-proc)
-				(make-arrow-type (map variable-type (cdr vars))
-						 (variable-type (car vars))))
-			       (else
-				(error "unknown type of lambda node ~S" node))))))
-
-(set-compiler-parameter! 'true-value #t)
-(set-compiler-parameter! 'false-value #f)
-
-; Tail-calls with goto-protocols cause the lambda node to be annotated
-; as tail-called.
-; Calls with a tuple argument need their argument spread out into separate
-; variables.
-
-(define (determine-lambda-protocol lambda-node call-refs)
-  (set-lambda-protocol! lambda-node #f)
-  (for-each (lambda (r)
-	      (let ((call (node-parent r)))
-		(cond ((goto-protocol? (literal-value (call-arg call 2)))
-		       (if (not (calls-this-primop? call 'unknown-tail-call))
-			   (bug "GOTO marker in non-tail-all ~S" call))
-		       (set-lambda-protocol! lambda-node 'tail-called)))
-		(unknown-call->known-call call)))
-	    call-refs)
-  (set-calls-known?! lambda-node))
-
-(set-compiler-parameter! 'determine-lambda-protocol determine-lambda-protocol)
-
-(define (unknown-call->known-call call)
-  (remove-call-arg call 2)  ; remove the protocol
-  (set-call-primop! call
-		    (case (primop-id (call-primop call))
-		      ((unknown-call)
-		       (get-primop (enum primop call)))
-		      ((unknown-tail-call)
-		       (get-primop (enum primop tail-call)))
-		      (else
-		       (bug "odd primop in call ~S" call)))))
-
-; CONT is the continuation passed to PROCS.
-
-(define (determine-continuation-protocol cont procs)
-  (for-each (lambda (proc)
-	      (let ((cont-var (car (lambda-variables proc))))
-		(walk-refs-safely
-		 (lambda (ref)
-		   (let ((call (node-parent ref)))
-		     (unknown-return->known-return call cont-var cont)))
-		 cont-var)))
-	    procs))
-
-(set-compiler-parameter! 'determine-continuation-protocol
-			 determine-continuation-protocol)
-
-; If the return is actually a tail-recursive call we change it to
-; a non-tail-recursive one (since we have identified the continuation)
-; and insert the appropriate continuation.
-
-(define (unknown-return->known-return call cont-var cont)
-  (case (primop-id (call-primop call))
-    ((unknown-return)
-     (set-call-primop! call (get-primop (enum primop return))))
-    ((unknown-tail-call tail-call)
-     (let* ((vars (map copy-variable (lambda-variables cont)))
-	    (args (map make-reference-node vars)))
-       (let-nodes ((cont vars (return 0 (* cont-var) . args)))
-	 (replace (call-arg call 0) cont)
-	 (set-call-primop! call
-			   (if (calls-this-primop? call 'tail-call)
-			       (get-primop (enum primop call))
-			       (get-primop (enum primop unknown-call))))
-	 (set-call-exits! call 1)
-	 (if (and (calls-this-primop? call 'unknown-call)
-		  (goto-protocol? (literal-value (call-arg call 2))))
-	     (set-literal-value! (call-arg call 2) #f)))))
-    (else
-     (bug "odd return primop ~S" (call-primop call)))))
-
-(define normal-protocol #f)
-(define goto-protocol 'goto)
-
-(define (goto-protocol? x)
-  (eq? x goto-protocol))
-
-(set-compiler-parameter! 'lookup-primop get-prescheme-primop)
-
-(set-compiler-parameter! 'type/unknown type/unknown)
-
-(set-compiler-parameter! 'type-eq? type-eq?)
-
diff --git a/ps-compiler/prescheme/substitute.scm b/ps-compiler/prescheme/substitute.scm
deleted file mode 100644
index 54a57ae..0000000
--- a/ps-compiler/prescheme/substitute.scm
+++ /dev/null
@@ -1,324 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-; Substituting new variables for old in expressions.
-
-(define *free-exp-vars* #f)
-
-(define (substitute-in-expression exp)
-  (set! *free-exp-vars* '())
-  (set! *letrec-datas* '())
-  (let* ((exp (substitute-in-exp exp))
-	 (free *free-exp-vars*))
-    (set! *free-exp-vars* '())
-    (for-each (lambda (var)
-		(set-variable-flag! var #f))
-	      free)
-    (values exp free)))
-
-(define global-marker (list 'global))
-
-(define (note-binding-use! binding)
-  (let ((var (binding-place binding)))
-    (if (variable? var)
-	(note-variable-use! var))))
-
-(define (note-variable-use! var)
-  (cond ((not (eq? (variable-flag var) global-marker))
-	 (set! *free-exp-vars* (cons var *free-exp-vars*))
-	 (set-variable-flag! var global-marker))))
-
-; Main dispatch
-
-(define (substitute-in-exp node)
-  ((operator-table-ref substitutions (node-operator-id node))
-   node))
-
-; Particular operators
-
-(define substitutions
-  (make-operator-table
-   (lambda (node)
-     (error "no substitution for node ~S" node))))
-
-(define (default-substitution node)
-  (make-similar-node node
-		     (cons (car (node-form node))
-			   (map substitute-in-exp (cdr (node-form node))))))
-
-(define (define-substitution name proc)
-  (operator-define! substitutions name #f proc))
-
-(define-substitution 'literal identity)
-(define-substitution 'quote identity)
-(define-substitution 'unspecific identity)
-
-(define-substitution 'real-external
-  (lambda (node)
-    (let* ((exp (node-form node))
-	   (type (expand-type-spec (cadr (node-form (caddr exp))))))
-      (make-literal-node (make-external-value (node-form (cadr exp))
-					      type)))))
-
-(define op/literal (get-operator 'literal))
-
-(define (make-literal-node x)
-  (make-node op/literal x))
-
-; We copy the names because the same node may occur in multiple places
-; in the tree.
-
-(define-substitution 'lambda
-  (lambda (node)
-    (let* ((new-names (copy-names (cadr (node-form node))))
-	   (body (substitute-in-exp (caddr (node-form node)))))
-      (make-similar-node node
-			 (list (car (node-form node))
-			       new-names
-                               body)))))
-
-(define (copy-names names)
-  (map (lambda (name)
-	 (let ((new (make-similar-node name (node-form name))))
-	   (node-set! name 'substitute new)
-	   new))
-       names))
-
-(define-substitution 'name
-  (lambda (node)
-    (substitute-name-node node #f)))
-
-(define (substitute-name-node node call?)
-  (let ((node (name-node-substitute node)))
-    (let ((binding (node-ref node 'binding)))
-      (cond ((not binding)
-	     (note-name-use! node)
-	     node)
-	    ((primitive? (binding-static binding))
-	     (make-primitive-node (binding-static binding) call?))
-	    ((location? (binding-place binding))
-	     (let ((value (contents (binding-place binding))))
-	       (if (constant? value)
-		   (make-literal-node value)
-		   (identity
-		   (bug "name ~S has non-constant location ~S" node value)))))
-	    (else
-	     (note-binding-use! binding)
-	     node)))))
-
-(define (name-node-substitute node)
-  (let loop ((node node) (first? #t))
-    (cond ((node-ref node 'substitute)
-	   => (lambda (node)
-		(loop node #f)))
-	  ((and first? (not (node-ref node 'binding)))
-	   (user-error "unbound variable ~S" (node-form node)))
-	  (else
-	   node))))
-
-(define-substitution 'set!
-  (lambda (node)
-    (let* ((exp (node-form node))
-	   (name (substitute-name-node (cadr exp) #f))
-	   (binding (node-ref name 'binding)))
-      (if (not (binding? binding))
-	  (user-error "SET! on local variable ~S" (node-form (cadr exp))))
-      ((structure-ref forms note-variable-set!!)
-        (binding-place binding))
-      (note-binding-use! binding)
-      (make-similar-node node
-			 (list (car exp)
-                               name
-                               (substitute-in-exp (caddr exp)))))))
-
-(define-substitution 'call
-  (lambda (node)
-    (let ((proc (car (node-form node)))
-	  (args (cdr (node-form node))))
-      (make-similar-node node
-			 (cons (if (name-node? proc)
-				   (substitute-name-node proc #t)
-				   (substitute-in-exp proc))
-			       (map substitute-in-exp args))))))
-
-; Flush GOTO when it is used with a primitive.
-
-(define-substitution 'goto
-  (lambda (node)
-    (let ((proc (cadr (node-form node)))
-	  (args (cddr (node-form node))))
-      (if (and (name-node? proc)
-	       (bound-to-primitive? proc))
-	  (make-node (get-operator 'call)
-		     (cons (substitute-name-node proc #t)
-			   (map substitute-in-exp args)))
-	  (make-similar-node node
-			     (cons 'goto
-				   (cons (if (name-node? proc)
-					     (substitute-name-node proc #t)
-					     (substitute-in-exp proc))
-					 (map substitute-in-exp args))))))))
-
-(define name-node? (node-predicate 'name))
-
-(define (bound-to-primitive? node)
-  (let ((node (name-node-substitute node)))
-    (let ((binding (node-ref node 'binding)))
-      (and binding
-	   (primitive? (binding-static binding))))))
-
-(define-substitution 'begin default-substitution)
-(define-substitution 'if    default-substitution)
-
-; drop the loophole part
-
-(define-substitution 'loophole
-  (lambda (node)
-    (substitute-in-exp (caddr (node-form node)))))
-
-;----------------------------------------------------------------
-; Breaking LETREC's down to improve type inference and make compilation
-; easier.
-
-(define-substitution 'letrec
-  (lambda (node)
-    (let* ((exp (node-form node))
-	   (vars (map car (cadr exp)))
-	   (vals (map cadr (cadr exp))))
-      (receive (names datas)
-	  (copy-letrec-names vars vals exp)
-	(for-each (lambda (data value)
-		    (expand-letrec-value data value datas exp))
-		  datas
-		  vals)
-	(let ((sets (strongly-connected-components datas
-						   letrec-data-uses
-						   letrec-data-seen?
-						   set-letrec-data-seen?!)))
-	  ;; so we don't keep track of which vars are referenced in the body
-	  (for-each (lambda (d)
-		      (set-letrec-data-seen?! d #t))
-		    datas)
-	  (do ((sets sets (cdr sets))
-	       (exp (substitute-in-exp (caddr exp))
-		    (build-letrec (car sets) exp)))
-	      ((null? sets)
-	       (for-each (lambda (n)
-			   (node-set! n 'letrec-data #f))
-			 names)
-	       exp)))))))
-
-(define-record-type letrec-data
-  (name      ; the name node for which this data exists
-   marker    ; a unique marker for this LETREC
-   cell?     ; variable is SET! or its value is not a (lambda ...).  This is
-             ; always #F until I can think of a reason to allow otherwise.
-   )
-  (value     ; the expanded value of this variable
-   uses      ; a list of variables that VALUE uses
-   seen?     ; #T if this has been seen before during the current expansion
-   ))
-
-(define (copy-letrec-names names vals marker)
-  (let ((names (map (lambda (name value)
-		      (let ((new (make-similar-node name (node-form name)))
-			    (cell? #f)) ; we no longer allow SET! on LETREC vars.
-			(node-set! new 'letrec-data
-				   (letrec-data-maker new marker cell?))
-			(node-set! name 'substitute new)
-			new))
-		    names
-		    vals)))
-    (values names (map (lambda (name) (node-ref name 'letrec-data)) names))))
-
-(define lambda-node? (node-predicate 'lambda))
-
-; List of LETREC bound variables currently in scope.
-
-(define *letrec-datas* '())
-
-(define (note-name-use! name)
-  (let ((data (node-ref name 'letrec-data)))
-    (cond ((and data (not (letrec-data-seen? data)))
-	   (set-letrec-data-seen?! data #t)
-	   (set! *letrec-datas* (cons data *letrec-datas*))))))
-
-; Expand VALUE and determine which of DATAS it uses.
-
-(define (expand-letrec-value data value datas mark)
-  (let ((old-letrec-vars *letrec-datas*))
-    (set! *letrec-datas* '())
-    (for-each (lambda (d) (set-letrec-data-seen?! d #f)) datas)
-    (set-letrec-data-value! data (substitute-in-exp value))
-    (receive (ours others)
-	(partition-list (lambda (data)
-			  (eq? (letrec-data-marker data) mark))
-			*letrec-datas*)
-      (set! *letrec-datas* (append others old-letrec-vars))
-      (set-letrec-data-uses! data ours))))
-
-; If there is only one variable and its value doesn't reference it, then
-; use a LET instead of a LETREC.  Variables whose value is either set! or
-; not a lambda have explicit cells introduced.
-
-(define (build-letrec datas body)
-  (if (and (null? (cdr datas))
-	   (not (memq? (car datas)
-		       (letrec-data-uses (car datas)))))
-      (make-let-node (map letrec-data-name datas)
-		     (map letrec-data-value datas)
-		     body)
-      (receive (cells normal)
-	  (partition-list letrec-data-cell? datas)
-	(make-let-node (map letrec-data-name cells)
-		       (map (lambda (ignore) (unspecific-node))
-			    cells)
-		       (make-letrec-node (map letrec-data-name normal)
-					 (map letrec-data-value normal)
-					 (make-begin-node
-					  (append (map letrec-data->set! cells)
-						  (list body))))))))
-
-(define op/unspecific (get-operator 'unspecific))
-(define op/set! (get-operator 'set!))
-
-(define (unspecific-node)
-  (make-node op/unspecific '()))
-
-(define (letrec-data->set! data)
-  (make-node op/set!
-	     (list 'set!
-		   (letrec-data-name data)
-		   (letrec-data-value data))))
-
-(define (make-let-node names values body)
-  (if (null? names)
-      body
-      (make-node op/call
-		 (cons (make-node op/lambda
-				  (list 'lambda names body))
-		       values))))
-
-(define (make-letrec-node names values body)
-  (if (null? names)
-      body
-      (make-node op/letrec
-		 (list 'letrec
-		       (map list names values)
-		       body))))
-
-(define (make-begin-node nodes)
-  (if (null? (cdr nodes))
-      (car nodes)
-      (make-node op/begin (cons 'begin nodes))))
-
-(define op/call   (get-operator 'call))
-(define op/lambda (get-operator 'lambda))
-(define op/letrec (get-operator 'letrec))
-(define op/begin  (get-operator 'begin))
-
-;----------------------------------------------------------------
-; A version of MAKE-SIMILAR-NODE that actually makes a new node.
-; I wish this could keep the old node's list of properties.
-
-(define (make-similar-node node form)
-  (make-node (node-operator node) form))
diff --git a/ps-compiler/prescheme/test/boolean.scm b/ps-compiler/prescheme/test/boolean.scm
deleted file mode 100644
index 7fcc255..0000000
--- a/ps-compiler/prescheme/test/boolean.scm
+++ /dev/null
@@ -1,25 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-
-
-(define (test in out)
-  (write-string '"Type in two numbers: " out)
-  (let* ((i (read-integer in))
-         (j (read-integer in)))
-    (write-string '"A = " out)
-    (write-integer i out)
-    (newline out)
-    (write-string '"B = " out)
-    (write-integer j out)
-    (newline out)
-    (write-string (if (and (< i j)
-			   (or (= (remainder i '2) '0)
-			       (= (remainder j '2) '0)))
-		      '"A < B and A or B is even"
-		      '"A >= B or A and B are both odd")
-		  out)
-    (newline out)
-    '0))
-
-(test (current-input-port) (current-output-port))
diff --git a/ps-compiler/prescheme/test/buffer.scm b/ps-compiler/prescheme/test/buffer.scm
deleted file mode 100644
index 3d7cf68..0000000
--- a/ps-compiler/prescheme/test/buffer.scm
+++ /dev/null
@@ -1,72 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-; (port->stream port type) -> stream or error value
-; (
-;
-;
-;
-
-
-(define-record-type stream
-  make-stream
-  (port   port)
-  (type   int8u)
-  (buffer int32)   ; pointer the start of the buffer
-  (size   int32)
-  (loc    int32)   ; pointer to the next char to be read or the next slot to
-                   ; be written
-  (limit  int32))  ; end of the available characters
-
-(define buffer-size 1024)
-
-(define (port->stream port type)
-  (let ((buffer (allocate-memory buffer-size))
-	(stream (make-stream)))
-    (if (or (null-memory? buffer)
-	    (null-pointer? stream))
-	(error "out of memory"))
-    (set-stream-port!   stream port)
-    (set-stream-type!   stream type)
-    (set-stream-buffer! stream buffer)
-    (set-stream-size!   stream buffer-size)
-    (set-stream-loc!    stream buffer)
-    (set-stream-limit!  stream buffer)
-    buffer))
-
-(define (stream-read-char stream)
-  (let ((loc (stream-loc stream)))
-    (cond ((< loc (stream-limit stream))
-	   (let ((ch (unsigned-byte-ref loc)))
-	     (set-stream-loc! stream (+ 1 (stream-loc stream)))
-	     ch))
-	  (else
-	   (let* ((buffer (stream-buffer stream))
-		  (count (read-block (stream-port stream)
-				     buffer
-				     (stream-size stream))))
-	     (cond ((= count 0)   ; EOF
-		    0)
-		   (else
-		    (set-stream-loc! stream (+ buffer 1))
-		    (set-stream-limit! stream (+ buffer count))
-		    (unsigned-byte-ref buffer))))))))
-
-; this will need to be PCLUSR'd.
-
-(define (stream-write-char stream char)
-  (let ((loc (stream-loc stream)))
-    (cond ((< loc (stream-limit stream))
-	   (unsigned-byte-set! loc char)
-	   (set-stream-loc! stream (+ 1 (stream-loc stream))))
-	  (else
-	   (let* ((buffer (stream-buffer stream))
-		  (count (write-block (stream-port stream)
-				      buffer
-				      (stream-limit stream))))
-	     (cond ((= count 0)   ; EOF
-		    0)
-		   (else
-		    (set-stream-loc! stream (+ buffer 1))
-		    (set-stream-limit! stream (+ buffer count))
-		    (unsigned-byte-ref buffer))))))))
diff --git a/ps-compiler/prescheme/test/bvector.scm b/ps-compiler/prescheme/test/bvector.scm
deleted file mode 100644
index 6fa8f56..0000000
--- a/ps-compiler/prescheme/test/bvector.scm
+++ /dev/null
@@ -1,11 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-(define (test)
-  (let ((v (make-byte-vector 10))
-	(out (current-output-port)))
-    (write-number (byte-vector-ref v 4) out)
-    (byte-vector-set! v 5 100)
-    (write-number (byte-vector-ref v 5) out)
-    (write-number (byte-vector-word-ref v 4) out)))
-
diff --git a/ps-compiler/prescheme/test/cell.scm b/ps-compiler/prescheme/test/cell.scm
deleted file mode 100644
index 958f64a..0000000
--- a/ps-compiler/prescheme/test/cell.scm
+++ /dev/null
@@ -1,18 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-(define *count* 0)
-
-(define (increment)
-  (set! *count* (+ *count* 1)))
-
-(define (value)
-  *count*)
-
-(define (test out)
-  (increment)
-  (increment)
-  (write-number (value) out)
-  (newline out))
-
-(test (current-output-port))
diff --git a/ps-compiler/prescheme/test/coerce.scm b/ps-compiler/prescheme/test/coerce.scm
deleted file mode 100644
index e86fe86..0000000
--- a/ps-compiler/prescheme/test/coerce.scm
+++ /dev/null
@@ -1,29 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-
-(define-local-syntax (define-primitive id nargs)
-  (let ((args (reverse (list-tail '(z y x) (- '3 nargs)))))
-    `(define (,id . ,args)
-       (call-primitively ,id . ,args))))
-
-(define-primitive make-byte-vector 1)
-(define-primitive null-pointer? 1)
-
-(define (byte-vector-ref vec index)
-  (call-primitively byte-contents-int8 (pointer-add vec index)))
-
-(define (byte-vector-set! vec index value)
-  (call-primitively byte-set-contents-int8! (pointer-add vec index) value))
-
-(define (pointer->integer x)
-  (call-primitively coerce x '(pointer int8) 'int32))
-
-(define (integer->pointer x)
-  (call-primitively coerce x 'int32 '(pointer int8)))
-
-(define (test)
-  (let ((bv (make-byte-vector 10)))
-    (if (null-pointer? bv)
-	100
-	(pointer->integer bv))))
\ No newline at end of file
diff --git a/ps-compiler/prescheme/test/dispatch.scm b/ps-compiler/prescheme/test/dispatch.scm
deleted file mode 100644
index 65816e2..0000000
--- a/ps-compiler/prescheme/test/dispatch.scm
+++ /dev/null
@@ -1,64 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-(define (fact n)
-  (let loop ((i n) (r 1))
-    (if (<= i 1)
-	r
-	(loop (- i 1) (* i r)))))
-
-(define (default y) y)
-
-(define do-it (make-vector 5))
-
-(do ((i 0 (+ i 1)))
-    ((>= i 5))
-  (vector-set! do-it i default))
-
-(define (add-entry i k)
-  (let ((f (fact k)))
-    (vector-set! do-it i (lambda (x) (+ x f)))))
-
-(add-entry 0 1)
-;(add-entry 1 1)
-(add-entry 2 3)
-(add-entry 3 4)
-(add-entry 4 4)
-   
-(define (test x)
-  ((vector-ref do-it x) 5))
-
-(define (main)
-  (write-number (test (read-number (current-input-port)))
-		(current-output-port)))
-
-(define (digit? ch)
-  (let ((ch (char->ascii ch)))
-    (and (>= ch (char->ascii #\0))
-	 (<= ch (char->ascii #\9)))))
-
-(define (read-number port)
-  (let loop ((r 0))
-    (ps-read-char port
-      (lambda (ch)
-	(cond ((digit? ch)
-	       (loop (+ (- (char->ascii ch) (char->ascii #\0))
-			(* r 10))))
-	      (else r)))
-      (lambda () 0))))
-
-(define (write-number x port)
-  (really-write-number (cond ((< x 0)
-			      (write-char #\- port)
-			      (- 0 x))
-			     (else
-			      x))
-		       port)
-  (newline port))
-
-(define (really-write-number x port)
-    (if (>= x 10)
-	(really-write-number (quotient x 10) port))
-    (write-char (ascii->char (+ (remainder x 10)
-				(char->ascii #\0)))
-		port))
diff --git a/ps-compiler/prescheme/test/dispatch2.scm b/ps-compiler/prescheme/test/dispatch2.scm
deleted file mode 100644
index d467fa5..0000000
--- a/ps-compiler/prescheme/test/dispatch2.scm
+++ /dev/null
@@ -1,57 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-(define-local-syntax (define-primitive id nargs)
-  (let ((args (reverse (list-tail '(z y x) (- '3 nargs)))))
-    `(define (,id . ,args)
-       (call-primitively ,id . ,args))))
-
-(define-primitive + 2)
-(define-primitive - 2)
-(define-primitive * 2)
-(define-primitive < 2)
-
-(define-primitive make-vector 2)
-(define-primitive pointer-add 2)
-(define-primitive contents 1)
-(define-primitive set-contents! 2)
-
-(define *current-input-port*
-  (call-primitively stdin))
-
-(define *current-output-port*
-  (call-primitively stdout))
-
-(define (current-input-port)
-  *current-input-port*)
-
-(define (current-output-port)
-  *current-output-port*)
-
-(define (vector-ref vec index)
-  (contents (pointer-add vec index)))
-
-(define (vector-set! vec index value)
-  (set-contents! (pointer-add vec index) value))
-
-(define (default y) y)
-
-(define do-it (make-vector 5 default))
-
-(define (add-entry i k)
-  (vector-set! do-it i (lambda (x) (+ x k))))
-
-(add-entry 0 1)
-;(add-entry 1 1)
-(add-entry 2 3)
-(add-entry 3 4)
-(add-entry 4 4)
-   
-(define (test x)
-  ((vector-ref do-it x) 5))
-
-(define (main)
-  (write-number (test (read-number (current-input-port)))
-		(current-output-port)))
-
-
diff --git a/ps-compiler/prescheme/test/eval.scm b/ps-compiler/prescheme/test/eval.scm
deleted file mode 100644
index 363c174..0000000
--- a/ps-compiler/prescheme/test/eval.scm
+++ /dev/null
@@ -1,18 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-
-(define (fact n)
-  (let loop ((i n) (r 1))
-    (if (<= i 1)
-	r
-	(loop (- i 1) (* i r)))))
-
-(define facts (make-vector 5))
-
-(do ((i 0 (+ i 1)))
-    ((< 4 i))
-  (vector-set! facts i (fact i)))
-
-(define f4 (vector-ref facts 4))
-
diff --git a/ps-compiler/prescheme/test/eval2.scm b/ps-compiler/prescheme/test/eval2.scm
deleted file mode 100644
index bc10d6b..0000000
--- a/ps-compiler/prescheme/test/eval2.scm
+++ /dev/null
@@ -1,12 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-(define-local-syntax (define-primitive id nargs)
-  (let ((args (reverse (list-tail '(z y x) (- '3 nargs)))))
-    `(define (,id . ,args)
-       (call-primitively ,id . ,args))))
-
-(define-primitive ashr 2)
-
-(define high-bits ashr)
-
diff --git a/ps-compiler/prescheme/test/eval3.scm b/ps-compiler/prescheme/test/eval3.scm
deleted file mode 100644
index 9b73616..0000000
--- a/ps-compiler/prescheme/test/eval3.scm
+++ /dev/null
@@ -1,38 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-(define-local-syntax (define-primitive id nargs)
-  (let ((args (reverse (list-tail '(z y x) (- '3 nargs)))))
-    `(define (,id . ,args)
-       (call-primitively ,id . ,args))))
-
-(define-primitive ashl 2)
-(define-primitive ashr 2)
-(define-primitive = 2)
-(define-primitive bitwise-and 2)
-
-(define (input-type pred coercer)  ;Alonzo wins
-  (lambda (f) (f pred coercer)))
-
-(define (input-type-predicate type) (type (lambda (x y) y x)))
-(define (input-type-coercion type)  (type (lambda (x y) x y)))
-
-(define (no-coercion x) x)
-
-(define (odd? x)
-  (= 1 (bitwise-and x 1)))
-
-(define (extract-odd x)
-  (ashr x 1))
-
-(define any->      (input-type (lambda (x) x #t) no-coercion))
-(define odd->      (input-type odd?  extract-odd))
-
-(define (test x y)
-  (if (and ((input-type-predicate any->) x)
-	   ((input-type-predicate odd->) y))
-      (let ((a ((input-type-coercion any->) x))
-	    (b ((input-type-coercion odd->) y)))
-	(+ a b))
-      x))
-
diff --git a/ps-compiler/prescheme/test/external.scm b/ps-compiler/prescheme/test/external.scm
deleted file mode 100644
index 3fc7874..0000000
--- a/ps-compiler/prescheme/test/external.scm
+++ /dev/null
@@ -1,10 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-(define foo
-  (external (=> (int32 int32) unit)
-	    (lambda (x y)
-	      (display (+ x y)))))
-
-(define (test)
-  (foo 3 4))
diff --git a/ps-compiler/prescheme/test/fact.cps b/ps-compiler/prescheme/test/fact.cps
deleted file mode 100644
index cc494ad..0000000
--- a/ps-compiler/prescheme/test/fact.cps
+++ /dev/null
@@ -1,27 +0,0 @@
-(FORM 0 random okay #f
-  ()
-
-    (P #f_0 (c_1)
-      (LET* (((loop_2)   (allocate 'single-set 'ptr))
-             (()         (set-contents loop_2 'cell '0 '0 ^loop_3)))
-        (jump 0 (contents loop_2 'cell '0 '0) '5 '1)))
-
-     (J loop_3 (i_4 r_5)
-       (LET* (((c_6)*     ^c_7))
-         (test 2 ^g_8 ^g_9 (less? '1 i_4))))
-
-      (C g_8 ()
-        (return 0 c_6 '#f))
-
-      (C g_9 ()
-        (return 0 c_6 '#t))
-
-      (C c_7 (v_10)
-        (test 2 ^g_11 ^g_12 v_10))
-
-       (C g_11 ()
-         (unknown-return 0 c_1 '1 r_5))
-
-       (C g_12 ()
-         (jump 0 (contents loop_2 'cell '0 '0) (subtract i_4 '1) (multiply i_4 r_5))))
-
diff --git a/ps-compiler/prescheme/test/fact.scm b/ps-compiler/prescheme/test/fact.scm
deleted file mode 100644
index 6119aa2..0000000
--- a/ps-compiler/prescheme/test/fact.scm
+++ /dev/null
@@ -1,14 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-
-(define *one* 1)
-
-(define (fact n)
-  (let loop ((i n) (r *one*))
-    (if (<= *one* i)
-	(loop (- i *one*) (* i r))
-	r)))
-
-(define (all)
-  (set! *one* (fact (if (> (fact 10) 100) 10 20))))
diff --git a/ps-compiler/prescheme/test/fact2.scm b/ps-compiler/prescheme/test/fact2.scm
deleted file mode 100644
index 7186372..0000000
--- a/ps-compiler/prescheme/test/fact2.scm
+++ /dev/null
@@ -1,85 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-
-(define (foo)
-  (fact 10)
-  (fact 20))
-
-(foo)
-(foo)
-(fact 5)
-
-(define *one* (unassigned))
-
-(define-local-syntax (define-primitive id nargs)
-  (let ((args (reverse (list-tail '(z y x) (- '3 nargs)))))
-    `(define (,id . ,args)
-       (call-primitively ,id . ,args))))
-
-(define-local-syntax (define-effect-primitive id nargs)
-  (let ((args (reverse (list-tail '(z y x) (- '3 nargs)))))
-    `(define (,id . ,args)
-       (call-primitively ,id . ,args)
-       (call-primitively undefined-value))))
-
-(define-primitive + 2)
-(define-primitive - 2)
-(define-primitive * 2)
-(define-primitive < 2)
-
-;(define-primitive quotient  2)
-;(define-primitive remainder 2)
-
-(define-primitive char->ascii 1)
-(define-primitive ascii->char 1)
-
-(define-effect-primitive write-char   2) 
-
-(define (unassigned) (call-primitively undefined-value))
-
-(define (byte-vector-ref vec index)
-  (call-primitively byte-contents (ptr+ vec index)))
-
-(define (byte-vector-set! vec index value)
-  (call-primitively byte-set-contents! (ptr+ vec index) value))
-
-(define (vector-set! vec index value)
-  (call-primitively set-contents! (ptr+ vec (* index 4)) value))
-
-;(write-number-no-newline 102 port)
-
-;(define (write-number-no-newline x port)
-;  (let ((x (cond ((< x 0)
-;                  (write-char '#\- port)
-;                  (- 0 x))
-;                 (else
-;                  x))))
-;    (let loop ((x x) (mask foo))
-;      (let ((digit (quotient x mask)))
-;        (write-char (ascii->char (+ digit (char->ascii '#\0))) port)
-;        (if (< mask 1)
-;	    (loop (remainder x mask) (quotient mask 10)))))))
-
-(define (fact n)
-  (let loop ((i n) (r *one*))
-    (if (<= *one* i)
-	(loop (- i *one*) (* i r))
-	r)))
-
-;(define (poobah x)
-;  (+ x (* x (+ x (* x *two*)))))
-
-;(define *two* 2)
-
-(define (<= x y)
-  (not (< y x)))
-
-(define (not x)
-  (if x #f #t))
-
-(define (identity x)
-  x)
-
-(define (two x)
-  2)
\ No newline at end of file
diff --git a/ps-compiler/prescheme/test/goto.scm b/ps-compiler/prescheme/test/goto.scm
deleted file mode 100644
index 3c26d12..0000000
--- a/ps-compiler/prescheme/test/goto.scm
+++ /dev/null
@@ -1,20 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-
-(define (odd? x)
-  (cond ((= x 0)
-	 #f)
-;	((= x 100)
-;	 (foo))
-	(else
-	 (goto even? (- x 1)))))
-
-(define (even? x)
-  (if (= x 0)
-      #t
-      (goto odd? (- x 1))))
-
-(define (test x)
-  (if (odd? (+ x 1))
-      (error "an even number" x)))
diff --git a/ps-compiler/prescheme/test/hoist.scm b/ps-compiler/prescheme/test/hoist.scm
deleted file mode 100644
index 9c715b2..0000000
--- a/ps-compiler/prescheme/test/hoist.scm
+++ /dev/null
@@ -1,15 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-
-(define (foo x y)
-  (let ((bar (lambda (y)
-	       (let ((baz (lambda (a b)
-			    (foo (- a 2) (+ 3 b)))))
-		 (+ (baz y 1) (baz (+ y 1) 2))))))
-    (if (= x 0)
-	(goto bar 10)
-	(goto bar 4))))
-
-(define (test)
-  (foo 30 40))
\ No newline at end of file
diff --git a/ps-compiler/prescheme/test/integers.scm b/ps-compiler/prescheme/test/integers.scm
deleted file mode 100644
index f8aedbb..0000000
--- a/ps-compiler/prescheme/test/integers.scm
+++ /dev/null
@@ -1,11 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-
-(define (main)
-  (write-number (+ (read-number (current-input-port)) 100)
-		(current-output-port))
-  0)
-
-
-
diff --git a/ps-compiler/prescheme/test/letrec.scm b/ps-compiler/prescheme/test/letrec.scm
deleted file mode 100644
index 53ee536..0000000
--- a/ps-compiler/prescheme/test/letrec.scm
+++ /dev/null
@@ -1,44 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-(define (t1)
-  (let loop ((x 1))
-    (if (g x)
-	(loop (h x))
-	x)))
-
-(define (t2)
-  (let loop ((x 1))
-    (if (g x) x y)))
-
-(define (t3)
-  (letrec ((loop (lambda (x)
-		   (if #t x (loop x)))))
-    (loop 4)))
-
-(define (t4)
-  (letrec ((loop (lambda (x)
-		   (if #t x (loop x))))
-	   (loop2 (lambda (x)
-		    (if x x (loop2 x)))))
-    (loop 4)))
-
-(define (t5)
-  (letrec ((loop (lambda (x)
-		   (if #t x (loop x))))
-	   (loop2 (lambda (x)
-		    (if x x (loop2 x)))))
-    (g (loop 4) (loop2 5))))
-
-(define (t6 y)
-  (letrec ((loop (if y
-		     (lambda (x) 5)
-		     (lambda (x) 6))))
-    (loop 4)))
-
-(define (t7 y)
-  (letrec ((loop (if y
-		     (lambda (x) 5)
-		     (lambda (x) (loop 6)))))
-    (loop 4)))
-
diff --git a/ps-compiler/prescheme/test/list.scm b/ps-compiler/prescheme/test/list.scm
deleted file mode 100644
index 43dada2..0000000
--- a/ps-compiler/prescheme/test/list.scm
+++ /dev/null
@@ -1,236 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-; write s-expressions
-
-; Memory
-
-(define *memory*)
-(define *hp*)
-
-(define (initialize-memory! size)
-  (set! *memory* (allocate-memory size))
-  ;(if (null-pointer? *memory*)
-  ;    (error "out of memory, unable to continue"))
-  (set! *hp* *memory*))
-
-(define (allocate size)
-  (let ((p *hp*))
-    (set! *hp* (address+ *hp* size))
-    p))
-
-(define (words->a-units x)
-  (* x 4))
-
-; Data
-
-(define tag-bits 1)
-(define tag-mask (- (shift-left 1 tag-bits) 1))
-
-(define tag/fixnum 0)
-(define tag/pair   1)
-
-(define (enter-fixnum x)
-  (+ (shift-left x tag-bits) tag/fixnum))
-
-(define (extract-fixnum x)
-  (arithmetic-shift-right x tag-bits))
-
-(define (make-predicate tag)
-  (lambda (x)
-    (= tag (bitwise-and x tag-mask))))
-
-(define fixnum?  (make-predicate tag/fixnum))
-(define my-pair? (make-predicate tag/pair))
-
-(define (make-accessor tag offset)
-  (lambda (x)
-    (word-ref (address+ (integer->address (+ x (- 0 tag)))
-			(words->a-units offset)))))
-
-(define (make-setter tag offset)
-  (lambda (x v)
-    (word-set! (address+ (integer->address (+ x (- 0 tag)))
-			 (words->a-units offset))
-	       v)))
-
-(define pair-size 16)   ; bytes
-
-(define head (make-accessor tag/pair 0))
-(define tail (make-accessor tag/pair 1))
-
-(define set-head! (make-setter tag/pair 0))
-(define set-tail! (make-setter tag/pair 1))
-
-(define (make-pair x y)
-  (let ((p (+ tag/pair (address->integer (allocate pair-size)))))
-    (set-head! p x)
-    (set-tail! p y)
-    p))
-
-(define null tag/pair)
-
-(define (my-null? x)
-  (= x null))
-
-(define (print-s-exp x out)
-  (cond ((fixnum? x)
-         (write-number-no-newline (extract-fixnum x) out))
-        ((my-null? x)
-         (write-char #\( out)
-         (write-char #\) out))
-        ((my-pair? x)
-         (write-char #\( out)
-         (print-s-exp (head x) out)
-         (let loop ((x (tail x)))
-           (cond ((my-null? x)
-                  (write-char #\) out))
-                 ((my-pair? x)
-                  (write-char #\space out)
-                  (print-s-exp (head x) out)
-                  (loop (tail x)))
-                 (else
-                  (write-char #\space out)
-                  (write-char #\. out)
-                  (write-char #\space out)
-                  (print-s-exp x out)
-                  (write-char #\) out)))))))
-
-(define *input-port*)
-(define *peeked-char?* #f)
-(define *peeked-char*)
-
-(define (readc)
-  (cond (*peeked-char?*
-	 (set! *peeked-char?* #f)
-	 *peeked-char*)
-	(else
-	 (call-with-values
-	  (lambda ()
-	    (read-char *input-port*))
-	  (lambda (ch eof? status)
-	    (if eof? (ascii->char 0) ch))))))
-
-(define (peekc)
-  (if *peeked-char?*
-      *peeked-char*
-      (call-with-values
-       (lambda ()
-	 (read-char *input-port*))
-       (lambda (ch eof? status)
-	 (if eof?
-	     (ascii->char 0)
-	     (begin
-	       (set! *peeked-char?* #t)
-	       (set! *peeked-char* ch)
-	       ch))))))
-
-(define (digit? ch)
-  (let ((ch (char->ascii ch)))
-    (and (>= ch (char->ascii #\0))
-	 (<= ch (char->ascii #\9)))))
-
-(define (read-number)
-  (let loop ()
-    (case (peekc)
-      ((#\-)
-       (readc)
-       (- 0 (really-read-number)))
-      ((#\+)
-       (readc)
-       (really-read-number))
-      (else
-       (really-read-number)))))
-
-(define (really-read-number)
-  (let loop ((r 0))
-    (let ((ch (peekc)))
-      (cond ((digit? ch)
-	     (readc)
-	     (loop (+ (- (char->ascii ch) (char->ascii #\0))
-		      (* r 10))))
-	    (else r)))))
-
-(define (read-s-exp)
-  (case (peekc)
-    ((#\space #\newline)
-     (readc)
-     (read-s-exp))
-    ((#\- #\+)
-     (enter-fixnum (read-number)))
-    ((#\()
-     (readc)
-     (read-list))
-    (else
-     (if (digit? (peekc))
-	 (enter-fixnum (read-number))
-	 -1))))
-
-(define (read-list)
-  (case (peekc)
-    ((#\space #\newline)
-     (readc)
-     (read-list))
-    ((#\))
-     (readc)
-     null)
-    ((#\.)
-     (readc)       ; eat the dot
-     (let ((res (read-s-exp)))
-       (if (read-r-paren)
-	   res
-	   -1)))
-    (else
-     (let ((head (read-s-exp)))
-       (make-pair head (read-list))))))
-
-(define (read-r-paren)
-  (case (peekc)
-    ((#\space #\newline)
-     (readc)
-     (read-r-paren))
-    ((#\))
-     #t)
-    (else #f)))
-
-; Printing integers
-
-; Return 10**n such that 10**n <= x < 10**(n+1)
-
-(define (integer-mask x)
-  (do ((x x (quotient x 10))
-       (mask 1 (* mask 10)))
-      ((< x 10) mask)))
-
-; Write positive integer X out to PORT
-
-(define (write-number x port)
-  (write-number-no-newline x port)
-  (write-char '#\newline port))
-
-(define (write-number-no-newline x port)
-  (let ((x (cond ((< x 0)
-                  (write-char '#\- port)
-                  (- 0 x))
-                 (else
-                  x))))
-    (let loop ((x x) (mask (integer-mask x)))
-      (let ((digit (quotient x mask)))
-        (write-char (ascii->char (+ digit (char->ascii '#\0))) port)
-        (if (> mask 1)
-	    (loop (remainder x mask) (quotient mask 10)))))))
-
-
-(define (test size)
-  (initialize-memory! size)
-  (let ((s-exp (make-pair (enter-fixnum 1)
-                (make-pair (enter-fixnum 2)
-                 (make-pair (make-pair (enter-fixnum 3) (enter-fixnum 4))
-                            null))))
-	(out (current-output-port)))
-    (print-s-exp s-exp out)
-    (newline out)
-    (set! *input-port* (current-input-port))
-    (print-s-exp (read-s-exp) out)
-    (newline out)))
-
diff --git a/ps-compiler/prescheme/test/loop.scm b/ps-compiler/prescheme/test/loop.scm
deleted file mode 100644
index b390d8d..0000000
--- a/ps-compiler/prescheme/test/loop.scm
+++ /dev/null
@@ -1,54 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-
-(xodd? 10)
-(xodd? 5)
-
-(define-local-syntax (define-primitive id nargs)
-  (let ((args (reverse (list-tail '(z y x) (- '3 nargs)))))
-    `(define (,id . ,args)
-       (call-primitively ,id . ,args))))
-
-(define-primitive + 2)
-(define-primitive - 2)
-(define-primitive * 2)
-(define-primitive < 2)
-(define-primitive = 2)
-
-(define (xodd? x)
-  (cond ((= 0 x)
-	 #f)
-	((< 100 x)                  ; efficiency hack
-	 (goto odd? (- x 100)))
-	((< 1000 x)                  ; efficiency hack
-	 (goto xodd? (- x 100)))
-	(else
-	 (goto xeven? (- x 1)))))
-
-(define (xeven? x)
-  (cond ((= 0 x)
-	 #t)
-	((< 100 x)                  ; efficiency hack
-	 (goto xeven? (- x 100)))
-	(else
-	 (goto xodd? (- x 1)))))
-
-
-(define (odd? x)
-  (cond ((= 0 x)
-	 #f)
-	((< 100 x)                  ; efficiency hack
-	 (goto odd? (- x 100)))
-	(else
-	 (goto even? (- x 1)))))
-
-(define (even? x)
-  (cond ((= 0 x)
-	 #t)
-	((< 100 x)                  ; efficiency hack
-	 (goto even? (- x 100)))
-	(else
-	 (goto odd? (- x 1)))))
-
-
diff --git a/ps-compiler/prescheme/test/memory.scm b/ps-compiler/prescheme/test/memory.scm
deleted file mode 100644
index 5a30ba6..0000000
--- a/ps-compiler/prescheme/test/memory.scm
+++ /dev/null
@@ -1,8 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-(define (test x i)
-  (let ((m (allocate-memory 10)))
-    (unsigned-byte-set! (+ m i) x)
-    (word-set! (+ m i) (+ 1 (word-ref (+ m i))))
-    (unsigned-byte-ref (+ m i))))
diff --git a/ps-compiler/prescheme/test/package-defs.scm b/ps-compiler/prescheme/test/package-defs.scm
deleted file mode 100644
index 311a64e..0000000
--- a/ps-compiler/prescheme/test/package-defs.scm
+++ /dev/null
@@ -1,67 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-(define-structures ((fact (export *one* fact all)))
-  (open prescheme)
-  (files fact))
-
-(define-structures ((list (export test)))
-  (open prescheme ps-memory)
-  (files list))
-
-(define-structures ((dispatch (export main)))
-  (open prescheme)
-  (files dispatch))
-
-(define-structures ((vector (export test)))
-  (open prescheme)
-  (files vector))
-
-(define-structures ((string (export test)))
-  (open prescheme)
-  (files string))
-
-(define-structures ((goto (export test odd?)))
-  (open prescheme)
-  (files goto))
-
-(define-structures ((external (export test)))
-  (open prescheme)
-  (files external))
-
-(define-structures ((eval (export f4)))
-  (open prescheme)
-  (files eval))
-
-(define-structures ((memory (export test)))
-  (open prescheme)
-  (files memory))
-
-(define-structures ((poly (export test)))
-  (open prescheme)
-  (files poly))
-
-(define-structures ((select (export test)))
-  (open prescheme)
-  (files select))
-
-(define-structures ((hoist (export test)))
-  (open prescheme)
-  (files hoist))
-
-(define-structures ((record (export init cons member? reverse!)))
-  (open prescheme ps-record-types)
-  (files record))
-
-(define-structures ((buffer (export port->stream stream-read-char)))
-  (open prescheme)
-  (files buffer))
-
-(define-structures ((values (export test)))
-  (open prescheme)
-  (files values))
-
-(define-structures ((write (export test)))
-  (open prescheme)
-  (files write))
-
diff --git a/ps-compiler/prescheme/test/poly.scm b/ps-compiler/prescheme/test/poly.scm
deleted file mode 100644
index 8cb2bef..0000000
--- a/ps-compiler/prescheme/test/poly.scm
+++ /dev/null
@@ -1,11 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-(define (identity x) x)  ; can't get much more polymorphic than that
-
-(define (test x)
-  (cond (#f
-	 (vector-ref (identity (make-vector 3)) 2))
-	(else
-	 (+ (identity (+ x 3)) (identity (+ x 2))))))
-
diff --git a/ps-compiler/prescheme/test/prescheme.h b/ps-compiler/prescheme/test/prescheme.h
deleted file mode 100644
index df80ac1..0000000
--- a/ps-compiler/prescheme/test/prescheme.h
+++ /dev/null
@@ -1,70 +0,0 @@
-#include <errno.h>
-
-#define PS_READ_CHAR(PORT,RESULT,EOFP,STATUS)		\
-{							\
-  FILE * TTport = PORT;					\
-  int TTchar;						\
-  if (EOF == (TTchar = getc(TTport)))			\
-    RESULT = ps_read_char(TTport, &EOFP, &STATUS, 0==1);\
-  else {						\
-    RESULT = TTchar; 					\
-    EOFP = 0;						\
-    STATUS = 0; }					\
-}
-
-#define PS_PEEK_CHAR(PORT,RESULT,EOFP,STATUS)		\
-{							\
-  FILE * TTport = PORT;					\
-  int TTchar;						\
-  if (EOF == (TTchar = getc(TTport)))			\
-    RESULT = ps_read_char(TTport, &EOFP, &STATUS, 0==0);\
-  else {						\
-    RESULT = TTchar; 					\
-    ungetc(RESULT, TTport);				\
-    EOFP = 0;						\
-    STATUS = 0; }					\
-}
-
-#define PS_READ_INTEGER(PORT,RESULT,EOFP,STATUS)	\
-RESULT = ps_read_integer(PORT,&EOFP,&STATUS);
-
-#define PS_WRITE_CHAR(CHAR,PORT,STATUS)			\
-{							\
-  FILE * TTport = PORT;					\
-  char TTchar = CHAR;					\
-  if (EOF == putc(TTchar,TTport))			\
-    STATUS = ps_write_char(TTchar,TTport);		\
-  else {						\
-    STATUS = 0; }					\
-}
-
-extern FILE *ps_open_input_file(unsigned char *, long *);
-extern FILE *ps_open_output_file(unsigned char *, long *);
-extern long ps_close(FILE *);
-extern char ps_read_char(FILE *, unsigned char *, long *, char);
-extern long ps_read_integer(FILE *, unsigned char *, long *);
-extern long ps_write_char(char, FILE *);
-extern long ps_write_integer(long, FILE *);
-extern long ps_write_string(unsigned char *, FILE *);
-extern long ps_read_block(FILE *, char *, long, unsigned char *, long *);
-extern long ps_write_block(FILE *, char *, long);
-extern unsigned char *ps_error_string(long);
-extern void ps_error(unsigned char *, ...);
-
-/* C shifts may not work if the amount is greater than the machine word size */
-/* Patched by JAR 6/6/93 */
-
-#define PS_SHIFT_RIGHT(X,Y,RESULT)   \
-{                                    \
-  long TTx = X,  TTy = Y;            \
-  RESULT = TTy >= 32 ? (TTx < 0 ? -1 : 0) : TTx >> TTy; \
-}  
-
-#define PS_SHIFT_LEFT(X,Y,RESULT)    \
-{                                    \
-  long TTy = Y;                      \
-  RESULT = TTy >= 32 ? 0 : X << TTy; \
-}  
-
-extern long TTreturn_value, TTrun_machine();
-
diff --git a/ps-compiler/prescheme/test/record.scm b/ps-compiler/prescheme/test/record.scm
deleted file mode 100644
index 647d48e..0000000
--- a/ps-compiler/prescheme/test/record.scm
+++ /dev/null
@@ -1,29 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-
-(define-data-type list
-  (pair? (cons car cdr)
-	 (car integer car set-car!)
-	 (cdr list    cdr set-cdr!))
-  (null? null))
-
-(define (member? list x)
-  (let loop ((list list))
-    (cond ((null? list)
-	   #f)
-	  ((= x (car list))
-	   #t)
-	  (else
-	   (loop (cdr list))))))
-
-(define (reverse! list)
-  (if (or (null? list)
-	  (null? (cdr list)))
-      list
-      (let loop ((list list) (prev null))
-	(let ((next (cdr list)))
-	  (set-cdr! list prev)
-	  (if (null? next)
-	      list
-	      (loop next list))))))
diff --git a/ps-compiler/prescheme/test/select.scm b/ps-compiler/prescheme/test/select.scm
deleted file mode 100644
index 01e6876..0000000
--- a/ps-compiler/prescheme/test/select.scm
+++ /dev/null
@@ -1,69 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-(define (test)
-  (let ((in (current-input-port))
-	(out (current-output-port))
-	(s1 (make-port-set))
-	(s2 (make-port-set)))
-    (let loop ((i 0))
-      (cond ((char-ready? in)
-	     (got-char in out i)
-	     (loop 0))
-	    (else
-	     (clear-port-set! s1)
-	     (clear-port-set! s2)
-	     (add-to-port-set! s1 in)
-	     (case (find-ready-ports s1 s2 #f)
-	       ((0)
-		(loop (+ i 1)))
-	       ((1)
-		(cond ((port-set-member? s1 in)
-		       (got-char in out i)
-		       (loop 0))
-		      (else
-		       (write-string "not in port set" out)
-		       (newline out))))
-	       (else
-		(write-string "funny port count " out))))))))
-
-(define (got-char in out i)
-  (write-string "Got " out)
-  (ps-read-char in
-		(lambda (char)
-		  (write-number-no-newline (ascii->char char) out))
-		(lambda ()
-		  (write-string "EOF!" out)))
-  (write-string " after " out)
-  (write-number i out))
-
-; Printing integers
-
-; Return 10**n such that 10**n <= x < 10**(n+1)
-
-(define (integer-mask x)
-  (do ((x x (quotient x 10))
-       (mask 1 (* mask 10)))
-      ((< x 10) mask)))
-
-; Write positive integer X out to PORT
-
-(define (write-number x port)
-  (write-number-no-newline x port)
-  (write-char '#\newline port))
-
-(define (write-number-no-newline x port)
-  (let ((x (cond ((< x 0)
-                  (write-char '#\- port)
-                  (- 0 x))
-                 (else
-                  x))))
-    (let loop ((x x) (mask (integer-mask x)))
-      (let ((digit (quotient x mask)))
-        (write-char (ascii->char (+ digit (char->ascii '#\0))) port)
-        (if (> mask 1)
-	    (loop (remainder x mask) (quotient mask 10)))))))
-
-
-
-		
diff --git a/ps-compiler/prescheme/test/simp.scm b/ps-compiler/prescheme/test/simp.scm
deleted file mode 100644
index ba1bd4b..0000000
--- a/ps-compiler/prescheme/test/simp.scm
+++ /dev/null
@@ -1,19 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-(define (foo x y z)
-  (if (and (= (bitwise-and x 3) 0)
-	   (= (bitwise-and y 3) 0)
-	   (= (bitwise-and z 3) 0))
-      (ashl (ashr x 2) 2)
-      (ashl y (ashr z 2))))
-
-(define-local-syntax (define-primitive id nargs)
-  (let ((args (reverse (list-tail '(z y x) (- '3 nargs)))))
-    `(define (,id . ,args)
-       (call-primitively ,id . ,args))))
-
-(define-primitive = 2)
-(define-primitive bitwise-and 2)
-(define-primitive ashl 2)
-(define-primitive ashr 2)
diff --git a/ps-compiler/prescheme/test/string.scm b/ps-compiler/prescheme/test/string.scm
deleted file mode 100644
index 4874101..0000000
--- a/ps-compiler/prescheme/test/string.scm
+++ /dev/null
@@ -1,54 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-
-(define (xwrite-string string out)
-  (let ((len (string-length string)))
-    (do ((i 0 (+ i 1)))
-	((>= i len))
-      (write-char (string-ref string (- len (+ i 1))) out))
-    (newline out)))
-
-(define (write-string string out)
-  (let ((len (string-length string)))
-    (do ((i 0 (+ i 1)))
-	((>= i len))
-      (write-char (string-ref string i) out))
-    (newline out)))
-
-(define a-string "Hello sailor...")
-
-(define (test)
-  (let* ((in (current-input-port))
-	 (out (current-output-port))
-	 (len (ashr (read-number in) 2))
-	 (string (make-string len)))
-    (let loop ((i 0))
-      (if (< i len)
-	  (ps-read-char in
-	    (lambda (ch)
-	      (string-set! string i ch)
-	      (loop (+ i 1)))
-	    (lambda ()
-	      (unassigned)))))
-    (write-string string out)
-    (xwrite-string string out)
-    (deallocate string)
-    (write-string a-string out)
-    (xwrite-string a-string out)))
-
-(define (read-number port)
-  (let loop ((r 0))
-    (ps-read-char port
-      (lambda (ch)
-	(cond ((digit? ch)
-	       (loop (+ (- (char->ascii ch) (char->ascii #\0))
-			(* r 10))))
-	      (else r)))
-      (lambda () 0))))
-
-(define (digit? ch)
-  (let ((ch (char->ascii ch)))
-    (and (>= ch (char->ascii #\0))
-	 (<= ch (char->ascii #\9)))))
-
diff --git a/ps-compiler/prescheme/test/test.scm b/ps-compiler/prescheme/test/test.scm
deleted file mode 100644
index 9a5930b..0000000
--- a/ps-compiler/prescheme/test/test.scm
+++ /dev/null
@@ -1,72 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-
-(define (test x)
-  (cond ((= x 1)
-	 (goto raise-exception 2))
-	((= x 2)
-	 (goto raise-exception1 2 0))
-	((= x 3)
-	 (goto raise-exception 3))
-	((= x 4)
-	 (goto raise-exception1 4 0))))
-
-(define *code-pointer* 0)
-(define *stack* 0)
-
-(define (push x)
-  (vector-set! *stack* 0 x)
-  (set! *stack* (- *stack* 4)))
-
-(define (fetch-byte address)
-  (byte-vector-ref address 0))
-
-(define (current-opcode code-args)
-  (fetch-byte (- *code-pointer* (+ code-args 1))))
-
-(define (start-exception args)
-  (push (current-opcode args)))
-
-(define (raise-exception args)
-  (start-exception args)
-  (goto raise 0))
-
-(define (raise-exception1 args a1)
-  (start-exception args)
-  (push a1)
-  (goto raise 1))
-
-(define (raise n)
-  (goto test n))
-
-(define-local-syntax (define-primitive id nargs)
-  (let ((args (reverse (list-tail '(z y x) (- '3 nargs)))))
-    `(define (,id . ,args)
-       (call-primitively ,id . ,args))))
-
-(define-local-syntax (define-effect-primitive id nargs)
-  (let ((args (reverse (list-tail '(z y x) (- '3 nargs)))))
-    `(define (,id . ,args)
-       (call-primitively ,id . ,args)
-       (call-primitively undefined-value))))
-
-(define-primitive + 2)
-(define-primitive - 2)
-(define-primitive * 2)
-(define-primitive < 2)
-(define-primitive = 2)
-
-(define-primitive quotient  2)
-(define-primitive remainder 2)
-
-(define (unassigned) (call-primitively undefined-value))
-
-(define (byte-vector-ref vec index)
-  (call-primitively byte-contents (+ vec index)))
-
-(define (byte-vector-set! vec index value)
-  (call-primitively byte-set-contents! (+ vec index) value))
-
-(define (vector-set! vec index value)
-  (call-primitively set-contents! (+ vec (* index 4)) value))
diff --git a/ps-compiler/prescheme/test/values.scm b/ps-compiler/prescheme/test/values.scm
deleted file mode 100644
index 3a8fdf3..0000000
--- a/ps-compiler/prescheme/test/values.scm
+++ /dev/null
@@ -1,11 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-(define (sender)
-  (values 1 2 3 4))
-
-(define (receiver a b c d)
-  (+ a (- b (* c d))))
-
-(define (test)
-  (call-with-values sender receiver))
diff --git a/ps-compiler/prescheme/test/vector.scm b/ps-compiler/prescheme/test/vector.scm
deleted file mode 100644
index 2918e72..0000000
--- a/ps-compiler/prescheme/test/vector.scm
+++ /dev/null
@@ -1,32 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-; Oops - this is polymorphic!
-
-(define (vector+length-fill! v length x)
-  (do ((i 0 (+ i 1)))
-      ((>= i length))
-    (vector-set! v i x)))
-
-(define *v* (unassigned))
-
-(define (test x)
-  (set! *v* (make-vector 10))
-  (vector+length-fill! *v* 10 3)
-  (vector-ref *v* x))
-
-;(define (find-port-index)
-;  (let loop ((i 0))
-;    (cond ((>= i 10)
-;           -1)
-;          ((= 3 (vector-ref *v* i))
-;           i)
-;          (else (loop (+ i 1))))))
-;
-;(define (foo)
-;  (let loop ((i (find-port-index)))
-;    (if (>= i 5)
-;        (let ((v *v*))
-;          (bar)
-;          (vector-set! v i (baz)))
-;        (loop (find-port-index)))))
diff --git a/ps-compiler/prescheme/test/vector2.scm b/ps-compiler/prescheme/test/vector2.scm
deleted file mode 100644
index 895b5c7..0000000
--- a/ps-compiler/prescheme/test/vector2.scm
+++ /dev/null
@@ -1,34 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-(define-local-syntax (define-primitive id nargs)
-  (let ((args (reverse (list-tail '(z y x) (- '3 nargs)))))
-    `(define (,id . ,args)
-       (call-primitively ,id . ,args))))
-
-(define-primitive + 2)
-(define-primitive - 2)
-(define-primitive * 2)
-(define-primitive < 2)
-
-(define-primitive make-vector 2)
-(define-primitive pointer-add 2)
-
-(define (vector-ref vec index)
-  (call-primitively contents (pointer-add vec index)))
-
-(define (vector-set! vec index value)
-  (call-primitively set-contents! (pointer-add vec index) value))
-
-(define (cons x y)
-  (let ((p (make-vector 2 0)))
-    (vector-set! p 0 x)
-    (vector-set! p 1 y)
-    p))
-
-(define (car p)
-  (vector-ref p 0))
-
-(define (cdr p)
-  (vector-ref p 1))
-
diff --git a/ps-compiler/prescheme/test/write.scm b/ps-compiler/prescheme/test/write.scm
deleted file mode 100644
index 5cd0c26..0000000
--- a/ps-compiler/prescheme/test/write.scm
+++ /dev/null
@@ -1,19 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-(define (test)
-  (let* ((b (allocate-memory 16))
-	 (res (read-block (current-input-port)
-			  b
-			  16
-			  (lambda (okay? eof? got)
-			    (if (or (not okay?)
-				    eof?)
-				-1
-				(write-block (current-output-port)
-					     b
-					     got
-					     (lambda (okay? sent)
-					       (if okay? sent -1))))))))
-    (deallocate-memory b)
-    res))
diff --git a/ps-compiler/prescheme/to-cps.scm b/ps-compiler/prescheme/to-cps.scm
deleted file mode 100644
index 9a8cdd6..0000000
--- a/ps-compiler/prescheme/to-cps.scm
+++ /dev/null
@@ -1,631 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-; Convert a byte-code-compiler node into a cps node.
-
-; Entry point.
-
-(define (x->cps node name)
-  (receive (value first-call last-lambda)
-      (cps node)
-    (if first-call
-	(bug "(X->CPS ~S) got a non-value" node))
-    (maybe-add-name! value name)
-    value))
-
-;----------------------------------------------------------------
-; (CPS <node>)
-;   -> <value> <first-call> <last-lambda>
-; <value> is the CPSed value of <node>.  If <node> contains no non-trivial
-; calls, <first-call> and <last-lambda> are both #f.  Otherwise they are
-; the first of the non-trivial calls and the continuation of the last.
-
-(define (cps node)
-  (receive (value first-call last-lambda)
-      (real-cps node)
-    (let ((value (cond ((not (list? value))
-			value)
-		       ((or (null? value)
-			    (not (null? (cdr value))))
-			(bug "value expression did not return one value ~S"
-			     (schemify node)))
-		       (else
-			(car value)))))
-      (values value first-call last-lambda))))
-    
-; Same as above except that <value> is a list of values.
-
-(define (values-cps node)
-  (receive (value first-call last-lambda)
-      (real-cps node)
-    (values (if (list? value)
-		value
-		(list value))
-	    first-call
-	    last-lambda)))
-
-(define (real-cps node)
-  ((operator-table-ref cps-converters
-		       (node-operator-id node))
-     node))
-
-(define cps-converters
-  (make-operator-table
-   (lambda (node id)
-     (error "no cps-converter for node ~S" node))))
-
-(define (define-cps-converter name proc)
-  (operator-define! cps-converters name #f proc))
-
-;----------------------------------------------------------------
-; (TAIL-CPS <node> <continuation-variable>)
-;   -> <first-call>
-
-(define (tail-cps node cont-var)
-  ((operator-table-ref tail-cps-converters (node-operator-id node))
-     node
-     cont-var))
-
-(define tail-cps-converters
-  (make-operator-table
-    (lambda (node cont-var)
-      (error "no tail-cps-converter for node ~S" node))))
-
-(define (define-tail-cps-converter name proc)
-  (operator-define! tail-cps-converters name #f proc))
-
-; Use PROC in the CPS table and give it a wrapper that makes a return for use
-; in the TAIL-CPS table.
-
-(define (define-value-cps-converter name proc)
-  (operator-define! cps-converters name #f
-		    (lambda (node)
-		      (values (proc node) #f #f)))
-  (operator-define! tail-cps-converters name #f
-		    (lambda (node cont-var)
-		      (make-return cont-var (proc node)))))
-
-; El Hacko Grande: we use the name of the CONT-VAR to determine whether
-; it is a return or a join point.
-
-(define (join? var)
-  (case (variable-name var)
-    ((c) #f)
-    ((j) #t)
-    (else
-     (bug "funny continuation variable name ~S" var))))
-
-(define (make-return cont-var value)
-  (really-make-return cont-var (list value)))
-
-(define (make-multiple-value-return cont-var values)
-  (really-make-return cont-var values))
-
-(define (really-make-return cont-var values)
-  (let ((return (make-call-node
-		 (get-primop (if (join? cont-var)
-				 (enum primop jump)
-				 (enum primop unknown-return)))
-		 (+ 1 (length values))
-		 0)))
-    (attach-call-args return (cons (make-reference-node cont-var) values))
-    return))
-
-;----------------------------------------------------------------
-; Constants are easy.
-
-(define-value-cps-converter 'literal
-  (lambda (node)
-    (cps-literal (node-form node) node)))
-
-(define-value-cps-converter 'quote
-  (lambda (node)
-    (cps-literal (cadr (node-form node)) node)))
-
-(define (cps-literal value node)
-  (make-literal-node value (node-type node)))
-
-(define-value-cps-converter 'unspecific
-  (lambda (node)
-    (make-unspecific)))
-
-(define (make-unspecific)
-  (make-call-node (get-prescheme-primop 'unspecific) 0 0))
-
-; Used for primitives in non-call position.  The CDR of the form is a
-; variable that will be bound to the primitive's closed-compiled value.
-
-(define-value-cps-converter 'primitive
-  (lambda (node)
-    (make-reference-node (cdr (node-form node)))))
-
-;----------------------------------------------------------------
-
-(define-value-cps-converter 'lambda
-  (lambda (node)
-    (let ((form (node-form node))
-	  (cont-var (make-variable 'c (lambda-node-return-type node)))
-	  (vars (map (lambda (name)
-		       (let ((var (make-variable (name-node->symbol name)
-						 (node-type name))))
-			 (node-set! name 'variable var)
-			 var))
-		     (cadr (node-form node)))))
-      (let ((lnode (make-lambda-node 'p 'proc (cons cont-var vars))))
-	(attach-body lnode (tail-cps (caddr form) cont-var))
-	lnode))))
-
-;----------------------------------------------------------------
-; References and SET!
-
-(define-value-cps-converter 'name
-  (lambda (node)
-    (cond ((node-ref node 'variable)
-	   => make-reference-node)    ; eventually have to check for SET!'s
-	  ((node-ref node 'binding)
-	   => (lambda (binding)
-		(let ((var (binding-place binding)))
-		  (cond ((not (variable? var))
-			 (bug "binding for ~S has funny place ~S" node var))
-			((variable-set!? var)
-			 (make-global-ref var))
-			(else
-			 (make-reference-node var))))))
-	  (else
-	   (bug "name node ~S has neither variable nor binding" node)))))
-  
-(define (make-global-ref var)
-  ((structure-ref node let-nodes)
-     ((call (global-ref 0 (* var))))
-   call))
-
-; Stolen from form.scm as an expedient.  This needs to be moved to somewhere
-; that both FORMS and TO-CPS can see it.
-
-(define (variable-set!? var)
-  (memq 'set! (variable-flags var)))
-
-(define-cps-converter 'set!
-  (lambda (node)
-    (receive (first-call last-lambda)
-	(make-global-set! (node-form node))
-      (values (make-unspecific) first-call last-lambda))))
-
-(define-tail-cps-converter 'set!
-  (lambda (node cont-var)
-    (receive (first-call last-lambda)
-	(make-global-set! (node-form node))
-      (attach-body last-lambda (make-return cont-var (make-unspecific)))
-      first-call)))
-
-(define (make-global-set! form)
-  (let ((name (cadr form))
-	(value (caddr form)))
-    (receive (value first-call last-lambda)
-	(cps value)
-      (maybe-add-name! value name)
-      (let ((cont (make-lambda-node 'c 'cont '()))
-	    (var (name-node->variable name)))
-	((structure-ref node let-nodes)
-	 ((call (global-set! 1 cont (* var) value)))
-	 (values (splice!->first first-call last-lambda call)
-		 cont))))))
-
-(define (name-node->variable name-node)
-  (let ((binding (node-ref name-node 'binding)))
-    (if (and binding
-             (variable? (binding-place binding)))
-        (binding-place binding)
-	(bug "name node ~S has no variable" name-node))))
-
-;----------------------------------------------------------------
-; CALL & GOTO
-
-(define-cps-converter 'call
-  (lambda (node)
-    (let ((exp (node-form node)))
-      (convert-call (car exp) (cdr exp) node))))
-
-; Treat non-tail-recursive GOTO's as normal calls.
-
-(define-cps-converter 'goto
-  (lambda (node)
-    (let ((exp (node-form node)))
-      (user-warning "Ignoring non-tail-recursive GOTO: ~S" (schemify node))
-      (convert-call (cadr exp) (cddr exp) node))))
-
-; Dispatch on the procedure.  Do something special with lambdas, primitives,
-; primops (in literal nodes).  Everything else is turned into an unknown call.
-; Calls to primitives are expanded and then CPS'ed.
-
-(define (convert-call proc args node)
-  (cond ((lambda-node? proc)
-	 (convert-let (node-form proc) args node))
-	((primitive-node? proc)
-	 (values-cps (expand-primitive-call proc args node)))
-	((and (literal-node? proc)
-	      (primop? (node-form proc)))
-	 (convert-primop-call (node-form proc) args (node-type node)))
-	(else
-	 (convert-primop-call (get-primop (enum primop unknown-call))
-			      (cons proc    ; add protocol argument
-				    (cons (make-literal normal-protocol)
-					  args))
-			      (node-type node)))))
-
-; Same again, except that for unknown tail-recursive calls we use different
-; protocols for CALL and GOTO.
-
-(define-tail-cps-converter 'call
-  (lambda (node cont-var)
-    (if (join? cont-var)
-	(convert-and-add-jump node cont-var)
-	(let ((exp (node-form node)))
-	  (tail-convert-call (car exp) (cdr exp) node cont-var normal-protocol)))))
-
-(define-tail-cps-converter 'goto
-  (lambda (node cont-var)
-    (if (join? cont-var)
-	(convert-and-add-jump node cont-var)
-	(let ((exp (node-form node)))
-	  (tail-convert-call (cadr exp) (cddr exp) node cont-var goto-protocol)))))
-
-(define (convert-and-add-jump node join-var)
-  (receive (values first-call last-lambda)
-      (values-cps node)
-    (let ((jump (make-multiple-value-return join-var values)))
-      (cond (first-call
-	     (attach-body last-lambda jump)
-	     first-call)
-	    (else
-	     jump)))))
-
-(define (tail-convert-call proc args node cont-var protocol)
-  (cond ((lambda-node? proc)
-	 (convert-tail-let (node-form proc) args node cont-var))
-	((primitive-node? proc)
-	 (tail-cps (expand-primitive-call proc args node)
-		   cont-var))
-	((and (literal-node? proc)
-	      (primop? (node-form proc)))
-	 (convert-primop-tail-call (node-form proc) args cont-var))
-	(else
-	 (convert-unknown-tail-call (cons proc args) cont-var protocol))))
-
-; Every primitive has its own expander.
-
-(define (expand-primitive-call proc args node)
-  ((primitive-expander (node-form proc)) args (node-type node)))
-
-(define lambda-node? (node-predicate 'lambda))
-(define primitive-node? (node-predicate 'primitive))
-(define literal-node? (node-predicate 'literal))
-
-(define literal-op (get-operator 'literal))
-
-(define (make-literal value)
-  (make-node literal-op value))
-
-;----------------------------------------------------------------
-; LET (= a call whose procedure is a LAMBDA)
-
-; REALLY-CONVERT-LET does all the work.  These convert the body of the LET
-; using either CPS or TAIL-CPS and connect everything up.
-
-(define (convert-let proc args node)
-  (receive (lnode first-call)
-      (really-convert-let proc args node)
-    (receive (vals body-first-call body-last-lambda)
-	(values-cps (caddr proc))
-      (values vals
-	      first-call
-	      (splice!->last lnode body-first-call body-last-lambda)))))
-	
-(define (convert-tail-let proc args node cont-var)
-  (receive (lnode first-call)
-      (really-convert-let proc args node)
-    (attach-body lnode (tail-cps (caddr proc) cont-var))
-    first-call))
-
-;  Make the call to the LET primop and build the lambda node for the procedure.
-
-(define (really-convert-let proc args node)
-  (receive (call first-call last-lambda)
-      (cps-call (get-primop (enum primop let)) 1 1 args cps)
-    (let ((vars (map (lambda (name)
-		       (let ((var (make-variable (name-node->symbol name)
-						 (node-type name))))
-			 (node-set! name 'variable var)
-			 var))
-		     (cadr proc))))
-      (do ((names (cadr proc) (cdr names))
-	   (index 1 (+ index 1)))
-	  ((null? names))
-	(maybe-add-argument-name! call index (node-form (car names))))
-      (let ((lnode (make-lambda-node #f 'cont vars)))
-	(attach call 0 lnode)
-	(values lnode (splice!->first first-call last-lambda call))))))
-
-; Primitive calls
-; Use CPS-CALL to do the work and then make a continuation if the primop is
-; not trivial.
-
-(define (convert-primop-call primop args type)
-  (let ((trivial? (primop-trivial? primop)))
-    (receive (call first-call last-lambda)
-	(cps-call primop (if trivial? 0 1) (if trivial? 0 1) args cps)
-      (if (not trivial?)
-	  (add-continuation call first-call last-lambda type)
-	  (values call first-call last-lambda)))))
-
-(define (add-continuation call first-call last-lambda type)
-  (let* ((vars (map (lambda (type)
-		      (make-variable 'v type))
-		    (if (tuple-type? type)
-			(tuple-type-types type)
-			(list type))))
-	 (cont (make-lambda-node 'c 'cont vars)))
-    (attach call 0 cont)
-    (values (if (tuple-type? type)
-		(map make-reference-node vars)
-		(make-reference-node (car vars)))
-	    (splice!->first first-call last-lambda call)
-	    cont)))
-
-; Call CONVERT-PRIMOP-CALL and then make a return.
-
-(define (convert-primop-tail-call primop args cont-var)
-  (receive (value first-call last-lambda)
-      (convert-primop-call primop args (variable-type cont-var))
-    (splice!->first first-call
-		    last-lambda
-		    (if (list? value)
-			(make-multiple-value-return cont-var value)
-			(make-return cont-var value)))))
-
-; Another front for CPS-CALL, passing it the UNKNOWN-TAIL-CALL primop and
-; its arguments, which are the procedure being called, the protocol, and
-; the actual arguments.
-
-(define (convert-unknown-tail-call args cont-var protocol)
-  (receive (call first-call last-lambda)
-      (cps-call (get-primop (enum primop unknown-tail-call)) 0 1
-		(cons (car args)
-		      (cons (make-literal protocol) (cdr args)))
-		cps)
-    (attach call 0 (make-reference-node cont-var))
-    (splice!->first first-call last-lambda call)))
-
-;----------------------------------------------------------------
-; BEGIN
-; These are fronts for CPS-SEQUENCE.
-
-(define-cps-converter 'begin
-  (lambda (node)
-    (receive (last-node real-first-call last-lambda)
-	(cps-sequence (cdr (node-form node)) values-cps)
-      (if (not real-first-call)
-	  (cps last-node)
-	  (receive (vals first-call real-last-lambda)
-	      (values-cps last-node)
-	    (values vals
-		    real-first-call
-		    (splice!->last last-lambda first-call real-last-lambda)))))))
-
-(define-tail-cps-converter 'begin
-  (lambda (node cont-var)
-    (receive (last-node first-call last-lambda)
-	(cps-sequence (cdr (node-form node)) values-cps)
-      (splice!->first first-call last-lambda (tail-cps last-node cont-var)))))
-
-;----------------------------------------------------------------
-;
-; (IF <a> <b> <c>)
-;  =>
-; (LET ((J (LAMBDA (V) [rest-goes-here])))
-;   (TEST (LAMBDA () [tail-cps <b> J])
-;         (LAMBDA () [tail-cps <c> J])
-;         <a>))
-
-(define-cps-converter 'if
-  (lambda (node)
-    (let ((exp (node-form node))
-	  (join-var (make-variable 'j type/unknown))
-	  (res-vars (make-variables (node-type node))))
-      (receive (call first-call last-lambda)
-	  (convert-if exp join-var)
-	(let ((let-lambda (make-lambda-node 'c 'cont (list join-var)))
-	      (let-call (make-call-node (get-primop (enum primop let)) 2 1))
-	      (join-lambda (make-lambda-node 'j 'jump res-vars)))
-	  (attach let-call 0 let-lambda)
-	  (attach let-call 1 join-lambda)
-	  (attach-body let-lambda call)
-	  (values (map make-reference-node res-vars)
-		  (splice!->first first-call last-lambda let-call )
-		  join-lambda))))))
-
-(define (make-variables type)
-  (map (lambda (type)
-	 (make-variable 'v type))
-       (if (tuple-type? type)
-	   (tuple-type-types type)
-	   (list type))))
-
-; Tail-recursive IFs do not require a join point.
-
-(define-tail-cps-converter 'if
-  (lambda (node cont-var)
-    (let ((exp (node-form node)))
-      (receive (call first-call last-lambda)
-	  (convert-if exp cont-var)
-	(splice!->first first-call last-lambda call)))))
-
-; Actually build the two-continuation call to the TEST primop.
-
-(define (convert-if exp cont-var)	
-  (receive (call first-call last-lambda)
-      (cps-call (get-prescheme-primop 'test) 2 2 (list (cadr exp)) cps)
-    (let ((true-cont (make-lambda-node 'c 'cont '()))
-	  (true-call (tail-cps (caddr exp) cont-var))
-	  (false-cont (make-lambda-node 'c 'cont '()))
-	  (false-call (tail-cps (cadddr exp) cont-var)))
-      (attach-body true-cont true-call)
-      (attach-body false-cont false-call)
-      (attach call 0 true-cont)
-      (attach call 1 false-cont)
-      (values call first-call last-lambda))))
-
-;----------------------------------------------------------------
-
-(define-cps-converter 'values
-  (lambda (node)
-    (let ((args (cdr (node-form node))))
-      (receive (call first-call last-lambda)
-	  (cps-call (get-prescheme-primop 'unspecific) 0 0 args cps)
-	(let ((vals (vector->list (call-args call))))
-	  (map detach vals)
-	  (values vals first-call last-lambda))))))
-	  
-(define-tail-cps-converter 'values
-  (lambda (node cont-var)
-    (let ((args (cdr (node-form node))))
-      (receive (call first-call last-lambda)
-	  (cps-call (get-primop (enum primop unknown-return)) 0 1 args cps)
-	(attach call 0 (make-reference-node cont-var))
-	(splice!->first first-call last-lambda call)))))
-	  
-(define-cps-converter 'call-with-values
-  (lambda (node)
-    (convert-call-with-values node #f)))
-
-(define-tail-cps-converter 'call-with-values
-  (lambda (node cont-var)
-    (convert-call-with-values node cont-var)))
-
-; Consumer is known to be a lambda node.
-
-(define (convert-call-with-values node maybe-cont-var)
-  (receive (vals first-call last-lambda)
-      (values-cps (cadr (node-form node)))
-    (let ((consumer (x->cps (caddr (node-form node)) #f))
-	  (call (make-call-node (get-primop (if maybe-cont-var
-						(enum primop tail-call)
-						(enum primop call)))
-				(+ 2 (length vals))
-				(if maybe-cont-var 0 1))))
-      (attach-call-args call `(#f ,consumer . ,vals))
-      (cond (maybe-cont-var
-	     (attach call 0 (make-reference-node maybe-cont-var))
-	     (splice!->first first-call last-lambda call))
-	    (else
-	     (add-continuation call first-call last-lambda (node-type node)))))))
-
-;----------------------------------------------------------------
-; LETRECs have been analyzed and restructured by FLATTEN, so we know that
-; the values are all lambdas.
-
-(define-cps-converter 'letrec
-  (lambda (node)
-    (let ((form (node-form node)))
-      (receive (first-call last-lambda)
-	  (convert-letrec form)
-	(receive (vals body-first-call body-last-lambda)
-	    (values-cps (caddr form))
-	  (values vals
-		  first-call
-		  (splice!->last last-lambda
-				 body-first-call
-				 body-last-lambda)))))))
-
-(define-tail-cps-converter 'letrec
-  (lambda (node cont-var)
-    (let ((form (node-form node)))
-      (receive (first-call last-lambda)
-	  (convert-letrec form)
-	(attach-body last-lambda (tail-cps (caddr form) cont-var))
-	first-call))))
-
-(define (convert-letrec form)
-  (let ((vars (map (lambda (l)
-		     (let ((var (make-variable (name-node->symbol (car l))
-					       (node-type (car l)))))
-		       (node-set! (car l) 'variable var)
-		       var))
-		   (cadr form)))
-	(vals (map (lambda (l)
-		     (receive (value first-call last-lambda)
-			 (cps (cadr l))
-		       value))
-		   (cadr form)))
-	(cont (make-lambda-node 'c 'cont '())))
-    ((structure-ref node let-nodes)
-       ((top (letrec1 1 l1))
-        (l1 ((x #f) . vars) call2)
-        (call2 (letrec2 1 cont (* x) . vals)))
-      (do ((names (cadr form) (cdr names))
-	   (index 2 (+ index 1)))
-	  ((null? names))
-	(maybe-add-argument-name! call2 index (node-form (caar names))))
-      (values top cont))))
-
-;----------------------------------------------------------------
-; Utilities.
-
-; Stuff is a list of alternating call and lambda nodes, with possible #Fs.
-; This joins the nodes together by making the calls be the bodies of the
-; lambdas (the call->lambda links are already done).  The last node is
-; returned.
-
-(define (splice! stuff)
-  (let loop ((stuff stuff) (first #f) (last #f))
-    (if (null? stuff)
-	(values first last)
-	(receive (first last)
-	    (let ((next (car stuff)))
-	      (cond ((not next)
-		     (values first last))
-		    ((not first)
-		     (values next next))
-		    (else
-		     (if (and ((structure-ref node lambda-node?) last)
-			      ((structure-ref node call-node?) next))
-			 (attach-body last next))
-		     (values first next))))
-	  (loop (cdr stuff) first last)))))
-
-(define (splice!->first . stuff)
-  (receive (first last)
-      (splice! stuff)
-    first))
-
-(define (splice!->last . stuff)
-  (receive (first last)
-      (splice! stuff)
-    last))
-
-; Stuff for making CPS nodes
-(define make-reference-node (structure-ref node make-reference-node))
-(define make-lambda-node    (structure-ref node make-lambda-node))
-(define make-literal-node   (structure-ref node make-literal-node))
-(define make-call-node      (structure-ref node make-call-node))
-(define attach              (structure-ref node attach))
-(define detach              (structure-ref node detach))
-(define attach-body         (structure-ref node attach-body))
-(define attach-call-args    (structure-ref node attach-call-args))
-(define call-args           (structure-ref node call-args))
-
-; Adding names to lambda nodes for debugging help.
-
-(define (maybe-add-argument-name! call index name)
-  (maybe-add-name! ((structure-ref node call-arg) call index) name))
-
-(define (maybe-add-name! value name)
-  (if ((structure-ref node lambda-node?) value)
-      ((structure-ref node set-lambda-name!) value (schemify name))))
-
-; Getting symbols for use as variable names.
-
-(define (name-node->symbol node)
-  (let ((name (node-form node)))
-    (if (generated? name)
-	(generated-symbol name)
-	name)))
diff --git a/ps-compiler/prescheme/top.scm b/ps-compiler/prescheme/top.scm
deleted file mode 100644
index 6b40f7d..0000000
--- a/ps-compiler/prescheme/top.scm
+++ /dev/null
@@ -1,318 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-; Entry point
-
-(define (prescheme-compiler package-id spec-files init-name c-file . commands)
-  (reset-node-id)
-  (initialize-lambdas)
-  (reset-record-data!)
-  (reset-type-vars!)
-  (receive (copy no-copy shadow integrate header)
-      (parse-prescheme-commands commands)
-    (let ((forms (prescheme-front-end (if (list? package-id)
-					  package-id
-					  (list package-id))
-				      spec-files copy no-copy shadow)))
-      (for-each simplify-form forms)
-      (let ((forms (remove-unreferenced-forms forms)))
-	(for-each integrate-stob-form forms) 
-	; prevent further automatic integration
-	(for-each (lambda (form)
-		    (remove-variable-known-value! (form-var form)))
-		  forms)
-	(integrate-by-command integrate forms)
-	(for-each resimplify-form forms)
-	(let* ((forms (remove-unreferenced-forms forms))
-	       (forms (integrate-single-uses forms))
-	       (forms (remove-unreferenced-forms forms)))
-	  (for-each resimplify-form forms)
-	  (for-each determine-form-protocol forms)
-	  (let ((forms (form-tail-calls->jumps forms)))
-	    (for-each maybe-add-self-label forms)
-	    (let ((forms (hoist-nested-procedures forms)))
-	      (for-each remove-polymorphism forms)
-	      ; (if cps-file (write-cps-file cps-file forms))
-	      (if c-file (write-c-file init-name c-file header forms)))))))))
-
-;(define (expand-and-eval-program package-id spec-files output-file . commands)
-;  (reset-node-id)
-;  (reset-record-data!)
-;  (receive (copy no-copy shadow integrate header)
-;      (parse-prescheme-commands commands)
-;    (let ((forms (prescheme-front-end package-id spec-files copy no-copy shadow)))
-;      (call-with-output-file output-file
-;        (lambda (out)
-;          (display-forms-as-scheme forms out))))))
-
-;(define (simplify-and-print-program package-id spec-files output-file c-file . commands)
-;  (reset-node-id)
-;  (reset-record-data!)
-;  (receive (copy no-copy shadow integrate header)
-;      (parse-prescheme-commands commands)
-;    (let ((forms (prescheme-front-end package-id spec-files copy no-copy shadow)))
-;      (for-each simplify-form forms)
-;      (let ((forms (remove-unreferenced-forms forms)))
-;        (call-with-output-file output-file
-;          (lambda (out)
-;            (display-cps-forms-as-scheme forms out)))))))
-
-(define command-names '(copy no-copy shadow integrate header))
-
-(define (parse-prescheme-commands commands)
-  (let ((res (map list command-names)))
-    (for-each (lambda (command)
-		(cond ((assq (car command) res)
-		       => (lambda (l)
-			    (set-cdr! l (append (reverse (cdr command))
-						(cdr l)))))
-		      (else
-		       (error "unknown directive ~S" command))))
-	      commands)
-    (apply values (map (lambda (l) (reverse (cdr l))) res))))
-
-;--------------------------------------------------
-
-(define (simplify-form form)
-  (format #t " ~A " (form-name form))
-  (let ((status (expand-and-simplify-form form)))
-    (if status
-	(format #t "(~A): " status)
-	(format #t ": "))
-    (display-type (variable-type (form-var form))
-		  (current-output-port))
-    (newline (current-output-port))))
-
-;--------------------------------------------------
-
-(define (integrate-single-uses forms)
-  (format #t "In-lining single-use procedures~%")
-  (let loop ((forms forms) (done '()) (hit? #f))
-    (cond ((null? forms)
-	   (if hit?
-	       (loop (reverse done) '() #f)
-	       (reverse done)))
-	  ((single-called-use? (car forms))
-	   (let ((form (car forms)))
-;	     (format #t " ~S~%" (variable-name (form-var form)))
-	     (integrate-single-use form
-				   (car (variable-refs (form-var form)))
-				   #f)
-	     (set-form-value! form #f)
-	     (make-form-unused! form)
-	     (loop (cdr forms) done #t)))
-	  (else
-	   (loop (cdr forms) (cons (car forms) done) hit?)))))
-
-(define (single-called-use? form)
-  (let ((var (form-var form)))
-    (and (not (form-exported? form))
-	 (eq? (form-type form) 'lambda)
-	 (not (null? (variable-refs var)))
-	 (null? (cdr (variable-refs var)))
-	 (called-node? (car (variable-refs var))))))
-
-(define (integrate-single-use form ref copy?)
-  (let* ((in-node (node-base ref))
-	 (in-form (node-form in-node))
-	 (type (variable-type (form-var form))))
-    (use-this-form! in-form)
-    (let ((node (cond (copy?
-		       (copy-node-tree (form-node form)))
-		      (else
-		       (also-use-this-form! form)
-		       (form-node form)))))
-      (if (type-scheme? type)
-	  (if (not (called-node? ref))
-	      (error "integrating polymorphic value into non-call position")
-	      (instantiate-type&value type node ref)))
-      (determine-lambda-protocol node (list ref))
-      (replace ref node)
-      (simplify-all in-node (form-name form))
-      (suspend-form-use! in-form))))
-
-; Commands are (<proc> <caller>)
-
-(define (integrate-by-command commands forms)
-  (for-each (lambda (command)
-	      (receive (proc refs)
-		  (process-integrate-command command forms)
-		(if proc
-		    (for-each (lambda (r)
-				(integrate-single-use proc r #t))
-			      refs))))
-	    commands))
-
-; Horrendous error checking and notification.
-
-(define (process-integrate-command command forms)
-  (let* ((proc (any (lambda (f)
-		      (eq? (form-name f) (car command)))
-		    forms))
-	 (var (if proc (form-var proc) #f))
-	 (node (if proc (form-value proc) #f))
-	 (caller (any (lambda (f)
-			(eq? (form-name f) (cadr command)))
-		      forms))
-	 (refs (if (and var caller)
-		   (filter (lambda (ref)
-			     (eq? caller (node-form ref)))
-			   (variable-refs var))
-		   #f)))
-    (cond ((or (not proc) (not var) (not caller))
-	   (cond ((or (not proc) (not var))
-		  (format #t "Bad command: no value for ~S~%"
-			  (car command)))
-		 ((or (not node)
-		      (not (lambda-node? node)))
-		  (format #t "Bad command: ~S is not a procedure~%"
-			  (car command))))
-	   (if (not caller)
-	       (format #t "Bad command: no definition for ~S~%"
-		       (cadr command)))
-	   (values #f #f))
-	  ((or (null? refs) (not node) (not (lambda-node? node)))
-	   (if (null? refs)
-	       (format #t "Bad command: ~S is not referenced by ~S~%"
-		       (car command) (cadr command)))
-	   (if (or (not node)
-		   (not (lambda-node? node)))
-	       (format #t "Bad command: ~S is not a procedure~%"
-		       (car command)))
-	   (values #f #f))
-	  (else
-	   (values proc refs)))))
-
-;--------------------------------------------------
-
-(define (determine-form-protocol form)
-  (let ((var (form-var form)))
-    (cond ((and (not (form-exported? form))
-		(eq? 'lambda (form-type form))
-		(every? called-node? (variable-refs var)))
-	   (determine-lambda-protocol (form-node form) (variable-refs var))
-	   (note-known-global-lambda! var (form-node form))))))
-
-;--------------------------------------------------
-
-(define (form-tail-calls->jumps forms)
-  (receive (hits useless)
-      (find-jump-procs (filter-map (lambda (form)
-				     (if (eq? 'lambda (form-type form))
-					 (form-node form)
-					 #f))
-				   forms)
-		       find-form-proc-calls)
-    (for-each (lambda (p)
-		(let* ((procs (cdr p))
-		       (proc-forms (map node-form procs))
-		       (owner (node-flag (node-base (car p))))
-		       (vars (map form-var proc-forms)))
-		  (use-this-form! owner)
-		  (for-each also-use-this-form! proc-forms)
-		  (procs->jumps (cdr p) vars (car p))
-		  (simplify-node (form-value owner)) ; worth it?
-		  (suspend-form-use! owner)
-		  (for-each (lambda (f)
-			      (set-form-value! f #f)
-			      (make-form-unused! f))
-			    proc-forms)))
-	      hits)
-    (for-each (lambda (p)
-		(make-form-unused! (node-form p)))
-	      useless)
-    (filter (lambda (f)
-	      (not (eq? (form-type f) 'unused)))
-	    forms)))
-
-(define (find-form-proc-calls l)
-  (let ((refs (variable-refs (form-var (node-form l)))))
-    (cond ((and refs (every? called-node? refs))
-	   refs)
-	  ((calls-known? l)
-	   (bug "cannot find calls for known lambda ~S" l))
-	  (else #f))))
-
-;--------------------------------------------------
-; Determine an actual type for a polymorphic procedure.
-
-(define (remove-polymorphism form)
-  (if (and (null? (variable-refs (form-var form)))
-	   (eq? 'lambda (form-type form)))
-      (for-each (lambda (var)
-		  (if (and (null? (variable-refs var))
-			   (uvar? (maybe-follow-uvar (variable-type var))))
-		      (unused-variable-warning var form)))
-		(cdr (lambda-variables (form-node form)))))
-  (if (type-scheme? (variable-type (form-var form)))
-      (make-monomorphic! (form-var form))))
-
-(define (unused-variable-warning var form)		
-  (format #t "Warning: argument `~S' of `~S' is not used, and `~S' is not called;~%"
-	  (variable-name var) (form-name form) (form-name form))
-  (format #t "  assuming the type of argument `~S' of procedure `~S' is `long'.~%"
-	  (variable-name var) (form-name form))
-  (set-variable-type! var type/integer))
-
-;--------------------------------------------------
-
-; Various methods for getting values from thunks.  These are no longer used
-; here.
-
-(define (thunk-value thunk)
-  (let ((refs (variable-refs (car (lambda-variables thunk)))))
-    (if (= 1 (length refs))
-        (call-arg (node-parent (car refs)) 2)
-        #f)))
-
-(define (simple-thunk? thunk value)
-  (eq? (node-parent (node-parent value)) thunk))
-
-;----------------------------------------------------------------
-; Turning internal tail-recursive calls to jumps.
-
-; f = (proc (c . vars)
-;       ... ([unknown-]tail-call c f . args) ...)
-;  =>
-; f = (proc (c . vars)
-;       (letrec ((f' (jump . vars) ... (jump f' . args) ...))
-;         (jump f' . vars)))
-
-(define (maybe-add-self-label form)
-  (if (eq? 'lambda (form-type form))
-      (let* ((node (form-node form))
-	     (self-calls (filter (lambda (ref)
-				   (and (eq? (node-index ref) 1)
-					(calls-this-primop? (node-parent ref)
-							    (if (calls-known? node)
-								'tail-call
-								'unknown-tail-call))
-					(eq? node (node-base ref))))
-				 (variable-refs (form-var form)))))
-	(if (not (null? self-calls))
-	    (begin
-	      (use-this-form! form)
-	      (replace-self-calls-with-jumps node self-calls)
-	      (suspend-form-use! form))))))
-
-(define (replace-self-calls-with-jumps proc refs)
-  (let* ((outside-var (reference-variable (car refs)))
-	 (var (make-variable (variable-name outside-var)
-			     (variable-type outside-var)))
-	 (vars (map copy-variable (cdr (lambda-variables proc))))
-	 (args (map make-reference-node vars))
-	 (body (lambda-body proc))
-	 (jump-proc (make-lambda-node (lambda-name proc) 'jump vars)))
-    (for-each (lambda (ref)
-		(let ((call (node-parent ref)))
-		  (if (not (calls-known? proc))
-		      (remove-call-arg call 2))  ; remove TAIL? argument
-		  (remove-call-arg call 0)       ; remove continuation argument
-		  (replace (call-arg call 0) (make-reference-node var))
-		  (set-call-primop! call (get-primop (enum primop jump)))))
-	      refs)
-    (let-nodes ((call (jump 0 (* var) . args)))
-      (move-body body (lambda (body)
-			(attach-body jump-proc body)
-			call))
-      (put-in-letrec (list var) (list jump-proc) call))))
-    
diff --git a/ps-compiler/prescheme/type-scheme.scm b/ps-compiler/prescheme/type-scheme.scm
deleted file mode 100644
index f066f1f..0000000
--- a/ps-compiler/prescheme/type-scheme.scm
+++ /dev/null
@@ -1,107 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-; Type schemes
-
-(define-record-type type-scheme
-  (
-   type           ; a type
-   free-uvars     ; uvars that are free
-   )
-  ())
-
-(define make-type-scheme type-scheme-maker)
-
-(define-record-discloser type/type-scheme
-  (lambda (type-scheme)
-    (list 'type-scheme
-	  (map uvar-id (type-scheme-free-uvars type-scheme))
-	  (type-scheme-type type-scheme))))
-
-; If TYPE has any variables bound at DEPTH this returns a type scheme making
-; those variables polymorphic; otherwise TYPE is returned.
-
-; Would like to do limited finalizing of uvars, but can't.
-; Consider (lambda (g x) (tuple (g 3) (g x) x))
-; (a -> b) -> c -> [d, e, f] with
-; a > int8, d > b, a > c, e > b, f > c
-; No polymorphism, and no simplification without restricting someone
-; But consider NOT  a ->b, bool > a, b > bool
-; It could just as well be bool -> bool.
-; Simplification okay on variables that are not used inside other types?
-
-(define *free-uvars* '())
-
-(define (schemify-type type depth)
-  (set! *free-uvars* '())
-  (let* ((type (find-free-uvars type depth))
-	 (free-uvars *free-uvars*))
-    (set! *free-uvars* '()) ; drop pointers
-    (for-each (lambda (uvar)
-		(set-uvar-place! uvar #f))
-	      free-uvars)
-    (if (not (null? free-uvars))
-	(make-type-scheme type free-uvars)
-	type)))
-  
-(define (find-free-uvars type depth)
-  (let label ((type type))
-    (cond ((other-type? type)
-	   (make-other-type (other-type-kind type)
-			    (map label
-				 (other-type-subtypes type))))
-	  ((not (uvar? type))
-	   type)
-	  ((uvar-binding type)
-	   => label)
-	  ((and (not (uvar-place type))
-		(<= depth (uvar-depth type)))
-	   (set-uvar-place! type type)
-	   (set! *free-uvars* (cons type *free-uvars*))
-	   type)
-	  (else
-	   type))))
-
-; Instantiate SCHEME at DEPTH.
-;
-; New sequence:
-;   (instantiate-type-scheme scheme depth)
-;   ... elide bindings in new copy ...
-;   (clean-type-scheme scheme)
-
-(define (instantiate-type-scheme scheme depth . maybe-thunk)
-  (instantiate-type-scheme! scheme depth)
-  (let ((type (copy-type (type-scheme-type scheme))))
-    (if (not (null? maybe-thunk))
-	((car maybe-thunk)))
-    (clean-type-scheme! scheme)
-    type))
-
-(define (instantiate-type-scheme! scheme depth)
-  (let ((uid (unique-id)))
-    (for-each (lambda (uvar)
-		(set-uvar-place!
-		 uvar
-		 (make-uvar (uvar-prefix uvar) depth uid)))
-	      (type-scheme-free-uvars scheme))))
-
-(define (clean-type-scheme! scheme)
-  (for-each (lambda (uvar)
-	      (set-uvar-place! uvar #f))
-	    (type-scheme-free-uvars scheme)))
-
-(define (copy-type type)
-  (cond ((other-type? type)
-	 (make-other-type (other-type-kind type)
-			  (map copy-type
-			       (other-type-subtypes type))))
-	((not (uvar? type))
-	 type)
-	((uvar-place type)
-	 => identity)
-	((uvar-binding type)
-	 => copy-type)
-	(else
-	 type)))
-
-
diff --git a/ps-compiler/prescheme/type-var.scm b/ps-compiler/prescheme/type-var.scm
deleted file mode 100644
index be9d28a..0000000
--- a/ps-compiler/prescheme/type-var.scm
+++ /dev/null
@@ -1,149 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-; Type variables - what a mess
-
-(define-record-type uvar
-  (prefix        ; a name for debugging
-   (depth)       ; lexical depth of the uvar
-   id            ; a number
-   (tuple-okay?) ; true if this can be unified with a tuple, set when merged
-   )
-  ((place        #f)  ; used in producing type schemes
-   (source       #f)  ; to let the user know where this came from
-   (binding      #f)  ; known value of this uvar
-   (temp         #f)  ; useful field
-   ))
-
-(define-record-discloser type/uvar
-  (lambda (uvar)
-    (list 'uvar
-	  (uvar-prefix uvar)
-	  (uvar-depth uvar)
-	  (uvar-id uvar)
-	  (uvar-binding uvar))))
-
-(define (make-uvar prefix depth . maybe-id)
-  (uvar-maker prefix
-	      depth
-	      (if (null? maybe-id)
-		  (unique-id)
-		  (car maybe-id))
-	      #f))
-
-(define (make-tuple-uvar prefix depth . maybe-id)
-  (uvar-maker prefix
-	      depth
-	      (if (null? maybe-id)
-		  (unique-id)
-		  (car maybe-id))
-	      #t))
-
-; Could this safely short-circuit the chains?
-
-(define (maybe-follow-uvar type)
-  (cond ((and (uvar? type)
-	      (uvar-binding type))
-	 => maybe-follow-uvar)
-	(else type)))
-
-; Substitute VALUE for UVAR, if this will not introduce a circularity.
-; or cause other problems.  Returns an error-printing thunk if there is
-; a problem.
-
-(define (bind-uvar! uvar value)
-  (cond ((uvar? value)
-	 (bind-uvar-to-uvar! uvar value)
-	 #f)
-	(else
-	 (bind-uvar-to-type! uvar value))))
-
-(define (bind-uvar-to-uvar! uvar0 uvar1)
-  (minimize-type-depth! uvar1 (uvar-depth uvar0))
-  (set-uvar-binding! uvar0 uvar1)
-  (if (and (uvar-tuple-okay? uvar1)
-	   (not (uvar-tuple-okay? uvar0)))
-      (set-uvar-tuple-okay?! uvar1 #f)))
-
-(define (bind-uvar-to-type! uvar type)
-  (let ((errors '()))
-    (if (uvar-in-type? uvar type)
-	(set! errors (cons circularity-error errors)))
-    (if (and (tuple-type? type)
-	     (not (uvar-tuple-okay? uvar)))
-	(set! errors (cons (tuple-error type) errors)))
-    (cond ((null? errors)  ; whew!
-	   (minimize-type-depth! type (uvar-depth uvar))
-	   (set-uvar-binding! uvar type)
-	   #f)
-	  (else
-	   (lambda ()
-	     (format #t "unifying ")
-	     (display-type uvar (current-output-port))
-	     (format #t " == ")
-	     (display-type type (current-output-port))
-	     (format #t "~% would cause the following problem~A:"
-		     (if (null? (cdr errors)) "" "s"))
-	     (for-each (lambda (x) (x)) errors))))))
-		       
-(define (circularity-error)
-  (format #t "~% creation of a circular type"))
-
-(define (tuple-error type)
-  (lambda ()
-    (if (null? (tuple-type-types type))
-	(format #t "~% returning no values where one is expected")
-	(format #t "~% returning ~D values where one is expected"
-		(length (tuple-type-types type))))))
-
-; Check that UVAR does not occur in EXP.
-
-(define (uvar-in-type? uvar exp)
-  (let label ((exp exp))
-    (cond ((or (base-type? exp)
-	       (record-type? exp))
-	   #f)
-	  ((uvar? exp)
-	   (if (uvar-binding exp)
-	       (label (uvar-binding exp))
-	       (eq? exp uvar)))
-	  ((other-type? exp)
-	   (every? label (other-type-subtypes exp)))
-	  (else
-	   (identity (bug "funny type ~S" exp))))))
-  
-; Make the depths of any uvars in TYPE be no greater than DEPTH.
-
-(define (minimize-type-depth! type depth)
-  (let label ((type type))
-    (cond ((other-type? type)
-	   (for-each label (other-type-subtypes type)))
-	  ((uvar? type)
-	   (cond ((uvar-binding type)
-		  => label)
-		 ((< depth (uvar-depth type))
-		  (set-uvar-depth! type depth)))))))
-
-; Set the depth of all uvars in TYPE to be -1 so that it will not be made
-; polymorphic at any level.
-
-(define (make-nonpolymorphic! type)
-  (cond ((uvar? type)
-	 (set-uvar-depth! type -1))
-	((other-type? type)
-	 (for-each make-nonpolymorphic! (other-type-subtypes type)))
-	;((type-scheme? type)
-	; (make-nonpolymorphic! (type-scheme-type type)))
-	))
-
-;------------------------------------------------------------
-; Micro utilities
-
-(define *unique-id-counter* 0)
-
-(define (unique-id)
-  (set! *unique-id-counter* (+ *unique-id-counter* 1))
-  *unique-id-counter*)
-
-(define (reset-type-vars!)
-  (set! *unique-id-counter* 0))
diff --git a/ps-compiler/prescheme/type.scm b/ps-compiler/prescheme/type.scm
deleted file mode 100644
index 7725058..0000000
--- a/ps-compiler/prescheme/type.scm
+++ /dev/null
@@ -1,233 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-(define-record-type base-type
-  (name
-   uid       ; an integer
-   )
-  ())
-
-(define-record-discloser type/base-type
-  (lambda (base-type)
-    (list (base-type-name base-type)
-	  (base-type-uid  base-type))))
-
-(define *next-base-type-uid* 0)
-
-(define (next-base-type-uid)
-  (let ((x *next-base-type-uid*))
-    (set! *next-base-type-uid* (+ x 1))
-    x))
-
-(define base-type-table (make-table))
-
-(define (make-base-type name)
-  (let ((type (base-type-maker name (next-base-type-uid))))
-    (table-set! base-type-table name type)
-    type))
-
-(define (lookup-type id)
-  (cond ((table-ref base-type-table id)
-	 => identity)
-	(else #f)))
-
-(define type/integer      (make-base-type 'integer))
-(define type/float        (make-base-type 'float))
-
-(define type/null         (make-base-type 'null))  ; no value
-(define type/unit         (make-base-type 'unit))  ; single value
-(define type/boolean      (make-base-type 'boolean))
-(define type/undetermined (make-base-type '?))
-(define type/input-port   (make-base-type 'input-port))
-(define type/output-port  (make-base-type 'output-port))
-(define type/address      (make-base-type 'address))
-(define type/char         (make-base-type 'char))
-
-(define (make-atomic-type name)
-  (base-type-maker name (next-base-type-uid)))
-
-(define type/unknown type/undetermined) ; an alias
-
-(define (type-name type)
-  (if (base-type? type)
-      (base-type-name type)
-      (error "type has no name ~S" type)))
-
-(define (make-base-type-table)
-  (let ((elts (make-vector *next-base-type-uid* #f)))
-    (values (lambda (type)
-	      (vector-ref elts (base-type-uid type)))
-	    (lambda (type value)
-	      (vector-set! elts (base-type-uid type) value)))))
-
-;--------------------------------------------------
-; This won't terminate on recursive types.
-
-(define (type-eq? type1 type2)
-  (let ((type1 (maybe-follow-uvar type1))
-	(type2 (maybe-follow-uvar type2)))
-    (or (eq? type1 type2)
-	(and (other-type? type1)
-	     (other-type? type2)
-	     (eq? (other-type-kind type1)
-		  (other-type-kind type2))
-	     (let loop ((l1 (other-type-subtypes type1))
-			(l2 (other-type-subtypes type2)))
-	       (cond ((null? l1) (null? l2))
-		     ((null? l2) #f)
-		     ((type-eq? (car l1) (car l2))
-		      (loop (cdr l1) (cdr l2)))
-		     (else #f)))))))
-
-;--------------------------------------------------
-; Arrow and pointer types (and perhaps others later)
-; All done together to simplify the type walking
-
-(define-record-type other-type
-  (
-   kind
-   (subtypes)       ; set when finalized
-   )
-  (
-   (finalized? #f)
-   ))
-
-(define make-other-type other-type-maker)
-
-(define-record-discloser type/other-type
-  (lambda (type)
-    (case (other-type-kind type)
-      ((arrow)
-       (list 'arrow-type
-	     (arrow-type-args type)
-	     (arrow-type-result type)))
-      (else
-       (cons (other-type-kind type)
-	     (other-type-subtypes type))))))
-
-(define (make-other-type-predicate kind)
-  (lambda (x)
-    (and (other-type? x)
-	 (eq? kind (other-type-kind x)))))
-
-; Arrow
-
-(define (make-arrow-type args result)
-  (other-type-maker 'arrow (cons result args)))
-
-(define arrow-type? (make-other-type-predicate 'arrow))
-
-(define (arrow-type-args type)
-  (cdr (other-type-subtypes type)))
-
-(define (arrow-type-result type)
-  (car (other-type-subtypes type)))
-
-; Pointer
-
-(define (make-pointer-type type)
-  (other-type-maker 'pointer (list type)))
-
-(define pointer-type? (make-other-type-predicate 'pointer))
-(define (pointer-type-to pointer-type)
-  (car (other-type-subtypes pointer-type)))
-
-(define type/string (make-pointer-type type/char))
-
-; Tuple (used for arguments and returning multiple values)
-
-(define (make-tuple-type types)
-  (if (and (not (null? types))
-	   (null? (cdr types)))
-      (car types)
-      (other-type-maker 'tuple types)))
-
-(define tuple-type? (make-other-type-predicate 'tuple))
-
-(define (tuple-type-types type)
-  (other-type-subtypes type))
-
-;--------------------------------------------------
-
-(define (finalize-type type)
-  (let ((type (maybe-follow-uvar type)))
-    (cond ((and (other-type? type)
-		(not (other-type-finalized? type)))
-	   (let ((subs (other-type-subtypes type)))
-	     (set-other-type-finalized?! type #t)
-	     (set-other-type-subtypes! type (map finalize-type subs))))
-	  ((and (uvar? type)               
-		(uvar-tuple-okay? type)) ; unused return value
-	   (bind-uvar! type type/unit)))
-    type))
-
-;--------------------------------------------------
-
-(define (expand-type-spec spec)
-  (cond ((pair? spec)
-	 (case (car spec)
-	   ((=>)
-	    (make-arrow-type (map expand-type-spec (cadr spec))
-			     (make-tuple-type (map expand-type-spec
-						   (cddr spec)))))
-	   ((^)
-	    (make-pointer-type (expand-type-spec (cadr spec))))
-	   ((tuple)
-	    (make-tuple-type (map expand-type-spec (cdr spec))))
-	   (else
-	    (error "unknown type syntax ~S" spec))))
-	((not (symbol? spec))
-	 (error "unknown type syntax ~S" spec))
-	((lookup-type spec)
-	 => identity)
-	((lookup-record-type spec)
-	 => make-pointer-type)
-	(else
-	 (error "unknown type name ~S" spec))))
-
-;--------------------------------------------------
-
-(define (display-type type port)
-
-  (define (do-list list)
-    (write-char #\( port)
-    (cond ((not (null? list))
-	   (do-type (car list))
-	   (for-each (lambda (type)
-		       (write-char #\space port)
-		       (do-type type))
-		     (cdr list))))
-    (write-char #\) port))
-
-  (define (do-type type)
-    (let ((type (maybe-follow-uvar type)))
-      (cond ((base-type? type)
-	     (display (base-type-name type) port))
-	    ((record-type? type)
-	     (display (record-type-name type) port))
-	    ((arrow-type? type)
-	     (write-char #\( port)
-	     (do-list (arrow-type-args type))
-	     (display " -> " port)
-	     (do-type (arrow-type-result type))
-	     (write-char #\) port))
-	    ((pointer-type? type)
-	     (write-char #\* port)
-	     (do-type (pointer-type-to type)))
-	    ((uvar? type)
-	     (write-char #\T port)
-	     (display (uvar-id type) port))
-	    ((type-scheme? type)
-	     (display "(for-all " port)
-	     (do-list (type-scheme-free-uvars type))
-	     (display " " port)
-	     (do-type (type-scheme-type type))
-	     (display ")" port))
-	    ((tuple-type? type)
-	     (display "(tuple " port)
-	     (do-list (tuple-type-types type))
-	     (display ")" port))
-	    (else
-	     (bug "don't know how to display type ~S" type)))))
-    
-  (do-type type))
\ No newline at end of file
diff --git a/ps-compiler/prescheme/unused/Notes b/ps-compiler/prescheme/unused/Notes
deleted file mode 100644
index c3c1a61..0000000
--- a/ps-compiler/prescheme/unused/Notes
+++ /dev/null
@@ -1,46 +0,0 @@
-
-Need to check for multiple (effectively) identical closures.
-node-equal?
-
-Flatten needs to do something about shared strings and byte-vectors.
-
-Do SET! globals need to be treated differently?  Will C allow the following?
- int f( int x ) { ... }
- main() { f = ... }
-
-Check what happens if a name->enumerand or enumerand->name survives loading.
-
-CALL-WITH-VALUES needs to simplify to two calls (so that the known-call
-stuff works) even when it doesn't know what the type is (because of
-polymorphism; we don't resimplify when types change).
- (call-with-values cont a b)
-   =>
- (unknown-call (lambda (res:tuple)
-                 (unknown-call cont 'tuple-args  b res))
-	       'tuple-result
-               a)
-Need tuple-args-goto as well.  The protocol stuff has to do the right thing.
-When the tuple type is determined RES has to change in both places.
-Actually, it can just expand into this.  The type stuff will work out.
-For now I am not going to allow polymorphic use of call-with-values.
-All of this is much like Scheme.
-
-Non-tail-recursive named-LETS appear to break things.
-
-CALL-WITH-VALUES and VALUES are only allowed in call position, and the
-second argument to CALL-WITH-VALUES must be a lambda form.
-
-STOB->NODE in form.scm needs to look for substobs.
-Or does flatten flatten non-shared structures?
-
-Pointer comparisons need to be done using unsigned longs.
-=> Pre-Scheme needs unsigned comparisons u=, u<, etc.
-
-Primitives do not appear to check the argument count!
-
-Channel library may be doable as externals, including decoding
-the events.
-
-Tail-called forms that return multiple values?
-
-MAX and other primitives need to check number-of-args when type checking.
diff --git a/ps-compiler/prescheme/unused/assert.scm b/ps-compiler/prescheme/unused/assert.scm
deleted file mode 100644
index 90bb546..0000000
--- a/ps-compiler/prescheme/unused/assert.scm
+++ /dev/null
@@ -1,152 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-; Inferencer needs to recognize predicates as such.
-; Also accessors if we want to get pattern matching working properly.
-; So we make a (predicate <record>) type.
-;
-; The inferencer needs to come up with true and false assertions for
-; each expression.  Assertion is either bottom or a list of
-; (<predicate> <exp> <#t-or-#f>) indicating predicates that are true
-; or false for that value of the expression.
-;
-; No.  For each expression we know its type, so we know exactly what
-; variants are possible.  All we need to keep track of is (<exp> <variants>).
-; The variants can be encoded as a bitset.
-
-; #t -> ()
-;       #f
-; #f -> #f
-;       ()
-; (<predicate> <exp>) -> ((<predicate> <exp> #t))
-;                        ((<predicate> <exp> #f))
-; (IF <test> <cons> <alt>) -> (or (and <test>t <cons>t)
-;                                 (and <test>f <alt>t))
-;                             (or (and <test>t <cons>f)
-;                                 (and <test>f <alt>f))
-;      (and #f S) -> #f
-;      (and S1 S2) -> (union S1 S2)
-;      (and ((e set1)) ((e set2))) -> #f if set3 = 0
-;                                     ((e set3)) otherwise
-;                                     where set3 = (bitwise-and set1 set2)
-;      (or S1 S2) -> (intersection S1 S2)
-;      (or ((e set1)) ((e set2))) -> ((e (bitwise-ior set1 set2)))
-;
-; (begin ... <last>) -> <last>t
-;                       <last>f
-; similarly for LETREC etc.
-;
-; NOT won't be inlined yet, so it will have to be known to the inferencer.
-; The usual OR macro won't work either, because the LET won't be understood.
-; That too will have to be primitive, and thus primitive in the interpreter
-; as well.  AND should work find as-is.
-;
-; NOT and OR can be ignored for the moment.
-;
-; (IF <test> <cons> <alt>) asserts <test>t values while checking <cons>
-; and <test>f while checking <alt>.
-;
-; There are so few rules that there is no need to have two separate
-; sets of inference rules.  Just have an entry point that drops the
-; assertions for those places that don't care.
-;
-; As a first cut the expressions in assertions can only be variables.
-; Also, since the assertions are type assertions, an assertion list can
-; have only one true assertion for any given expression.
-
-(define-record-type assertion
-  (value    ; variable (or, later, slot) whose value is being asserted
-   type     ; the union type we are making assertions about
-   variants ; bitset of allowable variants
-   ; slots  ; for assertions about particular slots, should we ever get that far
-   )
-  ())
-
-(define make-assertion assertion-maker)
-
-(define (copy-assertion assert new-variants)
-  (assertion-maker (assertion-value assert)
-		   (assertion-type assert)
-		   new-variants))
-
-; To make merging simpler, assertion lists are sorted by variable-id.
-
-; Union of two assertion lists.
-
-(define (assertion-and l1 l2)
-  (if (and l1 l2)
-      (real-assertion-and l1 l2)
-      #f))
-
-(define (real-assertion-and l1 l2)
-  (let loop ((l1 l1) (l2 l2) (res '()))
-    (cond ((null? l1)
-	   (append (reverse res) l2))
-	  ((null? l2)
-	   (append (reverse res) l1))
-	  (else
-	   (let ((i1 (variable-id (assertion-value (car l1))))
-		 (i2 (variable-id (assertion-value (car l2)))))
-	     (cond ((< i1 i2)
-		    (loop (cdr l1) l2 (cons (car l1) res)))
-		   ((< i2 i1)
-		    (loop l1 (cdr l2) (cons (car l2) res)))
-		   (else
-		    (let ((variants (set-and (assertion-variants (car l1))
-					     (assertion-variants (car l2)))))
-		      (if (null-set? variants)
-			  #f
-			  (loop (cdr l1)
-				(cdr l2)
-				(cons (copy-assertion (car l1) variants)
-				      res)))))))))))
-
-; Intersection of two assertion lists.
-
-(define (assertion-or l1 l2)
-  (if l1
-      (if l2
-	  (real-assertion-or l1 l2)
-	  l1)
-      #f))
-
-(define (real-assertion-or l1 l2)
-  (let loop ((l1 l1) (l2 l2) (res '()))
-    (if (or (null? l1)
-	    (null? l2))
-	(reverse res)
-	(let ((i1 (variable-id (assertion-value (car l1))))
-	      (i2 (variable-id (assertion-value (car l2)))))
-	  (cond ((< i1 i2)
-		 (loop (cdr l1) l2 res))
-		((< i2 i1)
-		 (loop l1 (cdr l2) res))
-		(else
-		 (loop (cdr l1)
-		       (cdr l2)
-		       (let ((variants (set-ior (assertion-variants (car l1))
-						(assertion-variants (car l2)))))
-			 (if (set-eq? variants
-				      (full-variant-set (assertion-type (car l1))))
-			     (cons (copy-assertion (car l1) variants)
-				   res)
-			     res)))))))))
-
-;----------------
-; Use shallow binding to install the types provided by ASSERTIONS while
-; THUNK is evaluated.
-
-(define (with-assertions assertions thunk)
-  (let ((old-types (map install-assertion! assertions)))
-    (thunk)
-    (for-each (lambda (assert type)
-		(set-variable-type! (assertion-value assert) type))
-	      assertions
-	      old-types)))
-
-(define (install-assertion! assert)
-  (let ((type (variable-type (assertion-value assert))))
-    (set-variable-type! (assertion-value assert)
-			(get-union-subtype (assertion-type assert)
-					   (assertion-variants assert)))
-    type))
diff --git a/ps-compiler/prescheme/unused/cps-to-scheme.scm b/ps-compiler/prescheme/unused/cps-to-scheme.scm
deleted file mode 100644
index f757f5f..0000000
--- a/ps-compiler/prescheme/unused/cps-to-scheme.scm
+++ /dev/null
@@ -1,340 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-; Printing the node tree as Scheme code
-
-; Sample output:
-
-;  (LAMBDA (C_11 UNIT_0)
-;    (SET-CONTENTS 1 C_11 UNIT_0 UNIT '0
-;      (LAMBDA (C_13 N_1)
-;        (LET ((LOOP_73 (CONS CELL '0)))
-;          (SET-CONTENTS LOOP_73 CELL '0
-;            (LAMBDA (C_33 I_9 R_7)
-;              (LET* ((V_61 (CONTENTS UNIT_0 UNIT '3))
-;                     (V_63 (V_61 I_9 '0)))
-;                (IF (TRUE? V_63)
-;                    (C_33 0 R_7)
-;                    (LET* ((V_46 (CONTENTS UNIT_0 UNIT '2))
-;                           (V_56 (V_46 I_9 R_7))
-;                           (V_44 (CONTENTS UNIT_0 UNIT '1))
-;                           (V_54 (V_44 I_9 '1))
-;                           (V_52 (CONTENTS LOOP_73 CELL '0)))
-;                      (V_52 1 C_33 V_54 V_56))))))
-;          (LET ((V_77 (CONTENTS LOOP_73 CELL '0)))
-;            (V_77 1 C_13 N_1 '1))))))
-
-; (CPS->SCHEME node port)
-;---------------------------------------------------------------------------
-; Print CPS node tree in linear form.  This just dispatches on the type of NODE.
-
-(define (cps->scheme node port)
-  (set! *next-pp-id* 0)
-  (let* ((port (if (current-column port)
-		   port
-		   (make-tracking-output-port port))))
-    (cond ((lambda-node? node)
-           (pp-cps-lambda node 4 port))
-          ((call-node? node)
-           (write-non-simple-call node port))
-          (else
-           (write-node-value node port)))
-    (newline port)))
-
-(define (indent port count)
-  (let ((count (cond ((<= (current-column port) count)
-		      (- count (current-column port)))
-		     (else
-		      (newline port)
-		      count))))
-    (do ((count count (- count 1)))
-	((>= 0 count))
-      (writec port #\space))))
-		      
-(define *next-pp-id* 0)
-
-(define (next-pp-id)
-  (let ((id *next-pp-id*))
-    (set! *next-pp-id* (+ *next-pp-id* 1))
-    id))
-
-; Print a lambda node by printing its identifiers, then its call, and finally
-; any other lambdas that it includes.
-
-(define (pp-cps-lambda node indent-to port)
-  (format port "~&~%")
-  (indent port indent-to)
-  (display "(lambda " port)
-  (write-lambda-vars node port)
-  (pp-cps-body (lambda-body node) indent-to port)
-  (writec port #\)))
-
-(define (write-lambda-vars node port)
-  (let ((vars (if (proc-lambda? node)
-		  (cdr (lambda-variables node))  ; ignore cont var
-		  (lambda-variables node))))
-    (cond ((not (null? vars))
-           (writec port '#\()
-           (print-variable-name (car vars) port)
-           (do ((v (cdr vars) (cdr v)))
-               ((null? v))
-             (writec port '#\space)
-             (print-variable-name (car v) port))
-           (writec port '#\)))
-          (else
-           (format port "()")))))
-
-; Print the body of a lambda node.  A simple call is one that has exactly
-; one exit.  They and calls to lambda nodes are printed as a LET*.
-
-(define (pp-cps-body call indent-to port)
-  (newline port)
-  (indent indent-to port)
-  (cond ((table-ref primop-print-table (primop-id (call-primop call)))
-	 => (lambda (proc)
-	      (proc call indent-to port)))
-	((not (= 1 (call-exits call)))
-	 (bug "no printer for primop in ~S" call))
-	(else
-	 (let* ((cont (call-arg call 0))
-		(cont-vars (lambda-variables cont)))
-	   (cond ((every? unused? cont-vars)
-		  (print-call call 1 port)
-		  (pp-cps-body (lambda-body (call-arg call 0))))
-		 ((null? (cdr cont-vars))
-		  (display "(let ((" port)
-		  (print-variable-name (car cont-vars))
-		  (display " " port)
-		  (print-call call 1 port)
-		  (display "))" port)
-		  (pp-cps-body call (+ indent-to 2) port))
-		 (else
-		  (display "(receive " port)
-		  (write-lambda-vars cont port)
-		  (newline port)
-		  (indent (+ indent-to 4) port)
-		  (print-call call 1 port)
-		  (pp-cps-body call (+ indent-to 2) port)))))))
-		  
-(define (print-call call start-arg port)
-  (display "(" port)
-  (display (primop-id (call-primop call)) port)
-  (print-args call start-arg port)
-  (display ")" port))
-	 
-(define (print-args call start-arg port)
-  (do ((i start-arg (+ i 1)))
-      ((= i (call-arg-count call)))
-    (display " " port)
-    (print-arg (call-arg call i) port)))
-
-(define (print-arg arg port)
-  (cond ((lambda-node? node)
-	 
-	((call-node? node)
-	 (format port "(~S" (primop-id (call-primop node)))
-	 (print-args node 0 port))
-        ((literal-node? node)
-         (cps-print-literal (literal-value node) port))
-        ((reference-node? node)
-         (print-variable-name (reference-variable node) port))
-        (else
-         (bug "WRITE-NODE-VALUE got funny node ~S" node))))
-
-
-
-  (cond ((or (simple-call? call)
-             (let-call? call))
-         (write-let* call indent-to port))
-        (else
-         (indent port (+ '2 indent-to))
-         (write-non-simple-call call port))))
-
-; Write out a series of calls as a LET*.  The LET* ends when a call is reached
-; that is neither a simple call or a call to a lambda.
-
-(define (write-let* call indent-to port)
-  (indent port (+ '2 indent-to))
-  (writec port '#\()
-  (format port "LET* ")
-  (writec port '#\()
-  (let loop ((call (next-call call))
-	     (ns (write-simple-call call indent-to port)))
-    (cond ((or (simple-call? call)
-               (let-call? call))
-           (newline port)
-           (indent port (+ '9 indent-to))
-           (loop (next-call call)
-                 (append (write-simple-call call indent-to port) ns)))
-          (else
-           (writec port '#\))
-           (newline port)
-           (indent port (+ '4 indent-to))
-           (let ((ns (append (write-non-simple-call call port) ns)))
-             (writec port '#\))
-             ns)))))
-
-(define (simple-call? call)
-  (and (= '1 (call-exits call))
-       (not (lambda-block (call-arg call 0)))))
-
-(define (let-call? call)
-  (calls-this-primop? call 'let))
-
-; Get the call that follows CALL in a LET*.
-
-(define (next-call call)
-  (lambda-body (call-arg call '0)))
-
-; Write out one line of a LET*.
-
-(define (write-simple-call call indent-to port)
-  (if (let-call? call)
-      (write-let-call call indent-to port)
-      (really-write-simple-call call indent-to port)))
-
-; Write the variables bound by the continuation and then the primop and
-; non-continuation arguments of the call.
-
-(define (really-write-simple-call call indent-to port)
-  (writec port '#\()
-  (write-lambda-vars (call-arg call '0) port)
-  (indent port (+ indent-to '21))
-  (writec port '#\()
-  (format port "~S" (primop-id (call-primop call)))
-  (write-call-args call '1 port)
-  (writec port '#\))
-  (find-lambda-nodes call 1))
-
-; Write the variables of the lambda and then the values of the arguments.
-
-(define (write-let-call call indent-to port)
-  (writec port '#\()
-  (write-lambda-vars (call-arg call '0) port)
-  (cond ((= '1 (vector-length (call-args call)))
-         (writec port '#\))
-         '())
-        (else
-	 (writec port #\*)
-         (indent port (+ indent-to '21))
-         (write-node-value (call-arg call '1) port)
-         (write-call-args call '2 port)
-	 (find-lambda-nodes call 1))))
-
-(define (find-lambda-nodes call start)
-  (reverse (let label ((call call) (start start) (ls '()))
-	     (do ((i start (+ i 1))
-		  (ls ls (let ((arg (call-arg call i)))
-			   (cond ((call-node? arg)
-				  (label arg 0 ls))
-				 ((lambda-node? arg)
-				  (cons arg ls))
-				 (else ls)))))
-		 ((>= i (call-arg-count call))
-		  ls)))))
-
-; Write out a call that ends a LET* block.
-
-(define (write-non-simple-call call port)
-  (writec port '#\()
-  (format port "~A ~D" (primop-id (call-primop call)) (call-exits call))
-  (write-call-args call '0 port)
-  (find-lambda-nodes call 0))
-
-; Write out the arguments of CALL starting with START.
-
-(define (write-call-args call start port)
-  (let* ((vec (call-args call))
-         (len (vector-length vec)))
-    (do ((i start (+ i '1)))
-        ((>= i len))
-      (writec port '#\space)
-      (write-node-value (vector-ref vec i) port))
-    (writec port '#\))))
-
-; Print out a literal value.
-
-(define (cps-print-literal value port)
-  (format port "'~S" value))
-
-; Dispatch on the type of NODE to get the appropriate printing method.
-
-(define (write-node-value node port)
-  (cond ((not (node? node))
-         (format port "{not a node}"))
-        ((lambda-node? node)
-         (writec port '#\^)
-         (print-lambda-name node port))
-	((call-node? node)
-	 (format port "(~S" (primop-id (call-primop node)))
-	 (write-call-args node '0 port))
-        ((literal-node? node)
-         (cps-print-literal (literal-value node) port))
-        ((reference-node? node)
-         (print-variable-name (reference-variable node) port))
-        (else
-         (bug "WRITE-NODE-VALUE got funny node ~S" node))))
-
-; Printing variables and lambda nodes
-
-; #T if variables are supposed to print as the name of the register containing
-; them instead of their name.
-
-(define *pp-register-names?* '#f)
-
-; A whole bunch of different entry points for printing variables in slightly
-; different ways.
-
-(define (print-variable-name var port)
-  (cond ((not var)
-         (format port "#f"))
-;        ((and *pp-register-names?*
-;              (reg? (variable-register var)))
-;         (format port "~S" (reg-name (variable-register var))))
-        (else
-	 (let ((id (cond ((variable-flag var)
-			  => identity)
-			 (else
-			  (let ((id (next-pp-id)))
-			    (set-variable-flag! var id)
-			    id)))))
-	   (format port "~S_~S" (variable-name var) id)))))
-
-; Same as the above without the check for a register.
-
-(define (print-variable-plain-name var port)
-  (cond ((not var)
-         (format port "#f"))
-        (else
-         (format port "~S_~D" (variable-name var) (variable-id var)))))
-
-; Return the name as a string.
-
-(define (variable-print-name var)
-  (print-variable-name var '#f))
-
-; Return the name as a symbol.
-
-(define (variable-unique-name var)
-  (string->symbol (variable-print-name var)))
-
-; Printing lambda-nodes as variables
-
-(define (print-lambda-name lnode port)
-  (let ((id (cond ((node-flag lnode)
-		   => identity)
-		  (else
-		   (let ((id (next-pp-id)))
-		     (set-node-flag! lnode id)
-		     id)))))
-    (format port "~S_~D" (lambda-name lnode) id)))
-
-(define (lambda-print-name lnode)
-  (print-lambda-name lnode '#f))
-
-(define (lambda-unique-name lnode)
-  (string->symbol (lambda-print-name lnode)))
-
-
-
-
-
diff --git a/ps-compiler/prescheme/unused/data.scm b/ps-compiler/prescheme/unused/data.scm
deleted file mode 100644
index dc36f01..0000000
--- a/ps-compiler/prescheme/unused/data.scm
+++ /dev/null
@@ -1,193 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-; Records & (tagged) Unions
-;
-; Can we arrange to pass records as a separate type from the including union?
-; Probably not.  This introduces type relations that have to be satisified.
-; No coercions are needed so it would be much simpler than before.  Unification
-; would have to find meets.  I guess that it would be doable, but not for now.
-;
-; The only records that have tags are those that are part of a multi-record
-; union.  If a record is not part of a union it does not need a tag field.
-;
-; The simplest thing is probably to only have tagged unions, with stand-alone
-; records being a degenerate case (to be added later).
-
-; Data types
-
-; Representation of union types.
-
-(define-record-type union-type
-  (name       ; name of the data type
-   variants   ; what this can be
-   )
-  ())
-
-(define-record-discloser type/union-type
-  (lambda (union)
-    (list 'union-type (union-type-name dtype))))
-
-; Record variants of unions
-
-(define-record-type record-type
-  (index                ; index of this record in parent union
-   predicate            ; name of the predicate   ; only at top-level
-   constructor          ; name of the constructor
-   )
-  (fields               ; filled in later because of circularity
-   constructor-args))   ; fields passed to the constructor 
-
-(define-record-discloser type/record-type
-  (lambda (rtype)
-    (list 'record-type (record-type-constructor rtype))))
-
-; Fields of record types.
-
-(define-record-type record-field
-  (record-type
-   name
-   type
-   )
-  ())
-
-; Global table of record types.  Since we compile to a single C file the
-; record types used within a single computation must have distinct names.
-; (This should really be a fluid.)
-; Or we could make up names as necessary.
-
-(define *record-type-table* (make-symbol-table))
-
-(define (reset-record-data!)
-  (set! *record-type-table* (make-symbol-table)))
-
-(define (get-record-type id)
-  (cond ((table-ref *record-type-table* id)
-	 => identity)
-	(else
-	 (error "no record type ~S" id))))
-
-(define (all-record-types)
-  (table->entry-list *record-type-table*))
-
-(define (lookup-union-type id)
-  (table-ref *record-type-table* id))
-
-; Construction a record type.  This gets the name, the list of fields whose
-; initial values are passed to the constructor, and the field specifications.
-; Each field specification consists of a name and a type.
-
-(define (make-record-type id constructor-args specs)
-  (let ((rt (record-type-maker id)))
-    (if (table-ref *record-type-table* id)
-	(user-error "multiple definitions of record type ~S" id))
-    (table-set! *record-type-table* id rt)
-    (set-record-type-fields! rt (map (lambda (spec)
-				       (record-field-maker
-					  rt
-					  (car spec)
-					  (expand-type-spec (cadr spec))))
-				     specs))
-    (set-record-type-constructor-args! rt
-				       (map (lambda (name)
-					      (get-record-type-field id name))
-					    constructor-args))
-    rt))
-
-; Return the field record for FIELD-ID in record-type TYPE-ID.
-
-(define (get-record-type-field type-id field-id)
-  (let ((rtype (get-record-type type-id)))
-    (cond ((any (lambda (field)
-		  (eq? field-id (record-field-name field)))
-		(record-type-fields rtype))
-	   => identity)
-	  (else
-	   (user-error "~S is not a field of ~S" field-id rtype)))))
-
-; The macro expander for DEFINE-RECORD-TYPE.
-;
-; (define-record-type <id> <type-id>
-;   (<constructor> . <field-names>)
-;   (<field-name> <type> <accessor-name> [<modifier-name>]) ...)
-; 
-; The <type-id> is used only by Pre-Scheme-in-Scheme.
-
-(define (expand-define-record-type exp r c)
-  (let ((id (cadr exp))
-	(maker (cadddr exp))
-	(fields (cddddr exp)))
-    (let ((rt (make-record-type id (cdr maker) fields)))
-      `(,(r 'begin)
-	(,(r 'define) ,maker
-	   (,(r 'let) ((,(r id) (,(r 'make-record) ',id)))
-	     (,(r 'if) (,(r 'not) (,(r 'null-pointer?) ,(r id)))
-	       (,(r 'begin)
-		 . ,(map (lambda (name)
-			   `(,(r 'record-set!) ,(r id) ,name ',id ',name))
-			 (cdr maker))))
-	     ,(r id)))
-	,@(map (lambda (field)
-		 `(,(r 'define) (,(caddr field) ,(r id))
-				(,(r 'record-ref) ,(r id) ',id ',(car field))))
-	       fields)
-	,@(map (lambda (field)
-		 `(,(r 'define) (,(cadddr field) ,(r id) ,(r 'x))
-			(,(r 'record-set!)
-			 ,(r id) ,(r 'x)',id ',(car field))))
-	       (filter (lambda (spec)
-			 (not (null? (cdddr spec))))
-		       fields))))))
-
-
-; In C.
-;
-; All unions are cast to a single type.  All records that are part of unions
-; have an initial tag field.
-;
-;struct datatypeX { int tagX; };
-;
-;#define NULL_TAGX 0
-;#define PAIR_TAGX 1
-;
-;struct pair {
-;  int tagX;
-;  long car;
-;  struct datatypeX *cdr;
-;};
-;
-;struct datatypeX nullX = { NULL_TAGX }, *null = &nullX;
-;
-;struct datatypeX *cons(unsigned char, struct datatypeX*);
-;struct datatypeX *reverseB(struct datatypeX*);
-;char memberP(struct datatypeX*, long);
-;void init(void);
-;
-;struct datatypeX *cons(unsigned char car_0X, struct datatypeX *cdr_1X)
-;{
-;  struct pair *pair_2X;
-; {pair_2X = (struct pair *)malloc(sizeof(struct pair));
-;  if ((NULL == pair_2X)) {
-;    return (struct datatypeX *)pair_2X;}
-;  else {
-;    pair_2X->tagX = PAIR_TAGX;
-;    pair_2X->car = (((unsigned long) car_0X));
-;    pair_2X->cdr = cdr_1X;
-;    return (struct datatypeX *)pair_2X;}}}
-;
-;char memberP(struct datatypeX *list_7X, long x_8X)
-;{
-;  struct datatypeX *arg0K0;
-;  struct datatypeX *list_9X;
-; {arg0K0 = list_7X;
-;  goto L169;}
-; L169: {
-;  list_9X = arg0K0;
-;  if ((list_9X->tagX == NULL_TAGX)) {
-;    return 0;}
-;  else {
-;    if ((x_8X == ((struct pair *)list_9X)->car)) {
-;      return 1;}
-;    else {
-;      arg0K0 = ((struct pair *)list_9X)->cdr;
-;      goto L169;}}}}
diff --git a/ps-compiler/prescheme/unused/data.txt b/ps-compiler/prescheme/unused/data.txt
deleted file mode 100644
index 413c078..0000000
--- a/ps-compiler/prescheme/unused/data.txt
+++ /dev/null
@@ -1,73 +0,0 @@
-
-(define-data-type list
-  (null? null)
-  (pair?
-   (cons car cdr)
-   (car type car set-car!)
-   (cdr pair cdr set-cdr!)))
-
-=>
-
-(define null 0)
-cons etc. as before
-
-Type as before, except that LIST is defined to be a datatype
-that includes NULL and PAIRs.  NULL and PAIRs are defined to
-be subtypes of LISTs.  How do pairs and null get injected into
-lists?
-
-What about polymorphism?  Ignore it for now.
-
-Note that setters have a problem with destructuring - they don't work.
-
-(if (bar? baz)
-    ...
-    ...)
-
-Need temporary type bindings, a la LET.  Env and type env?
-Have to do shallow binding, the infer code doesn't use environments.
-
-Hacks like
-
-   (if (bar? baz)
-       (error ...))
-   ... baz is not a bar ...
-
-won't work.
-
-----------------
-
-New plan.  Use functions for pattern matching, with a suitable macro.
-
-(define-data-type list delistify match-list
-  (null? null)
-  (pair?
-   (cons car cdr)
-   (car type car set-car!)
-   (cdr pair cdr set-cdr!)))
-
-Defines null as 0 and pairs as before.
-NULL? and PAIR? are only available at load time.  There is also a
-deconstructor DELISTIFY: [b list, [] -> a , [b, b list] -> a] -> a
-
-(define (map f l)
-  (delistify l
-    (lambda ()
-      null)
-    (lambda (car cdr)
-      (cons (f car) (map f cdr)))))
-
-Or, with syntax,
-
-(define (map f l)
-  (match-list l
-    ((null)
-     null)
-    ((cons car cdr)
-     (cons (f car) (map f cdr)))))
-
-This requires no change at all for the type checker.  Hee Wack!
-
-
-
-
diff --git a/ps-compiler/prescheme/unused/dispatch.scm b/ps-compiler/prescheme/unused/dispatch.scm
deleted file mode 100644
index 49a1da4..0000000
--- a/ps-compiler/prescheme/unused/dispatch.scm
+++ /dev/null
@@ -1,169 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-(define (dispatches->computed-gotos forms)
-  (walk (lambda (f)
-	  (if (and (form-var f)
-		   (eq? 'initialize (form-type f)))
-	      (let ((value (thunk-value (form-node f))))
-		(if (and value
-			 (call-node? value)
-			 (eq? 'make-dispatch-table
-			      (primop-id (call-primop value))))
-		    (dispatch->computed-goto f value)))))
-	forms)
-  forms)
-
-; FORM defines a dispatch vector, created in MAKE-CALL.  This replaces the
-; dispatch vector with a procedure that performs a computed goto.
-; The references to VAR, the variable to which the dispatch
-; vector is bound, are analysed to find all of the uses of the vector and all
-; of the dispatch procedures added to it.  These procedures are put in the
-; appropriate slot of VEC, a model of the dispatch vector.
-;   Once all of the references are known, the dispatch vector is replaced with
-; a procedure and all of the dispatches are replaced with calls.  The dispatch
-; procedures from VEC become the continuations of the computed-goto call.
-
-(define (dispatch->computed-goto form make-call)
-  (initialize-lambdas)
-  (let* ((var (form-var form))
-	 (size-node (call-arg make-call 0))
-	 (size (if (and (literal-node? size-node)
-			(integer? (literal-value size-node))
-			(>= (literal-value size-node) 0))
-		   (literal-value size-node)
-		   (error "dispatch vector ~A's size is not a positive integer"
-			  (variable-name (form-var form)))))
-	 (vec (make-vector size #f)))
-    (analyze-dispatch-vector var vec)
-    (add-lambdas (form-lambdas form))
-    (let ((goto-proc (make-computed-goto var vec size make-call)))
-      (for-each (lambda (ref)
-		  (let ((call (node-parent ref)))
-		    (set-call-primop! call (get-primop (enum primop unknown-call)))
-		    (insert-call-arg call 2 (make-literal-node 1 #f))))
-		(variable-refs var))
-      (set-form-node! form goto-proc (make-lambda-list))
-      (set-form-type! form 'lambda)
-      (values)))))
-
-; Possible problems with a call to DEFINE-DISPATCH are:
-; The index is not an integer constant in the right range.
-; The procedure value cannot be moved.
-
-(define (analyze-dispatch-vector var vec)
-  (walk-refs-safely
-   (lambda (ref)
-     (let ((call (node-parent ref)))
-       (if (and (eq? 'define-dispatch! (primop-id (call-primop call)))
-		(= 1 (node-index ref)))
-	   (let ((index (if (literal-node? (call-arg call 2))
-			    (literal-value (call-arg call 2))
-			    #f))
-		 (proc (get-procedure-value (call-arg call 3)))
-		 (form (node-flag (node-base ref))))
-	     (if (or (not (integer? index))
-		     (< index 0)
-		     (>= index (vector-length vec))
-		     (not proc))
-		 (error "problem with DEFINE-DISPATCH! in ~S"
-			(form-source form)))
-	     (receive (ours theirs)
-		 (partition-list (lambda (n)
-				   (eq? proc (node-base n)))
-				 (form-lambdas form))
-	       (replace-body call (detach-body (lambda-body (call-arg call 0))))
-	       (set-form-lambdas! form theirs)
-	       (add-lambdas ours)
-	       (vector-set! vec index proc))))))
-   var))
-
-(define (get-procedure-value node)
-  (cond ((lambda-node? node)
-	 (if (no-free-references? node)
-	     (detach node)
-	     #f))
-	((global-reference? node)
-	 (detach node))
-	(else #f)))
-
-; make computed goto call, put the exits in the call
-
-(define (make-computed-goto var vec size make-call)
-  (receive (goto-proc goto-call default-var cont-var)
-           (make-dispatch-procedure make-call size)
-    (do ((i 0 (+ i 1)))
-	((>= i size))
-      (let ((cont (if (vector-ref vec i)
-		      (make-goto-continuation (vector-ref vec i) cont-var)
-		      (make-goto-default default-var))))
-	(attach goto-call i cont)))
-    (simplify-lambda-body goto-proc)
-    goto-proc))
-
-; ($MAKE-DISPATCH-TABLE <cont> <size> <default>)
-;   =>
-; (LAMBDA (C I)
-;   ((LAMBDA (D)
-;      ($COMPUTED-GOTO <empty> ... <empty> I))
-;    (LAMBDA ()
-;      (LET ((X ($PROC-CALL <default>)))
-;        ($UNKNOWN-RETURN C X)))))
-;
-; The new procedure, the goto call, D, the default procedure, and C are all
-; returned.
-
-(define (make-dispatch-procedure call size)
-  (let ((default (detach (call-arg call 1)))
-	(goto-call (make-call-node (get-prescheme-primop 'computed-goto)
-				   (+ size 1)
-				   size)))
-    (if (not default)
-	(error '"cannot move dispatch default ~S" (call-arg call 1)))
-    (let-nodes ((l1 ((c type/unknown) (i type/unknown)) (let 1 l2 def))
-		(l2 ((d type/unknown)) goto-call)
-		(def () (unknown-call 1 l3 default '(0 #f)))
-		(l3 ((x type/unknown)) (unknown-return 0 (* c) '1 (* x))))
-      (attach goto-call size (make-reference-node i))
-      (change-lambda-type l1 'proc)  ; LET-NODES only makes CONT lambdas
-      (set-lambda-protocol! l1 1) ; indicate number of non-cont arguments
-      (erase (node-base call))
-      (values l1 goto-call d c))))
-
-; Return a continuation that calls DEFAULT-PROC (to which DEFAULT-VAR is bound).
-
-(define (make-goto-default default-var)
-  (let-nodes ((l1 () (jump 0 (* default-var))))
-    l1))
-
-; Make a continuation that calls PROC and then returns to CONT-VAR.
-;
-;  (LAMBDA ()
-;    (CALL (LAMBDA (V) (UNKNOWN-RETURN <cont-var> V))
-;          <proc>))
-
-(define (make-goto-continuation proc-node cont-var)
-  (let-nodes ((l1 () c1)
-	      (c1 (unknown-call 1 l2 proc-node '(0 #f)))
-	      (l2 ((v type/unknown))
-		  (unknown-return 0 (* cont-var) '1 (* v))))
-    l1))
-
-;------------------------------------------------------------------------------
-; Defining the primops used in all this.
-
-; (MAKE-DISPATCH-TABLE <size> <default>)
-
-(define-scheme-primop make-dispatch-table allocate)
-
-; ($DEFINE-DISPATCH! <table> <index> <procedure>)
-
-(define-nonsimple-scheme-primop define-dispatch! write)
-
-; ($DISPATCH <cont> <table>)
-
-(define-nonsimple-scheme-primop dispatch)
-
-; (COMPUTED-GOTO <exit0> <exit1> ... <exitN> <dispatch-value>)
-
-(define-nonsimple-scheme-primop computed-goto)
diff --git a/ps-compiler/prescheme/unused/infer-data.scm b/ps-compiler/prescheme/unused/infer-data.scm
deleted file mode 100644
index f6649e5..0000000
--- a/ps-compiler/prescheme/unused/infer-data.scm
+++ /dev/null
@@ -1,381 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-; Type checking nodes.
-
-; Hacked to propogate data-type information.
-
-; Entry point
-
-; Because NODE is not the car of a pair, this depends on lambdas not being
-; coerceable and literal nodes being coerced in place (instead of having a
-; call inserted).
-
-(define (infer-definition-type node name)
-  (set! *currently-checking* name)
-  (let ((res (cond ((literal-node? node)
-		    (infer-literal-type node name))
-		   ((lambda-node? node)
-		    (infer-type node 0))
-		   ((name-node? node)
-		    (get-global-type (binding-place (node-ref node 'binding))))
-		   (else
-		    (bug "definition value is not a value node ~S" node)))))
-    (set! *currently-checking* #f)
-    res))
-
-(define (infer-literal-type node name)
-  (let ((value (node-form node)))
-    (cond ((vector? value)
-	   (let ((uvar (make-uvar name -1)))
-	     (do ((i 0 (+ i 1)))
-		 ((>= i (vector-length value)))
-	       (unify! uvar (type-check-thing (vector-ref value i)) value))
-	     (make-pointer-type (maybe-follow-uvar uvar))))
-	  (else
-	   (infer-type node 0)))))
-
-(define (type-check-thing thing)
-  (if (variable? thing)
-      (get-package-variable-type thing)
-      (literal-value-type thing)))
-
-(define literal-operator (get-operator 'literal))
-
-(define (make-literal-node value)
-  (make-node literal-operator value))
-
-; Get the type of the variable - if it is a type-variable, then create a new
-; one and relate the two; if it is a polymorphic pattern, instantiate it.
-
-(define (get-package-variable-type var)
-  (let ((rep (variable-type var)))
-    (cond ((eq? rep type/undetermined)
-	   (let ((type (make-uvar (variable-name var) -1)))
-	     (set-variable-type! var type)
-	     (set-uvar-source! type var)
-	     type))
-	  ((type-scheme? rep)
-	   (instantiate-type-scheme rep -1))
-	  (else
-	   rep))))
-
-; Exported
-
-(define (get-variable-type var)
-  (let ((rep (variable-type var)))
-    (cond ((eq? rep type/undetermined)
-	   (bug "lexically bound variable ~S has no type" var))
-	  ((type-scheme? rep)
-	   (instantiate-type-scheme rep -1))
-	  (else
-	   rep))))
-
-;----------------------------------------------------------------
-
-(define (infer-type node depth)
-  (receive (type true false)
-      (infer-tail-type node depth #f)
-    type))
-
-; This returns both a type for the expression and two lists of type assertions
-; for variables.  Those in the first list apply if the expression evaluates to
-; true and those that apply if the predicate evaluates to false.  An assertion
-; has two parts: an expression E (which currently must be a variable) whose
-; type is a union, and the set of variants of that union which the variable
-; might have.  If NODE cannot have a particular boolean value the corresponding
-; list of assertions is #F.
-
-; RETURN? is true if NODE is syntactically tail-recursive in some procedure
-; or a non-final expression in a body, in which case NODE is allowed to have
-; a tuple type.
-
-(define (infer-tail-type node depth return?)
-  (receive (type true false)
-      ((operator-table-ref inference-rules (node-operator-id node))
-         node
-	 depth
-	 return?)
-    (set-node-type! node type)
-    (values (maybe-follow-uvar type) true false)))
-
-; Return a true value: no true assertions and value is never false.
-
-(define (true-value value)
-  (values value '() #f))
-
-(define (unknown-value value)
-  (values value '() '()))
-
-(define inference-rules
-  (make-operator-table
-   (lambda (node depth return?)
-     (error "no type inference for node ~S" node))))
-
-(define (define-inference-rule name proc)
-  (operator-define! inference-rules name #f proc))
-
-(define-inference-rule 'literal
-  (lambda (node depth return?)
-    (infer-literal (node-form node) node)))
-
-(define-inference-rule 'quote
-  (lambda (node depth return?)
-    (infer-literal (cadr (node-form node)) node)))
-
-(define (infer-literal value node)
-  (literal-value-type value))
-
-(define (literal-value-type value)
-  (if value
-      (true-value (or (maybe-literal-value-type value)
-		      (error "don't know type of literal ~S" value)))
-      (values type/boolean #f '())))  ; always false, but no actual assertions
-
-(define (maybe-literal-value-type value)
-  (cond ((boolean? value)
-	 type/boolean)
-	((char? value)
-	 type/char)
-	((integer? value)
-	 type/integer)
-	((string? value)
-	 type/string)
-	(((structure-ref eval-node unspecific?) value)
-	 type/null)
-	((input-port? value)
-	 type/input-port)
-	((output-port? value)
-	 type/output-port)
-	((external-value? value)
-	 (external-value-type value))
-	((external-constant? value)
-         type/integer)
-	(else
-	 #f)))
-
-(define-inference-rule 'unspecific
-  (lambda (node depth return?)
-    (unknown-value type/null)))
-
-(define-inference-rule 'lambda
-  (lambda (node depth return?)
-    (let* ((uid (unique-id))
-	   (exp (node-form node))
-	   (var-types (map (lambda (name-node)
-			     (initialize-name-node-type name-node uid depth))
-			   (cadr exp)))
-	   (result (infer-tail-type (caddr exp) depth #t)))
-      ; stash the return type
-      (set-lambda-node-return-type! node result)
-      (true-value (make-arrow-type var-types result)))))
-	
-; Create a new type variable for VAR.
-
-(define (initialize-name-node-type node uid depth)
-  (let ((uvar (make-uvar (node-form node) depth uid)))
-    (set-node-type! node uvar)
-    (set-uvar-source! uvar node)
-    uvar))
-
-; Get the type of the variable - if it is a type-variable, then create a new
-; one and relate the two; if it is a polymorphic pattern, instantiate it.
-; How to pass the source?
-
-(define-inference-rule 'name
-  (lambda (node depth return?)
-    (let ((type (if (node-ref node 'binding)
-		    (get-global-type (binding-place (node-ref node 'binding)))
-		    (node-type node))))
-      (if (not type)
-	  (bug "name node ~S has no type" node))
-      (if (type-scheme? type)
-	  (instantiate-type-scheme type depth)
-	  (unknown-value type)))))
-
-(define-inference-rule 'primitive
-  (lambda (node depth return?)
-    (let ((type (get-global-type (cdr (node-form node)))))
-      (true-value (if (type-scheme? type)
-		      (instantiate-type-scheme type depth)
-		      type)))))
-
-; If no type is present, create a type variable.
-
-(define (get-global-type value)
-  (if (location? value)
-      (literal-value-type (contents value))
-      (let ((has (maybe-follow-uvar (variable-type value))))
-	(cond ((not (eq? has type/undetermined))
-	       has)
-	      (else
-	       (let ((type (make-uvar (variable-name value) -1)))
-		 (set-variable-type! value type)
-		 (set-uvar-source! type value)
-		 type))))))
-
-(define-inference-rule 'set!
-  (lambda (node depth return?)
-    (let* ((exp (node-form node))
-	   (type (infer-type (caddr exp) depth))
-	   (binding (node-ref (cadr exp) 'binding)))
-      (if (not binding)
-	  (error "SET! on a local variable ~S" (schemify node)))
-      (unify! type (variable-type (binding-place binding)) node)
-      (unknown-value type/null))))
-
-(define-inference-rule 'call
-  (lambda (node depth return?)
-    (rule-for-calls (node-form node) node depth return?)))
-
-(define-inference-rule 'goto
-  (lambda (node depth return?)
-    (rule-for-calls (cdr (node-form node)) node depth return?)))
-
-(define (rule-for-calls proc+args node depth return?)
-  (let ((proc (car proc+args))
-	(args (cdr proc+args)))
-    (cond ((lambda-node? proc)
-	   (rule-for-let node depth proc args return?))
-	  ((primitive-node? proc)
-	   (rule-for-primitives node depth (node-form proc) args return?))
-	  (else
-	   (rule-for-unknown-calls node depth proc+args return?)))))
-
-(define name-node? (node-predicate 'name))
-(define lambda-node? (node-predicate 'lambda))
-(define literal-node? (node-predicate 'literal))
-(define primitive-node? (node-predicate 'primitive))
-
-(define (rule-for-let node depth proc args return?)
-  (let ((depth (+ depth 1))
-	(uid (unique-id))
-	(proc (node-form proc)))
-    (do ((names (cadr proc) (cdr names))
-	 (vals args (cdr vals)))
-	((null? names))
-      (let ((type (schemify-type (infer-type (car vals) depth) depth)))
-	(if (type-scheme? type)
-	    (set-node-type! (car names) type)
-	    (unify! (initialize-name-node-type (car names) uid depth)
-		    type
-		    node))))
-    (infer-tail-type (caddr proc) depth return?)))
-
-(define (rule-for-primitives node depth primitive args return?)
-  ((primitive-inference-rule primitive)
-     args node depth return?))
-
-(define (rule-for-unknown-calls node depth proc+args return?)
-  (let ((proc-type (infer-type (car proc+args) depth))
-	(arg-types (infer-types (cdr proc+args) depth))
-	(return-type (if return?
-			 (make-tuple-uvar 'result depth)
-			 (make-uvar 'result depth))))
-    (unify! proc-type
-	    (make-arrow-type arg-types return-type)
-	    node)
-    (unknown-value (maybe-follow-uvar return-type))))
-  
-(define (infer-types nodes depth)
-  (map (lambda (node)
-	 (infer-type node depth))
-       nodes))
-
-(define-inference-rule 'begin
-  (lambda (node depth return?)
-    (let ((exps (cdr (node-form node))))
-      (if (null? exps)
-	  (unknown-value type/unit)
-	  (let loop ((exps exps))
-	    (if (null? (cdr exps))
-		(infer-tail-type (car exps) depth return?)
-		(begin
-		  (infer-tail-type (car exps) depth #t)
-		  (loop (cdr exps)))))))))
-
-; It would be nice if we could just try to unify the two arms and return
-; type/unit if we lost, but unification has side-effects.
-
-(define-inference-rule 'if
-  (lambda (node depth return?)
-    (let ((args (cdr (node-form node))))
-      (receive (test-type test-true-asserts test-false-asserts)
-	  (infer-tail-type (car args) depth #f)
-	(unify! test-type type/boolean node)
-	(receive (cons-type cons-true-asserts cons-false-asserts)
-	    (with-assertions test-true-asserts
-	      (lambda ()
-		(infer-tail-type (cadr args) depth return?)))
-	  (receive (alt-type alt-true-asserts alt-false-asserts)
-	    (with-assertions test-false-asserts
-	      (lambda ()
-		(infer-tail-type (caddr args) depth return?)))
-	    (values (cond ((eq? cons-type type/null)
-			   alt-type)
-			  ((eq? alt-type type/null)
-			   cons-type)
-			  (else
-			   (unify! cons-type alt-type node)
-			   cons-type))
-		    (assertion-or (assertion-and test-true-asserts
-						 cons-true-asserts)
-				  (assertion-and test-false-asserts
-						 alt-true-asserts))
-		    (assertion-or (assertion-and test-true-asserts
-						 cons-false-asserts)
-				  (assertion-and test-false-asserts
-						 alt-false-asserts)))))))))
-
-(define-inference-rule 'letrec
-  (lambda (node depth return?)
-    (let ((form (node-form node))
-	  (depth (+ depth 1))
-	  (uid (unique-id)))
-      (let ((names (map car (cadr form)))
-	    (vals (map cadr (cadr form))))
-	(for-each (lambda (name)
-		    (initialize-name-node-type name uid depth))
-		  names)
-	(do ((names names (cdr names))
-	     (vals vals (cdr vals)))
-	    ((null? names))
-	  (unify! (infer-type (car vals) depth)
-		  (node-type (car names))
-		  node))
-	(for-each (lambda (name)
-		    (let ((type (schemify-type (node-type name) depth)))
-		      (if (type-scheme? type)
-			  (set-node-type! name type))))
-		  names)
-	(infer-tail-type (caddr form) depth return?)))))
-
-;--------------------------------------------------
-
-(define (node-type node)
-  (maybe-follow-uvar (node-ref node 'type)))
-
-(define (set-node-type! node type)
-  (node-set! node 'type type))
-
-(define (lambda-node-return-type node)
-  (node-ref node 'return-type))
-
-(define (set-lambda-node-return-type! node type)
-  (node-set! node 'return-type type))
-
-;--------------------------------------------------
-; Utility procedures used by the inferencers of the various primops.
-
-; Check that the INDEX'th argument of CALL has type TYPE.
-
-(define (check-arg-type args index type depth exp)
-  (if (null? args)
-      (begin
-	(format #t "Wrong number of arguments in ~S~% " (schemify exp))
-	(if *currently-checking*
-	    (format #t "~% while reconstructing the type of '~S'" *currently-checking*))
-	(error "type problem")))
-  (unify! (infer-type (list-ref args index) depth)
-	  type
-	  exp))
-
diff --git a/ps-compiler/prescheme/unused/ps-syntax.scm b/ps-compiler/prescheme/unused/ps-syntax.scm
deleted file mode 100644
index a7e08ce..0000000
--- a/ps-compiler/prescheme/unused/ps-syntax.scm
+++ /dev/null
@@ -1,116 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-; Redefine CASE so that it doesn't call MEMV
-
-(define-syntax case
-  (lambda (e r c)
-    (let ((x (r 'x))
-	  (xlet (r 'let))
-	  (xcond (r 'cond))
-	  (xif (r 'if))
-	  (xeq? (r 'eq?))
-	  (xquote (r 'quote)))
-      (let ((test (lambda (y)
-		    `(,xeq? ,x (,xquote ,y)))))
-	`(,xlet ((,x ,(cadr e)))
-		(,xcond . ,(map (lambda (clause)
-				  (if (c (car clause) 'else)
-				      clause
-				      `(,(let label ((xs (car clause)))
-					   (cond ((null? xs) #f)
-						 ((null? (cdr xs))
-						  (test (car xs)))
-						 (else
-						  `(,xif ,(test (car xs))
-							 #t
-							 ,(label (cdr xs))))))
-					. ,(cdr clause))))
-				(cddr e))))))))
-
-; RECEIVE (from big-scheme)
-
-(define-syntax receive
-  (syntax-rules ()
-    ((receive ?vars ?producer . ?body)
-     (call-with-values (lambda () ?producer)
-		       (lambda ?vars . ?body)))))
-
-
-(define-syntax external
-  (lambda (e r c)
-    (let ((l (length e)))
-      (if (and (or (= l 3) (= l 4))
-	       (string? (cadr e)))
-	  `(,(r 'real-external) ,(cadr e) ',(caddr e))
-	  e))))
-
-; DEFINE-EXTERNAL-ENUMERATION (from prescheme)
-
-(define-syntax define-external-enumeration
-  (lambda (form rename compare)
-    (let* ((name (cadr form))
-	   (symbol->upcase-string
-	    (lambda (s)
-	      (list->string (map (lambda (c)
-				   (if (char=? c #\-)
-				       #\_
-				       (char-upcase c)))
-				 (string->list (symbol->string s))))))
-	   (constant
-	    (lambda (sym string)
-	      `(,(rename 'make-external-constant) ',name ',sym ,string)))
-	   (conc (lambda things
-		   (string->symbol (apply string-append
-					  (map (lambda (thing)
-						 (if (symbol? thing)
-						     (symbol->string thing)
-						     thing))
-					       things)))))
-	   (var-name
-	    (lambda (sym)
-	      (conc name "/" sym)))
-	   (components
-	    (list->vector
-	     (map (lambda (stuff)
-		    (if (pair? stuff)
-			(cons (car stuff)
-			      (var-name (car stuff)))
-			(cons stuff
-			      (var-name stuff))))
-		  (caddr form))))
-	   (%define (rename 'define))
-	   (%define-syntax (rename 'define-syntax))
-	   (%begin (rename 'begin))
-	   (%quote (rename 'quote))
-	   (%make-external-constant (rename 'make-external-constant))
-	   (e-name (conc name '- 'enumeration))
-	   (count (vector-length components)))
-      `(,%begin
-	(,%define-syntax ,name
-	    (let ((components ',components))
-	      (lambda (e r c)
-		(let ((key (cadr e)))
-		  (cond ((c key 'enum)
-			 (let ((which (caddr e)))
-			   (let loop ((i 0)) ;vector-posq
-			     (if (< i ,count)
-				 (if (c which (car (vector-ref components i)))
-				     (r (cdr (vector-ref components i)))
-				     (loop (+ i 1)))
-				 ;; (syntax-error "unknown enumerand name"
-				 ;;               `(,(cadr e) ,(car e) ,(caddr e)))
-				 e))))
-			(else e))))))
-	(,%define ,(conc name '- 'count) ,count)
-        . ,(map (lambda (stuff)
-		  (if (pair? stuff)
-		      `(,%define ,(var-name (car stuff))
-			   (,%make-external-constant ',name
-						     ',(car stuff)
-						     ,(cadr stuff)))
-		      `(,%define ,(var-name stuff)
-			   (,%make-external-constant ',name
-						     ',stuff
-						     ,(symbol->upcase-string stuff)))))
-		(caddr form)))))
-    (begin define define-syntax quote external make-external-constant))
diff --git a/ps-compiler/prescheme/unused/record.scm b/ps-compiler/prescheme/unused/record.scm
deleted file mode 100644
index 9688698..0000000
--- a/ps-compiler/prescheme/unused/record.scm
+++ /dev/null
@@ -1,19 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-
-; (make-record 'type-id)
-; (record-ref <record> 'type-id 'field-id)
-; (record-set! <record> <value> 'type-id 'field-id)
-
-(define-polymorphic-scheme-primop make-record allocate
-  (lambda (call)
-    (get-record-type (literal-value (node-ref call 0)))))
-
-(define-polymorphic-scheme-primop record-ref read
-  (lambda (call)
-    (record-field-type
-     (get-record-type-field (get-record-type (literal-value (node-ref call 1)))
-			    (literal-value (node-ref call 2))))))
-
-(define-scheme-primop record-set! write type/unit)
diff --git a/ps-compiler/prescheme/unused/track-read.scm b/ps-compiler/prescheme/unused/track-read.scm
deleted file mode 100644
index 702aad5..0000000
--- a/ps-compiler/prescheme/unused/track-read.scm
+++ /dev/null
@@ -1,285 +0,0 @@
-; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-; Scheme48 reader modified to annotate pairs with source line and column
-; data.
-
-(define-record-type annotation
-  (
-   file
-   row
-   column
-   )
-  (form
-   ))
-
-(define $current-annotating-port (make-fluid #f))
-
-(define-syntax define-lap
-  (lambda (exp rename compare)
-    (let ((spec (cadr exp))
-	  (stuff (cddr exp)))
-      `(define ,(car spec) (lap ,spec . ,stuff)))))
-
-(define-lap (annotated-cons car cdr annotation)
-  (check-nargs= 3)
-  (pop)
-  (make-stored-object 3 pair)
-  (return))
-
-(define (file-annotated-cons car cdr row column)
-  (let* ((note (annotation-maker (fluid $current-annotating-port)
-				 row
-				 column))
-	 (pair (annotated-cons car cdr note)))
-    (set-annotation-form! note pair)
-    (make-immutable! note)
-    (make-immutable! pair)
-    pair))
-
-(define-lap (pair-annotation pair)
-  (check-nargs= 1)
-  (make-env 1)
-  (local pair)
-  (stored-object-length pair)
-  (push)
-  (literal 3)
-  (=)
-  (jump-if-false lose)
-  (local pair)
-  (stored-object-ref pair 2)  ; this is the reason for the LAP
-  (return)
- lose
-  (false)
-  (return))
-
-; A little Scheme reader.
-
-; Nonstandard things needed:
-;  char->ascii, ascii->char (for dispatch table)
-;  make-fluid, fluid (used only to implement ##)
-;  reverse-list->string (ok to define as list->string of reverse)
-;  really-string->symbol (ok to define this to be string->symbol)
-
-(define preferred-case
-  (if (char=? (string-ref (symbol->string 't) 0) #\T)
-      char-upcase
-      char-downcase))
-
-(define close-paren (list 'close-paren))
-(define dot         (string->symbol "."))
-
-(define (read-and-annotate port id)
-  (let-fluid $current-annotating-port id
-    (lambda ()
-      (let loop ()
-	(let ((form (sub-read port)))
-	  (cond ((eq? form dot)
-		 (error "\" . \" in illegal context"))
-		((eq? form close-paren)
-		 ;; Too many right parens.
-		 (loop))
-		(else form)))))))
-
-(define (sub-read-carefully port)
-  (let ((form (sub-read port)))
-    (cond ((eof-object? form)
-           (error "unexpected end of file"))
-          ((eq? form close-paren)
-           (error "unexpected right parenthesis"))
-          ((eq? form dot)
-           (error "unexpected \" . \""))
-          (else form))))
-
-; Main dispatch
-
-(define (sub-read port)
-  (let ((c (read-char port)))
-    (if (eof-object? c)
-        c
-        ((vector-ref read-dispatch-vector (char->ascii c))
-         c port))))
-
-(define read-dispatch-vector
-  (make-vector 256
-               (lambda (c port)
-                 (error "illegal character read" c))))
-
-(define read-terminating?-vector
-  (make-vector 256 #t))
-
-(define (set-standard-syntax! char terminating? reader)
-  (vector-set! read-dispatch-vector     (char->ascii char) reader)
-  (vector-set! read-terminating?-vector (char->ascii char) terminating?))
-
-(let ((sub-read-whitespace
-       (lambda (c port)
-         c                              ;ignored
-         (sub-read port))))
-  (do ((i 0 (+ i 1)))
-      ((>= i (vector-length read-dispatch-vector)))
-    (if (char-whitespace? (ascii->char i))
-	(vector-set! read-dispatch-vector i sub-read-whitespace))))
-
-(let ((sub-read-constituent
-       (lambda (c port)
-	 (parse-token (sub-read-token c port)))))
-  (for-each (lambda (c)
-              (set-standard-syntax! c #f sub-read-constituent))
-            (string->list
-             (string-append "!$%&*+-./0123456789:<=>?@^_~ABCDEFGHIJKLM"
-                            "NOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"))))
-
-; Usual read macros
-
-(define (set-standard-read-macro! c terminating? proc)
-  (set-standard-syntax! c terminating? proc))
-
-(define (sub-read-list c port)
-  (let* ((row (current-row port))
-	 (column (- (current-column port) 1))  ; to get the location of "("
-	 (form (sub-read port)))
-    (cond ((eof-object? form)
-           (error "end of file inside list -- unbalanced parentheses"))
-          ((eq? form close-paren) '())
-          ((eq? form dot)
-           (let* ((last-form (sub-read-carefully port))
-                  (another-form (sub-read port)))
-             (cond ((eq? another-form close-paren)
-		    last-form)
-                   (else
-                    (error "randomness after form after dot" another-form)))))
-          (else
-	   (file-annotated-cons form (sub-read-list c port) row column)))))
-
-(set-standard-read-macro! #\( #t sub-read-list)
-
-(set-standard-read-macro! #\) #t
-  (lambda (c port)
-    c port
-    close-paren))
-
-(set-standard-read-macro! #\' #t
-  (lambda (c port)
-    c
-    (list 'quote (sub-read-carefully port))))
-
-(set-standard-read-macro! #\` #t
-  (lambda (c port)
-    c
-    (list 'quasiquote (sub-read-carefully port))))
-
-(set-standard-read-macro! #\, #t
-  (lambda (c port)
-    c
-    ;; Do not beta-reduce this!
-    (let* ((next (peek-char port))
-	   (marker (cond ((eof-object? next)
-			  (error "end of file after ,"))
-			 ((char=? next #\@)
-			  (read-char port)
-			  'unquote-splicing)
-			 (else 'unquote))))
-      (list marker
-            (sub-read-carefully port)))))
-
-(set-standard-read-macro! #\" #t
-  (lambda (c port)
-    c ;ignored
-    (let loop ((l '()) (i 0))
-      (let ((c (read-char port)))
-        (cond ((eof-object? c)
-               (error "end of file within a string"))
-              ((char=? c #\\)
-               (let ((c (read-char port)))
-		 (cond ((eof-object? c)
-			(error "end of file within a string"))
-		       ((or (char=? c #\\) (char=? c #\"))
-			(loop (cons c l) (+ i 1)))
-		       (else
-			(error "invalid escaped character in string" c)))))
-              ((char=? c #\")
-	       (reverse-list->string l i))
-              (else
-	       (loop (cons c l) (+ i 1))))))))
-
-(set-standard-read-macro! #\; #t
-  (lambda (c port)
-    c ;ignored
-    (gobble-line port)
-    (sub-read port)))
-
-(define (gobble-line port)
-  (let loop ()
-    (let ((c (read-char port)))
-      (cond ((eof-object? c) c)
-	    ((char=? c #\newline) #f)
-	    (else (loop))))))
-
-(set-standard-read-macro! #\# #f
-  (lambda (c port)
-    c ;ignored
-    (let* ((c (peek-char port))
-	   (c (if (eof-object? c)
-		  (error "end of file after #")
-		  (char-downcase c))))
-      (cond ((char=? c #\f) (read-char port) #f)
-            ((char=? c #\t) (read-char port) #t)
-            ((char=? c #\\)
-	     (read-char port)
-             (let ((c (peek-char port)))
-               (cond ((eof-object? c)
-		      (error "end of file after #\\"))
-		     ((char-alphabetic? c)
-		      (let ((name (sub-read-carefully port)))
-			(cond ((= (string-length (symbol->string name)) 1)
-			       c)
-			      ((assq name '((space   #\space)
-					    (newline #\newline)))
-			       => cadr)
-			      (else
-			       (error "unknown #\\ name" name)))))
-		     (else
-		      (read-char port)))))
-            ((char=? c #\()
-	     (read-char port)
-             (list->vector (sub-read-list c port)))
-            ;; ## should evaluate to the last REP-loop result.
-            ((memq c '(#\b #\o #\d #\x #\i #\e))
-	     (let ((string (sub-read-token #\# port)))
-	       (or (string->number string)
-		   (error "unsupported number syntax" string))))
-;            ((char=? c #\#)   ; don't worry about this
-;	     (read-char port)
-;	     (make-last-value-expression))
-            (else
-             (error "unknown # syntax" c))))))
-
-
-; Tokens
-
-(define (sub-read-token c port)
-  (let loop ((l (list (preferred-case c))) (n 1))
-    (let ((c (peek-char port)))
-      (cond ((or (eof-object? c)
-                 (vector-ref read-terminating?-vector (char->ascii c)))
-             (reverse-list->string l n))
-            (else
-             (loop (cons (preferred-case (read-char port)) l)
-                   (+ n 1)))))))
-
-(define (parse-token string)
-  (if (let ((c (string-ref string 0)))
-	(or (char-numeric? c) (char=? c #\+) (char=? c #\-) (char=? c #\.)))
-      (cond ((string->number string))
-	    ((member string strange-symbol-names)
-	     (string->symbol string))
-	    ((string=? string ".")
-	     dot)
-	    (else
-	     (error "unsupported number syntax" string)))
-      (string->symbol string)))
-
-(define strange-symbol-names
-  '("+" "-" "..." "1+" "-1+"))  ;The latter two only for S&ICP support
diff --git a/ps-compiler/prescheme/unused/user.scm b/ps-compiler/prescheme/unused/user.scm
deleted file mode 100644
index 4a807bd..0000000
--- a/ps-compiler/prescheme/unused/user.scm
+++ /dev/null
@@ -1,104 +0,0 @@
-; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
-
-
-(define *break-on-user-errors?* #f)
-
-(define (user-error node string . args)
-  (format #t "~%PreScheme error: ")
-  (apply format #t string args)
-  (newline)
-  (if node (display-source node))
-  (if *break-on-user-errors?*
-      (breakpoint "")))
-
-(define (display-source node)
-  (let ((source-node (find-some-source node)))
-    (if source-node
-	(display-annotation (node-source source-node)
-			    (eq? source-node node)
-			    node)
-	(pp-cps (top-call node)))))
-
-(define (top-call node)
-  (let loop ((node node))
-    (if (or (not (node? (node-parent node)))
-	    (and (call-node? node)
-		 (not (call-node? (node-parent node)))))
-	node
-	(loop (node-parent node)))))
-
-(define (node-source node)
-  (cond ((call-node? node)
-	 (call-source node))
-	((lambda-node? node)
-	 (lambda-source node))
-	(else
-	 #f)))
-
-(define (find-some-source node)
-  (let loop ((node node))
-    (cond ((not (node? node))
-	   #f)
-	  ((annotation? (node-source node))
-	   node)
-	  (else (loop (node-parent node))))))
-
-(define (display-annotation annotation exact? node)
-  (let ((file   (annotation-file annotation))
-	(form   (annotation-form annotation))
-	(row    (annotation-row annotation))
-	(column (annotation-column annotation)))
-    (newline)
-    (cond (exact?
-	   (display "  "))
-	  (else
-	   (write-one-line (current-output-port)
-			   60
-			   (lambda (port)
-			     (show-user-node node port)))
-	   (display "  within ")))
-    (newline)
-    (write-one-line (current-output-port)
-		    70
-		    (lambda (port) (display form port)))
-    (format #t "~%    on line ~D of ~A~%" column file)))
-
-(define (show-user-node node port)
-  (cond ((literal-node? node)
-	 (format port "'~S" (literal-value node)))
-	((reference-node? node)
-	 (format port "~S" (variable-name (reference-variable node))))
-	((lambda-node? node)
-	 (format port "(lambda ~A ...)"
-		 (map variable-name
-		      (if (proc-lambda? node)
-			  (cdr (lambda-variables node))
-			  (lambda-variables node))))
-	 (show-user-node (lambda-body node) port))
-	((call-node? node)
-	 (show-user-call-node node port))))
-
-(define (show-user-call-node call port)
-  (let ((exits (call-exits call))
-	(id (primop-id (call-primop call))))
-    (case id
-      ((let)
-       (display "(let ..." port)	; wimpy
-       )
-      ((call unknown-call)
-       (display "(" port)
-       (show-user-node (call-arg call 1) port)
-       (show-user-call-args call (if (eq? 'call id) 2 3) port)
-       (display ")" port))
-      (else				; wimpy
-       (format port "(~S" id)
-       (show-user-call-args call exits port)
-       (format port ")")))))
-
-(define (show-user-call-args call start port)
-  (do ((i start (+ i 1)))
-      ((>= i (call-arg-count call)))
-    (display " " port)
-    (show-user-node (call-arg call i) port)))
-       
-      
\ No newline at end of file
diff --git a/ps-compiler/simp/call.scm b/ps-compiler/simp/call.scm
deleted file mode 100644
index 4925518..0000000
--- a/ps-compiler/simp/call.scm
+++ /dev/null
@@ -1,251 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-
-(define (simplify-jump call)
-  (cond ((lambda-node? (call-arg call 0))
-	 (set-call-primop! call (get-primop (enum primop let)))
-	 (set-call-exits! call 1)
-	 (set-node-simplified?! call #f))
-	(else
-	 (default-simplifier call))))
-
-(define simplify-return simplify-jump)
-
-; If the procedure is a lambda-node:
-;   1. note that we know where the continuation lambda is used (and turn any
-;      tail-calls using it into regular calls)
-;   2. change the primop to LET
-;   3. the procedure is now the continuation
-;   4. the continuation is now a jump lambda
-;   5. change the primop used to call the continuation to jump
-;   6. swap the cont and proc.
-;   (CALL <cont> (LAMBDA (c . vars) ...) . args))
-;     =>
-;   (LET (LAMBDA (c . vars) ...) <cont> . args)
-; If the continuation just returns somewhere else, replace UNKNOWN-CALL
-; with UNKNOWN-TAIL-CALL.
-
-(define (simplify-known-call call)
-  (let ((proc (call-arg call 1))
-	(cont (call-arg call 0)))
-    (cond ((lambda-node? proc)
-	   (determine-continuation-protocol cont (list proc))
-	   (set-call-primop! call (get-primop (enum primop let)))
-	   (change-lambda-type proc 'cont)
-	   (change-lambda-type cont 'jump)
-	   (for-each (lambda (ref)
-		       (set-call-primop! (node-parent ref)
-					 (get-primop (enum primop jump))))
-		     (variable-refs (car (lambda-variables proc))))
-	   (move cont
-		 (lambda (cont)
-		   (detach proc)
-		   (attach call 1 cont)
-		   proc)))
-	  ((trivial-continuation? cont)
-	   (replace cont (detach (call-arg (lambda-body cont) 0)))
-	   (set-call-primop! call (get-primop (enum primop tail-call)))
-	   (set-call-exits! call 0))
-	  (else
-	   (default-simplifier call)))))
-
-;  (CALL (CONT (v1 ... vN) (RETURN c v1 ... vN)) ...args...)
-
-(define (trivial-continuation? cont)
-  (let ((body (lambda-body cont)))
-    (and (calls-this-primop? body 'return)
-	 (= (length (lambda-variables cont))
-	    (- (call-arg-count body ) 1))
-	 (let loop ((vars (lambda-variables cont)) (i 1))
-	   (cond ((null? vars)
-		  #t)
-		 ((and (reference-node? (call-arg body i))
-		       (eq? (car vars)
-			    (reference-variable (call-arg body i))))
-		  (loop (cdr vars) (+ i 1)))
-		 (else #f))))))
-
-; The same as the above, except that the continuation is a reference node
-; and not a lambda, so we substitute it for the proc's continuation variable.
-
-(define (simplify-known-tail-call call)
-  (let ((proc (call-arg call 1))
-	(cont (call-arg call 0)))
-    (cond ((lambda-node? proc)
-	   (set-call-primop! call (get-primop (enum primop let)))
-	   (change-lambda-type proc 'cont)
-	   (substitute (car (lambda-variables proc)) cont #t)
-	   (set-lambda-variables! proc (cdr (lambda-variables proc)))
-	   (remove-call-arg call 0)
-	   (set-call-exits! call 1)  ; must be after REMOVE-CALL-ARG
-	   (mark-changed proc))
-	  (else
-	   (default-simplifier call)))))
-
-(define (simplify-test call)
-  (simplify-arg call 2)
-  (let ((value (call-arg call 2)))
-    (cond ((literal-node? value)
-	   (fold-conditional call (if (eq? false-value (literal-value value))
-				      1
-				      0)))
-	  ((reference-node? value)
-	   (simplify-variable-test call (reference-variable value)))
-	  ((collapse-multiple-zero-bit-tests call)
-	   )
-	  (else
-	   (default-simplifier call)))))
-
-(define (simplify-variable-test call var)
-  (cond ((flag-assq 'test (variable-flags var))
-	 => (lambda (pair)
-	      (fold-conditional call (cdr pair))))
-	(else
-	 (let ((pair (cons 'test 0))
-	       (flags (variable-flags var)))
-	   (set-variable-flags! var (cons pair flags))
-	   (simplify-arg call 0)
-	   (set-cdr! pair 1)
-	   (simplify-arg call 1)
-	   (set-variable-flags! var flags)))))
-
-(define (fold-conditional call index)
-  (replace-body call (detach-body (lambda-body (call-arg call index)))))
-
-; (if (and (= 0 (bitwise-and 'j x))
-;          (= 0 (bitwise-and 'j y)))
-;     ...)
-; =>
-; (if (= 0 (bitwise-and (bitwise-or x y) 'j))
-;     ...)
-; This comes up in the Scheme48 VM.
-
-(define (collapse-multiple-zero-bit-tests test)
-  (receive (mask first-arg)
-      (zero-bit-test (call-arg test 2))
-    (if mask
-	(let ((false-exit (call-arg test 1))
-	      (true-exit (call-arg test 0)))
-	  (simplify-lambda-body true-exit)
-	  (simplify-lambda-body false-exit)
-	  (let ((call (lambda-body true-exit)))
-	    (if (and (eq? 'test (primop-id (call-primop call)))
-		     (node-equal? false-exit (call-arg call 1)))
-		(receive (new-mask second-arg)
-		    (zero-bit-test (call-arg call 2))
-		  (if (and new-mask (= mask new-mask))
-		      (fold-zero-bit-tests test first-arg second-arg
-					   (call-arg call 0))
-		      #f))
-		#f)))
-	#f)))
-
-; = and bitwise-and always have any literal node as arg1
-;
-; 1. call to =
-; 2. first arg is literal 0
-; 3. second arg is call to and
-; 4. first arg of and-call is numeric literal
-; 5. second arg of and-call has no side-effects (reads are okay)
-;  Returns #f or the two arguments to bitwise-and.
-
-(define (zero-bit-test call)
-  (if (eq? '= (primop-id (call-primop call)))
-      (let ((literal-0 (call-arg call 0))
-	    (bitwise-and-call (call-arg call 1)))
-	(if (and (literal-node? literal-0)
-		 (number? (literal-value literal-0))
-		 (= 0 (literal-value literal-0))
-		 (call-node? bitwise-and-call)
-		 (eq? 'bitwise-and (primop-id (call-primop bitwise-and-call)))
-		 (literal-node? (call-arg bitwise-and-call 0))
-		 (number? (literal-value (call-arg bitwise-and-call 0)))
-		 (not (side-effects? (call-arg bitwise-and-call 1) 'read)))
-	    (values (literal-value (call-arg bitwise-and-call 0))
-		    (call-arg bitwise-and-call 1))
-	    (values #f #f)))
-      (values #f #f)))
-
-(define (fold-zero-bit-tests test first-arg second-arg true-cont)
-  (detach second-arg)
-  (replace (call-arg test 0) (detach true-cont))
-  (move first-arg
-	(lambda (first-arg)
-	  (let-nodes ((call (bitwise-ior 0 first-arg second-arg)))
-	    call))))
-
-(define (expand-test call)
-  (bug "Trying to expand a call to TEST (~D) ~S"
-       (node-hash (node-parent (nontrivial-ancestor call)))))
-
-; TEST can be simplified using any literal value.
-; The check for reference nodes is a heuristic.  It will only help if the
-; two tests end up being sequential.
-
-(define (simplify-test? call index value)
-  (cond ((literal-node? value)
-	 #t)
-	((reference-node? value)
-	 (any? (lambda (r)
-		 (eq? 'test (primop-id (call-primop (node-parent r)))))
-	       (variable-refs (reference-variable value))))
-	(else
-	 #f)))
-
-(define (simplify-unknown-call call)
-  (simplify-args call 0)
-  (let ((proc (call-arg call 1)))
-    (cond ((lambda-node? proc)
-	   (determine-lambda-protocol proc (list proc))
-	   (mark-changed proc))
-	  ((and (reference-node? proc)
-		(variable-simplifier (reference-variable proc)))
-           => (lambda (proc)
-		(proc call))))))
-
-; Simplify a cell.  A set-once cell is one that is set only once and does
-; not escape.  If such a cell is set to a value that can be hoisted (without
-; moving variables out of scope) to the point the cell is created the cell
-; is replace with the value.
-
-; This should make use of the type of the cell.
-
-(define (simplify-allocation call)
-  (set-node-simplified?! call #t)
-  (simplify-args call 0)    ; simplify all arguments, including continuation
-  (let ((var (car (lambda-variables (call-arg call 0)))))
-    (if (every? cell-use? (variable-refs var))
-	(receive (uses sets)
-	    (partition-list (lambda (n)
-			      (eq? 'contents
-				   (primop-id (call-primop (node-parent n)))))
-			    (variable-refs var))
-	  (simplify-cell-part call uses sets)))))
-
-(define (cell-use? ref)
-  (let ((call (node-parent ref)))
-    (case (primop-id (call-primop call))
-      ((contents)
-       #t)
-      ((set-contents)
-       (= (node-index ref) set/owner))
-      (else
-       #f))))
-
-(define (simplify-cell-part call my-uses my-sets)
-  (cond ((null? my-uses)
-         (for-each (lambda (n) (remove-body (node-parent n)))
-		   my-sets))
-        ((null? my-sets)
-         (for-each (lambda (n)
-		     (replace-call-with-value
-		      (node-parent n)
-		      (make-undefined-literal)))
-		   my-uses))
-;        ((null? (cdr my-sets))
-;	  (set-literal-value! (call-arg call 1) 'single-set)
-;	  (really-simplify-single-set call (car my-sets) my-uses))
-	(else
-	 (if (neq? 'small (literal-value (call-arg call 1)))
-	     (set-literal-value! (call-arg call 1) 'small)))))
-	     
diff --git a/ps-compiler/simp/join.scm b/ps-compiler/simp/join.scm
deleted file mode 100644
index a9f0ac1..0000000
--- a/ps-compiler/simp/join.scm
+++ /dev/null
@@ -1,223 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-
-; Call JOIN-SUBSTITUTE on all variable/value pairs.
-
-(define (substitute-join-arguments lambda-proc call)
-  (let ((vec (call-args call))
-        (vars (lambda-variables lambda-proc)))
-    (do ((vars vars (cdr vars))
-         (i    1   (+ i 1))
-         (c?   #f  (or (join-substitute (car vars) (vector-ref vec i))
-                        c?)))
-        ((null? vars) c?))))
-
-; Does VAL take only one argument and is that argument passed to $TEST?
-; Is VAR applied to constants?
-; Then two possiblities are checked for:
-;   Does the tree rooted at the least-common-ancestor of VAR's references
-;   contain no side-effects and necessarily passed control to VAR?
-;  or
-;   Does the join point contain no side-effects above the test?
-;
-; If so, make the transformation described below.
-
-(define (join-substitute var val)
-  (let ((ref (and (lambda-node? val)
-		  (simple-test-procedure val))))
-    (and ref
-	 (applied-to-useful-value? var ref)
-	 (let ((lca (least-common-ancestor (variable-refs var))))
-	   (cond ((or (suitable-join-conditional? lca var)
-		      (suitable-join-point? val (node-parent ref)))
-		  (really-join-substitute var val lca (node-parent ref))
-		  #t)
-		 (else #f))))))
-
-; Check that VAL (a lambda-node) takes one argument, is jumped to, tests its
-; argument, and that all references to the argument are at or below the test.
-
-(define (simple-test-procedure val)
-  (let ((vars (lambda-variables val)))
-    (if (or (null? vars)
-	    (not (null? (cdr vars)))
-	    (not (car vars))
-	    (not (calls-known? val))
-	    (neq? 'jump (lambda-type val)))
-	#f
-	(let* ((var (car vars))
-	       (ref (any simple-cond-ref (variable-refs var))))
-	  (if (and ref (all-refs-below? var (node-parent ref)))
-	      ref
-	      #f)))))
-
-(define (simple-cond-ref ref)
-  (if (primop-conditional? (call-primop (node-parent ref)))
-      ref
-      #f))
-
-(define (all-refs-below? var node)
-  (set-node-flag! node #t)
-  (set-node-flag! (variable-binder var) #t)
-  (let ((res (every? (lambda (r)
-		       (eq? node (marked-ancestor r)))
-		     (variable-refs var))))
-    (set-node-flag! node #f)
-    (set-node-flag! (variable-binder var) #f)
-    res))
-
-; Is VAR applied to something that can be used to simplify the conditional?
-
-(define (applied-to-useful-value? var ref)
-  (let ((call (node-parent ref))
-	(index (node-index ref)))
-    (any? (lambda (r)
-	    (simplify-conditional? call index (call-arg (node-parent r) 1)))
-	  (variable-refs var))))
-
-; CALL is the least-common-ancestor of the references to VAR.  Check that
-; the tree rooted at CALL contains no side-effects and that the control flow
-; necessarily passes to VAR.  (Could check for undefined-effect here...)
-; could do check that jumped-to proc if not VAR jumped to VAR eventually
-
-(define (suitable-join-conditional? call var)
-  (let label ((call call))
-    (cond ((call-side-effects? call)
-	   #f)
-	  ((= 0 (call-exits call))
-	   (and (eq? 'jump (primop-id (call-primop call)))
-		(eq? var (reference-variable (called-node call)))))
-	  (else
-	   (let loop ((i 0))
-	     (cond ((>= i (call-exits call))
-		    #t)
-		   ((not (label (lambda-body (call-arg call i))))
-		    #f)
-		   (else
-		    (loop (+ i 1)))))))))
-
-; #t if CALL performs side-effects.  The continuations to CALL are ignored.
-
-(define (call-side-effects? call)
-  (or (primop-side-effects (call-primop call))
-      (let loop ((i (call-exits call)))
-	(cond ((>= i (call-arg-count call))
-	       #f)
-	      ((side-effects? (call-arg call i))
-	       #t)
-	      (else
-	       (loop (+ i 1)))))))
-
-; The alternative to the above test: does the join point contain no side-effects
-; above the test?
-
-(define (suitable-join-point? join test)
-  (let label ((call (lambda-body join)))
-    (cond ((eq? call test)
-	   #t)
-	  ((call-side-effects? call)
-	   #f)
-	  (else
-	   (let loop ((i 0))
-	     (cond ((>= i (call-exits call))
-		    #t)
-		   ((not (label (lambda-body (call-arg call i))))
-		    #f)
-		   (else
-		    (loop (+ i 1)))))))))
-	     
-; (let ((j (lambda (v)                  ; VAR VAL
-;            .a.
-;            ($test c1 c2 ... v ...)    ; TEST
-;            .b.)))
-;   .c.
-;   (... (j x) ...)                     ; CALL
-;   .d.)
-; ==>
-; .c.
-; (.a.
-;  (let ((v1 (lambda (x) c1[x/v]))
-;        (v2 (lambda (x) c2[x/v])))
-;    (... ((lambda (v)
-;            ($test (lambda () (v1 v)) (lambda () (v2 v)) ... v ...))
-;          x)
-;     ...))
-;  .b.)
-; .d.
-;
-; CALL is the least common ancestor of the references to VAR, which is bound to
-; VAL, a procedure.  TEST is a conditional that tests the argument passed to
-; VAL.
-;
-; (lambda-body VAL) is moved to where CALL is.
-; In the body of VAL, TEST is replaced by a LET that binds TEST's continuations
-; and then executes CALL.  TEST's continuations are replaced by calls to
-; the variables bound by the LET.
-; Finally, references to VAR are replaced by a procedure whose body is TEST,
-; which is the point of the whole exercise.
-
-(define (really-join-substitute var val call test)
-  (let ((value-var (car (lambda-variables val))))
-    (receive (cont-call conts)
-	(move-continuations test call value-var)
-      (let ((test-parent (node-parent test))
-	    (val-parent (node-parent val))
-	    (val-index (node-index val)))
-	(parameterize-continuations conts value-var)
-	(detach-body test)
-	(move-body cont-call
-		   (lambda (cont-call)
-		     (attach-body test-parent cont-call)
-		     (detach-body (lambda-body val))))
-	(attach-body val test)
-	(mark-changed (call-arg test 1)) ; marks test as changed.
-	(mark-changed cont-call)
-	(substitute var val #t)
-	(attach val-parent val-index (make-literal-node #f #f))
-	(values)))))
-
-; Move the continuations of CALL to a LET call just above TO.  Returns a list
-; of the variables now bound to the continuations and the continuations
-; themselves.
-
-(define (move-continuations call to arg-var)
-  (let ((count (call-exits call)))
-    (let loop ((i (- count 1)) (vs '()) (es '()))
-      (cond ((< i 0)
-	     (let ((new-call (make-call-node (get-primop (enum primop let))
-					     (+ count 1)
-					     1))
-		   (new-proc (make-lambda-node 'j 'cont vs)))
-	       (attach-call-args new-call (cons new-proc es))
-	       (insert-body new-call new-proc (node-parent to))
-	       (values new-call es)))
-	    (else
-	     (let ((var (make-variable 'e (node-type (call-arg call i))))
-		   (cont (detach (call-arg call i))))
-	       (let-nodes ((new-cont () c1)
-			   (c1 (jump 0 (* var) (* arg-var))))
-		 (attach call i new-cont))
-	       (change-lambda-type cont 'jump)
-	       (loop (- i 1) (cons var vs) (cons cont es))))))))
-
-; Add a new variable to each of CONTS and substitute a reference to the correct
-; variable for each reference to VAR within CONTS.
-
-(define (parameterize-continuations conts var)
-  (for-each (lambda (n)
-	      (let ((var (copy-variable var)))
-		(set-lambda-variables! n (cons var (lambda-variables n)))
-		(set-variable-binder! var n)
-		(set-node-flag! n #t)))
-	    conts)
-  (let ((backstop (variable-binder var)))
-    (set-node-flag! backstop #t)
-    (walk-refs-safely
-     (lambda (n)
-       (let ((cont (marked-ancestor n)))
-	 (if (not (eq? cont backstop))
-	     (replace n (make-reference-node (car (lambda-variables cont)))))))
-     var)
-    (set-node-flag! backstop #f)
-    (for-each (lambda (n) (set-node-flag! n #f)) conts)
-    (values)))
diff --git a/ps-compiler/simp/let.scm b/ps-compiler/simp/let.scm
deleted file mode 100644
index e9bff31..0000000
--- a/ps-compiler/simp/let.scm
+++ /dev/null
@@ -1,155 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-
-; Simplifying LET nodes, i.e. calls to the LET primop.
-
-; 1. Change the procedure to a JUMP procedure if necessary.
-; 2. Check that the right number of arguments are present.
-; 3. Substitute any values that can be substituted without reference to
-;    how they are used in the body; then remove the call if it is no
-;    longer necessary.
-; 4. Try harder.
-
-(define (simplify-let call)
-  (let ((proc (call-arg call 0)))
-    (if (eq? (lambda-type proc) 'jump)
-	(change-lambda-type proc 'cont))
-    (cond ((n= (length (lambda-variables proc))
-	       (- (call-arg-count call) 1))
-	   (bug "wrong number of arguments in ~S" call))
-	  ((or (null? (lambda-variables proc))
-	       (substitute-let-arguments proc call quick-substitute))
-	   (remove-body call))
-	  (else
-	   (really-simplify-let proc call)))))
-
-; A value can be quickly substituted if it is a leaf node or if it has no
-; side-effects and is used only once.
-
-(define (quick-substitute var val)
-  (or (literal-node? val)
-      (reference-node? val)
-      (and (not (side-effects? val))
-	   (null? (cdr (variable-refs var))))))
-
-; Simplify the arguments and then repeatedly simplify the body of PROC
-; and try substituting the arguments.
-; If all the arguments can be substituted the call node is removed.
-;
-; SUBSTITUTE-JOIN-ARGUMENTS copies arguments in an attempt to remove
-; conditionals via constant folding.
-
-(define (really-simplify-let proc call)
-  (simplify-args call 1)
-  (let loop ()
-    (set-node-simplified?! proc #t)
-    (simplify-lambda-body proc)
-    (cond ((substitute-let-arguments proc call slow-substitute)
-	   (remove-body call))
-          ((substitute-join-arguments proc call)
-           (loop))
-          ((not (node-simplified? proc))
-           (loop)))))
-
-(define *duplicate-lambda-size* '-1)   ; don't duplicate anything
-(define *duplicate-jump-lambda-size* 1) ; duplicate one call
-
-(define (slow-substitute var val)
-  (cond ((or (literal-node? val) (reference-node? val))
-	 #t)
-	((call-node? val)
-	 (let ((refs (variable-refs var)))
-	   (and (not (null? refs))
-		(null? (cdr refs))
-		(or (not (side-effects? val 'allocate))
-		    (and (not (side-effects? val 'allocate 'read))
-			 (not-used-between? val (car refs)))))))
-	((every? called-node? (variable-refs var))
-	 (simplify-known-cont-calls (variable-refs var) val)
-	 (or (null? (cdr (variable-refs var)))
-	     (case (lambda-type val)
-	       ((proc known-proc)
-		(small-node? val *duplicate-lambda-size*))
-	       ((jump)
-		(small-node? val *duplicate-jump-lambda-size*))
-	       (else
-		#f))))
-        (else #f)))
-
-; This only detects the following situation:
-; (let (lambda (... var ...) (primop ... var ...))
-;      ... value ...)
-; where the reference to VAR is contained within nested, non-writing calls
-; This depends on there being no simple calls with WRITE side-effects
-
-(define (not-used-between? call ref)
-  (let ((top (lambda-body (call-arg (node-parent call) 0))))
-    (let loop ((call (node-parent ref)))
-      (cond ((eq? call top) #t)
-	    ((or (not (call-node? call))
-		 (eq? 'write (primop-side-effects (call-primop call))))
-	     #f)
-	    (else (loop (node-parent call)))))))
-
-(define (simplify-known-cont-calls refs l-node)
-  (case (lambda-type l-node)
-    ((proc)
-     (determine-lambda-protocol l-node refs))
-    ((cont)
-     (bug "CONT lambda bound by LET ~S" l-node)))
-  (if (calls-known? l-node)
-      (simplify-known-lambda l-node)))
-
-; ($some-RETURN <proc> . <args>)
-;   =>
-; ($JUMP <proc> . <args>)
-
-; could check argument reps as well
-
-(define (add-return-mark call l-node arg-count)
-  (if (not (= (call-arg-count call) (+ arg-count 1)))
-      (bug '"call ~S to join ~S has the wrong number of arguments"
-           call l-node))
-  (set-call-primop! call (get-primop (enum primop jump))))
-
-; Removed arguments to a lambda-node in call position.
-; If any arguments are actually removed
-; REMOVE-NULL-ARGUMENTS shortens the argument vector.
-
-(define (substitute-let-arguments node call gone-proc)
-  (let* ((vec (call-args call))
-         (c (do ((vars (lambda-variables node) (cdr vars))
-                 (i 1 (+ i 1))
-                 (c 0 (if (keep-var-val (car vars) (vector-ref vec i) gone-proc)
-			  c
-			  (+ 1 c))))
-                ((null? vars) c))))
-    (cond ((= (+ c 1) (call-arg-count call)) #t)
-          ((= c 0)                           #f)
-          (else
-           (remove-unused-variables node)
-           (remove-null-arguments call (- (call-arg-count call) c))
-           #f))))
-
-(define (keep-var-val var val gone-proc)
-  (cond ((and (unused? var)
-	      (or (not (call-node? val))
-		  (not (side-effects? val 'allocate 'read))))
-         (erase (detach val))
-         #f)
-        ((gone-proc var val)
-         (substitute var val #t)
-         #f)
-        (else '#t)))
-
-; VAL is simple enough to be substituted in more than one location if
-; its body is a call with all leaf nodes.
-; -- no longer used --
-;(define (simple-lambda? val)
-;  (vector-every? (lambda (n)
-;                   (and (not (lambda-node? n))
-;                 (call-args (lambda-body val))))
-
-(define (called-anywhere? var)
-  (any? called-node? (variable-refs var)))
-
diff --git a/ps-compiler/simp/pattern.scm b/ps-compiler/simp/pattern.scm
deleted file mode 100644
index 8db2236..0000000
--- a/ps-compiler/simp/pattern.scm
+++ /dev/null
@@ -1,414 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-
-;(define (simplify-subtract call)
-;  (simplify-args call 0)
-;  ((pattern-simplifier
-;    ((- 'a 'b) '(- a b))                    ; constant folding
-;    ((- x 'a) (+ '(- 0 a) x))               ; convert to a normal form
-;    ((- 'a (+ 'b x)) (- '(- a b) x))        ; merging constants
-;    ((- 'a (- 'b x)) (+ x '(- a b)))        ; ditto
-;    ((- x (+ 'a y)) (+ '(- 0 a) (- x y)))   ; convert to a normal form
-;    ((- (+ 'a x) (+ 'b y)) (- (+ '(- a b) x) y)))
-;   call))
-
-; (pattern-simplifier pattern-spec ...)
-;  =>
-; (lambda (call-node) ...)
-; The resulting procedure replaces instances of IN-PATTERNs with the
-; corresponding OUT-PATTERNs.
-;
-; <pattern-spec> ::= (in-pattern out-pattern) |
-;                    (in-pattern boolean-expression out-pattern) 
-;
-; All of the IN-PATTERNs for a particular simplifier must be calls to the
-; same primop.  If the boolean-expression is present it is evaluated after
-; the in-pattern is matched and in an environment where the symbols of the
-; the in-pattern are bound to the corresponding values from the call.
-;
-; x       matches anything
-; 'x      matches any literal
-; (x ...) matches a call to primop X
-; 5       matches the literal 5
-
-; The patterns are matched in order.
-
-;----------------
-; Call MATCH-CALLS with a continuation that makes code to construct the
-; right-hand side of the specification.  This assumes that the left-hand side
-; of all of the specifications will be calls to the same primitive.  The
-; initial CASE is removed from the code returned by MATCH-CALLS.
-
-(define (make-pattern-simplifier specs)
-  (set! *generate-symbol-index* 0)
-  (let* ((initial (generate-symbol 'initial))
-	 (exp (match-calls (map (lambda (spec)
-				  (make-pattern (car spec) (cdr spec)))
-				specs)
-			   initial
-			   #f
-			   (lambda (patterns)
-			     (if (null? patterns)
-				 (error "no patterns matched" specs)
-				 (check-predicates patterns initial))))))
-    `(lambda (,initial)
-       ,(cadar (cddr exp))))) ; strip off initial CASE
-
-(define-record-type pattern
-  (spec        ; the specification this pattern is to match
-   (env)       ; an a-list mapping atoms in the pattern to the identifiers
-               ; that will be bound to the value matched by the atom
-   parent      ; if this pattern is an argument in another pattern, this
-               ; field contains the other pattern
-   predicate   ; predicate call or #F
-   build-spec  ; specification for the transformed pattern
-   )
-  ())
-
-; Returns the pattern for the I'th argument in PATTERN.
-
-(define (pattern-arg pattern i)
-  (list-ref (pattern-spec pattern) (+ i 1)))
-
-(define (make-pattern spec specs)
-  (receive (build-spec predicate)
-      (if (null? (cdr specs))
-	  (values (car specs) #f)
-	  (values (cadr specs) (car specs)))
-    (pattern-maker spec '() #f predicate build-spec)))
-
-; For each pattern in PATTERN, extend the environment with the I'th argument
-; of the pattern bound to ID.
-
-(define (extend-pattern-envs patterns i id)
-  (map (lambda (pattern)
-	 (let ((arg (pattern-arg pattern i)))
-	   (set-pattern-env! pattern
-			     (cons (if (pair? arg)
-				       (list (cadr arg) id #t)
-				       (list arg id #f))
-				   (pattern-env pattern)))))
-       patterns))
-
-; Return the parent of PATTERN, setting the environment of the parent to be
-; the environment of PATTERN.  This is only used once we are done with PATTERN
-; and want to continue with the next argument in the parent.
-
-(define (get-pattern-parent pattern)
-  (let ((p (pattern-parent pattern)))
-    (set-pattern-env! p (pattern-env pattern))
-    p))
-
-; Sort PATTERNS by the primop being called, and for each set of patterns
-; matching the same primop, call MATCH-CALL-ARGS to generate code for
-; those patterns.  FINISH-CALL-MATCH builds the clauses that this generates
-; into a CASE expression.
-; CALL-VAR is the identifier that will be bound to the call being matched.
-; FAIL-VAR is either #f or a variable that should be called if no pattern
-; matches.
-; MORE is a procedure that finishes with the patterns after this call has
-; been matched.
-
-(define (match-calls patterns call-var fail-var more)
-  (let ((primop-var (generate-symbol 'primop)))
-    (let loop ((patterns patterns) (res '()))
-      (if (null? patterns)
-	  (finish-call-match res call-var primop-var fail-var)
-	  (let ((primop (car (pattern-spec (car patterns)))))
-	    (receive (same other)
-		(partition-list (lambda (p)
-				  (eq? primop (car (pattern-spec p))))
-				(cdr patterns))
-	      (loop other
-		    (cons `(,(if (number? primop) 'else `(,primop))
-			    ,(match-call-args (cons (car patterns) same)
-					      0
-					      call-var
-					      fail-var
-					      more))
-			  res))))))))
-
-(define (finish-call-match clauses call-var primop-var fail-var)
-  (receive (elses other)
-      (partition-list (lambda (c)
-			(eq? (car c) 'else))
-		      clauses)
-    `(case (primop-id (call-primop ,call-var))
-       ,@(reverse other)
-       (else ,(cond ((null? elses)
-		     (if fail-var `(,fail-var) #f))
-		    ((null? (cdr elses))
-		     `(let ((,primop-var (call-primop ,call-var)))
-			,(cadar elses)))  ; strip of uneeded ELSE
-		    (else
-		     (error "more than one ELSE clause" elses)))))))
-
-; Similar to MATCH-CALLS, except that this is matching the I'th argument of a
-; call.  All patterns with similar I'th arguments are grouped together and
-; passed to MATCH-CALL-ARG.  The clauses that are returned are made into a
-; COND expression by FINISH-MATCH-CALL-ARGS.
-; If there are fewer than I arguments, MORE is called to continue matching
-; other parts of the patterns.
-; Patterns that always match the I'th argument are handled separately.
-; They are used to generate the ELSE clause of the conditional returned.
-; If there are no such patterns, then the passed-in FAIL-VAR is called
-; if no patterns match.
-
-(define (match-call-args patterns i call-var fail-var more)
-  (if (>= i (length (cdr (pattern-spec (car patterns)))))
-      (more patterns)
-      (receive (atom-patterns other-patterns)
-	  (partition-list (lambda (p)
-			    (atom? (pattern-arg p i)))
-			  patterns)
-	(let* ((arg-var (generate-symbol 'arg))
-	       (else-code (cond ((null? atom-patterns)
-				 #f)
-				(else
-				 (extend-pattern-envs atom-patterns i arg-var)
-				 (match-call-args atom-patterns (+ i 1)
-						  call-var fail-var more))))
-	       (fail-var (if else-code (generate-symbol 'fail) fail-var))
-	       (more (lambda (patterns)
-		       (match-call-args patterns (+ i 1)
-					call-var fail-var more))))
-	  (let loop ((patterns other-patterns) (clauses '()))
-	    (if (null? patterns)
-		(finish-match-call-args i call-var arg-var fail-var
-					else-code clauses)
-		(let ((first (car patterns)))
-		  (receive (same other)
-		      (partition-list (lambda (p)
-					(same-arg-pattern? first p i))
-				      (cdr patterns))
-		    (loop other
-			  (cons (match-call-arg (cons first same)
-						i
-						arg-var
-						fail-var
-						more)
-				clauses))))))))))
-
-; If ELSE-CODE exists this binds FAIL-VAR to a failure procedure containing it.
-; The CLAUSES are put in a COND.
-
-(define (finish-match-call-args i call-var arg-var fail-var else-code clauses)
-  `(let ((,arg-var (call-arg ,call-var ,i)))
-     ,(if else-code
-	  `(let ((,fail-var (lambda () ,else-code)))
-	     (cond ,@clauses (else (,fail-var))))
-	  `(cond ,@clauses (else ,(if fail-var `(,fail-var) #f))))))
-
-; Are the I'th arguments of patterns P1 and P2 the same as far as matching
-; arguments is concerned?
-
-(define (same-arg-pattern? p1 p2 i)
-  (let ((a1 (pattern-arg p1 i))
-	(a2 (pattern-arg p2 i)))
-    (cond ((atom? a1)
-	   (atom? a2))
-	  ((atom? a2)
-	   #f)
-	  ((eq? (car a1) 'quote)
-	   (eq? (car a2) 'quote))
-	  ((eq? (car a2) 'quote)
-	   #f)
-	  (else #t))))
-
-; Dispatch on the type of the I'th argument of PATTERNS (all of which have
-; similar I'th arguments) and generate the appropriate code.
-; ARG-VAR is the identifier that will be bound to the actual argument.
-; MORE is a procedure that generates code for the rest of the patterns.
-; Atoms always match and require that the environments of the patterns
-; be extended.
-; Code for literals and calls are generated by other procedures.
-
-(define (match-call-arg patterns i arg-var fail-var more)
-  (let ((arg (pattern-arg (car patterns) i)))
-    (cond ((eq? (car arg) 'quote)
-	   `((literal-node? ,arg-var)
-	     ,(match-literal patterns i arg-var fail-var more)))
-	  (else
-	   `((call-node? ,arg-var)
-	     ,(match-calls (map (lambda (p)
-				  (pattern-maker (pattern-arg p i)
-						 (pattern-env p)
-						 p
-						 (pattern-predicate p)
-						 (pattern-build-spec p)))
-				patterns)
-			   arg-var
-			   fail-var
-			   (lambda (patterns)
-			     (more (map get-pattern-parent patterns)))))))))
-
-; Again we sort the patterns into similar groups and build a clause for
-; each group.  Patterns with symbols have their environments extended.
-; FINISH-MATCH-LITERAL puts the clauses into a CASE expression.
-
-(define (match-literal patterns i arg-var fail-var more)
-  (receive (symbols numbers)
-      (partition-list (lambda (p)
-			(symbol? (cadr (pattern-arg p i))))
-		      patterns)
-    (extend-pattern-envs symbols i arg-var)
-    (if (null? numbers)
-	(more symbols)
-	(let loop ((patterns numbers) (clauses '()))
-	  (if (null? patterns)
-	      (finish-match-literal clauses
-				    (if (null? symbols)
-					(if fail-var `(,fail-var) #f)
-					(more symbols))
-				    arg-var)
-	      (receive (same other)
-		  (partition-list (lambda (p)
-				    (= (cadr (pattern-arg (car patterns) i))
-				       (cadr (pattern-arg p i))))
-				  (cdr patterns))
-		(loop other
-		      (cons `((,(cadr (pattern-arg (car patterns) i)))
-			      ,(more (cons (car patterns) same)))
-			    clauses))))))))
-
-(define (finish-match-literal clauses else arg-var)
-  (if (null? clauses)
-      else
-      `(case (literal-value ,arg-var)
-	 ,@(reverse clauses)
-	 (else ,else))))
-				   
-;------------------------------------------------------------------------------
-; GENSYM utility
-
-(define *generate-symbol-index* 0)
-
-(define (generate-symbol sym)
-  (let ((i *generate-symbol-index*))
-    (set! *generate-symbol-index* (+ i 1))
-    (concatenate-symbol sym "." i)))
-
-;------------------------------------------------------------------------------
-; Add code to check the predicate if any.
-
-(define (check-predicates patterns initial)
-  (let label ((patterns patterns))
-    (cond ((null? (cdr patterns))
-	   (let ((pattern (car patterns)))
-	     (if (pattern-predicate pattern)
-		 (make-predicate-check pattern initial #f)
-		 (make-builder pattern initial))))
-	  ((pattern-predicate (car patterns))
-	   (make-predicate-check (car patterns)
-				 initial
-				 (label (cdr patterns))))
-	  (else
-	   (error "multiple patterns matched ~S"
-		  patterns)))))
-
-(define (make-predicate-check pattern initial rest)
-  `(if (let ,(map (lambda (p)
-		    `(,(car p) ,(if (caddr p)
-				    `(literal-value ,(cadr p))
-				    (cadr p))))
-		  (pattern-env pattern))
-	 ,(pattern-predicate pattern))
-       ,(make-builder pattern initial)
-       ,rest))
-
-;------------------------------------------------------------------------------
-; Building the result of a pattern match
-; A new environment is made as the builder must keep track of how many times
-; each node in the matched pattern is used.
-; CLAUSES is a list of LET-NODES clauses for making the call nodes in the
-; produced pattern.  VALUE is what will replace the original pattern in the
-; node tree.  Any nodes that are used in the result are DETACHed.
-
-(define (make-builder pattern initial)
-  (let ((env (map (lambda (p)
-		    (list (car p) (cadr p) #f))
-		  (pattern-env pattern)))
-	(pattern (pattern-build-spec pattern))
-	(sym (generate-symbol 'result)))
-    (let ((clauses (if (and (pair? pattern)
-			    (neq? (car pattern) 'quote))
-		       (reverse (build-call sym pattern env))
-		       '()))
-	  (value (cond ((not (pair? pattern))
-			(lookup-pattern pattern env))
-		       ((eq? (car pattern) 'quote)
-			`(make-literal-node ,(build-literal (cadr pattern) env)
-					    (node-type ,initial)))
-		       (else
-			sym))))
-      `(begin
-	 ,@(filter-map (lambda (data)
-			 (if (caddr data)
-			     `(detach ,(cadr data))
-			     #f))
-		       env)
-	 (let-nodes ,clauses
-           (replace ,initial ,value))))))
-
-; Go down the arguments in PATTERN making the appropriate LET-NODES spec
-; for each.
-
-(define (build-call id pattern env)
-  (let loop ((arg-patterns (cdr pattern)) (args '()) (clauses '()))
-    (if (null? arg-patterns)
-	`((,id (,(car pattern) 0 . ,(reverse args)))
-	  . ,clauses)
-	(let ((arg (car arg-patterns)))
-	  (cond ((atom? arg)
-		 (loop (cdr arg-patterns)
-		       (cons (lookup-pattern arg env) args)
-		       clauses))
-		((eq? (car arg) 'quote)
-		 (loop (cdr arg-patterns)
-		       (cons `'(,(build-literal (cadr arg) env)
-				type/unknown)
-			     args)
-		       clauses))
-		(else
-		 (let ((sym (generate-symbol 'new)))
-		   (loop (cdr arg-patterns)
-			 (cons sym args)
-			 (append (build-call sym arg env) clauses)))))))))
-
-; A literal specification is either a number, a symbol which will bound to a
-; number, or an expression to be evaluated.
-
-(define (build-literal spec env)
-  (cond ((number? spec)
-	 spec)
-	((symbol? spec)
-	 `(literal-value ,(lookup-literal spec env)))
-	(else
-	 `(,(car spec)
-	   . ,(map (lambda (a)
-		     (build-literal a env))
-		   (cdr spec))))))
-
-; Get the identifier that will be bound to the value of PATTERN.
-
-(define (lookup-literal pattern env)
-  (cond ((assoc pattern env)
-	 => cadr)
-	(else
-	 (error "pattern ~S not found in env" pattern))))
-
-; Get the identifier that will be bound to the node value of PATTERN.
-; Annotate the environment to mark that the node has been used.
-
-(define (lookup-pattern pattern env)
-  (cond ((assoc pattern env)
-	 => (lambda (data)
-	      (if (caddr data)
-		  (error "node ~S is used more than once" (car data)))
-	      (set-car! (cddr data) 1)
-	      (cadr data)))
-	(else
-	 (error "pattern ~S not found in env" pattern))))
-
-
-
diff --git a/ps-compiler/simp/simplify.scm b/ps-compiler/simp/simplify.scm
deleted file mode 100644
index f4c11d6..0000000
--- a/ps-compiler/simp/simplify.scm
+++ /dev/null
@@ -1,93 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-
-;   Post-CPS optimizer.  All simplifications are done by changing the
-; structure of the node tree.
-;
-; There are two requirements for the simplifiers:
-;    1) Only the node being simplified and its descendents may be changed.
-;    2) If a node is changed the NODE-SIMPLIFIED? flag of that node and all
-;       its ancestors must be set to false.
-
-; No way to simplify literal or reference nodes.
-
-(define (simplify-node node)
-  (cond ((call-node? node)
-	 (simplify-call node))
-	((lambda-node? node)
-	 (simplify-lambda-body node))))
-
-(define (simplify-global-reference ref)
-  (let ((value (variable-known-value (reference-variable ref))))
-    (if value
-	(replace ref (vector->node value)))))
-
-(define (simplify-lambda-body lambda-node)
-  (let loop ()
-    (let ((node (lambda-body lambda-node)))
-      (cond ((not (node-simplified? node))
-	     (set-node-simplified?! node #t)
-             (simplify-call node)
-             (loop))))))
-
-(define (default-simplifier call)
-  (simplify-args call 0))
-
-; Utility used by many simplifiers - simplify the specified children.
-
-(define (simplify-args call start)
-  (let* ((vec (call-args call))
-         (len (vector-length vec)))
-    (do ((i start (+ i '1)))
-        ((>= i len))
-      (really-simplify-arg vec i))))
-
-; Keep simplifying a node until it stops changing.
-
-(define (simplify-arg call index)
-  (really-simplify-arg (call-args call) index))
-
-(define (really-simplify-arg vec index)
-  (let loop ((node (vector-ref vec index)))
-    (cond ((not (node-simplified? node))
-	   (set-node-simplified?! node #t)
-	   (case (node-variant node)
-	     ((reference)
-	      (if (global-variable? (reference-variable node))
-		  (simplify-global-reference node)))
-	     ((call)
-	      (simplify-call node))
-	     ((lambda)
-	      (simplify-lambda-body node)))
-	   (loop (vector-ref vec index))))))
-
-; Remove any unused arguments to L-NODE
-; Could substitute identical arguments as well...
-
-(define (simplify-known-lambda l-node)
-  (let ((unused (filter (lambda (var) (not (used? var)))
-			(if (eq? 'proc (lambda-type l-node))
-			    (cdr (lambda-variables l-node))
-			    (lambda-variables l-node)))))
-    (if (not (null? unused))
-	(let ((refs (find-calls l-node)))
-	  (for-each (lambda (var)
-		      (let ((index (+ 1 (variable-index var))))
-			(for-each (lambda (ref)
-				    (remove-ith-argument (node-parent ref)
-							 index
-							 var))
-				  refs)
-			(remove-variable l-node var)))
-		    unused)))))
-    
-; VAR is used to get the appropriate representation
-
-(define (remove-ith-argument call index var)
-  (let ((value (detach (call-arg call index))))
-    (remove-call-arg call index)
-    (move-body call
-	       (lambda (call)
-		 (let-nodes ((c1 (let 1 l1 value))
-			     (l1 (var) call))
-		   c1)))))
diff --git a/ps-compiler/util/byte-vector.scm b/ps-compiler/util/byte-vector.scm
deleted file mode 100644
index 247628f..0000000
--- a/ps-compiler/util/byte-vector.scm
+++ /dev/null
@@ -1,93 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-
-; byte vectors are just code vectors
-
-(define make-byte-vector   make-code-vector)
-(define byte-vector?       code-vector?)
-(define byte-vector-length code-vector-length)
-
-(define byte-vector-ref  code-vector-ref)
-(define byte-vector-set! code-vector-set!)
-
-(define (byte-vector-endianess)
-  (if (eq? byte-vector-word-ref high-byte-vector-word-ref)
-      'high
-      'low))
-
-(define (set-byte-vector-endianess! high-or-low)
-  (case high-or-low
-    ((high)
-     (set! byte-vector-word-ref       high-byte-vector-word-ref)
-     (set! byte-vector-half-word-ref  high-byte-vector-half-word-ref)
-     (set! byte-vector-word-set!      high-byte-vector-word-set!)
-     (set! byte-vector-half-word-set! high-byte-vector-half-word-set!))
-    ((low)
-     (set! byte-vector-word-ref       low-byte-vector-word-ref)
-     (set! byte-vector-half-word-ref  low-byte-vector-half-word-ref)
-     (set! byte-vector-word-set!      low-byte-vector-word-set!)
-     (set! byte-vector-half-word-set! low-byte-vector-half-word-set!))
-    (else
-     (error "endianess specifier is neither HIGH nor LOW" high-or-low))))
-
-(define (high-byte-vector-word-ref vector index)
-  (+ (code-vector-ref vector (+ index 3))
-     (arithmetic-shift
-      (+ (code-vector-ref vector (+ index 2))
-	 (arithmetic-shift
-	  (+ (code-vector-ref vector (+ index 1))
-	     (arithmetic-shift
-	      (code-vector-ref vector index)
-	      8))
-	  8))
-      8)))
-
-(define (high-byte-vector-word-set! vector index value)
-  (byte-vector-set! vector index       (arithmetic-shift value -24))
-  (byte-vector-set! vector (+ index 1) (arithmetic-shift value -16))
-  (byte-vector-set! vector (+ index 2) (arithmetic-shift value -8))
-  (byte-vector-set! vector (+ index 3)                   value))
-
-(define (high-byte-vector-half-word-ref vector index)
-  (+ (code-vector-ref vector (+ index 1))
-     (arithmetic-shift
-      (code-vector-ref vector index)
-      8)))
-
-(define (high-byte-vector-half-word-set! vector index value)
-  (byte-vector-set! vector index       (arithmetic-shift value -8))
-  (byte-vector-set! vector (+ index 1)                   value))
-
-(define (low-byte-vector-word-ref vector index)
-  (+ (code-vector-ref vector index)
-     (arithmetic-shift
-      (+ (code-vector-ref vector (+ index 1))
-	 (arithmetic-shift
-	  (+ (code-vector-ref vector (+ index 2))
-	     (arithmetic-shift
-	      (code-vector-ref vector (+ index 3))
-	      8))
-	  8))
-      8)))
-
-(define (low-byte-vector-word-set! vector index value)
-  (byte-vector-set! vector index                         value)
-  (byte-vector-set! vector (+ index 1) (arithmetic-shift value -8))
-  (byte-vector-set! vector (+ index 2) (arithmetic-shift value -16))
-  (byte-vector-set! vector (+ index 3) (arithmetic-shift value -24)))
-
-(define (low-byte-vector-half-word-ref vector index)
-  (+ (code-vector-ref vector index)
-     (arithmetic-shift
-      (code-vector-ref vector (+ index 1))
-      8)))
-
-(define (low-byte-vector-half-word-set! vector index value)
-  (byte-vector-set! vector index                         value)
-  (byte-vector-set! vector (+ index 1) (arithmetic-shift value -8)))
-
-; Start high-endian
-(define byte-vector-word-ref       high-byte-vector-word-ref)
-(define byte-vector-half-word-ref  high-byte-vector-half-word-ref)
-(define byte-vector-word-set!      high-byte-vector-word-set!)
-(define byte-vector-half-word-set! high-byte-vector-half-word-set!)
diff --git a/ps-compiler/util/dominators.scm b/ps-compiler/util/dominators.scm
deleted file mode 100644
index 1eea4b2..0000000
--- a/ps-compiler/util/dominators.scm
+++ /dev/null
@@ -1,273 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-;;; Find immediate dominators in a directed graph
-;;; Mark Reinhold (mbr@research.nj.nec.com)/3 February 1995
-; Debugging code removed and everything reluctantly Scheme-ized by
-; R. Kelsey, St. Valentine's Day, 1995
-
-; This fast dominator code is based upon Lengauer and Tarjan, "A Fast
-; Algorithm for Finding Dominators in a Flowgraph," ACM TOPLAS 1:1, pp.
-; 121--141, July 1979.  It runs in time $O(|E|\log|V|)$, where $|E|$ is the
-; number of edges and $|V|$ is the number of vertices.  A smaller time bound
-; of $O(|E|\alpha(|E|,|V|))$, where $\alpha$ is the inverse of Ackerman's
-; function, can be achieved with more complex versions of the internal link!
-; and eval! procedures.
-;
-; The client provides a rooted, directed graph by passing a root node,
-; successor and predecessor functions, and auxiliary procedures for accessing
-; and setting a slot in each node.  The dominator code creates a shadow of
-; the client's graph using the vertex record type defined below.  To keep
-; things clear, the client's graph is considered to contain "nodes," while
-; the shadow graph contains "vertices."
-
-(define-record-type vertex :vertex
-  (really-make-vertex node semi bucket ancestor debug)
-  vertex?
-  (node vertex-node)        ; Corresponding node in client's graph
-  (semi vertex-semi         ; A number for this vertex, w, as follows:
-	set-vertex-semi!)   ;   After w is numbered, but before its semidominator
-			    ;      is computed: w's DFS number
-		            ;   After w's semidominator is computed:
-		            ;      the number of its semidominator
-  (parent vertex-parent     ; Parent of this vertex in DFS spanning tree
-	  set-vertex-parent!)
-  (pred vertex-pred         ; Parents
-	set-vertex-pred!)
-  (label vertex-label       ; Label in spanning forest, initially this vertex
-	 set-vertex-label!)
-  (bucket vertex-bucket     ; List of vertices whose semidominator is this vertex
-	  set-vertex-bucket!)
-  (dom vertex-dom           ; A vertex, as follows:
-       set-vertex-dom!)     ;   After step 3: If the semidominator of this
-    		            ;      vertex, w, is its immediate dominator, then
-		            ;      this slot contains that vertex; otherwise,
-		            ;      this slot is a vertex v whose number is
-		            ;      smaller than w's and whose immediate dominator
-                            ;      is also w's immediate dominator
-		            ;   After step 4: The immediate dominator of this
-                            ;      vertex
-  (ancestor vertex-ancestor ; An ancestor of this vertex in the spanning forest
-	    set-vertex-ancestor!)
-  (debug vertex-debug       ; Debug field ##
-	 set-vertex-debug!))
-
-(define (make-vertex node semi)
-  (really-make-vertex node
-		      semi
-		      '()	; bucket
-		      #f	; ancestor
-		      #f))	; debug
-
-(define (push-vertex-bucket! inf elt)
-  (set-vertex-bucket! inf (cons elt (vertex-bucket inf))))
-
-
-(define (find-dominators-quickly! root		; root node
-				  succ		; maps a node to its children
-				  pred		; maps a node to its parents
-				  slot		; result slot accessor
-				  set-slot!)	; result slot setter
-  ;; Compute the dominator tree of the given rooted, directed graph;
-  ;; when done, the slot of each node will contain its immediate dominator.
-  ;; Requires that each slot initially contain #f.
-
-  (define (dfs root)
-    (let ((n 0) (vertices '()))
-      (let go ((node root) (parent #f))
-	(let ((v (make-vertex node n)))
-	  (set-slot! node v)
-	  (set! n (+ n 1))
-	  (set-vertex-parent! v parent)
-	  (set-vertex-label! v v)
-	  (set! vertices (cons v vertices))
-	  (for-each (lambda (node)
-		      (if (not (slot node))
-			  (go node v)))
-		    (succ node))))
-      
-      (let ((vertex-map (list->vector (reverse! vertices))))
-	(do ((i 0 (+ i 1)))
-	    ((= i (vector-length vertex-map)))
-	  (let ((v (vector-ref vertex-map i)))
-	    (set-vertex-pred! v (map slot (pred (vertex-node v))))))
-	(values n vertex-map))))
-
-  (define (compress! v)
-    (let ((a (vertex-ancestor v)))
-      (if (vertex-ancestor a)
-	  (begin
-	    (compress! a)
-	    (if (< (vertex-semi (vertex-label a))
-		   (vertex-semi (vertex-label v)))
-		(set-vertex-label! v (vertex-label a)))
-	    (set-vertex-ancestor! v (vertex-ancestor (vertex-ancestor v)))))))
-    
-  (define (eval! v)
-    (cond ((not (vertex-ancestor v))
-	   v)
-	  (else
-	   (compress! v)
-	   (vertex-label v))))
-  
-  (define (link! v w)
-    (set-vertex-ancestor! w v))
-  
-  (receive (n vertex-map) (dfs root)	; Step 1
-    (do ((i (- n 1) (- i 1)))
-	((= i 0))
-      (let ((w (vector-ref vertex-map i)))
-	
-	(for-each (lambda (v)		; Step 2
-		    (let ((u (eval! v)))
-		      (if (< (vertex-semi u)
-			     (vertex-semi w))
-			  (set-vertex-semi! w
-					    (vertex-semi u)))))
-		  (vertex-pred w))
-	(push-vertex-bucket! (vector-ref vertex-map (vertex-semi w)) w)
-	(link! (vertex-parent w) w)
-	
-	(for-each (lambda (v)		; Step 3
-		    ;; T&L delete v from the bucket list at this point,
-		    ;; but there is no reason to do so
-		    (let ((u (eval! v)))
-		      (set-vertex-dom! v
-				       (if (< (vertex-semi u)
-					      (vertex-semi v))
-					   u
-					   (vertex-parent w)))))
-		  (vertex-bucket (vertex-parent w)))))
-    
-    (do ((i 1 (+ i 1)))			; Step 4
-	((= i n))
-      (let ((w (vector-ref vertex-map i)))
-	(if (not (eq? (vertex-dom w)
-		      (vector-ref vertex-map (vertex-semi w))))
-	    (set-vertex-dom! w
-			     (vertex-dom (vertex-dom w))))))
-    (set-vertex-dom! (slot root) #f)
-    
-    ;(show-nodes root succ slot)	; ## debug
-    
-    (do ((i 0 (+ i 1)))			; Set dominator pointers
-	((= i n))
-      (let ((w (vector-ref vertex-map i)))
-	(let ((d (vertex-dom w)))
-	  (set-slot! (vertex-node w) (if d (vertex-node d) #f)))))))
-
-
-;;; The fast dominator algorithm is difficult to prove correct, so the
-;;; following slow code is provided in order to check its results.  The slow
-;;; algorithm, which runs in time $O(|E||V|)$, is adapted from Aho and Ullman,
-;;; _The Theory of Parsing, Translation, and Compiling_, Prentice-Hall, 1973,
-;;; p. 916.
-
-
-(define (find-dominators-slowly! root succ pred slot set-slot!)
-
-  (define vertex-succ vertex-pred)
-  (define set-vertex-succ! set-vertex-pred!)
-  (define vertex-mark vertex-ancestor)
-  (define set-vertex-mark! set-vertex-ancestor!)
-
-  (define (dfs root)
-    (let ((n 0) (vertices '()))
-      (let go ((node root) (parent #f))
-	(let ((v (make-vertex node n)))
-	  (set-slot! node v)
-	  (set! n (+ n 1))
-	  (set! vertices (cons v vertices))
-	  (set-vertex-parent! v #f)
-	  (set-vertex-label! v #f)
-	  (for-each (lambda (node)
-		      (if (not (slot node))
-			  (go node v)))
-		    (succ node))))
-
-      (for-each (lambda (v)
-		  (set-vertex-succ! v (map slot (succ (vertex-node v)))))
-		vertices)
-      (values n (reverse! vertices))))
-
-  (receive (n vertices) (dfs root)
-
-    (define (inaccessible v)
-      ;; Determine set of vertices that are inaccessible if vertex v is ignored
-      (set-vertex-mark! v #t)
-      (let go ((w (car vertices)))
-	(set-vertex-mark! w #t)
-	(for-each (lambda (u)
-		    (if (not (vertex-mark u))
-			(go u)))
-		  (vertex-succ w)))
-      (filter (lambda (w)
-		(cond
-		 ((vertex-mark w)
-		  (set-vertex-mark! w #f)
-		  #f)
-		 (else #t)))
-	      vertices))
-
-    (for-each (lambda (v) (set-vertex-dom! v (car vertices)))
-	      (cdr vertices))
-
-    (for-each (lambda (v)
-		(let ((dominated-by-v (inaccessible v)))
-		  (for-each (lambda (w)
-			      (if (eq? (vertex-dom w) (vertex-dom v))
-				  (set-vertex-dom! w v)))
-			    dominated-by-v)))
-	      (cdr vertices))
-    (set-vertex-dom! (car vertices) #f)
-
-					;(show-nodes root succ slot)	; ## debug
-
-    (for-each (lambda (v)
-		(set-slot! (vertex-node v)
-			   (let ((d (vertex-dom v)))
-			     (if d (vertex-node d) #f))))
-	      vertices)))
-
-
-(define (time-thunk thunk) (thunk))
-
-(define (find-and-check-dominators! root succ pred slot set-slot!)
-  (let ((set-fast-slot! (lambda (x v) (set-car! (slot x) v)))
-	(fast-slot (lambda (x) (car (slot x))))
-	(set-slow-slot! (lambda (x v) (set-cdr! (slot x) v)))
-	(slow-slot (lambda (x) (cdr (slot x)))))
-
-    (let go ((node root))
-      (set-slot! node (cons #f #f))
-      (for-each (lambda (node)
-		  (if (not (slot node))
-		      (go node)))
-		(succ node)))
-
-    (let ((fast (time-thunk
-		 (lambda ()
-		   (find-dominators-quickly!
-		    root succ pred fast-slot set-fast-slot!))))
-	  (slow (time-thunk (lambda ()
-			      (find-dominators-slowly!
-			       root succ pred slow-slot set-slow-slot!)))))
-
-					;     (format #t "** find-and-check-dominators!: fast ~a, slow ~a~%" fast slow)	; ##
-      (let go ((node root))
-	(if (not (eq? (fast-slot node) (slow-slot node)))
-	    (bug "Dominator algorithm error"))
-	(set-slot! node (fast-slot node))
-	(for-each (lambda (node)
-		    (if (pair? (slot node)) ; ## Assumes nodes are not pairs
-			(go node)))
-		  (succ node))))))
-
-
-(define *check?* #t)
-
-(define (find-dominators! . args)
-  (apply (if *check?*
-	     find-and-check-dominators!
-	     find-dominators-quickly!)
-	 args))
-
diff --git a/ps-compiler/util/expand-vec.scm b/ps-compiler/util/expand-vec.scm
deleted file mode 100644
index dfe2e84..0000000
--- a/ps-compiler/util/expand-vec.scm
+++ /dev/null
@@ -1,124 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-
-; Vectors of infinite length.  These work as do regular vectors except that
-; they have no fixed size.  XVECTOR-LENGTH is one more than the highest index
-; that has been passed to XVECTOR-SET!.
-;
-; (MAKE-XVECTOR <fill>)
-; (XVECTOR-LENGTH <xvec>)
-; (XVECTOR-REF <xvec> <index>)
-; (XVECTOR-SET! <xvec> <index> <value>)
-; (XVECTOR->VECTOR <xvec>)
-
-; The actual record fields are:
-;  default  - the fill value
-;  length   - total length of internal vector(s)
-;  contents - either:
-;      a: vector of entries, or
-;      b: vector of vectors of entries, vector has #f's after the last needed
-;         sub-vector, each sub-vector has length XVEC-MAX-CONTENTS-SIZE
-;  max      - maximum index used in a XVECTOR-SET!
-
-
-(define-record-type expanding-vector :expanding-vector
-  (make-expanding-vector default length contents max)
-  expanding-vector?
-  (default expanding-vector-default)
-  (length expanding-vector-length set-expanding-vector-length!)
-  (contents expanding-vector-contents set-expanding-vector-contents!)
-  (max expanding-vector-max set-expanding-vector-max!))
-
-(define (make-xvector default)
-  (make-expanding-vector default 0 '#() -1))
-
-; Maximum size of any internal vector
-
-(define xvec-max-contents-size 1024)
-
-; XVECTOR-LENGTH returns 1 + the maximum index passed to XVECTOR-SET!
-
-(define (xvector-length xvec)
-  (+ 1 (expanding-vector-max xvec)))
-
-; If INDEX points outside current storage, the default is returned, otherwise
-; the value is extracted from the one-or-two-level contents vector.
-
-(define (xvector-ref xvec index)
-  (let ((length (expanding-vector-length xvec)))
-    (cond ((>= index length)
-	   (expanding-vector-default xvec))
-	  ((<= length xvec-max-contents-size)
-	   (vector-ref (expanding-vector-contents xvec) index))
-	  (else
-	   (vector-ref (vector-ref (expanding-vector-contents xvec)
-				   (quotient index xvec-max-contents-size))
-		       (remainder index xvec-max-contents-size))))))
-
-; Same as the above, setting instead of extracting.  INDEX is checked agains
-; the maximum index, and the contents may have to be expanded.
-
-(define (xvector-set! xvec index value)
-  (let ((length (expanding-vector-length xvec)))
-    (if (> index (expanding-vector-max xvec))
-	(set-expanding-vector-max! xvec index))
-    (cond ((>= index length)
-	   (expand-expanding-vector xvec)
-	   (xvector-set! xvec index value))
-	  ((<= length xvec-max-contents-size)
-	   (vector-set! (expanding-vector-contents xvec) index value))
-	  (else
-	   (vector-set! (vector-ref (expanding-vector-contents xvec)
-				    (quotient index xvec-max-contents-size))
-			(remainder index xvec-max-contents-size)
-			value)))))
-
-; Copy an expanding vector into a regular vector.
-
-(define (xvector->vector xvec)
-  (let ((new (make-vector (xvector-length xvec))))
-    (do ((i 0 (+ i 1)))
-        ((>= i (xvector-length xvec)))
-      (vector-set! new i (xvector-ref xvec i)))
-    new))
-
-; Expand an expanding vector.  A new length and contents are produced and
-; put in XVEC.  If LENGTH is below the maximum for a contents vector it is
-; doubled in size.  If the two-level structure is being used, a new sub-
-; vector is added to it.
-
-(define (expand-expanding-vector xvec)
-  (let ((length   (expanding-vector-length   xvec))
-	(contents (expanding-vector-contents xvec))
-	(default  (expanding-vector-default  xvec))
-	(finish (lambda (length contents)
-		  (set-expanding-vector-length!   xvec length)
-		  (set-expanding-vector-contents! xvec contents))))
-    (if (< length xvec-max-contents-size)
-	(let ((new (expand-vector contents default)))
-	  (finish (vector-length new) new))
-	(let ((contents (cond ((= length xvec-max-contents-size)
-			       (let ((new (make-vector 4 #f)))
-				 (vector-set! new 0 contents)
-				 new))
-			      ((vector-ref contents
-					   (- (vector-length contents) 1))
-			       (expand-vector contents #f))
-			      (else
-			       contents))))
-	  (vector-set! contents
-		       (quotient length xvec-max-contents-size)
-		       (make-vector xvec-max-contents-size default))
-	  (finish (+ length xvec-max-contents-size) contents)))))
-
-; Make a new vector twice the length of OLD and copy the contents of OLD into
-; it.  DEFAULT is used to fill in the other slots.
-
-(define (expand-vector old default)
-  (let* ((length (vector-length old))
-	 (new (make-vector (if (= 0 length) 4 (* 2 length)) default)))
-    (do ((i 0 (+ i 1)))
-	((>= i length))
-      (vector-set! new i (vector-ref old i)))
-    new))
-	  
\ No newline at end of file
diff --git a/ps-compiler/util/separators.scm b/ps-compiler/util/separators.scm
deleted file mode 100644
index 84f4827..0000000
--- a/ps-compiler/util/separators.scm
+++ /dev/null
@@ -1,195 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-
-; Code to determine the separation vertices of a graph
-
-; NODES is a list of nodes
-; (TO node) returns a list of the nodes which are connected to this one
-; (SLOT-NODE node) and (SET-SLOT! node value) are used by the algorithm to
-; associate data with nodes (in the absence of a tables).
-
-(define (separation-vertices nodes to slot set-slot!)
-  (cond ((null? nodes)
-	 (values '() '()))
-	((null? (cdr nodes))
-	 (values nodes (list nodes)))
-	(else
-	 (receive (separators components)
-	     (real-separation-vertices (make-vertices nodes to slot set-slot!))
-	   (for-each (lambda (n) (set-slot! n #f)) nodes)
-	   (values separators components)))))
-
-(define-record-type vertex :vertex
-  (really-make-vertex data edges dfs-index)
-  vertex?
-  (data vertex-data)                  ; user's data
-  (edges vertex-edges                 ; list of edges from this vertex
-	 set-vertex-edges!)    
-  (dfs-index vertex-dfs-index         ; ordering from depth-first-search
-	     set-vertex-dfs-index!)    
-  (level vertex-level                 ; value used in algorithm...
-	 set-vertex-level!)
-  (parent vertex-parent               ; parent of this node in DFS tree
-	  set-vertex-parent!))
-
-(define (make-vertex data)
-  (really-make-vertex data '() 0))
-
-(define-record-type edge :edge
-  (make-edge from to unused?)
-  (from edge-from)             ; two (unordered) vertices
-  (to edge-to)
-  (unused? edge-unused         ; used to mark edges that have been traversed
-	   set-edge-unused!))
-
-(define (make-edge from to)
-  (really-make-edge from to #t))
-
-(define (other-vertex edge v)
-  (if (eq? v (edge-from edge))
-      (edge-to edge)
-      (edge-from edge)))
-
-(define (maybe-add-edge from to)
-  (if (and (not (eq? from to))
-	   (not (any? (lambda (e)
-			(or (eq? to (edge-from e))
-			    (eq? to (edge-to e))))
-		      (vertex-edges from))))
-      (let ((e (make-edge from to)))
-	(set-vertex-edges! from (cons e (vertex-edges from)))
-	(set-vertex-edges! to   (cons e (vertex-edges to))))))
-
-(define (make-vertices nodes to slot set-slot!)
-  (let ((vertices (map (lambda (n)
-			 (let ((v (make-vertex n)))
-			   (set-slot! n v)
-			   v))
-		       nodes)))
-    (for-each (lambda (n)
-		(for-each (lambda (n0)
-			    (maybe-add-edge (slot n) (slot n0)))
-			  (to n)))
-	      nodes)
-    vertices))
-    
-; The numbers are the algorithm step numbers from page 62 of Graph Algorithms,
-; Shimon Even, Computer Science Press, 1979.
-; Them           Us
-;  L(v)     (vertex-level v)
-;  k(v)     (vertex-dfs-index v)
-;  f(v)     (vertex-parent v)
-;  S        stack
-;  s        start
-
-(define (real-separation-vertices vertices)
-  (do-vertex (car vertices) 0 '() (car vertices) '() '()))
-
-; 2
-
-(define (do-vertex v i stack start v-res c-res)
-  (let ((i (+ i 1)))
-    (set-vertex-level! v i)
-    (set-vertex-dfs-index! v i)
-    (find-unused-edge v i (cons v stack) start v-res c-res)))
-
-; 3
-
-(define (find-unused-edge v i stack start v-res c-res)
-  (let ((e (first edge-unused? (vertex-edges v))))
-    (if e
-	(do-edge e v i stack start v-res c-res)
-	(no-unused-edge v i stack start v-res c-res))))
-
-; 4
-
-(define (do-edge e v i stack start v-res c-res)
-  (let ((u (other-vertex e v)))
-    (set-edge-unused?! e #f)
-    (cond ((= 0 (vertex-dfs-index u))
-	   (set-vertex-parent! u v)
-	   (do-vertex u i stack start v-res c-res))
-	  (else
-	   (if (> (vertex-level v)
-		  (vertex-dfs-index u))
-	       (set-vertex-level! v (vertex-dfs-index u)))
-	   (find-unused-edge v i stack start v-res c-res)))))
-
-; 5
-
-(define (no-unused-edge v i stack start v-res c-res)
-  (let* ((parent (vertex-parent v))
-	 (p-dfs-index (vertex-dfs-index parent)))
-    (cond ((= 1 p-dfs-index)
-	   (gather-nonseparable-with-start v i stack start v-res c-res))
-	  ((< (vertex-level v) p-dfs-index)
-	   (if (< (vertex-level v)
-		  (vertex-level parent))
-	       (set-vertex-level! parent (vertex-level v)))
-	   (find-unused-edge parent i stack start v-res c-res))
-	  (else
-	   (gather-nonseparable v i stack start v-res c-res)))))
-
-; 7
-
-(define (gather-nonseparable v i stack start v-res c-res)
-  (let* ((parent (vertex-parent v))
-	 (data (vertex-data parent)))
-    (receive (vertices stack)
-	(pop-down-to stack v)
-      (find-unused-edge parent
-			i
-			stack
-			start
-			(if (not (memq? data v-res))
-			    (cons data v-res)
-			    v-res)
-			(cons (cons data (map vertex-data vertices)) c-res)))))
-
-; 9
-
-(define (gather-nonseparable-with-start v i stack start v-res c-res)
-  (receive (vertices stack)
-      (pop-down-to stack v)
-    (let* ((data (vertex-data start))
-	   (c-res (cons (cons data (map vertex-data vertices)) c-res)))
-      (if (not (any? edge-unused? (vertex-edges start)))
-	  (values v-res c-res)
-	  (find-unused-edge start
-			    i
-			    stack
-			    start
-			    (if (not (memq? data v-res))
-				(cons data v-res)
-				v-res)
-			    c-res)))))
-
-(define (pop-down-to stack v)
-  (do ((stack stack (cdr stack))
-       (res '() (cons (car stack) res)))
-      ((eq? v (car stack))
-       (values (cons v res) (cdr stack)))))
-
-(define (test-separation-vertices graph)
-  (let ((nodes (map (lambda (n)
-		      (vector (car n) #f #f))
-		    graph)))
-    (for-each (lambda (data node)
-		(vector-set! node 1 (map (lambda (s)
-					   (first (lambda (v)
-						    (eq? s (vector-ref v 0)))
-						  nodes))
-					 (cdr data))))
-	      graph
-	      nodes)
-    (receive (separation-vertices components)
-	(separation-vertices nodes
-			     (lambda (v) (vector-ref v 1))
-			     (lambda (v) (vector-ref v 2))
-			     (lambda (v val) (vector-set! v 2 val)))
-      (values (map (lambda (v) (vector-ref v 0)) separation-vertices)
-	      (map (lambda (l)
-		     (map (lambda (v) (vector-ref v 0))
-			  l))
-		   components)))))
-			   
diff --git a/ps-compiler/util/ssa.scm b/ps-compiler/util/ssa.scm
deleted file mode 100644
index c3c5b5c..0000000
--- a/ps-compiler/util/ssa.scm
+++ /dev/null
@@ -1,177 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-
-; Finding where to put phi-functions.
-;
-; First call:
-; (GRAPH->SSA-GRAPH! <root-node> <node-successors> <node-temp> <set-node-temp!>)
-;
-; Then:
-; (FIND-JOINS <nodes> <node-temp>)
-;  will return the list of nodes N for which there are (at least) two paths
-;  ... N_0 M_0 ... M_i N and ... N_1 P_0 ... P_j N such that N_0 and N_1
-;  are distinct members of <nodes> and the M's and P's are disjoint sets.
-;
-; Algorithm from:
-;   Efficiently computing static single assignment form and the control
-;     dependence graph,
-;   Ron Cytron, Jeanne Ferrante, Barry K. Rosen, Mark N. Wegman, and
-;     F. Kenneth Zadeck,
-;   ACM Transactions on Programming Languages and Systems 1991 13(4)
-;   pages 451-490
-
-(define-record-type node :node
-  (really-make-node data use-uid predecessors dominator dominated
-		    seen-mark join-mark)
-  node?
-  (data node-data)                ; user's stuff
-  (use-uid node-use-uid)          ; distinguishes between different invocations
-  (successors node-successors     ; parents
-	      set-node-successors!)
-  (predecessors node-predecessors ;  and children in the graph
-		set-node-predecessors!)
-  (dominator node-dominator       ; parent ;; initialize for goofy dominator code
-	     set-node-dominator!)
-  (dominated node-dominated       ;   and children in the dominator tree
-	     set-node-dominated!)
-  (frontier node-frontier         ; dominator frontier
-	    set-node-frontier!)
-  (seen-mark node-seen-mark       ; two markers used in
-	     set-node-seen-mark!)
-  (join-mark node-join-mark       ;  the ssa algorithm
-	     set-node-join-mark!))
-
-(define (make-node data use-uid)
-  (really-make-node data
-		    use-uid
-		    '()       ; predecessors
-		    #f        ; dominator
-		    '()       ; dominated
-		    -1        ; see-mark
-		    -1))      ; join-mark
-
-(define (graph->ssa-graph! root successors temp set-temp!)
-  (let ((graph (real-graph->ssa-graph root successors temp set-temp!)))
-    (find-dominators! (car graph)
-		      node-successors node-predecessors
-		      node-dominator set-node-dominator!)
-    (for-each (lambda (node)
-		(let ((dom (node-dominator node)))
-		  (set-node-dominated! dom (cons node (node-dominated dom)))))
-	      (cdr graph))   ; root has no dominator
-    (find-frontiers! (car graph))
-    (values)))
-
-; Turn the user's graph into a NODE graph.
-
-(define (real-graph->ssa-graph root successors temp set-temp!)
-  (let ((uid (next-uid))
-	(nodes '()))
-    (let recur ((data root))
-      (let ((node (temp data)))
-	(if (and (node? node)
-		 (= uid (node-use-uid node)))
-	    node
-	    (let ((node (make-node data uid)))
-	      (set! nodes (cons node nodes))
-	      (set-temp! data node)
-	      (let ((succs (map recur (successors data))))
-		(for-each (lambda (succ)
-			    (set-node-predecessors! succ
-						    (cons node (node-predecessors succ))))
-			  succs)
-		(set-node-successors! node succs))
-	      node))))
-    (reverse! nodes)))  ; root ends up at front
-
-; Find the dominance frontiers of the nodes in a graph.
-
-(define (find-frontiers! node)
-  (let ((frontier (let loop ((succs (node-successors node)) (frontier '()))
-               (if (null? succs)
-                   frontier
-                        (loop (cdr succs)
-                             (if (eq? node (node-dominator (car succs)))
-                                 frontier
-                                (cons (car succs) frontier)))))))
-    (let loop ((kids (node-dominated node)) (frontier frontier))
-      (cond ((null? kids)
-         (set-node-frontier! node frontier)
-      frontier)
-      (else
-            (let kid-loop ((kid-frontier (find-frontiers! (car kids)))
-                      (frontier frontier))
-               (if (null? kid-frontier)
-            (loop (cdr kids) frontier)
-              (kid-loop (cdr kid-frontier)
-                      (if (eq? node (node-dominator (car kid-frontier)))
-                          frontier
-                                (cons (car kid-frontier) frontier))))))))))
-
-(define (find-joins nodes temp)
-  (map node-data (really-find-joins (map temp nodes))))
-
-(define (really-find-joins nodes)
-  (let ((marker (next-uid)))
-    (for-each (lambda (n)
-		(set-node-seen-mark! n marker))
-	      nodes)
-    (let loop ((to-do nodes) (joins '()))
-      (if (null? to-do)
-	  joins
-	  (let frontier-loop ((frontier (node-frontier (car to-do)))
-			      (to-do (cdr to-do))
-			      (joins joins))
-	    (cond ((null? frontier)
-		   (loop to-do joins))
-		  ((eq? marker (node-join-mark (car frontier)))
-		   (frontier-loop (cdr frontier) to-do joins))
-		  (else
-		   (let ((node (car frontier)))
-		     (set-node-join-mark! node marker)
-		     (frontier-loop (cdr frontier)
-				    (if (eq? marker (node-seen-mark node))
-					to-do
-					(begin
-					  (set-node-seen-mark! node marker)
-					  (cons node to-do)))
-				    (cons node joins))))))))))
-
-; Integers as UID's
-
-(define *next-uid* 0)
-
-(define (next-uid)
-  (let ((uid *next-uid*))
-    (set! *next-uid* (+ uid 1))
-    uid))
-
-;----------------------------------------------------------------
-; Testing
-
-;(define-record-type data
-;  (name)
-;  (kids
-;   temp))
-;
-;(define-record-discloser type/data
-;  (lambda (data)
-;    (list 'data (data-name data))))
-;
-;(define (make-test-graph spec)
-;  (let ((vertices (map (lambda (d)
-;                         (data-maker (car d)))
-;                       spec)))
-;    (for-each (lambda (data vertex)
-;                (set-data-kids! vertex (map (lambda (s)
-;                                              (first (lambda (v)
-;                                                       (eq? s (data-name v)))
-;                                                     vertices))
-;                                            (cdr data))))
-;              spec
-;              vertices)
-;    vertices))
-
-;(define g1 (make-test-graph '((a b) (b c d) (c b e) (d d e) (e))))
-;(graph->ssa-graph (car g1) data-kids data-temp set-data-temp!)
-;(find-joins (list (list-ref g1 0)) data-temp)
\ No newline at end of file
diff --git a/ps-compiler/util/strong.scm b/ps-compiler/util/strong.scm
deleted file mode 100644
index 9dd94e0..0000000
--- a/ps-compiler/util/strong.scm
+++ /dev/null
@@ -1,147 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-
-; Code to find the strongly connected components of a graph.
-; (TO <vertex>) are the vertices that have an edge to <vertex>.
-; (SLOT <vertex>) and (SET-SLOT! <vertex> <value>) is a settable slot
-; used by the algorithm.
-;
-; The components are returned in a backwards topologically sorted list.
-
-(define (strongly-connected-components vertices to slot set-slot!)
-  (make-vertices vertices to slot set-slot!)
-  (let loop ((to-do vertices) (index 0) (stack #t) (comps '()))
-    (let ((to-do (find-next-vertex to-do slot)))
-      (cond ((null? to-do)
-	     (for-each (lambda (n) (set-slot! n #f)) vertices)
-	     comps)
-	    (else
-	     (call-with-values
-	      (lambda () 
-		(do-vertex (slot (car to-do)) index stack comps))
-	      (lambda (index stack comps)
-		(loop to-do index stack comps))))))))
-
-(define (find-next-vertex vertices slot)
-  (do ((vertices vertices (cdr vertices)))
-      ((or (null? vertices)
-           (= 0 (vertex-index (slot (car vertices)))))
-       vertices)))
-
-(define-record-type vertex
-  (data            ; user's data
-   )
-  ((edges   '())   ; list of vertices
-   (stack    #f)   ; next vertex on the stack
-   (index    0)    ; time at which this vertex was reached in the traversal
-   (parent   #f)   ; a vertex pointing to this one
-   (lowpoint #f)   ; lowest index in this vertices strongly connected component
-   ))
-  
-(define (make-vertices vertices to slot set-slot!)
-  (let ((maybe-slot (lambda (n)
-		      (let ((s (slot n)))
-			(if (vertex? s)
-			    s
-			    (error "graph edge points to non-vertex" n))))))
-    (for-each (lambda (n)
-		(set-slot! n (vertex-maker n)))
-	      vertices)
-    (for-each (lambda (n)
-		(set-vertex-edges! (slot n) (map maybe-slot (to n))))
-	      vertices)
-    (values)))
-
-; The numbers are the algorithm step numbers from page 65 of Graph Algorithms,
-; Shimon Even, Computer Science Press, 1979.
-
-; 2
-
-(define (do-vertex vertex index stack comps)
-  (let ((index (+ index '1)))
-    (set-vertex-index!    vertex index)
-    (set-vertex-lowpoint! vertex index)
-    (set-vertex-stack!    vertex stack)
-    (get-strong vertex index vertex comps)))
-
-; 3
-
-(define (get-strong vertex index stack comps)
-  (if (null? (vertex-edges vertex))
-      (end-vertex    vertex index stack comps)
-      (follow-edge vertex index stack comps)))
-
-; 7
-
-(define (end-vertex vertex index stack comps)
-  (call-with-values
-   (lambda ()
-     (if (= (vertex-index vertex) (vertex-lowpoint vertex))
-	 (unwind-stack vertex stack comps)
-	 (values stack comps)))
-   (lambda (stack comps)
-     (cond ((vertex-parent vertex)
-	    => (lambda (parent)
-		 (if (> (vertex-lowpoint parent) (vertex-lowpoint vertex))
-		     (set-vertex-lowpoint! parent (vertex-lowpoint vertex)))
-		 (get-strong parent index stack comps)))
-	   (else
-	    (values index stack comps))))))
-
-(define (unwind-stack vertex stack comps)
-  (let loop ((n stack) (c '()))
-    (let ((next (vertex-stack n))
-          (c (cons (vertex-data n) c)))
-      (set-vertex-stack! n #f)
-      (if (eq? n vertex)
-          (values next (cons c comps))
-          (loop next c)))))
-
-; 4
-
-(define (follow-edge vertex index stack comps)
-  (let* ((next (pop-vertex-edge! vertex))
-         (next-index (vertex-index next)))
-    (cond ((= next-index 0)
-           (set-vertex-parent! next vertex)
-           (do-vertex next index stack comps))
-          (else
-           (if (and (< next-index (vertex-index vertex))
-                    (vertex-stack next)
-                    (< next-index (vertex-lowpoint vertex)))
-               (set-vertex-lowpoint! vertex next-index))
-           (get-strong vertex index stack comps)))))
-
-(define (pop-vertex-edge! vertex)
-  (let ((edges (vertex-edges vertex)))
-    (set-vertex-edges! vertex (cdr edges))
-    (car edges)))
-
-; GRAPH is ((<symbol> . <symbol>*)*)
-             
-;(define (test-strong graph)
-;  (let ((vertices (map (lambda (n)
-;                         (vector (car n) #f #f))
-;                       graph)))
-;    (for-each (lambda (data vertex)
-;                (vector-set! vertex 1 (map (lambda (s)
-;                                             (first (lambda (v)
-;                                                      (eq? s (vector-ref v 0)))
-;                                                    vertices))
-;                                           (cdr data))))
-;              graph
-;              vertices)
-;    (map (lambda (l)
-;           (map (lambda (n) (vector-ref n 0)) l))
-;         (strongly-connected-components vertices
-;                                        (lambda (v) (vector-ref v 1))
-;                                        (lambda (v) (vector-ref v 2))
-;                                        (lambda (v val)
-;                                          (vector-set! v 2 val))))))
-
-
-
-
-
-
-
diff --git a/ps-compiler/util/syntax.scm b/ps-compiler/util/syntax.scm
deleted file mode 100644
index a4120a4..0000000
--- a/ps-compiler/util/syntax.scm
+++ /dev/null
@@ -1,61 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-
-; Syntax used by the compiler
-
-; Subrecords
-;
-; SUPER is the name of the existing record
-; SUB is the name of the subrecord
-; SLOT is the name of the slot to use in the existing sturcture
-; STUFF is the usual stuff from DEFINE-RECORD-TYPE
-
-(define-syntax define-subrecord
-  (lambda (form rename compare)
-    (let ((super (cadr form))
-	  (sub (caddr form))
-	  (slot (cadddr form))
-	  (stuff (cddddr form)))
-      (let ((access-names (map (lambda (spec)
-				 (if (pair? spec) (car spec) spec))
-			       (append (car stuff) (cadr stuff))))
-	    (set-names (append (filter-map (lambda (spec)
-					     (if (pair? spec) (car spec) #f))
-					   (car stuff))
-			       (map (lambda (spec)
-				      (if (pair? spec) (car spec) spec))
-				    (cadr stuff)))))
-	`(begin (define-record-type ,sub . ,stuff)
-		,@(map (lambda (name)
-			 `(define ,(concatenate-symbol super '- name)
-			    (lambda (v)
-			      (,(concatenate-symbol sub '- name)
-			       (,slot v)))))
-		       access-names)
-		,@(map (lambda (name)
-			 `(define ,(concatenate-symbol 'set- super '- name '!)
-			    (lambda (v n)
-			      (,(concatenate-symbol 'set- sub '- name '!)
-			       (,slot v)
-			       n))))
-		       set-names))))))
-
-;(define-syntax define-simple-record-type
-;  (lambda (form rename compare)
-;    (let ((name (cadr form))
-;          (slots (cddr form)))
-;      `(begin (define-record-type ,name ,slots ())
-;              (define ,(concatenate-symbol 'make- name)
-;                ,(concatenate-symbol name '- 'maker))))))
-
-; Nothing actually local about it...
-
-(define-syntax define-local-syntax
-  (lambda (form rename compare)
-    (let ((pattern (cadr form))
-	  (body (cddr form)))
-      `(,(rename 'define-syntax) ,(car pattern)
-	 (,(rename 'lambda) (form rename compare)
-	   (,(rename 'destructure) ((,(cdr pattern)
-				     (,(rename 'cdr) form)))
-	     . ,body))))))
diff --git a/ps-compiler/util/transitive.scm b/ps-compiler/util/transitive.scm
deleted file mode 100644
index 3e0141b..0000000
--- a/ps-compiler/util/transitive.scm
+++ /dev/null
@@ -1,401 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-; General transitive closure
-
-; (make-graph-from-predecessors nodes node-parents node-temp set-node-temp!)
-;            -> graph
-; (make-graph-from-successors nodes node-kids node-temp set-node-temp!)
-;            -> graph
-;
-; (transitive-or! graph elements set-elements! element-temp set-element-temp!)
-; (transitive-or-with-kill! graph elements set-elements! node-kills element-temp set-element-temp!)
-; (transitive-or-with-pass! graph elements set-elements! node-passes element-temp set-element-temp!)
-;
-; (transitive-and! graph elements set-elements! element-temp set-element-temp!)
-; (transitive-and-with-kill! graph elements set-elements! node-kills element-temp set-element-temp!)
-; (transitive-and-with-pass! graph elements set-elements! node-passes element-temp set-element-temp!)
-
-;----------------
-
-(define (make-graph-from-predecessors user-nodes user-node-parents node-temp set-node-temp!)
-  (let ((nodes (make-nodes user-nodes set-node-temp!)))
-    (connect-nodes-using-parents! nodes user-node-parents node-temp)
-    (for-each (lambda (node)
-		(set-node-temp! (node-data node) #f))
-	      nodes)
-    (make-graph nodes)))
-
-(define (make-graph-from-successors user-nodes user-node-kids node-temp set-node-temp!)
-  (let ((nodes (make-nodes user-nodes set-node-temp!)))
-    (connect-nodes-using-children! nodes user-node-kids node-temp)
-    (for-each (lambda (node)
-		(set-node-temp! (node-data node) #f))
-	      nodes)
-    (make-graph nodes)))
-
-(define (make-nodes user-nodes set-node-temp!)    
-  (map (lambda (data)
-	 (let ((node (node-maker data '() '())))
-	   (set-node-temp! data node)
-	   node))
-       user-nodes))
-
-(define-record-type graph
-  (nodes         ; list of nodes
-   )
-  ())
-
-(define make-graph graph-maker)
-  
-(define-record-type node
-  (data          ; user's data
-   (parents)     ; predecessors
-   (kids))       ; successors
-  (elt-set       ; elements
-   kill-set      ; elements that are not passed
-   changed?      ; change flag for iteration
-   ))
-
-;------------------------------
-; Six false fronts for the real procedure.
-
-(define (transitive-or! graph elts set-elts! elt-hash set-elt-hash!)
-  (do-it graph elts set-elts! #f #f elt-hash set-elt-hash!
-	 (transitive-or-closure! or-update-node)))
-
-(define (transitive-or-with-kill! graph elts set-elts! kill-elts elt-hash set-elt-hash!)
-  (do-it graph elts set-elts! kill-elts #f elt-hash set-elt-hash!
-	 (transitive-or-closure! or-update-node-with-kill)))
-
-(define (transitive-or-with-pass! graph elts set-elts! pass-elts elt-hash set-elt-hash!)
-  (do-it graph elts set-elts! pass-elts #t elt-hash set-elt-hash!
-	 (transitive-or-closure! or-update-node-with-kill)))
-
-(define (transitive-and! graph elts set-elts! elt-hash set-elt-hash!)
-  (do-it graph elts set-elts! #f #f elt-hash set-elt-hash!
-	 (transitive-and-closure! and-update-node)))
-
-(define (transitive-and-with-kill! graph elts set-elts! kill-elts elt-hash set-elt-hash!)
-  (do-it graph elts set-elts! kill-elts #f elt-hash set-elt-hash!
-	 (transitive-and-closure! and-update-node-with-kill)))
-
-(define (transitive-and-with-pass! graph elts set-elts! pass-elts elt-hash set-elt-hash!)
-  (do-it graph elts set-elts! pass-elts #t elt-hash set-elt-hash!
-	 (transitive-and-closure! and-update-node-with-kill)))
-
-(define (do-it graph elts set-elts! kill-elts pass? elt-hash set-elt-hash! op)
-  (let* ((nodes (graph-nodes graph))
-	 (elt-unhash-vec (add-elements! nodes elts kill-elts pass?
-					elt-hash set-elt-hash!)))
-    (op nodes)
-    (record-results! nodes elt-unhash-vec set-elts!)
-    (do ((i 0 (+ i 1)))
-	((= i (vector-length elt-unhash-vec)))
-      (set-elt-hash! (vector-ref elt-unhash-vec i) #f))
-    (values)))
-
-;----------------
-; Setting the kids field of the nodes
-
-(define (connect-nodes-using-children! nodes children node-slot)
-  (for-each
-   (lambda (node)
-     (set-node-kids! node
-		      (map (lambda (kid)
-			     (let ((t (node-slot kid)))
-			       (if (not (node? t))
-				   (missing-node-error kid "child" node))
-			       (set-node-parents! t
-						   (cons node
-							 (node-parents t)))
-			       t))
-			   (children (node-data node)))))
-   nodes))
-
-(define (connect-nodes-using-parents! nodes parents node-slot)
-  (for-each
-   (lambda (node)
-     (set-node-parents! node
-			 (map (lambda (parent)
-				(let ((t (node-slot parent)))
-				  (if (not (node? t))
-				      (missing-node-error t "parent" node))
-				  (set-node-kids! t
-						   (cons node
-							 (node-kids t)))
-				  t))
-			      (parents (node-data node)))))
-   nodes))
-
-(define (missing-node-error node relationship relation)
-  (error (format #f "Transitive - ~S, ~A of ~S, not in list of nodes"
-		 node relationship (node-data relation))))
-
-;----------------
-
-(define (add-elements! nodes node-elements node-kills pass?
-		       element-temp set-element-temp!)
-  (let ((unhash-vec (element-hasher nodes node-elements element-temp set-element-temp!))
-	(element-hash (make-element-hash element-temp)))
-    (for-each (lambda (node)
-		(set-node-elt-set! node
-				   (make-element-set (node-elements (node-data node))
-						     element-hash)))
-	      nodes)
-    (if node-kills
-	(for-each (lambda (node)
-		    (let ((kill-set (make-element-set (node-kills (node-data node))
-						      element-hash)))
-		      (set-node-kill-set! node (if pass?
-						   (integer-set-not kill-set)
-						   kill-set))))
-		  nodes))
-    unhash-vec))
-
-(define (make-element-set elts elt-hash)
-  (let loop ((elts elts) (set (make-empty-integer-set)))
-    (if (null? elts)
-	set
-	(loop (cdr elts)
-	      (cond ((elt-hash (car elts))
-		     => (lambda (hash)
-			  (add-to-integer-set set hash)))
-		    (else set))))))
-
-;----------------
-; Counting the elements and assigning numbers to them
-
-(define-record-type element-hash
-  (number  ; the element-hash record is just a way of tagging this number
-   )       ; with a unique predicate
-  ())
-
-(define (element-hasher nodes elts elt-hash set-elt-hash!)
-  (let loop ((to-do '()) (ts nodes) (all-elts '()) (count 0))
-    (cond ((null? to-do)
-	   (if (null? ts)
-	       (real-element-hasher all-elts count)
-	       (loop (elts (node-data (car ts))) (cdr ts) all-elts count)))
-	  ((element-hash? (elt-hash (car to-do)))
-	   (loop (cdr to-do) ts all-elts count))
-	  (else
-	   (set-elt-hash! (car to-do) (element-hash-maker count))
-	   (loop (cdr to-do) ts (cons (car to-do) all-elts) (+ count 1))))))
-
-(define (real-element-hasher elts count)
-  (let ((unhash-vec (make-vector count)))
-    (do ((i (- count 1) (- i 1))
-	 (elts elts (cdr elts)))
-	((null? elts))
-      (vector-set! unhash-vec i (car elts)))
-    unhash-vec))
-
-(define (make-element-hash elt-hash)
-  (lambda (elt)
-    (let ((hash (elt-hash elt)))
-      (if (element-hash? hash)
-	  (element-hash-number hash)
-	  #f))))
-
-;----------------
-; Turn the element sets into lists of elements and clean up stray pointers
-; at the same time.
-
-(define (record-results! nodes elt-unhash-vec set-elts!)
-  (for-each (lambda (node)
-	      (set-elts! (node-data node)
-			 (map-over-integer-set
-			  (lambda (i) (vector-ref elt-unhash-vec i))
-			  (node-elt-set node)))
-	      (set-node-elt-set! node #f)
-	      (set-node-kill-set! node #f))
-	    nodes))
-
-;----------------
-; The OR algorithm - keeps passing elements around until the changes stop.
-
-(define (transitive-or-closure! op)
-  (lambda (nodes)
-    (for-each (lambda (node)
-		(set-node-changed?! node #t))
-	      nodes)
-    (let loop ((to-do nodes))
-      (if (not (null? to-do))
-	  (let* ((node (car to-do))
-		 (elt-set (node-elt-set node)))
-	    (set-node-changed?! node #f)
-	    (let kids-loop ((ts (node-kids node))
-			    (to-do (cdr to-do)))
-	      (cond ((null? ts)
-		     (loop to-do))
-		    ((and (op (car ts) elt-set)
-			  (not (node-changed? (car ts))))
-		     (set-node-changed?! (car ts) #t)
-		     (kids-loop (cdr ts) (cons (car ts) to-do)))
-		    (else
-		     (kids-loop (cdr ts) to-do)))))))))
-
-; The weird function INTEGER-SET-SUBTRACT&IOR-WITH-TEST! takes three integer
-; sets, subtracts the second from the first and inclusive OR's the result
-; with the third.  It returns the resulting set and a flag which is #T if
-; the result is not the same as the original third set.  The inclusive OR
-; may be destructive.
-
-(define (or-update-node-with-kill node elt-set)
-  (receive (set change?)
-      (integer-set-subtract&ior-with-test! elt-set
-					   (node-kill-set node)
-					   (node-elt-set node))
-    (set-node-elt-set! node set)
-    change?))
-
-(define (or-update-node node elt-set)
-  (receive (set change?)
-      (integer-set-ior-with-test! elt-set
-				  (node-elt-set node))
-    (set-node-elt-set! node set)
-    change?))
-
-; Implementations using simpler, nondestructive operations (these might be
-; done more efficiently if they had access to the underlying representation
-; of integer sets).
-
-(define (integer-set-subtract&ior-with-test! set1 set2 set3)
-  (let ((result (integer-set-ior set3 (integer-set-subtract set1 set2))))
-    (values result (not (integer-set-equal? set3 result)))))
-
-(define (integer-set-ior-with-test! set1 set3)
-  (let ((result (integer-set-ior set3 set1)))
-    (values result (not (integer-set-equal? set3 result)))))
-
-;----------------
-; The AND algorithm - keeps a to-do list of nodes whose parents' elements
-; have changed, instead of a list of nodes whose elements have changed.
-
-(define (transitive-and-closure! op)
-  (lambda (nodes)
-    (let loop ((to-do (filter (lambda (node)
-				(if (not (null? (node-parents node)))
-				    (begin
-				      (set-node-changed?! node #t)
-				      #t)
-				    #f))
-			      nodes)))
-      (if (not (null? to-do))
-	  (let ((node (car to-do)))
-	    (set-node-changed?! node #f)
-	    (if (op node)
-		(let kids-loop ((ts (node-kids node))
-				(to-do (cdr to-do)))
-		  (cond ((null? ts)
-			 (loop to-do))
-			((node-changed? (car ts))
-			 (kids-loop (cdr ts) to-do))
-			(else
-			 (set-node-changed?! (car ts) #t)
-			 (kids-loop (cdr ts) (cons (car ts) to-do)))))
-		(loop (cdr to-do))))))))
-  
-; These are the same as for OR except that we AND together the parents'
-; elt-sets instead of using the one provided.
-
-(define (and-update-node-with-kill node)
-  (receive (set change?)
-      (integer-set-subtract&ior-with-test! (parents-elt-set node)
-					   (node-kill-set node)
-					   (node-elt-set node))
-    (set-node-elt-set! node set)
-    change?))
-  
-(define (and-update-node node)
-  (receive (set change?)
-      (integer-set-ior-with-test! (parents-elt-set node)
-				  (node-elt-set node))
-    (set-node-elt-set! node set)
-    change?))
-
-(define (parents-elt-set node)
-  (do ((parents (cdr (node-parents node))
-		(cdr parents))
-       (elts (node-elt-set (car (node-parents node)))
-	     (integer-set-and elts (node-elt-set (car parents)))))
-      ((null? parents)
-       elts)))
-
-;------------------------------------------------------------
-; Testing
-
-; GRAPH is ((<symbol>           name
-;            (element*)         elements
-;            (element*)         kills
-;            . <symbol*>)*)     children
-;
-'((node1 (elt1 elt2) ()     node2)
-  (node2 (elt3)      (elt2) node1 node3)
-  (node3 ()          ()     ))
-
-'((a (1) () b)
-  (b ()  () ))
-
-'((a (1 2 3 4) (1) b)
-  (b ()        (2) c)
-  (c ()        (3) d)
-  (d (5)       (4) a))
-             
-(define (test-transitive graph down? or? pass?)
-  (let* ((elts '())
-	 (get-elt (lambda (sym)
-		    (cond ((first (lambda (v)
-				    (eq? sym (vector-ref v 0)))
-				  elts)
-			   => identity)
-			  (else
-			   (let ((new (vector sym #f)))
-			     (set! elts (cons new elts))
-			     new)))))
-	 (vertices (map (lambda (n)
-			  (vector (car n)
-				  (map get-elt (cadr n))
-				  (map get-elt (caddr n))
-				  #f #f))
-			graph)))
-    (for-each (lambda (data vertex)
-		(vector-set! vertex 3 (map (lambda (s)
-					     (first (lambda (v)
-						      (eq? s (vector-ref v 0)))
-						    vertices))
-					   (cdddr data))))
-	      graph
-	      vertices)
-    (let ((the-graph ((if down?
-			  make-graph-from-successors
-			  make-graph-from-predecessors)
-		      vertices
-		      (lambda (x) (vector-ref x 3))
-		      (lambda (x) (vector-ref x 4))
-		      (lambda (x v) (vector-set! x 4 v)))))
-      (if (every? (lambda (n) (null? (caddr n))) graph)
-	  ((if or? transitive-or! transitive-and!)
-	   the-graph
-	   (lambda (v) (vector-ref v 1))        ; elts
-	   (lambda (v x) (vector-set! v 1 x))   ; set-elts!
-	   (lambda (e) (vector-ref e 1))        ; elt-hash
-	   (lambda (e x) (vector-set! e 1 x)))  ; set-elt-hash!
-          ((if or?					    
-	       (if pass?
-		   transitive-or-with-pass!
-		   transitive-or-with-kill!)
-	       (if pass?
-		   transitive-and-with-pass!
-		   transitive-and-with-kill!))
-	   the-graph
-	   (lambda (v) (vector-ref v 1))         ; elts
-	   (lambda (v x) (vector-set! v 1 x))    ; set-elts!
-	   (lambda (v) (vector-ref v 2))         ; kills
-	   (lambda (e) (vector-ref e 1))         ; elt-hash
-	   (lambda (e x) (vector-set! e 1 x))))) ; set-elt-hash!
-    (map (lambda (v)
-	   (list (vector-ref v 0)
-		 (map (lambda (e) (vector-ref e 0))
-		      (vector-ref v 1))))
-	 vertices)))
diff --git a/ps-compiler/util/util.scm b/ps-compiler/util/util.scm
deleted file mode 100644
index 6873505..0000000
--- a/ps-compiler/util/util.scm
+++ /dev/null
@@ -1,187 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-
-; Messages
-;==========================================================================
-
-(define (bug format-string . args)
-  (apply error (list "~?~%  (compiler error)" format-string args)))
-
-(define (user-error format-string . args)
-  (apply error (list "~?~%  (source error)" format-string args)))
-
-(define (user-warning format-string . args)
-  (apply error (list "~?~%  (source error)" format-string args)))
-
-; Little utilities.
-;========================================================================
-
-(define (true  x) #t)
-(define (false x) #f)
-
-(define (or-map proc list)
-  (do ((list list (cdr list))
-       (r '#f (or (proc (car list)) r)))
-      ((null? list) r)))
-
-(define (remove-similar-elts pred list)
-  (do ((list list (cdr list))
-       (res  '()  (if (mem? pred (car list) res)
-                      res
-                      (cons (car list) res))))
-      ((null-list? list)
-       res)))
-
-(define (select-from-table pred table)
-  (let ((res '()))
-    (table-walk (lambda (key entry)
-                  (if (pred key entry)
-                      (set! res `((,key . ,entry) . ,res))))
-                table)
-    res))
-
-(define (table->list table)
-  (select-from-table (lambda (x y) #t) table))
-
-(define (table->entry-list table)
-  (let ((res '()))
-    (table-walk (lambda  (key entry)
-                  (set! res (cons entry res)))
-                table)
-    res))
-
-(define (table-push table key val)
-  (let ((old (table-ref table key)))
-    (table-set! table key (if old
-			      (cons val old)
-			      (list val)))
-    val))
-
-(define (table-pop table key)
-  (let ((old (table-ref table key)))
-    (table-set! table key (cdr old))
-    (car old)))
-
-(define (merge-lists x y)
-  (cond ((null? y) x)
-        (else (do ((z x (cdr z))
-                   (u y (let ((w (car z)))
-                          (if (memq? w u) u (cons w u)))))
-                  ((null? z) u)))))
-
-(define (vector-every? pred vec)
-  (let loop ((i (- (vector-length vec) '1)))
-    (cond ((< i '0)
-	   '#t)
-          ((not (pred (vector-ref vec i)))
-	   '#f)
-          (else
-	   (loop (- i '1))))))
-
-(define (make-ignorable vars)
-  (let loop ((vars vars) (res '()))
-    (cond ((null? vars)
-           `(ignorable . ,res))
-          ((atom? vars)
-           `(ignorable ,vars . ,res))
-          (else
-           (loop (cdr vars) (cons (car vars) res))))))
-
-(define (sub-vector->list vec start)
-  (do ((i (- (vector-length vec) '1) (- i '1))
-       (r '() (cons (vector-ref vec i) r)))
-      ((< i start)
-       r)))
-
-; A version of ASSQ that works on lists containing atoms.
-
-(define (flag-assq obj list)
-  (let loop ((l list))
-    (if (null-list? l) 
-        #f
-        (let ((z (car l)))
-          (if (and (pair? z)
-                   (eq? obj (car z)))
-              z
-              (loop (cdr l)))))))
-
-; T system stuff
-
-(define (enforce predicate value)
-  (if (predicate value)
-      value
-      (error "enforce ~A failed on ~A" predicate value)))
-
-(define (writec port char)
-  (write-char char port))
-
-(define (mem? predicate object list)
-  (let loop ((list list))
-    (cond ((null? list)
-	   #f)
-	  ((predicate object (car list))
-	   #t)
-	  (else
-	   (loop (cdr list))))))
-
-(define (walk-vector procedure vector)
-  (do ((i 0 (+ i 1)))
-      ((>= i (vector-length vector))
-       (values))
-    (procedure (vector-ref vector i))))
-
-(define (vector-replace to from count)
-  (do ((i 0 (+ i 1)))
-      ((>= i count))
-    (vector-set! to i (vector-ref from i)))
-  (values))
-
-(define (copy-vector vector)
-  (let ((new (make-vector (vector-length vector))))
-    (do ((i 0 (+ i 1)))
-	((= i (vector-length vector)))
-      (vector-set! new i (vector-ref vector i)))
-    new))
-
-(define (copy-list list)
-  (if (null-list? list)
-      list
-      (let ((copy (cons (car list) '())))
-	(let loop ((list (cdr list)) (result copy))
-	  (cond ((not (null-list? list))
-		 (let ((next (cons (car list) '())))
-		   (set-cdr! result next)
-		   (loop (cdr list) next)))))
-	copy)))
-
-(define (symbol-hash symbol)
-  (string-hash (symbol->string symbol)))
-
-(define string-hash (structure-ref features string-hash))
-
-(define (object-hash x)
-  0)           ; wah!
-
-(define (union l1 l2)
-  (if (null? l2)
-      l1
-      (do ((l1 l1 (cdr l1))
-	   (res l2 (if (memq? (car l1) res) res (cons (car l1) res))))
-	  ((null? l1)
-	   res))))
-
-(define (intersection l1 l2)
-  (if (null? l2)
-      '()
-      (do ((l1 l1 (cdr l1))
-	   (res '() (if (memq? (car l1) l2) (cons (car l1) res) res)))
-	  ((null? l1)
-	   res))))
-
-(define (set-difference l1 l2)
-  (if (null? l2)
-      l1
-      (do ((l1 l1 (cdr l1))
-	   (res '() (if (memq? (car l1) l2) res (cons (car l1) res))))
-	  ((null? l1)
-	   res))))
diff --git a/ps-compiler/util/z-set.scm b/ps-compiler/util/z-set.scm
deleted file mode 100644
index 2df83d2..0000000
--- a/ps-compiler/util/z-set.scm
+++ /dev/null
@@ -1,38 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
-
-
-; Sets of integers implemented as integers.
-
-(define (make-empty-integer-set)
-  0)
-
-(define (add-to-integer-set set integer)
-  (bitwise-ior set (arithmetic-shift 1 integer)))
-
-(define integer-set-chunk-size 24)
-(define word-mask (- (arithmetic-shift 1 integer-set-chunk-size) 1))
-
-; The nested loop reduces the amount of bignum arithmetic needed (and reduces
-; the time by as much as a factor of 10).
-
-(define (map-over-integer-set proc set)
-  (do ((set set (arithmetic-shift set (- integer-set-chunk-size)))
-       (i 0 (+ i integer-set-chunk-size))
-       (l '() (do ((set (bitwise-and set word-mask) (arithmetic-shift set -1))
-		   (j 0 (+ j 1))
-		   (l l (if (odd? set)
-			    (cons (proc (+ i j)) l)
-			    l)))
-		  ((or (= 0 set) (>= j integer-set-chunk-size))
-		   l))))
-      ((= 0 set)
-       (reverse l))))
-
-(define integer-set-and bitwise-and)
-(define integer-set-ior bitwise-ior)
-(define integer-set-not bitwise-not)
-
-(define (integer-set-subtract set1 set2)
-  (bitwise-and set1 (bitwise-not set2)))
-
-(define integer-set-equal? =)
\ No newline at end of file
diff --git a/scheme/alt-packages.scm b/scheme/alt-packages.scm
deleted file mode 100644
index 4b364d1..0000000
--- a/scheme/alt-packages.scm
+++ /dev/null
@@ -1,135 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; This configuration file provides alternative implementations of the
-; low, run-time, and run-time-internals structures.  Cf. the interface
-; definitions in packages.scm.
-
-(define-structure scheme-level-0 scheme-level-0-interface
-  (open scheme))
-
-(define-structure escapes escapes-interface ;cf. alt/low-packages.scm
-  (open scheme-level-2 define-record-types signals)
-  (files (alt escape)))
-
-(define-structures ((low-level low-level-interface)
-		    (source-file-names (export (%file-name% :syntax)))
-		    (structure-refs (export (structure-ref :syntax))))
-  (open scheme-level-2 signals)
-  (files (alt low)))
-
-(define-structure closures closures-interface
-  (open scheme-level-1 records)
-  (files (alt closure)))
-
-(define-structure locations locations-interface
-  (open scheme-level-2 records)
-  (files (alt locations)))
-
-(define-structure loopholes (export (loophole :syntax))
-  (open scheme-level-2)
-  (files (alt loophole)))
-
-(define-structure silly (export reverse-list->string)
-  (open scheme-level-1)
-  (files (alt silly)))
-
-(define-structure write-images (export write-image)
-  (open scheme-level-2
-	tables			;Forward reference
-	features bitwise ascii enumerated
-	architecture
-	templates
-	closures
-	signals)
-  (files (link data)
-	 (link transport)
-	 (link write-image)))
-
-; --------------------
-; run-time (generally speaking, things needed by the linker)
-
-; Same as in rts-packages.scm:
-(define-structure architecture architecture-interface
-  (open scheme-level-1 signals enumerated)
-  (files (vm arch)))
-
-(define-structure define-record-types define-record-types-interface
-  (open scheme-level-1 records)
-  (files (alt jar-defrecord)))
-
-; Same as in rts-packages.scm:
-(define-structure enumerated enumerated-interface
-  (open scheme-level-1 signals)
-  (files (rts defenum scm)))
-
-(define-structure fluids fluids-interface
-  (open scheme-level-1 signals)
-  (files (alt fluid)))
-
-(define-structures ((scheme-level-2 scheme-level-2-interface)
-		    (scheme-level-1 scheme-level-1-interface))
-  (open scheme))
-
-(define-structure templates templates-interface
-  (open scheme-level-1)
-  (files (alt template)
-	 (rts template)))
-
-(define-structure util util-interface
-  (open scheme-level-1)
-  (files (rts util)))
-
-(define-structure weak weak-interface
-  (open scheme-level-1 signals)
-  (files (alt weak)
-	 (rts population)))
-
-
-; --------------------
-; run-time internals (generally speaking, things not needed by the linker)
-
-; * = mentioned in more-packages.scm
-;   conditions
-;   continuations
-;   display-conditions
-; * exceptions
-; * fluids-internal
-;   methods
-;   meta-methods
-;   interrupts
-;   low-level
-;   more-types
-; * number-i/o
-; * ports
-; * reading
-; * records-internal
-;   usual-resumer
-; * wind
-;   writing
-
-(define-structure wind wind-interface
-  (open scheme-level-2)
-  (files (alt reroot)))
-
-(define-structure continuations continuations-interface
-  (open scheme-level-1 templates methods)
-  (files (alt contin)
-	 (rts continuation))
-  (optimize auto-integrate))
-
-; --------------------
-; These don't really belong here, but I sure don't know where they
-; ought to go.
-
-(define-structure environments (export *structure-ref)
-  (open )				;Assume flatloading
-  (files (alt environments)))
-
-
-; Procedure annotations
-
-(define-structure annotations
-    (export annotate-procedure procedure-annotation)
-  (open scheme-level-1)
-  (files (alt annotate)))
diff --git a/scheme/alt/ascii.scm b/scheme/alt/ascii.scm
deleted file mode 100644
index cad56c1..0000000
--- a/scheme/alt/ascii.scm
+++ /dev/null
@@ -1,69 +0,0 @@
-; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-;;;; Portable definitions of char->ascii and ascii->char
-
-; Don't detabify this file!
-
-; This module defines char->ascii and ascii->char in terms of
-; char->integer and integer->char, with no assumptions about the encoding.
-; Portable except maybe for the strings that contain tab, page, and
-; carriage return characters.  Those can be flushed if necessary.
-
-(define ascii-limit 128)
-
-(define ascii-chars
-  (let* ((ascii-chars (make-vector ascii-limit #f))
-	 (unusual (lambda (s)
-		    (if (or (not (= (string-length s) 1))
-			    (let ((c (string-ref s 0)))
-			      (or (char=? c #\space)
-				  (char=? c #\newline))))
-			(error "unusual whitespace character lost" s)
-			s)))
-	 (init (lambda (i s)
-		 (do ((i i (+ i 1))
-		      (j 0 (+ j 1)))
-		     ((= j (string-length s)))
-		   (vector-set! ascii-chars i (string-ref s j))))))
-    (init 9 (unusual "	"))   ;tab
-    (init 12 (unusual ""))  ;page
-    (init 13 (unusual "
"))  ;carriage return
-    (init 10 (string #\newline))
-    (init 32 " !\"#$%&'()*+,-./0123456789:;<=>?")
-    (init 64 "@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_")
-    (init 96 "`abcdefghijklmnopqrstuvwxyz{|}~")
-    ascii-chars))
-
-(define (ascii->char n)
-  (or (vector-ref ascii-chars n)
-      (error "not a standard character's ASCII code" n)))
-
-(define native-chars
-  (let ((end (vector-length ascii-chars)))
-    (let loop ((i 0)
-	       (least    #f)
-	       (greatest #f))
-      (cond ((= i end)
-	     (let ((v (make-vector (+ (- greatest least) 1) #f)))
-	       (do ((i 0 (+ i 1)))
-		   ((= i end) (cons least v))
-		 (let ((c (vector-ref ascii-chars i)))
-		   (if c
-		       (vector-set! v (- (char->integer c) least) i))))))
-	    (else
-	     (let ((c (vector-ref ascii-chars i)))
-	       (if c
-		   (let ((n (char->integer c)))
-		     (loop (+ i 1)
-			   (if least    (min least    n) n)
-			   (if greatest (max greatest n) n)))
-		   (loop (+ i 1) least greatest))))))))
-
-(define (char->ascii char)
-  (or (vector-ref (cdr native-chars)
-		  (- (char->integer char) (car native-chars)))
-      (error "not a standard character" char)))
-
-(define ascii-whitespaces '(32 10 9 12 13)) ;space linefeed tab page return
diff --git a/scheme/alt/bitwise-tests.scm b/scheme/alt/bitwise-tests.scm
deleted file mode 100644
index 665adfb..0000000
--- a/scheme/alt/bitwise-tests.scm
+++ /dev/null
@@ -1,58 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Lost: (ARITHMETIC-SHIFT 5 27) => -402653184 [wanted 671088640.]
-; Lost: (ARITHMETIC-SHIFT 5 28) => 268435456 [wanted 1342177280.]
-
-
-(define (testit name proc x y z)
-  (let ((result (proc x y)))
-    (if (not (= result z))
-	(begin (display "Lost: ")
-	       (write `(,name ,x ,y))
-	       (display " => ")
-	       (write result)
-	       (display " [wanted ")
-	       (write z)
-	       (display "]")
-	       (newline)))))
-
-(define most-positive-fixnum
-  (let ((n (arithmetic-shift 2 27))) (+ n (- n 1))))
-
-(define (test-left-shifts x)
-  (let ((crossover (arithmetic-shift 2 27)))
-    (do ((y 0 (+ y 1))
-	 (z x (* z (if (>= z crossover) 2. 2))))
-	((= y 34))
-      (testit 'arithmetic-shift arithmetic-shift x y z))))
-
-(test-left-shifts 5)
-(test-left-shifts -5)
-
-(define (test-right-shifts x)
-  (do ((y 0 (- y 1))
-       (z x (quotient z 2)))
-      ((= y -34))
-    (testit 'arithmetic-shift arithmetic-shift x y z)))
-
-(test-right-shifts (* 5 (expt 2 36)))
-(test-right-shifts (* -5 (expt 2 36)))
-
-(define (bit1? x)
-  (if (< x 0)
-      (even? (quotient (- -1 x) 2))
-      (odd? (quotient x 2))))
-
-(define (try-truth-table name proc predicate)
-  (do ((x -4 (+ x 1)))
-      ((= x 4))
-    (do ((y -4 (+ y 1)))
-	((= y 4))
-      (testit name proc x y
-	      (+ (if (predicate (odd? x) (odd? y)) 1 0)
-		 (if (predicate (bit1? x) (bit1? y)) 2 0)
-		 (if (predicate (negative? x) (negative? y)) -4 0))))))
-
-(try-truth-table 'bitwise-and bitwise-and (lambda (a b) (and a b)))
-(try-truth-table 'bitwise-ior bitwise-ior (lambda (a b) (or a b)))
diff --git a/scheme/alt/bitwise.scm b/scheme/alt/bitwise.scm
deleted file mode 100644
index 1a1f4f6..0000000
--- a/scheme/alt/bitwise.scm
+++ /dev/null
@@ -1,44 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Bitwise operators written in vanilla Scheme.
-; Written for clarity and simplicity, not for speed.
-
-; No need to use these in Scheme 48 since Scheme 48's virtual machine
-; provides fast machine-level implementations.
-
-
-(define (bitwise-not i)
-  (- -1 i))
-
-(define (bitwise-and x y)
-  (cond ((= x 0) 0)
-	((= x -1) y)
-	(else
-	 (+ (* (bitwise-and (arithmetic-shift x -1)
-			    (arithmetic-shift y -1))
-	       2)
-	    (* (modulo x 2) (modulo y 2))))))
-
-(define (bitwise-ior x y)
-  (bitwise-not (bitwise-and (bitwise-not x)
-			    (bitwise-not y))))
-
-(define (bitwise-xor x y)
-  (bitwise-and (bitwise-not (bitwise-and x y))
-	       (bitwise-ior x y)))
-
-(define (bitwise-eqv x y)
-  (bitwise-not (bitwise-xor x y)))
-
-
-(define (arithmetic-shift n m)
-  (floor (* n (expt 2 m))))
-
-
-(define (count-bits x)		; Count 1's in the positive 2's comp rep
-  (let ((x (if (< x 0) (bitwise-not x) x)))
-    (do ((x x (arithmetic-shift x 1))
-	 (result 0 (+ result (modulo x 2))))
-	((= x 0) result))))
-
-;(define (integer-length integer) ...) ;?
diff --git a/scheme/alt/closure.scm b/scheme/alt/closure.scm
deleted file mode 100644
index 3cabfaf..0000000
--- a/scheme/alt/closure.scm
+++ /dev/null
@@ -1,11 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-
-; Closures
-
-(define closure-rtd      (make-record-type 'closure '(template env)))
-(define closure?         (record-predicate closure-rtd))
-(define make-closure     (record-constructor closure-rtd '(template env)))
-(define closure-template (record-accessor closure-rtd 'template))
-(define closure-env	 (record-accessor closure-rtd 'env))
diff --git a/scheme/alt/code-vector.scm b/scheme/alt/code-vector.scm
deleted file mode 100644
index 6121bc9..0000000
--- a/scheme/alt/code-vector.scm
+++ /dev/null
@@ -1,19 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Code-vectors implemented as vectors.
-
-(define *code-vector-marker* (list '*code-vector-marker*))
-
-(define (make-code-vector len init)
-  (let ((t (make-vector (+ len 1) init)))
-    (vector-set! t 0 *code-vector-marker*)
-    t))
-
-(define (code-vector? obj)
-  (and (vector? obj)
-       (> (vector-length obj) 0)
-       (eq? (vector-ref obj 0) *code-vector-marker*)))
-
-(define (code-vector-length t) (- (vector-length t) 1))
-(define (code-vector-ref t i) (vector-ref t (+ i 1)))
-(define (code-vector-set! t i x) (vector-set! t (+ i 1) x))
diff --git a/scheme/alt/contin.scm b/scheme/alt/contin.scm
deleted file mode 100644
index badfb4e..0000000
--- a/scheme/alt/contin.scm
+++ /dev/null
@@ -1,20 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Continuations implemented as vectors.
-
-(define *continuation-marker* (list '*continuation-marker*))
-
-(define (make-continuation len init)
-  (let ((c (make-vector (+ len 1) init)))
-    (vector-set! c 0 *continuation-marker*)
-    c))
-
-(define (continuation? obj)
-  (and (vector? obj)
-       (> (vector-length obj) 0)
-       (eq? (vector-ref obj 0) *continuation-marker*)))
-
-(define (continuation-length c) (- (vector-length c) 1))
-(define (continuation-ref c i) (vector-ref c (+ i 1)))
-(define (continuation-set! c i x) (vector-set! c (+ i 1) x))
diff --git a/scheme/alt/environments.scm b/scheme/alt/environments.scm
deleted file mode 100644
index dd990bb..0000000
--- a/scheme/alt/environments.scm
+++ /dev/null
@@ -1,7 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; don't put a copyright notice, silly shell script
-
-(define (*structure-ref struct name)
-  (eval name (interaction-environment)))
-
diff --git a/scheme/alt/escape.scm b/scheme/alt/escape.scm
deleted file mode 100644
index da90946..0000000
--- a/scheme/alt/escape.scm
+++ /dev/null
@@ -1,32 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-
-; For an explanation, see comments in rts/low.scm.
-
-; The debugger invokes EXTRACT-CONTINUATION on a "native" continuation
-; as obtained by PRIMITIVE-CWCC in order to get a VM continuation.
-; The distinction between native and VM continuations is useful when
-; debugging a program running under a VM that's different from
-; whatever machine is running the debugger.
-
-(define-record-type escape :escape
-  (make-escape proc)
-  (proc escape-procedure))
-
-(define (with-continuation esc thunk)
-  (if esc
-      ((escape-procedure esc) thunk)
-      (let ((answer (thunk)))
-	(signal 'vm-return answer)	;#f means halt
-	(call-error "halt" answer))))
-
-(define (primitive-cwcc proc)
-  (call-with-current-continuation
-    (lambda (done)
-      ((call-with-current-continuation
-	 (lambda (k)
-	   (call-with-values
-	       (lambda ()
-		 (proc (make-escape k)))
-	     done)))))))
diff --git a/scheme/alt/features-packages.scm b/scheme/alt/features-packages.scm
deleted file mode 100644
index 91cc0ea..0000000
--- a/scheme/alt/features-packages.scm
+++ /dev/null
@@ -1,29 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-
-; The following several packages have Scheme-implementation-specific 
-; variants that are much better for one reason or another than
-; the generic versions defined here.
-
-(define-structures ((signals signals-interface)
-		    (handle (export ignore-errors))
-		    (features features-interface))
-  (open scheme-level-2)
-  (files features))
-
-(define-structure records records-interface
-  (open scheme-level-2 signals)
-  (files record))
-
-(define-structure ascii (export ascii->char char->ascii)
-  (open scheme-level-2 signals)
-  (files ascii))
-
-(define-structure bitwise bitwise-interface
-  (open scheme-level-2 signals)
-  (files bitwise))
-
-(define-structure code-vectors code-vectors-interface
-  (open scheme-level-1)
-  (files code-vectors))
diff --git a/scheme/alt/features.scm b/scheme/alt/features.scm
deleted file mode 100644
index 707accb..0000000
--- a/scheme/alt/features.scm
+++ /dev/null
@@ -1,53 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; This is file features.scm.
-; Synchronize any changes with all the other *-features.scm files.
-
-; These definitions should be quite portable to any Scheme implementation.
-; Assumes Revised^5 Report Scheme, for EVAL and friends.
-
-
-; SIGNALS
-
-(define (error message . irritants)
-  (display-error-message "Error: " message irritants)
-  (an-error-occurred-now-what?))
-
-(define (warn message . irritants)
-  (display-error-message "Warning: " message irritants))
-
-(define (display-error-message heading message irritants)
-  (display heading)
-  (display message)
-  (newline)
-  (let ((spaces (list->string
-		 (map (lambda (c) #\space) (string->list heading)))))
-    (for-each (lambda (irritant)
-		(display spaces)
-		(write irritant)
-		(newline))
-	      irritants)))
-
-; Linker also needs SIGNAL, SYNTAX-ERROR, CALL-ERROR
-
-; FEATURES
-
-(define (force-output port) #f)
-
-(define current-noise-port current-output-port)
-
-(define (string-hash s)
-  (let ((n (string-length s)))
-    (do ((i 0 (+ i 1))
-         (h 0 (+ h (char->ascii (string-ref s i)))))
-        ((>= i n) h))))
-
-(define (make-immutable! thing) #f)
-(define (immutable? thing) #f)
-(define (unspecific) (if #f #f))
-
-
-; BITWISE -- use alt/bitwise.scm (!)
-; ACII -- use alt/ascii.scm
-; CODE-VECTORS -- use alt/code-vectors.scm
diff --git a/scheme/alt/fluid.scm b/scheme/alt/fluid.scm
deleted file mode 100644
index d520b21..0000000
--- a/scheme/alt/fluid.scm
+++ /dev/null
@@ -1,33 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Fluid variables
-
-(define (make-fluid val)
-  (vector '<fluid> val))
-
-(define (fluid f) (vector-ref f 1))
-
-(define (set-fluid! f val)
-  (vector-set! f 1 val))
-
-(define (let-fluid f val thunk)
-  (let ((swap (lambda () (let ((temp (fluid f)))
-			   (set-fluid! f val)
-			   (set! val temp)))))
-    (dynamic-wind swap thunk swap)))
-
-(define (let-fluids . args)		;Kind of gross
-  (let loop ((args args)
-	     (swap (lambda () #f)))
-    (if (null? (cdr args))
-	(dynamic-wind swap (car args) swap)
-	(loop (cddr args)
-	      (let ((f (car args))
-		    (val (cadr args)))
-		(lambda ()
-		  (swap)
-		  (let ((temp (fluid f)))
-		    (set-fluid! f val)
-		    (set! val temp))))))))
-		
diff --git a/scheme/alt/init-defpackage.scm b/scheme/alt/init-defpackage.scm
deleted file mode 100644
index 79a65a7..0000000
--- a/scheme/alt/init-defpackage.scm
+++ /dev/null
@@ -1,14 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; This file should be loaded into the bootstrap linker before any use
-; of DEFINE-STRUCTURE.  Compare with env/init-defpackage.scm.
-
-(define-reflective-tower-maker
-  (lambda (clauses names)
-    (let ((env (interaction-environment)))
-      (delay
-	(begin (if (not (null? clauses))
-		   (warn "a FOR-SYNTAX clause appears in a package being linked by the cross-linker"
-			 `(for-syntax ,@clauses)))
-	       (cons eval env))))))
diff --git a/scheme/alt/jar-defrecord.scm b/scheme/alt/jar-defrecord.scm
deleted file mode 100644
index e37b590..0000000
--- a/scheme/alt/jar-defrecord.scm
+++ /dev/null
@@ -1,47 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; This is JAR's define-record-type, which doesn't resemble Richard's.
-
-; There's no implicit name concatenation, so it can be defined
-; entirely using syntax-rules.  Example:
-;  (define-record-type foo :foo
-;    (make-foo x y)
-;    foo?              - predicate name is optional
-;    (x foo-x)
-;    (y foo-y)
-;    (z foo-z set-foo-z!))
-
-(define-syntax define-record-type
-  (syntax-rules ()
-    ((define-record-type ?id ?type
-       (?constructor ?arg ...)
-       (?field . ?field-stuff)
-       ...)
-     (begin (define ?type (make-record-type '?id '(?field ...)))
-	    (define ?constructor (record-constructor ?type '(?arg ...)))
-	    (define-accessors ?type (?field . ?field-stuff) ...)))
-    ((define-record-type ?id ?type
-       (?constructor ?arg ...)
-       ?pred
-       ?more ...)
-     (begin (define-record-type ?id ?type
-	      (?constructor ?arg ...)
-	      ?more ...)
-	    (define ?pred (record-predicate ?type))))))
-
-; Straightforward version
-(define-syntax define-accessors
-  (syntax-rules ()
-    ((define-accessors ?type ?field-spec ...)
-     (begin (define-accessor ?type . ?field-spec) ...))))
-
-(define-syntax define-accessor
-  (syntax-rules ()
-    ((define-accessor ?type ?field ?accessor)
-     (define ?accessor (record-accessor ?type '?field)))
-    ((define-accessor ?type ?field ?accessor ?modifier)
-     (begin (define ?accessor (record-accessor ?type '?field))
-	    (define ?modifier (record-modifier ?type '?field))))
-    ((define-accessor ?type ?field)
-     (begin))))
diff --git a/scheme/alt/locations.scm b/scheme/alt/locations.scm
deleted file mode 100644
index 5b4a384..0000000
--- a/scheme/alt/locations.scm
+++ /dev/null
@@ -1,31 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Locations
-
-(define location-rtd
-  (make-record-type 'location '(id defined? contents)))
-
-(define-record-discloser location-rtd
-  (lambda (l) `(location ,(location-id l))))
-
-(define make-undefined-location
-  (let ((make (record-constructor location-rtd
-				  '(id defined? contents))))
-    (lambda (id)
-      (make id #f '*empty*))))
-
-(define location? (record-predicate location-rtd))
-(define location-id        (record-accessor location-rtd 'id))
-(define set-location-id!   (record-modifier location-rtd 'id))
-(define location-defined?  (record-accessor location-rtd 'defined?))
-(define contents  (record-accessor location-rtd 'contents))
-
-(define set-defined?! (record-modifier location-rtd 'defined?))
-
-(define (set-location-defined?! loc ?)
-  (set-defined?! loc ?)
-  (if (not ?)
-      (set-contents! loc '*empty*)))
-
-(define set-contents!		(record-modifier location-rtd 'contents))
diff --git a/scheme/alt/loophole.scm b/scheme/alt/loophole.scm
deleted file mode 100644
index d8d7a96..0000000
--- a/scheme/alt/loophole.scm
+++ /dev/null
@@ -1,9 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-(define-syntax loophole
-  (syntax-rules ()
-    ((loophole ?type ?form)
-     (begin (lambda () ?type)    ;Elicit unbound-variable warnings, etc.
-	    ?form))))
-    
diff --git a/scheme/alt/low.scm b/scheme/alt/low.scm
deleted file mode 100644
index 1628da1..0000000
--- a/scheme/alt/low.scm
+++ /dev/null
@@ -1,25 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Portable versions of low-level things that would really like to rely
-; on the Scheme 48 VM or on special features provided by the byte code
-; compiler.
-
-(define (vector-unassigned? v i) #f)
-
-(define (flush-the-symbol-table!) #f)
-
-(define maybe-open-input-file open-input-file)
-(define maybe-open-output-file open-output-file)
-
-
-; Suppress undefined export warnings.
-
-(define-syntax %file-name%
-  (syntax-rules ()
-    ((%file-name%) "")))
-
-(define-syntax structure-ref
-  (syntax-rules ()
-    ((structure-ref ?struct ?name)
-     (error "structure-ref isn't implemented" '?struct '?name))))
diff --git a/scheme/alt/pseudoscheme-features.scm b/scheme/alt/pseudoscheme-features.scm
deleted file mode 100644
index 416bcc5..0000000
--- a/scheme/alt/pseudoscheme-features.scm
+++ /dev/null
@@ -1,111 +0,0 @@
-; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; This is file pseudoscheme-features.scm.
-; Synchronize any changes with all the other *-features.scm files.
-
-(define *load-file-type* #f) ;For fun
-
-
-; SIGNALS
-
-(define error #'ps:scheme-error)
-
-(define warn #'ps:scheme-warn)
-
-(define (signal type . stuff)
-  (apply warn "condition signalled" type stuff))
-
-(define (syntax-error . rest)		; Must return a valid expression.
-  (apply warn rest)
-  ''syntax-error)
-
-(define (call-error message proc . args)
-  (error message (cons proc args)))
-
-
-; FEATURES
-
-(define force-output #'lisp:force-output)
-
-(define (string-hash s)
-  (let ((n (string-length s)))
-    (do ((i 0 (+ i 1))
-         (h 0 (+ h (lisp:char-code (string-ref s i)))))
-        ((>= i n) h))))
-
-(define (make-immutable! thing) thing)
-(define (immutable? thing) #f)
-(define (unspecific) (if #f #f))
-
-
-; BITWISE
-
-(define arithmetic-shift #'lisp:ash)
-(define bitwise-and #'lisp:logand)
-(define bitwise-ior #'lisp:logior)
-(define bitwise-not #'lisp:lognot)
-
-
-; ASCII
-
-(define char->ascii #'lisp:char-code)
-(define ascii->char #'lisp:code-char)
-(define ascii-limit lisp:char-code-limit)
-(define ascii-whitespaces '(32 10 9 12 13))
-
-
-; CODE-VECTORS
-
-(define (make-code-vector len . fill-option)
-  (lisp:make-array len :element-type '(lisp:unsigned-byte 8)
-		       :initial-element (if (null? fill-option)
-					    0
-					    (car fill-option))))
-
-(define (code-vector? obj)
-  (ps:true? (lisp:typep obj
-			(lisp:quote (lisp:simple-array (lisp:unsigned-byte 8)
-						       (lisp:*))))))
-
-(define (code-vector-ref bv k)
-  (lisp:aref (lisp:the (lisp:simple-array (lisp:unsigned-byte 8) (lisp:*))
-		       bv)
-	     k))
-
-(define (code-vector-set! bv k val)
-  (lisp:setf (lisp:aref (lisp:the (lisp:simple-array (lisp:unsigned-byte 8)
-						     (lisp:*))
-				  bv)
-			k)
-	     val))
-
-(define (code-vector-length bv)
-  (lisp:length (lisp:the (lisp:simple-array (lisp:unsigned-byte 8) (lisp:*))
-			 bv)))
-
-
-; The rest is unnecessary in Pseudoscheme versions 2.8d and after.
-
-;(define eval #'schi:scheme-eval)
-;(define (interaction-environment) schi:*current-rep-environment*)
-;(define scheme-report-environment
-;  (let ((env (scheme-translator:make-program-env
-;              'rscheme
-;              (list scheme-translator:revised^4-scheme-module))))
-;    (lambda (n)
-;      n ;ignore
-;      env)))
-
-; Dynamic-wind.
-;
-;(define (dynamic-wind in body out)
-;  (in)
-;  (lisp:unwind-protect (body)
-;    (out)))
-;
-;(define values #'lisp:values)
-;
-;(define (call-with-values thunk receiver)
-;  (lisp:multiple-value-call receiver (thunk)))
diff --git a/scheme/alt/pseudoscheme-record.scm b/scheme/alt/pseudoscheme-record.scm
deleted file mode 100644
index da46538..0000000
--- a/scheme/alt/pseudoscheme-record.scm
+++ /dev/null
@@ -1,19 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-(define make-record-type   #'scheme-translator::make-record-type)
-(define record-constructor #'scheme-translator::record-constructor)
-(define record-accessor    #'scheme-translator::record-accessor)
-(define record-modifier    #'scheme-translator::record-modifier)
-(define record-predicate   #'scheme-translator::record-predicate)
-(define define-record-discloser #'scheme-translator::define-record-discloser)
-
-(define (record-type? x)
-  (lisp:if (scheme-translator::record-type-descriptor-p x) #t #f))
-(define record-type-field-names #'scheme-translator::rtd-field-names)
-(define record-type-name	#'scheme-translator::rtd-identification)
-
-; Internal record things, for inspector or whatever
-(define disclose-record #'scheme-translator::disclose-record)
-(define record-type #'scheme-translator::record-type)
-(define (record? x) (lisp:if (scheme-translator::record-type x) #t #f))
-
diff --git a/scheme/alt/queue.scm b/scheme/alt/queue.scm
deleted file mode 100644
index fb1214c..0000000
--- a/scheme/alt/queue.scm
+++ /dev/null
@@ -1,28 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Queues
-
-(define (make-queue)
-  (cons '() '()))
-
-(define (queue-empty? q)
-  (and (null? (car q))
-       (null? (cdr q))))
-
-(define (enqueue! q obj)
-  (set-car! q (cons obj (car q))))
-
-(define (dequeue! q)
-  (normalize-queue! q)
-  (let ((head (car (cdr q))))
-    (set-cdr! q (cdr (cdr q)))
-    head))
-
-(define (normalize-queue! q)
-  (if (null? (cdr q))
-      (begin (set-cdr! q (reverse (car q)))
-	     (set-car! q '()))))
-
-(define (queue-head q)
-  (normalize-queue! q)
-  (car (cdr q)))
diff --git a/scheme/alt/record.scm b/scheme/alt/record.scm
deleted file mode 100644
index 5570b11..0000000
--- a/scheme/alt/record.scm
+++ /dev/null
@@ -1,96 +0,0 @@
-; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; This is file record.scm.
-
-;;;; Records
-
-; This is completely vanilla Scheme code.  Should work anywhere.
-
-(define (make-record-type type-id field-names)
-
-  (define unique (list type-id))
-
-  (define size (+ (length field-names) 1))
-
-  (define (constructor . names-option)
-    (let* ((names (if (null? names-option)
-		      field-names
-		      (car names-option)))
-	   (number-of-inits (length names))
-	   (indexes (map field-index names)))
-      (lambda field-values
-	(if (= (length field-values) number-of-inits)
-	    (let ((record (make-vector size 'uninitialized)))
-	      (vector-set! record 0 unique)
-	      (for-each (lambda (index value)
-			  (vector-set! record index value))
-			indexes
-			field-values)
-	      record)
-	    (error "wrong number of arguments to record constructor"
-		   field-values type-id names)))))
-
-  (define (predicate obj)
-    (and (vector? obj)
-	 (= (vector-length obj) size)
-	 (eq? (vector-ref obj 0) unique)))
-
-  (define (accessor name)
-    (let ((i (field-index name)))
-      (lambda (record)
-	(if (predicate record) ;Faster: (eq? (vector-ref record 0) unique)
-	    (vector-ref record i)
-	    (error "invalid argument to record accessor"
-		   record type-id name)))))
-
-  (define (modifier name)
-    (let ((i (field-index name)))
-      (lambda (record new-value)
-	(if (predicate record) ;Faster: (eq? (vector-ref record 0) unique)
-	    (vector-set! record i new-value)
-	    (error "invalid argument to record modifier"
-		   record type-id name)))))
-
-  (define (field-index name)
-    (let loop ((l field-names) (i 1))
-      (if (null? l)
-	  (error "bad field name" name)
-	  (if (eq? name (car l))
-	      i
-	      (loop (cdr l) (+ i 1))))))
-
-  (define the-descriptor
-    (lambda (request)
-      (case request
-	((constructor) constructor)
-	((predicate) predicate)
-	((accessor) accessor)
-	((modifier) modifier)
-	((name) type-id)
-	((field-names) field-names))))
-
-  the-descriptor)
-
-(define (record-constructor r-t . names-option)
-  (apply (r-t 'constructor) names-option))
-
-(define (record-predicate r-t)
-  (r-t 'predicate))
-
-(define (record-accessor r-t field-name)
-  ((r-t 'accessor) field-name))
-
-(define (record-modifier r-t field-name)
-  ((r-t 'modifier) field-name))
-
-(define (record-type-name r-t) (r-t 'name))
-(define (record-type-field-names r-t) (r-t 'field-names))
-
-(define (record-type? r-t)
-  (and (procedure? r-t)
-       (error "record-type? not implemented" r-t)))
-
-(define (define-record-discloser r-t proc)
-  "ignoring define-record-discloser form")
diff --git a/scheme/alt/reroot.scm b/scheme/alt/reroot.scm
deleted file mode 100644
index 406ce05..0000000
--- a/scheme/alt/reroot.scm
+++ /dev/null
@@ -1,54 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; A state space is a tree with the state at the root.  Each node other
-; than the root is a triple <before, after, parent>, represented in
-; this implementation as a structure ((before . after) . parent).
-; Moving from one state to another means re-rooting the tree by pointer
-; reversal. 
-
-(define *here* (list #f))
-
-(define original-cwcc call-with-current-continuation)
-
-(define (call-with-current-continuation proc)
-  (let ((here *here*))
-    (original-cwcc (lambda (cont)
-		     (proc (lambda results
-			     (reroot! here)
-			     (apply cont results)))))))
-
-(define (dynamic-wind before during after)
-  (let ((here *here*))
-    (reroot! (cons (cons before after) here))
-    (call-with-values during
-      (lambda results
-	(reroot! here)
-	(apply values results)))))
-
-(define (reroot! there)
-  (if (not (eq? *here* there))
-      (begin (reroot! (cdr there))
-	     (let ((before (caar there))
-		   (after (cdar there)))
-	       (set-car! *here* (cons after before))
-	       (set-cdr! *here* there)
-	       (set-car! there #f)
-	       (set-cdr! there '())
-	       (set! *here* there)
-	       (before)))))
-
-; -----
-;
-;(define r #f) (define s #f) (define (p x) (write x) (newline))
-;(define (tst)
-;  (set! r *here*)
-;  (set! s (cons (cons (lambda () (p 'in)) (lambda () (p 'out))) *here*))
-;  (reroot! s))
-;
-;
-;(define (check)                         ;Algorithm invariants
-;  (if (not (null? (cdr *here*)))
-;      (error "confusion #1"))
-;  (if (car *here*)
-;      (error "confusion #2")))
diff --git a/scheme/alt/schemetoc-features.scm b/scheme/alt/schemetoc-features.scm
deleted file mode 100644
index b2fe33f..0000000
--- a/scheme/alt/schemetoc-features.scm
+++ /dev/null
@@ -1,121 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; BUG: (+ (expt 2 28) (expt 2 28)), (* (expt 2 28) 2)
-
-(define-external schemetoc-error ;(schemetoc-error symbol format-string . args)
-  "scdebug" "error_v")
-
-(eval-when (eval)
-  (define schemetoc-error error))
-
-
-; SIGNALS
-
-(define (error message . irritants)
-  (if (symbol? message)
-      (apply schemetoc-error message irritants)
-      (apply schemetoc-error
-	     "Error:"
-	     (apply string-append
-		    message
-		    (map (lambda (x) "~%      ~s")
-			 irritants))
-	     irritants)))
-
-(define (warn message . irritants)
-  (display-error-message "Warning: " message irritants))
-
-(define (display-error-message heading message irritants)
-  (display heading)
-  (display message)
-  (newline)
-  (let ((spaces (list->string
-		 (map (lambda (c) #\space) (string->list heading)))))
-    (for-each (lambda (irritant)
-		(display spaces)
-		(write irritant)
-		(newline))
-	      irritants)))
-
-(define (signal type . stuff)
-  (apply warn "condition signalled" type stuff))
-
-(define (syntax-error . rest)		; Must return a valid expression.
-  (apply warn rest)
-  ''syntax-error)
-
-(define (call-error message proc . args)
-  (error message (cons proc args)))
-
-
-; FEATURES
-
-(define force-output flush-buffer)
-
-(define (string-hash s)
-  (let ((n (string-length s)))
-    (do ((i 0 (+ i 1))
-         (h 0 (+ h (char->ascii (string-ref s i)))))
-        ((>= i n) h))))
-
-(define (make-immutable! thing) thing)
-(define (immutable? thing) #f)
-(define (unspecific) (if #f #f))
-
-
-; BITWISE
-
-(define (arithmetic-shift x n)
-  (if (< x 0)
-      (let ((r (- -1 (arithmetic-shift (- -1 x) n))))
-	(if (> n 0)
-	    (- r (- (arithmetic-shift 1 n) 1))
-	    r))
-      (if (>= n 0)			;shift left?
-	  (if (and (<= n 8)
-		   (exact? x)
-		   (< x 4194304))
-	      (bit-lsh x n)
-	      (* x (expt 2 n)))
-	  (if (and (<= n 28) (exact? x))
-	      (bit-rsh x (- n))
-	      (floor (* x (expt 2. n)))))))
-
-(define (bitwise-and x y)
-  (if (and (< x 0) (< y 0))
-      (- -1 (bit-or (- -1 x) (- -1 y)))
-      (bit-and x y)))
-
-(define (bitwise-ior x y)
-  (if (or (< x 0) (< y 0))
-      (- -1 (bit-and (- -1 x) (- -1 y)))
-      (bit-or x y)))
-
-(define (bitwise-not x) (- -1 x))
-
-; ASCII
-
-(define char->ascii char->integer)
-(define ascii->char integer->char)
-(define ascii-limit 256)
-(define ascii-whitespaces '(32 10 9 12 13))
-
-
-; CODE-VECTORS (= alt/code-vectors.scm)
-
-(define *code-vector-marker* (list '*code-vector-marker*))
-
-(define (make-code-vector len init)
-  (let ((t (make-vector (+ len 1) init)))
-    (vector-set! t 0 *code-vector-marker*)
-    t))
-
-(define (code-vector? obj)
-  (and (vector? obj)
-       (> (vector-length obj) 0)
-       (eq? (vector-ref obj 0) *code-vector-marker*)))
-
-(define (code-vector-length t) (- (vector-length t) 1))
-(define (code-vector-ref t i) (vector-ref t (+ i 1)))
-(define (code-vector-set! t i x) (vector-set! t (+ i 1) x))
diff --git a/scheme/alt/schemetoc-record.scm b/scheme/alt/schemetoc-record.scm
deleted file mode 100644
index 5095e83..0000000
--- a/scheme/alt/schemetoc-record.scm
+++ /dev/null
@@ -1,120 +0,0 @@
-; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; This is file schemetoc-record.scm.
-; Synchronize any changes with the other *record.scm files.
-
-;;;; Records
-
-(define (make-record-type type-id field-names)
-
-  (define unique (lambda () the-descriptor))
-
-  (define size (+ (length field-names) 1))
-
-  (define (constructor . names-option)
-    (let* ((names (if (null? names-option)
-		      field-names
-		      (car names-option)))
-	   (foo (cons unique
-		      (map (lambda (name) 'uninitialized) field-names)))
-	   (number-of-inits (length names))
-	   (indexes (map field-index names)))
-      (lambda field-values
-	(if (= (length field-values) number-of-inits)
-	    (let ((record (list->%record foo)))
-	      (for-each (lambda (index value)
-			  (%record-set! record index value))
-			indexes
-			field-values)
-	      (%record-methods-set! record usual-record-methods)
-	      record)
-	    (error "wrong number of arguments to record constructor"
-		   field-values type-id names)))))
-
-  (define (predicate obj)
-    (and (%record? obj)
-	 (= (%record-length obj) size)
-	 (eq? (%record-ref obj 0) unique)))
-
-  (define (accessor name)
-    (let ((i (field-index name)))
-      (lambda (record)
-	(if (predicate record) ;Faster: (eq? (%record-ref record 0) unique)
-	    (%record-ref record i)
-	    (error "invalid argument to record accessor"
-		   record type-id name)))))
-
-  (define (modifier name)
-    (let ((i (field-index name)))
-      (lambda (record new-value)
-	(if (predicate record) ;Faster: (eq? (%record-ref record 0) unique)
-	    (%record-set! record i new-value)
-	    (error "invalid argument to record modifier"
-		   record type-id name)))))
-
-  (define (field-index name)
-    (let loop ((l field-names) (i 1))
-      (if (null? l)
-	  (error "bad field name" name)
-	  (if (eq? name (car l))
-	      i
-	      (loop (cdr l) (+ i 1))))))
-
-  (define (discloser r) (list type-id))
-
-  (define the-descriptor
-    (lambda (request)
-      (case request
-	((constructor) constructor)
-	((predicate) predicate)
-	((accessor) accessor)
-	((modifier) modifier)
-	((identification) type-id)
-	((field-names) field-names)
-	((discloser) discloser)
-	((set-discloser!) (lambda (d) (set! discloser d))))))
-
-  the-descriptor)
-
-(define (record-type x)
-  (if (%record? x)
-      (let ((probe (%record-ref x 0)))
-	(if (procedure? probe)
-	    (probe)
-	    #f))
-      #f))
-
-(define (record-type-identification r-t)
-  (r-t 'identification))
-
-(define (record-type-field-names r-t)
-  (r-t 'field-names))
-
-(define (record-constructor r-t . names-option)
-  (apply (r-t 'constructor) names-option))
-
-(define (record-predicate r-t)
-  (r-t 'predicate))
-
-(define (record-accessor r-t field-name)
-  ((r-t 'accessor) field-name))
-
-(define (record-modifier r-t field-name)
-  ((r-t 'modifier) field-name))
-
-(define (define-record-discloser r-t proc)
-  ((r-t 'set-discloser!) proc))
-
-(define (disclose-record r)
-  (((record-type r) 'discloser) r))
-
-(define usual-record-methods
-  (list (cons '%to-write
-	      (lambda (r port indent levels length seen)
-		(write-char #\# port)
-		(write-char %record-prefix-char port)
-		(list (disclose-record r))))))
-
-(set! %record-prefix-char #\~)
diff --git a/scheme/alt/silly.scm b/scheme/alt/silly.scm
deleted file mode 100644
index 69e7354..0000000
--- a/scheme/alt/silly.scm
+++ /dev/null
@@ -1,10 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-
-(define (reverse-list->string l n)
-  ;; Significantly faster than (list->string (reverse l))
-  (let ((s (make-string n #\x)))
-    (let loop ((i (- n 1)) (l l))
-      (if (< i 0) s (begin (string-set! s i (car l))
-			   (loop (- i 1) (cdr l)))))))
diff --git a/scheme/alt/t-features.scm b/scheme/alt/t-features.scm
deleted file mode 100644
index d8be299..0000000
--- a/scheme/alt/t-features.scm
+++ /dev/null
@@ -1,118 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; This is file t-features.scm.
-; Synchronize any changes with all the other *-features.scm files.
-
-; This hasn't been tested in a long time.
-
-
-(define (get-from-t name)
-  (*value t-implementation-env name))
-
-; (define error (get-from-t 'error))   - already present
-; (define warn (get-from-t 'warn))   - already present?
-
-(define (interaction-environment)
-  scheme-user-env)			;Foo
-(define scheme-report-environment
-  (let ((env (interaction-environment))) ;Isn't there a scheme-env?
-    (lambda (n) env)))
-
-(define (ignore-errors thunk)
-  '(error "ignore-errors isn't implemented"))
-
-(define force-output (get-from-t 'force-output))
-
-(define char->ascii char->integer)
-(define ascii->char integer->char)
-
-(define (string-hash s)
-  (let ((n (string-length s)))
-    (do ((i 0 (+ i 1))
-         (h 0 (+ h (char->ascii (string-ref s i)))))
-        ((>= i n) h))))
-
-;==============================================================================
-; Bitwise logical operations on integers
-
-; T's ASH doesn't work on negative numbers
-
-(define arithmetic-shift
-  (let ((fx-ashl (get-from-t 'fx-ashl))
-	(fx-ashr (get-from-t 'fx-ashr)))
-    (lambda (integer count)
-      (if (>= count 0)
-	  (fx-ashl integer count)
-	  (fx-ashr integer (- 0 count))))))
-
-; This is from Olin Shivers:
-;   (define (correct-ash n m)
-;     (cond ((or (= m 0) (= n 0)) n)
-;           ((> n 0) (ash n m))
-;           ;; shifting a negative number.
-;           ((> m 0)                     ; left shift
-;            (- (ash (- n) m)))
-;           (else                                ; right shift
-;            (lognot (ash (lognot n) m)))))
-
-(define bitwise-and (get-from-t 'fx-and))
-(define bitwise-ior (get-from-t 'fx-ior))
-
-;==============================================================================
-; Code vectors
-
-(define make-bytev         (get-from-t 'make-bytev))
-(define code-vector?       (get-from-t 'bytev?))
-(define code-vector-length (get-from-t 'bytev-length))
-(define code-vector-ref    (get-from-t 'bref-8))
-(define code-vector-set! ((get-from-t 'setter) code-vector-ref))
-
-(define (make-code-vector size . init)
-  (let ((vec (make-bytev size)))
-    (if (not (null? init))
-	(code-vector-fill! vec (car init)))
-    vec))
-
-(define (code-vector-fill! cv x)
-  (do ((i 0 (+ i 1)))
-      ((>= i (code-vector-length cv)))
-    (code-vector-set! cv i x)))
-
-;==============================================================================
-; Bug fixes and modernizations
-; I think syntax-rules will be needed, as well.
-
-; Simulate a modernized DEFINE-SYNTAX.
-
-(#[syntax define-syntax] (define-syntax name xformer)
-  `(#[syntax define-syntax] (,name . %tail%)
-       (,xformer (cons ',name %tail%)
-		 (lambda (x) x)		;rename
-		 eq?)))			;compare
-
-; T's MAKE-VECTOR and MAKE-STRING ignore their init argument.
-
-(define make-vector
-  (let ((broken-make-vector (get-from-t 'make-vector)))
-    (lambda (size . init)
-      (let ((vec (broken-make-vector size)))
-	(if (not (null? init))
-	    (vector-fill! vec (car init)))
-	vec))))
-
-(define make-string
-  (let ((make-string (get-from-t 'make-string))
-	(string-fill (get-from-t 'string-fill)))
-    (lambda (size . init-option)
-      (if (null? init-option) 
-	  (make-string size)
-	  (string-fill (make-string size) (car init-option))))))
-
-; Dynamic-wind.
-
-(define (dynamic-wind before during after)
-  (before)
-  (let ((result (during)))
-    (after)
-    result))
diff --git a/scheme/alt/t-record.scm b/scheme/alt/t-record.scm
deleted file mode 100644
index 1e354ec..0000000
--- a/scheme/alt/t-record.scm
+++ /dev/null
@@ -1,57 +0,0 @@
-; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; This is file t-record.scm.
-; Synchronize any changes with the other *record.scm files.
-
-;;;; Records
-
-(define make-record-type
-  (let ((make-stype        (*value t-standard-env 'make-stype))
-	(crawl-exhibit     (*value t-standard-env 'crawl-exhibit))
-	(exhibit-structure (*value t-standard-env 'exhibit-structure))
-	(structure-type    (*value t-standard-env 'structure-type))
-	(object-hash	   (*value t-standard-env 'object-hash))
-	(print   	   (*value t-standard-env 'print))
-	(format		   (*value t-standard-env 'format)))
-    (lambda (id names)
-      (letrec ((rtd
-		(make-stype id names
-		  (#[syntax object] #f
-		     ((crawl-exhibit self)
-		      (exhibit-structure self))
-		     ((print self port)
-		      (format port "#{Record~_~S~_~S}" id (object-hash self)))
-		     ((structure-type self) rtd)))))
-	rtd))))
-
-(define record-predicate (*value t-standard-env 'stype-predicator))
-
-(define record-accessor (*value t-standard-env 'stype-selector))
-
-(define (record-modifier rtd name)
-  (setter (record-accessor rtd name)))
-
-(define (record-constructor rtd names)
-  (let ((number-of-inits (length names))
-	(modifiers (map (lambda (name) (record-modifier rtd name))
-			names))
-	(make ((*value t-implementation-env 'stype-constructor) rtd)))
-    (lambda values
-      (let ((record (make)))
-	(let loop ((vals values)
-		   (ups modifiers))
-	  (cond ((null? vals)
-		 (if (null? ups)
-		     record
-		     (error "too few arguments to record constructor"
-			    values type-id names)))
-		((null? ups)
-		 (error "too many arguments to record constructor"
-			values type-id names))
-		(else
-		 ((car ups) record (car vals))
-		 (loop (cdr vals) (cdr ups)))))))))
-
-(define (define-record-discloser rtd proc) 'unimplemented)
diff --git a/scheme/alt/table.scm b/scheme/alt/table.scm
deleted file mode 100644
index 62f3544..0000000
--- a/scheme/alt/table.scm
+++ /dev/null
@@ -1,15 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; unworthy of copyright notice
-
-(define (make-table . hash-procedure-option) (list 'table))
-
-(define (table-ref table key)
-  (let ((probe (assq key (cdr table))))
-    (if probe (cdr probe) #f)))
-
-(define (table-set! table key value)
-  (let ((probe (assq key (cdr table))))
-    (if probe
-	(set-cdr! probe value)
-	(set-cdr! table (cons (cons key value) (cdr table))))))
diff --git a/scheme/alt/template.scm b/scheme/alt/template.scm
deleted file mode 100644
index f258194..0000000
--- a/scheme/alt/template.scm
+++ /dev/null
@@ -1,21 +0,0 @@
-; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Templates implemented as vectors.
-
-(define *template-marker* (list '*template-marker*))
-
-(define (make-template len init)
-  (let ((t (make-vector (+ len 1) init)))
-    (vector-set! t 0 *template-marker*)
-    t))
-
-(define (template? obj)
-  (and (vector? obj)
-       (> (vector-length obj) 0)
-       (eq? (vector-ref obj 0) *template-marker*)))
-
-(define (template-length t) (- (vector-length t) 1))
-(define (template-ref t i) (vector-ref t (+ i 1)))
-(define (template-set! t i x) (vector-set! t (+ i 1) x))
diff --git a/scheme/alt/values.scm b/scheme/alt/values.scm
deleted file mode 100644
index f43d02f..0000000
--- a/scheme/alt/values.scm
+++ /dev/null
@@ -1,19 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Multiple return values
-
-(define multiple-value-token (vector 'multiple-value-token))
-
-(define (values . things)
-  (if (and (pair? things)
-	   (null? (cdr things)))
-      (car things)
-      (cons multiple-value-token things)))
-
-(define (call-with-values producer consumer)
-  (let ((things (producer)))
-    (if (and (pair? things)
-	     (eq? (car things) multiple-value-token))
-	(apply consumer (cdr things))
-	(consumer things))))
diff --git a/scheme/alt/weak.scm b/scheme/alt/weak.scm
deleted file mode 100644
index 64b55e5..0000000
--- a/scheme/alt/weak.scm
+++ /dev/null
@@ -1,8 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-(define (make-weak-pointer x) (cons '<weak> x))
-(define weak-pointer-ref cdr)
-(define (weak-pointer? x)
-  (and (pair? x) (eq? (car x) '<weak>)))
-
diff --git a/scheme/bcomp/binding.scm b/scheme/bcomp/binding.scm
deleted file mode 100644
index e23e107..0000000
--- a/scheme/bcomp/binding.scm
+++ /dev/null
@@ -1,97 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Bindings: used to store bindings in packages.
-
-; Representation is #(type place operator-or-transform-or-#f [path]).
-; PLACE is a unique (to EQ?) value, usually a location.
-
-; Why aren't these records?  Because they need to be written out in
-; the initial image?
-
-(define binding? vector?)
-
-(define (binding-type b)   (vector-ref b 0))
-(define (binding-place b)  (vector-ref b 1))
-(define (binding-static b) (vector-ref b 2))
-
-(define (binding-path binding)
-  (if (= 4 (vector-length binding))
-      (vector-ref binding 3)
-      #f))
-
-(define (set-binding-place! binding place)
-  (vector-set! binding 1 place))
-
-(define (make-binding type place static)
-  (vector type place static))
-
-(define (add-path binding path)
-  (vector (binding-type binding)
-	  (binding-place binding)
-	  (binding-static binding)
-	  path))
-
-; Used when updating a package binding.
-
-(define (clobber-binding! binding type place static)
-  (vector-set! binding 0 type)
-  (if place
-      (vector-set! binding 1 place))
-  (vector-set! binding 2 static))
-
-; Return a binding that's similar to the given one, but has its type
-; replaced with the given type.
-
-(define (impose-type type binding integrate?)
-  (if (or (eq? type syntax-type)
-	  (not (binding? binding)))
-      binding
-      (make-binding (if (eq? type undeclared-type)
-			(let ((type (binding-type binding)))
-			  (if (variable-type? type)
-			      (variable-value-type type)
-			      type))
-			type)
-		    (binding-place binding)
-		    (if integrate?
-			(binding-static binding)
-			#f))))
-
-; Return a binding that's similar to the given one, but has any
-; procedure integration or other unnecesary static information
-; removed.  But don't remove static information for macros (or
-; structures, interfaces, etc.)
-
-(define (forget-integration binding)
-  (if (and (binding-static binding)
-	   (subtype? (binding-type binding) any-values-type))
-      (make-binding (binding-type binding)
-		    (binding-place binding)
-		    #f)
-      binding))
-
-; Do X and Y denote the same thing?
-
-(define (same-denotation? x y)
-  (or (eq? x y)	    ; was EQUAL? because of names, now just for nodes
-      (and (binding? x)
-	   (binding? y)
-	   (eq? (binding-place x)
-		(binding-place y)))))
-
-; Special kludge for shadowing and package mutation.
-; Ignore this on first reading.  See env/shadow.scm.
-
-(define (maybe-fix-place! binding)
-  (let ((place (binding-place binding)))
-    (if (and (location? place)
-             (vector? (location-id place)))
-        (set-binding-place! binding (follow-forwarding-pointers place))))
-  binding)
-
-(define (follow-forwarding-pointers place)
-  (let ((id (location-id place)))
-    (if (vector? id)
-        (follow-forwarding-pointers (vector-ref id 0))
-        place)))
-
diff --git a/scheme/bcomp/cenv.scm b/scheme/bcomp/cenv.scm
deleted file mode 100644
index 84394ae..0000000
--- a/scheme/bcomp/cenv.scm
+++ /dev/null
@@ -1,91 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Compile-time environments
-; These are functions
-;  name -> node			; lexical variable
-;          binding              ; package variable, any syntax
-;          #f			; free
-;
-; Special names are used to retrieve various values from environments.
-
-(define (lookup cenv name)
-  (cenv name))
-
-(define (bind1 name binding cenv)
-  (lambda (a-name)
-    (if (eq? a-name name)
-	binding
-	(lookup cenv a-name))))
-
-(define (bind names bindings cenv)
-  (cond ((null? names) cenv)
-	(else
-	 (bind1 (car names)
-		(car bindings)
-		(bind (cdr names) (cdr bindings) cenv)))))
-
-(define (bindrec names cenv->bindings cenv)
-  (set! cenv (bind names
-		  (cenv->bindings (lambda (a-name) (cenv a-name)))
-		  cenv))
-  cenv)
-
-; Making the initial environment.
-;
-;  lookup : name -> binding or (binding . path) or #f
-;  define : name type [static] -> void
-;  macro-eval : form -> delay that returns (<eval> . <env>) for evaluating
-;   macro expanders
-
-(define (make-compiler-env lookup define! macro-eval package)
-  (lambda (name)
-    (cond ((eq? name funny-name/macro-eval)
-	   macro-eval)
-	  ((eq? name funny-name/define!)
-	   define!)
-	  ((eq? name funny-name/source-file-name)
-	   #f)
-	  ((eq? name funny-name/package)
-	   package)
-	  (else
-	   (lookup name)))))
-
-; EVAL function for evaluating macro expanders.
-
-(define funny-name/macro-eval (string->symbol "Eval function for macros"))
-
-(define (environment-macro-eval cenv)
-  (cenv funny-name/macro-eval))
-
-; Function for adding definitions to the outer package.
-
-(define funny-name/define! (string->symbol "Definition function"))
-
-(define (environment-define! cenv name type . maybe-value)
-  (apply (cenv funny-name/define!) name type maybe-value))
-
-; The package on which the environment is based.  This is a temporary hack
-; to keep the package-editing code working.
-
-(define funny-name/package (string->symbol "Base package"))
-
-(define (extract-package-from-environment cenv)
-  (cenv funny-name/package))
-
-; The name of the source file.
-;   This is used by the %FILE-NAME% special form,
-;   which is in turn used by the (MODULE ...) form to save the current file in
-;    each package, 
-;   which is (finally) used to look up filenames in the correct directory.
-
-(define funny-name/source-file-name (string->symbol "Source file name"))
-
-(define (bind-source-file-name filename env)
-  (if filename
-      (bind1 funny-name/source-file-name filename env)
-      env))
-
-(define (source-file-name cenv)
-  (cenv funny-name/source-file-name))
-
-
diff --git a/scheme/bcomp/comp-exp.scm b/scheme/bcomp/comp-exp.scm
deleted file mode 100644
index 3bef4da..0000000
--- a/scheme/bcomp/comp-exp.scm
+++ /dev/null
@@ -1,697 +0,0 @@
-; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Compiling expressions.
-
-; This is a two-phase compiler.  The first phase does macro expansion,
-; variable resolution, and instruction selection, and computes the
-; size of the code vector.  The second phase (assembly) creates the
-; code vector, "template" (literals vector), and debugging data
-; structures.
-
-; The output of the first phase (the COMPILE- and INSTRUCTION-
-; routines) and the input to the second phase (SEGMENT->TEMPLATE) is a
-; "segment."  A segment is a pair (size . proc) where size is the size
-; of the code segment in bytes, and proc is a procedure that during
-; phase 2 will store the segment's bytes into the code vector.
-
-; Optimizations are marked with +++, and may be flushed if desired.
-
-(define (compile-expression node depth cont)
-  (compile node 0 depth cont))
-
-; Main dispatch for compiling a single expression.
-
-(define (compile node level depth cont)
-  (let ((node (type-check node)))
-    ((operator-table-ref compilators (node-operator-id node))
-     node
-     level
-     depth
-     cont)))
-
-; Specialists
-
-(define compilators
-  (make-operator-table
-    (lambda (node level depth cont)
-      (generate-trap cont
-		     "not valid in expression context"
-		     (schemify node)))))
-
-(define (define-compilator name type proc)
-  (operator-define! compilators name type proc))
-
-(define-compilator 'literal 'leaf
-  (lambda (node level depth cont)
-    (let ((obj (node-form node)))
-      (if (eq? obj #f)
-	  ;; +++ hack for bootstrap from Schemes that don't distinguish #f/()
-	  (deliver-value (instruction (enum op false)) cont)
-	  (compile-constant obj depth cont)))))
-
-(define-compilator 'unspecific (proc () unspecific-type)
-  (lambda (node level depth cont)
-    (deliver-value (instruction (enum op unspecific))
-		   cont)))
-
-(define-compilator 'unassigned (proc () unspecific-type)
-  (lambda (node level depth cont)
-    (deliver-value (instruction (enum op unassigned))
-		   cont)))
-
-(define-compilator 'quote syntax-type
-  (lambda (node level depth cont)
-    (let ((exp (node-form node)))
-      level				;ignored
-      (let ((obj (cadr exp)))
-	(compile-constant obj depth cont)))))
-
-(define (compile-constant obj depth cont)
-  (if (ignore-values-cont? cont)
-      empty-segment			;+++ dead code
-      (deliver-value (instruction-with-literal (enum op literal) obj)
-		     cont)))
-
-; Variable reference
-
-(define-compilator 'name 'leaf
-  (lambda (node level depth cont)
-    (let* ((binding (name-node-binding node))
-	   (name (node-form node)))
-      (deliver-value
-         (if (pair? binding)
-	     (let ((back (- level (car binding)))
-		   (over (cdr binding)))
-	       (if (or (>= back byte-limit)
-		       (>= over byte-limit))
-		   (instruction (enum op big-local)
-				(high-byte back)
-				(low-byte back)
-				(high-byte over)
-				(low-byte over))
-		   (case back
-		     ((0) (instruction (enum op local0) over)) ;+++
-		     ((1) (instruction (enum op local1) over)) ;+++
-		     ((2) (instruction (enum op local2) over)) ;+++
-		     (else (instruction (enum op local) back over)))))
-	     (instruction-with-location (enum op global)
-					binding
-					name
-					value-type))
-	 cont))))
-
-; Assignment
-
-(define-compilator 'set! syntax-type
-  (lambda (node level depth cont)
-    (let* ((exp (node-form node))
-	   (lhs-node (cadr exp))
-	   (name (node-form lhs-node))
-	   ;; Error if not a name node...
-	   (binding (name-node-binding lhs-node)))
-      (sequentially
-       (compile (caddr exp) level depth (named-cont name))
-       (deliver-value
-	(if (pair? binding)
-	    (let ((back (- level (car binding)))
-		  (over (cdr binding)))
-	      (instruction (enum op set-local!)
-			   (high-byte back)
-			   (low-byte back)
-			   (high-byte over)
-			   (low-byte over)))
-	    (instruction-with-location (enum op set-global!)
-				       binding
-				       name
-				       usual-variable-type))
-	cont)))))
-
-; Conditional
-
-(define-compilator 'if syntax-type
-  (lambda (node level depth cont)
-    (let ((exp (node-form node))
-	  (alt-label (make-label))
-	  (join-label (make-label)))
-      (sequentially
-       ;; Test
-       (compile (cadr exp) level depth (fall-through-cont node 1))
-       (instruction-using-label (enum op jump-if-false) alt-label)
-       ;; Consequent
-       (compile (caddr exp) level depth cont)
-       (if (fall-through-cont? cont)
-	   (instruction-using-label (enum op jump) join-label)
-	   empty-segment)
-       ;; Alternate
-       (attach-label alt-label
-		     (compile (cadddr exp) level depth cont))
-       (attach-label join-label
-		     empty-segment)))))
-
-(define-compilator 'begin syntax-type
-  (lambda (node level depth cont)
-    (let ((exp-list (cdr (node-form node))))
-      (if (null? exp-list)
-	  (generate-trap cont "null begin")
-	  (let ((dummy
-		 (make-node operator/begin ;For debugging database
-			    `(begin ,@exp-list))))
-	    (let loop ((exp-list exp-list) (i 1))
-	      (if (null? (cdr exp-list))
-		  (compile (car exp-list) level depth cont)
-		  (sequentially
-		    (compile (car exp-list) level depth
-			     (ignore-values-cont dummy i))
-		    (loop (cdr exp-list) (+ i 1))))))))))
-
-; Compile a call
-
-(define (compile-call node level depth cont)
-  (if (node-ref node 'type-error)
-      (compile-unknown-call node level depth cont)
-      (let ((proc-node (car (node-form node))))
-	(cond ((name-node? proc-node)
-	       (compile-name-call node proc-node level depth cont))
-	      ((and (lambda-node? proc-node)
-		    (not (n-ary? (cadr (node-form proc-node)))))
-	       (compile-redex proc-node (cdr (node-form node)) level depth cont))
- 	      ((and (literal-node? proc-node)
- 		    (primop? (node-form proc-node)))
- 	       (let ((primop (node-form proc-node)))
- 		 (if (primop-compilator primop)
- 		     ((primop-compilator primop) node level depth cont)
- 		     (error "compiler bug: primop has no compilator"
- 			    primop
- 			    (schemify node)))))
-	      (else
-	       (compile-unknown-call node level depth cont))))))
-
-(define (compile-name-call node proc-node level depth cont)
-  (let ((binding (name-node-binding proc-node)))
-    (if (binding? binding)
-	(let ((static (binding-static binding)))
-	  (cond ((primop? static)
-		 (if (primop-compilator static)
-		     ((primop-compilator static) node level depth cont)
-		     (compile-unknown-call node level depth cont)))
-		((transform? static)
-		 (let* ((form (node-form node))
-			(new (apply-inline-transform static
-						     form
-						     (node-form proc-node))))
-		   (if (eq? new form)
-		       (compile-unknown-call node level depth cont)
-		       (compile new level depth cont))))
-		(else
-		 (compile-unknown-call node level depth cont))))
-	(compile-unknown-call node level depth cont))))
-
-(define-compilator 'call 'internal compile-call)
-
-; A redex is a call of the form ((lambda (x1 ... xn) body ...) e1 ... en).
-
-(define (compile-redex proc-node args level depth cont)
-  (let* ((proc-exp (node-form proc-node))
-	 (formals (cadr proc-exp))
-	 (body (caddr proc-exp)))
-    (cond ((not (= (length formals)
-		   (length args)))
-	   (generate-trap cont
-			  "wrong number of arguments"
-			  (cons (schemify proc-node)
-				(map schemify args))))
-	  ((null? formals)
-	   (compile body level depth cont)) ;+++
-	  (else
-	   (maybe-push-continuation
-	    (sequentially 
-	     (push-all-with-names args formals level 0)
-	     (compile-lambda-code formals body level (cont-name cont)))
-	    depth
-	    cont)))))
-
-; Compile a call to a computed procedure.
-
-(define (compile-unknown-call node level depth cont)
-  (let ((exp (node-form node)))
-    (let ((call (sequentially (push-arguments node level 0)
-			      (compile (car exp)
-				       level
-				       (length (cdr exp))
-				       (fall-through-cont node 0))
-			      (let ((nargs (length (cdr exp))))
-				(if (> nargs maximum-stack-args)
-				    (instruction (enum op big-call)
-						 (high-byte nargs)
-						 (low-byte nargs))
-				    (instruction (enum op call) nargs))))))
-      (maybe-push-continuation call depth cont))))
-
-(define (maybe-push-continuation code depth cont)
-  (if (return-cont? cont) 
-      code
-      (let ((label (make-label)))
-	(sequentially (if (>= depth byte-limit)
-			  (instruction-using-label (enum op make-big-cont)
-						   label
-						   (high-byte depth)
-						   (low-byte depth))
-			  (instruction-using-label (enum op make-cont)
-						   label
-						   depth))
-		      (if (keep-source-code?)
-			  (note-source-code (fixup-source (cont-source-info cont))
-					    code)
-			  code)
-		      (attach-label label
-				    (cont-segment cont))))))
-
-(define (fixup-source info)
-  ;; Abbreviate this somehow?
-  (if (pair? info)
-      (cons (car info)
-	    (schemify (cdr info)))
-      ;; Name might be generated...
-      info))
-
-; Continuation is implicitly fall-through.
-
-(define (push-arguments node level depth)
-  (let recur ((args (cdr (node-form node))) (depth depth) (i 1))
-    (if (null? args)
-	empty-segment
-	(sequentially (compile (car args) level depth
-			       (fall-through-cont node i))
-		      (instruction (enum op push))
-		      (recur (cdr args) (+ depth 1) (+ i 1))))))
-
-(define (push-all-with-names exp-list names level depth)
-  (if (null? exp-list)
-      empty-segment
-      (sequentially (compile (car exp-list)
-			     level depth
-			     (named-cont (node-form (car names))))
-		    (instruction (enum op push))
-                    (push-all-with-names (cdr exp-list)
-					 (cdr names)
-					 level
-					 (+ depth 1)))))
-     
-; OK, now that you've got all that under your belt, here's LAMBDA.
-
-(define-compilator 'lambda syntax-type
-  (lambda (node level depth cont)
-    (let ((exp (node-form node))
-	  (name (cont-name cont)))
-      (deliver-value
-       (sequentially
-	 (instruction (enum op closure))
-	 (template (compile-lambda exp level #f)
-		   (if (name? name)
-		       (name->symbol name)
-		       #f))
-	 (instruction 0)) ; last byte of closure instruction, 0 means use
-                          ; *env* for environment
-       cont))))
-
-(define (compile-lambda exp level body-name)
-  (let* ((formals (cadr exp))
-	 (nargs (number-of-required-args formals))
-	 (fast-protocol? (and (<= nargs maximum-stack-args)
-			      (not (n-ary? formals)))))
-    (sequentially
-     ;; Insert protocol
-     (cond (fast-protocol?
-	    (instruction (enum op protocol) nargs))
-	   ((<= nargs available-stack-space)
-	    (instruction (enum op protocol)
-			 (if (n-ary? formals)
-			     two-byte-nargs+list-protocol
-			     two-byte-nargs-protocol)
-			 (high-byte nargs)
-			 (low-byte nargs)))
-	   (else
-	    (error "compiler bug: too many formals"
-		   (schemify exp))))
-     (compile-lambda-code formals (caddr exp) level body-name))))
-
-; name isn't the name of the procedure, it's the name to be given to
-; the value that the procedure will return.
-
-(define (compile-lambda-code formals body level name)
-  (if (null? formals)		;+++ Don't make null environment
-      (compile body level 0 (return-cont name))
-      ;; (if (node-ref node 'no-inferior-lambdas) ...)
-      (sequentially
-       (let* ((nargs (number-of-required-args formals))
-	      (nargs (if (n-ary? formals)
-			 (+ nargs 1)
-			 nargs)))
-	 (instruction (enum op make-env)
-		      (high-byte nargs)
-		      (low-byte nargs)))
-       (let ((vars (normalize-formals formals))
-	     (level (+ level 1)))
-	 (set-lexical-offsets! (reverse vars) level)
-	 (note-environment
-	  (map name-node->symbol vars)
-	  (compile body level 0 (return-cont name)))))))
-
-(define (name-node->symbol node)
-  (let ((form (node-form node)))
-    (cond ((name? form)
-	   (name->symbol form))
-	  ((symbol? form)
-	   form)
-	  (else
-	   #f))))
-
-; Give each name node in NAMES a binding record that has the names lexical
-; level and offset.
-
-(define (set-lexical-offsets! names level)
-  (let loop ((over 1) (names names))
-    (if (not (null? names))
-	(begin
-	  (node-set! (car names) 
-		     'binding
-		     (cons level over))
-	  (loop (+ over 1) (cdr names))))))
-
-(define-compilator 'flat-lambda syntax-type
-  (lambda (node level depth cont)
-    (let ((exp (node-form node))
-	  (name (cont-name cont)))
-      (let ((vars (cadr exp))
-	    (free (caddr exp))
- 	    (body (cadddr exp)))
- 	(deliver-value (compile-flat-lambda name vars body free level)
- 		       cont)))))
- 
-; The MAKE-FLAT-ENV instruction is designed to allow us to make nested flat
-; environments (i.e. flat environments consisting of a linked chain of vectors)
-; but this code doesn't generate them.  The nested environments would avoid
-; the need for offsets larger than a byte.  The current code cannot handle
-; large environments.
-; When we're done we have to restore the old locations of the free variables.
-
-(define (compile-flat-lambda name vars body free level)
-  (let* ((alist (sort-list (get-variables-offsets free level)
-			   (lambda (p1 p2)
-			     (< (cadr p1)
-				(cadr p2)))))
-	 (free (map car alist))
-	 (old-locations (map name-node-binding free)))
-    (set-lexical-offsets! free 0)  ; 0 is the level
-    (let ((code (sequentially
-		 (instruction (enum op false)) ; either the super env or the env
-		 (if (null? free)
-		     empty-segment
-		     (apply instruction (enum op make-flat-env)
-			    1   ; add in *val*
-			    (+ (length free) 1)
-			    (variable-env-data (map cdr alist))))
-		 (instruction (enum op closure))
-		 (note-environment (reverse (map node-form free))
-				   (template (compile-lambda `(lambda ,vars
-								,body)
-							     0
-							     #f)
-					     (if (name? name)
-						 (name->symbol name)
-						 #f)))
-		 (instruction 1)))) ; last byte of closure instruction, 1 means
-                                    ; use *val* as environment, instead of *env*
-      (for-each (lambda (node location)
-		  (node-set! node 'binding location))
-		free
-		old-locations)
-      code)))
-
-; Looks up VARS in CENV and returns an alist of (<name> . (<level> <over>))
-; pairs.
-
-(define (get-variables-offsets vars level)
-  (let loop ((vars vars) (locs '()))
-    (if (null? vars)
-	locs
-	(let ((binding (name-node-binding (car vars))))
-	  (if (pair? binding)
-	      (let ((back (- level (car binding)))
-		    (over (cdr binding)))
-		(if (< byte-limit over)
-		    (error "lexical environment limit exceeded; complain to implementors"))
-		(loop (cdr vars)
-		      (cons (cons (car vars)
-				  (cons back over))
-			    locs)))
-	      (error "variable in flat-lambda list is not local"
-		     (car vars)))))))
-
-; Addresses is a list of (level . over) pairs, sorted by level.
-; This returns the reverse of the following data:
-;   <back for level>
-;   <number of variables from this level>
-;   <over of 1st var> ...
-;   <back for next level>
-;   ...
-; If a <back> is too large we insert some empty levels.
-
-(define (variable-env-data addresses)
-  (let level-loop ((addresses addresses) (last-level 0) (data '()))
-    (if (null? addresses)
-	(reverse data)
-	(let ((level (caar addresses)))
-	  (let loop ((addresses addresses) (overs '()))
-	    (if (or (null? addresses)
-		    (not (= level (caar addresses))))
-		(level-loop addresses
-			    level
-			    (append overs
-				    (list (length overs))
-				    (let loop ((delta (- level last-level))
-					       (back '()))
-				      (if (<= delta byte-limit)
-					  (cons delta back)
-					  (loop (- delta byte-limit)
-						`(0 ,byte-limit . ,back))))
-				    data))
-		(loop (cdr addresses)
-		      (cons (cdar addresses) overs))))))))
-	  
-; We should probably just use the sort from big-scheme.
-
-(define (sort-list xs less?)
-  (letrec ((insert (lambda (x xs)
-		     (if (null? xs)
-			 (list x)
-			 (if (less? (car xs) x)
-			     (cons (car xs)
-				   (insert x (cdr xs)))
-			     (cons x xs))))))
-    (let sort ((xs xs))    
-      (if (null? xs)
-	  '()
-	  (insert (car xs)
-		  (sort (cdr xs)))))))
-
-; LETREC.
-
-(define-compilator 'letrec syntax-type
-  (lambda (node level depth cont)
-    ;; (if (node-ref node 'pure-letrec) ...)
-    (let* ((exp (node-form node))
-	   (specs (cadr exp))
-	   (body (caddr exp))
-	   (body (make-node operator/begin
-			    `(begin
-			       ,@(map (lambda (spec)
-					(make-node operator/set!
-						   `(set! ,@spec)))
-				      specs)
-			       ,body))))
-      (if (null? specs)
-	  (compile body level depth cont) ;+++
-	  (maybe-push-continuation
-	    (sequentially
-	      (apply sequentially
-		     (map (lambda (spec)
-			    (sequentially
-			      (instruction (enum op unassigned))
-			      (instruction (enum op push))))
-			  specs))
-	      (compile-lambda-code (map car specs) body level (cont-name cont)))
-	    depth
-	    cont)))))
-
-; --------------------
-; Compile-time continuations
-;
-; A compile-time continuation is a pair (segment . source-info).
-; Segment is one of the following:
-;   a return instruction - invoke the current full continuation.
-;   empty-segment - fall through to subsequent instructions.
-;   an ignore-values instruction - ignore values, then fall through.
-; Source-info is one of:
-;   #f - we don't know anything
-;   symbol - value delivered to subsequent instructions will be assigned to
-;     a variable with this name.  If the value being assigned is a lambda, we
-;     can give that lambda that name.
-;   (i . node) - the value being computed is the i'th subexpression of the node.
-
-(define (make-cont seg source-info) (cons seg source-info))
-(define cont-segment car)
-(define cont-source-info cdr)
-
-; We could probably be able to optimize jumps to jumps.
-;(define (make-jump-cont label cont)
-;  (if (fall-through-cont? cont)
-;      (make-cont label (cont-name cont))
-;      cont))
-
-(define return-cont-segment (instruction (enum op return)))
-
-(define (return-cont name)
-  (make-cont return-cont-segment name))
-
-(define (return-cont? cont)
-  (eq? (cont-segment cont) return-cont-segment))
-
-; Fall through into next instruction while compiling the I'th part of NODE.
-
-(define (fall-through-cont node i)
-  (make-cont empty-segment (cons i node)))
-
-(define (fall-through-cont? cont)
-  (not (return-cont? cont)))
-
-; Ignore return value, then fall through
-
-(define ignore-values-segment
-  (instruction (enum op ignore-values)))
-
-(define (ignore-values-cont node i)
-  (make-cont ignore-values-segment (cons i node)))
-
-(define (ignore-values-cont? cont)
-  (eq? (cont-segment cont) ignore-values-segment))
-
-; Value is in *val*; deliver it to its continuation.
-; No need to generate an ignore-values instruction in this case.
-
-(define (deliver-value segment cont)
-  (if (ignore-values-cont? cont)	;+++
-      segment
-      (sequentially segment (cont-segment cont))))
-
-; For putting names to lambda expressions:
-
-(define (named-cont name)
-  (make-cont empty-segment name))
-
-(define (cont-name cont)
-  (if (pair? (cont-source-info cont))
-      #f
-      (cont-source-info cont)))
-
-; Find lookup result that was cached by classifier
-
-(define (name-node-binding node)
-  (or (node-ref node 'binding)
-      (node-form node)))
-
-; --------------------
-; Utilities
-
-; Produce something for source code that contains a compile-time error.
-
-(define (generate-trap cont . stuff)
-  (apply warn stuff)
-  (sequentially (instruction-with-literal (enum op literal)
-					  (cons 'error stuff))
-		(deliver-value (instruction (enum op trap))
-			       cont)))
-
-; --------------------
-; Type checking.  This gets called on all nodes.
-
-(define (type-check node)
-  (if *type-check?*
-      (let ((form (node-form node)))
-	(if (pair? form)
-	    (let ((proc-node (car form)))
-	      (if (node? proc-node)
-		  (let ((proc-type (node-type proc-node)))
-		    (cond ((procedure-type? proc-type)
-			   (if (restrictive? proc-type)
-			       (let* ((args (cdr form))
-				      (args-type (make-some-values-type
-						  (map (lambda (arg)
-							 (meet-type
-							  (node-type arg)
-							  value-type))
-						       args)))
-				      (node (make-similar-node node
-							       (cons proc-node
-								     args))))
-				 (if (not (meet? args-type
-						 (procedure-type-domain proc-type)))
-				     (diagnose-call-error node proc-type))
-				 node)
-			       node))
-			  ((not (meet? proc-type any-procedure-type))
-			   ;; Could also check args for one-valuedness.
-			   (let ((message "non-procedure in operator position"))
-			     (warn message
-				   (schemify node)
-				   `(procedure: ,proc-type))
-			     (node-set! node 'type-error message))
-			   node)
-			  (else node)))
-		  node))
-	    node))
-      node))
-
-(define (set-type-check?! check?)
-  (set! *type-check?* check?))
-
-(define *type-check?* #t)
-
-
-(define (diagnose-call-error node proc-type)
-  (let ((message
-	 (cond ((not (fixed-arity-procedure-type? proc-type))
-		"invalid arguments")
-	       ((= (procedure-type-arity proc-type)
-		   (length (cdr (node-form node))))
-		"argument type error")
-	       (else
-		"wrong number of arguments"))))
-    (warn message
-	  (schemify node)
-	  `(procedure wants:
-		      ,(rail-type->sexp (procedure-type-domain proc-type)
-					#f))
-	  `(arguments are: ,(map (lambda (arg)
-				   (type->sexp (node-type arg) #t))
-				 (cdr (node-form node)))))
-    (node-set! node 'type-error message)))
-
-
-; Type system loophole
-
-(define-compilator 'loophole syntax-type
-  (lambda (node level depth cont)
-    (compile (caddr (node-form node)) level depth cont)))
-
-; Node predicates and operators.
-
-(define lambda-node?  (node-predicate 'lambda syntax-type))
-(define name-node?    (node-predicate 'name 'leaf))
-(define literal-node? (node-predicate 'literal 'leaf))
-
-(define operator/lambda     (get-operator 'lambda syntax-type))
-(define operator/set!	    (get-operator 'set!   syntax-type))
-(define operator/call	    (get-operator 'call   'internal))
-(define operator/begin      (get-operator 'begin  syntax-type))
diff --git a/scheme/bcomp/comp-package.scm b/scheme/bcomp/comp-package.scm
deleted file mode 100644
index b62cc32..0000000
--- a/scheme/bcomp/comp-package.scm
+++ /dev/null
@@ -1,92 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; package -> template
-
-(define (compile-package package)
-  (let ((template (compile-forms ((get-optimizer
-				     (package-optimizer-names package))
-				    (expand-package package)
-				    package)
-				 (package-name package))))
-    (link! template package #t)		; #t means warn about undefined variables
-    template))
-
-; First we map down the FORMS+FILES, adding the filenames to ENV and
-; scanning the forms.  Then we walk down the list of scanned forms and
-; expand all the macros.
-;
-; All of the reversing in the second step makes it so that we process the
-; forms in there original order, to keep any errors or warnings in as
-; appropriate an order as possible, and then return them in their original
-; order.
-
-(define (expand-package package)
-  (let ((env (package->environment package)))
-    (call-with-values
-     (lambda ()
-       (package-source package))
-     (lambda (forms+files transforms needs-primitives?)
-       (for-each (lambda (name)
-		   (define-usual-transform env name))
-		 transforms)
-       (let ((scanned+envs
-	      (map (lambda (forms+file)
-		     (let ((filename (car forms+file))
-			   (forms (cdr forms+file)))
-		       (let ((env (bind-source-file-name filename env)))
-			 (cons env
-			       (scan-forms forms env)))))
-		   (if needs-primitives?
-		       `((#f . ,(define-primitives env))
-			 . ,forms+files)
-		       forms+files))))
-	 (reverse 
-	  (fold (lambda (scanned+env expanded)
-		  (let ((env (car scanned+env)))
-		    (fold (lambda (form expanded)
-			    (cons (delay (expand-scanned-form form env))
-				  expanded))
-			  (cdr scanned+env)
-			  expanded)))
-		scanned+envs
-		'())))))))
-		       
-; NAME is the name of one of the usual Scheme macros (AND, OR, COND, and so
-; forth).  This adds the appropriate transform to ENV.
-
-(define (define-usual-transform env name)
-  (environment-define! env
-		       name
-		       syntax-type
-		       (make-transform (usual-transform name)
-				       (extract-package-from-environment env)
-				       syntax-type
-				       `(usual-transform ',name)
-				       name)))
-
-; This adds definitions of all operators to ENV and returns a list of forms
-; that define the closed-compiled versions of those operators that have such.
-
-(define (define-primitives env)
-  (let ((procs '()))
-    (table-walk (lambda (name op)
-		  (let ((type (operator-type op)))
-		    (if (not (eq? (operator-type op) 'leaf))
-			(environment-define! env name (operator-type op) op))))
-		operators-table)
-    (walk-primops (lambda (name type primop)
-		    (environment-define! env name type primop)
-		    (set! procs
-			  (cons (make-define-primitive-node name env)
-				procs))))
-    procs))
-
-(define (make-define-primitive-node name env)
-  (make-node operator/define
-	     `(define ,(expand name env)
-		,(make-node operator/primitive-procedure
-			    `(primitive-procedure ,name)))))
-
-;----------------
-(define operator/define	             (get-operator 'define syntax-type))
-(define operator/primitive-procedure (get-operator 'primitive-procedure syntax-type))
diff --git a/scheme/bcomp/comp.scm b/scheme/bcomp/comp.scm
deleted file mode 100644
index 3757898..0000000
--- a/scheme/bcomp/comp.scm
+++ /dev/null
@@ -1,152 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; This is the main entry point to the compiler.  It returns a template
-; that will execute the forms (each of which is a node).
-;
-; This is written in a somewhat odd fashion to make sure that the forms are
-; not retained once they have been compiled.
-
-;(define (compile-forms forms name)
-;  (if (null? forms)
-;      (segment->template (sequentially
-;                           (instruction (enum op protocol) 0)
-;                           (deliver-value (instruction (enum op unspecific))
-;                                          (return-cont #f)))
-;                         name
-;                         #f             ;pc-in-segment
-;                         #f)            ;debug data
-;      (really-compile-forms forms
-;                            (instruction (enum op protocol) 0)
-;                            name)))
-;      
-;(define (really-compile-forms forms segment name)
-;  (if (null? (cdr forms))
-;      (segment->template (sequentially segment
-;                                       (compile-form (car forms)
-;                                                     (return-cont #f)))
-;                         name
-;                         #f             ;pc-in-segment
-;                         #f)            ;debug data
-;      (really-compile-forms (cdr forms)
-;                            (sequentially segment
-;                                          (compile-form (car forms)
-;                                                        an-ignore-values-cont))
-;                            name)))
-
-(define (compile-forms forms name)
-  (if (null? forms)
-      (segment->template (sequentially
-                           (instruction (enum op protocol) 0)
-                           (deliver-value (instruction (enum op unspecific))
-                                          (return-cont #f)))
-                         name
-                         #f             ;pc-in-segment
-                         #f)            ;debug data
-      (compile-forms-loop (reverse forms) name #f)))
-
-(define (compile-forms-loop forms name next)
-  (if (null? forms)
-      next
-      (compile-forms-loop (cdr forms)
-			  name
-			  (compile-form (car forms) name next))))
-
-; Compile a single top-level form, returning a template.  NEXT is either #F or
-; a template; if it is a template we jump to it after FORM.
-  
-(define (compile-form form name next)
-  (segment->template (sequentially
-		      (instruction (enum op protocol) 0)
-		      (let ((node (force-node form))
-			    (cont (if next
-				      an-ignore-values-cont
-				      (return-cont #f))))
-			(if (define-node? node)
-			    (compile-definition node cont)
-			    (compile-expression node 0 cont)))
-		      (if next
-			  (instruction-with-literal (enum op call-template)
-						    next
-						    0)
-			  empty-segment))
-		     name
-		     #f		;pc-in-segment
-		     #f))	;debug data
-
-(define define-node? (node-predicate 'define syntax-type))
-
-; Definitions must be treated differently from assignments: we must
-; use SET-CONTENTS! instead of SET-GLOBAL! because the SET-GLOBAL!
-; instruction traps if an attempt is made to store into an undefined
-; location.
-
-(define (compile-definition node cont)
-  (let* ((form (node-form node))
-	 (name (cadr form)))
-    (sequentially (instruction-with-location (enum op literal)
-					     (node-ref name 'binding)
-					     (node-form name)
-					     value-type)
-		  (instruction (enum op push))
-		  (compile-expression (caddr form)
-				      1
-				      (named-cont (node-form name)))
-		  (deliver-value
-		   (instruction (enum op stored-object-set!)
-				(enum stob location)
-				location-contents-offset)
-		   cont))))
-
-(define location-contents-offset
-  (cond ((assq 'location stob-data)
-	 => (lambda (stuff)
-	      (let loop ((slots (cdddr stuff)) (i 0))
-		(if (eq? (caar slots) 'contents)
-		    i
-		    (loop (cdr slots) (+ i 1))))))
-	(else
-	 (error "can't find location data in STOB-DATA"))))
-
-;----------------
-; Make a startup procedure from a list of initialization templates.  This
-; is only used by the static linker.  RESUMER should be a template that
-; returns a procedure that takes 5 arguments (the number the VM passes to
-; the startup procedure).
-
-(define (make-startup-procedure inits resumer)
-  (let ((nargs 5))
-    (append-templates inits
-		      nargs
-		      (sequentially
-		        (maybe-push-continuation
-			  (instruction-with-literal (enum op call-template)
-						    resumer
-						    0)
-			  nargs
-			  (fall-through-cont #f #f))
-			(instruction (enum op call) nargs)))))
-
-; Return a template that accepts NARGS arguments, invokes TEMPLATES in turn,
-; and then calls template FINAL on the arguments.
-
-(define (append-templates templates nargs final)
-  (segment->template
-    (sequentially
-      (instruction (enum op protocol) nargs)
-      (reduce (lambda (template seg)
-		(sequentially
-		  (maybe-push-continuation
-		    (instruction-with-literal (enum op call-template)
-					      template
-					      0)
-		    nargs
-		    an-ignore-values-cont)
-		  seg))
-	      final
-	      templates))
-    #f		; no name
-    #f		; pc-in-segment = #f
-    #f))	; no debug data
-
-(define an-ignore-values-cont (ignore-values-cont #f #f))
-
diff --git a/scheme/bcomp/config.scm b/scheme/bcomp/config.scm
deleted file mode 100644
index a8f45c5..0000000
--- a/scheme/bcomp/config.scm
+++ /dev/null
@@ -1,34 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; For DEFINE-STRUCTURE macro
-
-(define (make-a-package opens-thunk accesses-thunk tower
-			dir clauses name)
-  (make-package opens-thunk accesses-thunk
-		#t    ;unstable
-		tower
-		dir
-		clauses
-		#f
-		name))
-
-(define (loser . rest)
-  (error "init-defpackage! neglected"))
-
-(define interface-of structure-interface)
-
-(define *verify-later!* (lambda (thunk) #f))
-
-(define (verify-later! thunk)
-  (*verify-later!* thunk))
-
-(define (set-verify-later! proc)
-  (set! *verify-later!* proc))
-
-(define (note-name! thing name)
-  (cond ((interface? thing)
-	 (note-interface-name! thing name))
-	((structure? thing)
-	 (note-structure-name! thing name)))
-  thing)
diff --git a/scheme/bcomp/ddata.scm b/scheme/bcomp/ddata.scm
deleted file mode 100644
index 4fab4d6..0000000
--- a/scheme/bcomp/ddata.scm
+++ /dev/null
@@ -1,36 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Stuff moved from segment.scm  6/5/93
-; Some of that stuff moved to state.scm 4/28/95
-
-; Debug-data records are for communicating information from the
-; compiler to various debugging tools.
-
-; An environment map has the form
-;   #(pc-before pc-after #(name ...) (env-map ...))
-; where the two pc's delimit the region of code that executes in this
-; environment.  The names indicate which variables become bound at
-; pc-before, and the list of env-maps is for inferior (deeper)
-; environments.
-
-; pc-in-parent gives the pc of a make-closure instruction in the code
-; for this template's superior (outer) lambda-expression.
-
-; Source is in the form of an a-list mapping pc's used in continuations
-; to pairs of the form (i . expression), indicating that the continuation
-; is returning the value of i'th subexpression in the source expression.
-
-(define-record-type debug-data :debug-data
-  (make-debug-data uid name parent pc-in-parent env-maps source)
-  debug-data?
-  (uid      debug-data-uid)
-  (name	    debug-data-name)
-  (parent   debug-data-parent)
-  (pc-in-parent debug-data-pc-in-parent)
-  (env-maps debug-data-env-maps set-debug-data-env-maps!)
-  (source   debug-data-source set-debug-data-source!))
-
-(define-record-discloser :debug-data
-  (lambda (dd)
-    (list 'debug-data (debug-data-uid dd) (debug-data-name dd))))
diff --git a/scheme/bcomp/for-reify.scm b/scheme/bcomp/for-reify.scm
deleted file mode 100644
index 5e8fe96..0000000
--- a/scheme/bcomp/for-reify.scm
+++ /dev/null
@@ -1,55 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Things used by the expression returned by REIFY-STRUCTURES.
-; Cf. link/reify.scm.
-
-(define (operator name type-exp)
-  (get-operator name (sexp->type type-exp #t)))
-
-(define (primop name)
-  (get-primop name))
-
-(define (simple-interface names types)
-  (make-simple-interface #f
-			 (map (lambda (name type)
-				(list name (sexp->type type #t)))
-			      (vector->list names)
-			      (vector->list types))))
-
-(define (package names locs get-location uid)
-  (let ((end (vector-length names))
-	(p (make-package list list ;(lambda () '())
-			 #f #f "" '()
-			 uid #f)))
-    (set-package-loaded?! p #t)
-    (do ((i 0 (+ i 1)))
-	((= i end))
-      (let* ((name (vector-ref names i))
-	     (probe (package-lookup p name)))
-	(if (not (binding? probe))
-	    (package-define! p
-			     name
-			     usual-variable-type
-			     (get-location (vector-ref locs i))
-			     #f))))
-    (make-table-immutable! (package-definitions p))
-    p))
-
-(define (transform names+proc env type-exp source name)
-  (make-transform names+proc env (sexp->type type-exp #t) source name))
-
-(define (package-define-static! package name static)
-  (package-define! package
-		   name
-		   (cond ((transform? static)
-			  (transform-type static))
-			 ((primop? static)
-			  (primop-type static))
-			 ((operator? static)
-			  (operator-type static))
-			 ((structure? static)
-			  structure-type)
-			 (else
-			  (error "unknown kind of static value" static)))
-		   #f
-		   static))
diff --git a/scheme/bcomp/node.scm b/scheme/bcomp/node.scm
deleted file mode 100644
index b65e69f..0000000
--- a/scheme/bcomp/node.scm
+++ /dev/null
@@ -1,143 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; --------------------
-; Operators (= special operators and primitives)
-
-(define-record-type operator :operator
-  (make-operator type nargs uid name)
-  operator?
-  (type operator-type set-operator-type!)
-  (nargs operator-nargs)
-  (uid operator-uid)
-  (name operator-name))
-
-(define-record-discloser :operator
-  (lambda (s)
-    (list 'operator
-	  (operator-name s)
-	  (if (symbol? (operator-type s))
-	      (operator-type s)
-	      (type->sexp (operator-type s) #t)))))
-
-(define usual-operator-type
-  (procedure-type any-arguments-type value-type #f))
-
-(define (get-operator name . type-option)
-  (let ((type (if (null? type-option) #f (car type-option)))
-	(probe (table-ref operators-table name)))
-    (if (operator? probe)
-	(let ((previous-type (operator-type probe)))
-	  (cond ((not type))
-		((not previous-type)
-		 (set-operator-type! probe type))
-		((symbol? type)		; 'leaf or 'internal
-		 (if (not (eq? type previous-type))
-		     (warn "operator type inconsistency" name type previous-type)))
-		((subtype? type previous-type)  ;Improvement
-		 (set-operator-type! probe type))
-		((not (subtype? previous-type type))
-		 (warn "operator type inconsistency"
-		       name
-		       (type->sexp previous-type 'foo)
-		       (type->sexp type 'foo))))
-	  probe)
-	(let* ((uid *operator-uid*)
-	       (op (make-operator type
-				  (if (and type
-					   (not (symbol? type))
-					   (fixed-arity-procedure-type? type))
-				      (procedure-type-arity type)
-				      #f)
-				  uid
-				  name)))
-	  (if (>= uid number-of-operators)
-	      (warn "too many operators" (operator-name op) (operator-type op)))
-	  (set! *operator-uid* (+ *operator-uid* 1))
-	  (table-set! operators-table (operator-name op) op)
-	  (vector-set! the-operators uid op)
-	  op))))
-
-(define *operator-uid* 0)
-
-(define operators-table (make-table))
-
-(define number-of-operators 400)  ;Fixed-size limits bad, but speed good
-(define the-operators (make-vector number-of-operators #f))
-
-; --------------------
-; Operator tables (for fast dispatch)
-
-(define (make-operator-table default)
-  (make-vector number-of-operators default))
-
-(define operator-table-ref vector-ref)
-
-(define (operator-lookup table op)
-  (operator-table-ref table (operator-uid op)))
-
-(define (operator-define! table name type proc)
-  (vector-set! table
-	       (operator-uid (get-operator name type))
-	       proc))
-
-; --------------------
-; Nodes
-
-; A node is an annotated expression (or definition or other form).
-; The FORM component of a node is an S-expression of the same form as
-; the S-expression representation of the expression.  E.g. for
-; literals, the form is the literal value; for variables the form is
-; the variable name; for IF expressions the form is a 4-element list
-; (ignored test con alt).  Nodes also have a tag identifying what kind
-; of node it is (literal, variable, if, etc.) and a property list.
-
-(define-record-type node :node
-  (really-make-node uid form plist)
-  node?
-  (uid node-operator-id)
-  (form node-form)
-  (plist node-plist set-node-plist!))
-
-(define-record-discloser :node
-  (lambda (n) (list (operator-name (node-operator n)) (node-form n))))
-
-(define (make-node operator form)
-  (really-make-node (operator-uid operator) form '()))
-
-(define (node-ref node key)
-  (let ((probe (assq key (node-plist node))))
-    (if probe (cdr probe) #f)))
-
-(define (node-set! node key value) ;gross
-  (if value
-      (let ((probe (assq key (node-plist node))))
-	(if probe
-	    (set-cdr! probe value)
-	    (set-node-plist! node (cons (cons key value) (node-plist node)))))
-      (let loop ((l (node-plist node)) (prev #f))
-	(cond ((null? l) 'lose)
-	      ((eq? key (caar l))
-	       (if prev
-		   (set-cdr! prev (cdr l))
-		   (set-node-plist! node (cdr l))))
-	      (else (loop (cdr l) l))))))
-
-(define (node-operator node)
-  (vector-ref the-operators (node-operator-id node)))
-
-(define (node-predicate name . type-option)
-  (let ((id (operator-uid (apply get-operator name type-option))))
-    (lambda (node)
-      (= (node-operator-id node) id))))
-
-(define (make-similar-node node form)
-  (if (equal? form (node-form node))
-      node
-      (make-node (node-operator node) form)))
-
-; Top-level nodes are often delayed.
-
-(define (force-node node)
-  (if (node? node)
-      node
-      (force node)))
diff --git a/scheme/bcomp/optimize.scm b/scheme/bcomp/optimize.scm
deleted file mode 100644
index 66d2f77..0000000
--- a/scheme/bcomp/optimize.scm
+++ /dev/null
@@ -1,28 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Optimizers
-
-(define optimizers-table (make-table))
-
-(define (set-optimizer! name opt)
-  (table-set! optimizers-table name opt))
-
-(define (get-optimizer names)
-  (lambda (forms package)
-    (apply-optimizers (map (lambda (name)
-			     (or (table-ref optimizers-table name)
-				 (begin
-				   (signal 'note
-					   "optional optimization pass not invoked"
-					   name)
-				   (lambda (forms package) forms))))
-			   names)
-		      forms
-		      package)))
-
-(define (apply-optimizers optimizers forms package)
-  (fold (lambda (optimizer forms)
-	  (optimizer forms package))
-	optimizers
-	forms))
-
diff --git a/scheme/bcomp/primop.scm b/scheme/bcomp/primop.scm
deleted file mode 100644
index 6557490..0000000
--- a/scheme/bcomp/primop.scm
+++ /dev/null
@@ -1,33 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Primops.
-
-(define-record-type primop :primop
-  (make-primop name type closed compilator)
-  primop?
-  (name primop-name)
-  (type primop-type)
-  (closed primop-closed)
-  (compilator primop-compilator))
-
-(define-record-discloser :primop
-  (lambda (primop)
-    `(primop ,(primop-name primop))))
-
-(define primop-table (make-symbol-table))
-
-; This is used to add definitions of the primitives to a package.
-
-(define (walk-primops proc)
-  (table-walk (lambda (name primop)
-		(proc name (primop-type primop) primop))
-	      primop-table))
-
-(define (define-compiler-primitive name type compilator closed)
-  (table-set! primop-table
-	      name
-	      (make-primop name (or type value-type) closed compilator)))
-
-(define (get-primop name)
-  (or (table-ref primop-table name)
-      (error "unknown compiler primitive" name)))
diff --git a/scheme/bcomp/recon.scm b/scheme/bcomp/recon.scm
deleted file mode 100644
index b962513..0000000
--- a/scheme/bcomp/recon.scm
+++ /dev/null
@@ -1,323 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Rudimentary type reconstruction, hardly worthy of the name.
-
-; Currently, NODE-TYPE is called in two places.  One is to determine
-; the type of the right-hand side of a DEFINE for a variable that is
-; never assigned, so uses of the variable can be checked later.  The
-; other is when compiling a call, to check types of arguments and
-; produce warning messages.
-
-; This is heuristic, to say the least.  It's not clear what the right
-; interface or formalism is for Scheme; I'm still experimenting.
-
-; Obviously we can't do Hindley-Milner inference.  Not only does
-; Scheme have subtyping, but it also has dependent types up the wazoo.
-; For example, the following is perfectly correct Scheme:
-;
-;   (define (foo x y) (if (even? x) (car y) (vector-ref y 3)))
-
-(define (node-type node)
-  (reconstruct node 'fast any-values-type))
-
-(define (reconstruct-type node env)
-  (reconstruct node '() any-values-type))
-
-(define (reconstruct node constrained want-type)
-  ((operator-table-ref reconstructors (node-operator-id node))
-    node
-    constrained
-    want-type))
-
-(define (examine node constrained want-type)
-  (if (pair? constrained)
-      (reconstruct node constrained want-type)
-      want-type))
-
-(define reconstructors
-  (make-operator-table (lambda (node constrained want-type)
-                         (reconstruct-call (node-form node)
-					   constrained
-					   want-type))))
-
-(define (define-reconstructor name type proc)
-  (operator-define! reconstructors name type proc))
-
-(define-reconstructor 'lambda syntax-type
-  (lambda (node constrained want-type)
-    (reconstruct-lambda node constrained want-type #f)))
-
-(define-reconstructor 'flat-lambda syntax-type
-  (lambda (node constrained want-type)
-    (reconstruct-lambda node constrained want-type #f)))
-
-(define (reconstruct-lambda node constrained want-type called?)
-  (if (eq? constrained 'fast)
-      any-procedure-type
-      (let* ((form (node-form node))
-	     (want-result (careful-codomain want-type))
-	     (formals (cadr form))
-	     (alist (map (lambda (node)
-			   (cons node value-type))
-			 (normalize-formals formals)))
-	     (cod (reconstruct (last form)	; works for normal and flat
-			       (if called?
-				   (append alist constrained)
-				   alist)
-			       want-result)))
-	(procedure-type (if (n-ary? formals)
-			    any-values-type ;lose
-			    (make-some-values-type (map cdr alist)))
-			cod
-			#t))))
-
-(define (careful-codomain proc-type)
-  (if (procedure-type? proc-type)
-      (procedure-type-codomain proc-type)
-      any-values-type))
-
-(define-reconstructor 'name 'leaf
-  (lambda (node constrained want-type)
-    (if (eq? constrained 'fast)
-        (reconstruct-name node)
-        (let ((z (assq node constrained)))
-          (if z
-              (let ((type (meet-type (cdr z) want-type)))
-                (begin (set-cdr! z type)
-                       type))
-              (reconstruct-name node))))))
-
-(define (reconstruct-name node)
-  (let ((probe (node-ref node 'binding)))
-    (if (binding? probe)
-        (let ((type (binding-type probe)))
-          (cond ((variable-type? type)
-		 (variable-value-type type))
-                ((subtype? type value-type)
-		 type)
-                (else
-		 value-type)))
-        value-type)))
-
-(define-reconstructor 'call 'internal
-  (lambda (node constrained want-type)
-    (let ((form (node-form node)))
-      (cond ((proc->reconstructor (car form))
-	     => (lambda (recon)
-		  (recon (cdr form) constrained want-type)))
-	    (else
-	     (reconstruct-call form constrained want-type))))))
-
-; See if PROC is a primop or a variable bound to a primop, and then return
-; that primops reconstructor, if it has one.
-
-(define (proc->reconstructor proc)      
-  (cond ((name-node? proc)
-	 (let ((probe (node-ref proc 'binding)))
-	   (if (and probe
-		    (binding? probe)
-		    (primop? (binding-static probe)))
-	       (table-ref primop-reconstructors
-			  (binding-static probe))
-	       #f)))
-	((literal-node? proc)
-	 (if (primop? (node-form proc))
-	     (table-ref primop-reconstructors
-			(node-form proc))
-	     #f))
-	(else #f)))
-
-(define (reconstruct-call form constrained want-type)
-  (let* ((want-op-type (procedure-type any-arguments-type
-				       want-type
-				       #f))
-	 (op-type (if (lambda-node? (car form))
-		      (reconstruct-lambda (car form)
-					  constrained
-					  want-op-type
-					  #t)
-		      (reconstruct (car form)
-				   constrained
-				   want-op-type)))
-	 (args (cdr form))
-	 (lose (lambda ()
-		 (for-each (lambda (arg)
-			     (examine arg constrained value-type))
-			   args))))
-    (if (procedure-type? op-type)
-	(begin (if (restrictive? op-type)
-		   (let loop ((args args)
-			      (dom (procedure-type-domain op-type)))
-		     (if (not (or (null? args)
-				  (empty-rail-type? dom)))
-			 (begin (examine (car args)
-					 constrained
-					 (head-type dom))
-				(loop (cdr args) (tail-type dom)))))
-		   (lose))
-	       (procedure-type-codomain op-type))
-	(begin (lose)
-	       any-values-type))))
-
-(define-reconstructor 'literal 'leaf
-  (lambda (node constrained want-type)
-    (constant-type (node-form node))))
-
-(define-reconstructor 'quote syntax-type
-  (lambda (node constrained want-type)
-    (constant-type (cadr (node-form node)))))
-
-(define-reconstructor 'unspecific #f
-  (lambda (node constrained wnat-type)
-    unspecific-type))
-
-(define-reconstructor 'unassigned #f
-  (lambda (node constrained wnat-type)
-    unspecific-type))
-
-(define-reconstructor 'if syntax-type
-  (lambda (node constrained want-type)
-    (let ((form (node-form node)))
-      (examine (cadr form) constrained value-type)
-      ;; Fork off two different constrain sets
-      (let ((con-alist (fork-constraints constrained))
-            (alt-alist (fork-constraints constrained)))
-        (let ((con-type (reconstruct (caddr form) con-alist want-type))
-              (alt-type (reconstruct (cadddr form) alt-alist want-type)))
-          (if (pair? constrained)
-              (for-each (lambda (c1 c2 c)
-                          (set-cdr! c (join-type (cdr c1) (cdr c2))))
-                        con-alist
-                        alt-alist
-                        constrained))
-          (join-type con-type alt-type))))))
-
-(define (fork-constraints constrained)
-  (if (pair? constrained)
-      (map (lambda (x) (cons (car x) (cdr x)))
-           constrained)
-      constrained))-
-
-(define-reconstructor 'begin syntax-type
-  (lambda (node constrained want-type)
-    ;; This is unsound - there might be a throw out of some subform
-    ;; other than the final one.
-    (do ((forms (cdr (node-form node)) (cdr forms)))
-        ((null? (cdr forms))
-         (reconstruct (car forms) constrained want-type))
-      (examine (car forms) constrained any-values-type))))
-
-(define-reconstructor 'set! syntax-type
-  (lambda (node constrained want-type)
-    (examine (caddr (node-form node)) constrained value-type)
-    unspecific-type))
-
-(define-reconstructor 'letrec syntax-type
-  (lambda (node constrained want-type)
-    (let ((form (node-form node)))
-      (if (eq? constrained 'fast)
-          (reconstruct (caddr form) 'fast want-type)
-          (let ((alist (map (lambda (spec)
-			      (cons (car spec)
-				    (reconstruct (cadr spec)
-						 constrained
-						 value-type)))
-                            (cadr form))))
-            (reconstruct (caddr form)
-			 (append alist constrained)
-                         want-type))))))
-
-(define-reconstructor 'loophole syntax-type
-  (lambda (node constrained want-type)
-    (let ((args (cdr (node-form node))))
-      (examine (cadr args) constrained any-values-type)
-      (car args))))
-
-(define (node->type node)
-  (if (node? node)
-      (let ((form (node-form node)))
-        (if (pair? form)
-            (map node->type form)
-            (desyntaxify form)))
-      (desyntaxify node)))
-
-(define-reconstructor 'define syntax-type
-  (lambda (node constrained want-type)
-    ':definition))
-
-(define-reconstructor 'lap syntax-type
-  (lambda (node constrained want-type)
-    any-procedure-type))
-
-(define name-node?    (node-predicate 'name    'leaf))
-(define lambda-node?  (node-predicate 'lambda  syntax-type))
-(define literal-node? (node-predicate 'literal 'leaf))
-; --------------------
-; Primops.
-;
-; Most primops just have the types assigned in comp-prim.scm.
-
-(define primop-reconstructors (make-symbol-table))
-
-(define (define-primop-reconstructor name proc)
-  (table-set! primop-reconstructors name proc))
-
-(define-reconstructor 'primitive-procedure syntax-type
-  (lambda (node constrained want-type)
-    (primop-type (get-primop (cadr (node-form node))))))
-
-(define-primop-reconstructor 'values
-  (lambda (args constrained want-type)
-    (make-some-values-type (map (lambda (node)
-                                  (meet-type
-                                   (reconstruct node constrained value-type)
-                                   value-type))
-				args))))
-
-(define-primop-reconstructor 'call-with-values
-  (lambda (args constrained want-type)
-    (if (= (length args) 2)
-	(let ((thunk-type (reconstruct (car args)
-				       constrained
-				       (procedure-type empty-rail-type
-						       any-values-type
-						       #f))))
-	  (careful-codomain
-	   (reconstruct (cadr args)
-			constrained
-			(procedure-type (careful-codomain thunk-type)
-					any-values-type
-					#f))))
-	error-type)))
-
-(define (reconstruct-apply args constrained want-type)
-  (if (not (null? args))
-      (let ((proc-type (reconstruct (car args)
-				    constrained
-				    any-procedure-type)))
-	(for-each (lambda (arg) (examine arg constrained value-type))
-		  (cdr args))
-	(careful-codomain proc-type))
-      error-type))
-
-(define-primop-reconstructor 'apply reconstruct-apply)
-
-(define-primop-reconstructor 'primitive-catch reconstruct-apply)
-
-(define (constant-type x)
-  (cond ((number? x)
-         (meet-type (if (exact? x) exact-type inexact-type)
-                    (cond ((integer? x) integer-type)
-                          ((rational? x) rational-type)
-                          ((real? x) real-type)
-                          ((complex? x) complex-type)
-                          (else number-type))))
-        ((boolean? x) boolean-type)
-        ((pair? x) pair-type)
-        ((string? x) string-type)
-        ((char? x) char-type)
-        ((null? x) null-type)
-        ((symbol? x) symbol-type)
-        ((vector? x) vector-type)
-        (else value-type)))
-
diff --git a/scheme/bcomp/scan-package.scm b/scheme/bcomp/scan-package.scm
deleted file mode 100644
index fd5efb7..0000000
--- a/scheme/bcomp/scan-package.scm
+++ /dev/null
@@ -1,126 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Scanning structures and processing package clauses.
-
-; Utility for compile-structures (link/link.scm) and
-; ensure-loaded (env/load-package.scm).
-;
-; Returns a list of all packages reachable from STRUCTS that answer true to
-; INCLUDE-THIS-PACKAGE?.
-
-(define (collect-packages structs include-this-package?)
-  (let ((package-seen '())
-	(structure-seen '())
-	(packages '()))
-    (letrec ((recur
-	      (lambda (structure)
-		(if (not (memq structure structure-seen))
-		    (begin
-		      (set! structure-seen (cons structure structure-seen))
-		      (let ((package (structure-package structure)))
-			(if (not (memq package package-seen))
-			    (begin
-			      (set! package-seen (cons package package-seen))
-			      (if (include-this-package? package)
-				  (begin
-				    (for-each recur (package-opens package))
-				    (for-each (lambda (name+struct)
-						(recur (cdr name+struct)))
-					      (package-accesses package))
-				    (set! packages (cons package packages))))))))))))
-      (for-each recur structs)
-      (reverse packages))))
-
-; Walk through PACKAGE's clauses to find the source code.  The relevent
-; clauses are:
-;   (file name ...)
-;   (begin form ...)
-;   (define-all-operators)
-;   (usual-transforms)
-;
-; Returns a list of pairs (file . (node1 node2 ...)), a list of names
-; of standard transforms, and a boolean value which is true if the package
-; is to include definitions of all primitives.
-
-(define (package-source package)
-  (let* ((config-file (package-file-name package))
-	 (dir (if config-file
-		  (file-name-directory config-file)
-		  #f)))
-    (fold->3 (lambda (clause stuff transforms primitives?)
-	       (case (car clause)
-		 ((files)
-		  (values (read-files (cdr clause) stuff dir package)
-			  transforms
-			  primitives?))
-		 ((begin)
-		  (values (cons (cons config-file (cdr clause))
-				stuff)
-			  transforms
-			  primitives?))
-		 ((integrate)
-		  (set-package-integrate?! package
-					   (or (null? (cdr clause))
-					       (cadr clause)))
-		  (values stuff transforms primitives?))
-		 ((optimize)
-		  (values stuff transforms primitives?))
-		 ((define-all-operators)
-		  (values stuff transforms #t))
-		 ((usual-transforms)
-		  (values stuff
-			  (append (cdr clause) transforms)
-			  primitives?))
-		 (else
-		  (error "unrecognized define-structure keyword"
-			 clause))))
-	     (reverse (package-clauses package))
-	     '() '() #f)))
-
-; Also prints out the filenames (courtesy of READ-FORMS).
-
-(define (read-files all-files stuff dir package)
-  (force-output (current-output-port))		; just to be nice
-  (fold (lambda (filespec stuff)
-	  (let ((file (namestring filespec
-				  dir
-				  *scheme-file-type*)))
-	    (display #\space (current-noise-port))
-	    (cons (cons file (read-forms file package))
-		  stuff)))
-	(reverse all-files)
-	stuff))
-
-(define (package-optimizer-names package)
-  (if (package-integrate? package)
-      (let ((opts (apply append
-			 (map cdr (filter (lambda (clause)
-					    (eq? (car clause) 'optimize))
-					  (package-clauses package))))))
-	(reduce (lambda (name opts)
-		  (if (memq name opts)
-		      opts
-		      (cons name opts)))
-		opts
-		'()))
-      '()))
-
-(define (check-structure structure)
-  (let ((undefined '()))
-    (for-each-export
-         (lambda (name want-type binding)
-	   (if (binding? binding)
-	       (let ((have-type (binding-type binding)))
-		 (if (not (compatible-types? have-type want-type))
-		     (warn "Type in interface doesn't match binding"
-			   name
-			   `(binding: ,(type->sexp have-type #t))
-			   `(interface: ,(type->sexp want-type #t))
-			   structure)))
-	       (set! undefined (cons name undefined))))
-	 structure)
-    (if (not (null? undefined))
-	(warn "Structure has undefined exports"
-	      structure
-	      undefined))))
-
diff --git a/scheme/bcomp/schemify.scm b/scheme/bcomp/schemify.scm
deleted file mode 100644
index 623b94f..0000000
--- a/scheme/bcomp/schemify.scm
+++ /dev/null
@@ -1,141 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; schemify
-
-; This is only used for producing error and warning messages.
-
-; Flush nodes and generated names in favor of something a little more
-; readable.  Eventually, (schemify node env) ought to produce an
-; s-expression that has the same semantics as node, when node is fully
-; expanded.
-
-(define (schemify node . maybe-env)
-  (if (node? node)
-      (schemify-node node
-		     (if (null? maybe-env)
-			 #f
-			 (car maybe-env)))
-      (schemify-sexp node)))
-		     
-
-(define schemifiers
-  (make-operator-table (lambda (node env)
-			 (let ((form (node-form node)))
-			   (if (list? form)
-			       (let ((op (car form)))
-				 (cons (cond ((operator? op)
-					      (operator-name op))
-					     ((node? op)
-					      (schemify-node op env))
-					     (else
-					      (schemify-sexp op)))
-				       (schemify-nodes (cdr form) env)))
-			       form)))))
-
-; We cache the no-env version because that's the one used to generate the
-; sources in the debugging info (which takes up a lot of space).
-
-(define (schemify-node node env)
-  (or (and (not env)
-	   (node-ref node 'schemify))
-      (let ((form ((operator-table-ref schemifiers (node-operator-id node))
-		     node
-		     env)))
-	(if (not env)
-	    (node-set! node 'schemify form))
-	form)))
-
-(define (schemify-nodes nodes env)
-  (map (lambda (node)
-	 (schemify-node node env))
-       nodes))
-
-(define (define-schemifier name type proc)
-  (operator-define! schemifiers name type proc))
-
-(define-schemifier 'name 'leaf
-  (lambda (node env)
-    (if env
-	(name->qualified (node-form node)
-			 env)
-	(desyntaxify (node-form node)))))
-
-(define-schemifier 'quote syntax-type
-  (lambda (node env)
-    (let ((form (node-form node)))
-      `(quote ,(cadr form)))))
-
-(define-schemifier 'call 'internal
-  (lambda (node env)
-    (map (lambda (node)
-	   (schemify-node node env))
-	 (node-form node))))
-
-; We ignore the list of free variables in flat lambdas.
-
-(define (schemify-lambda node env)
-  (let ((form (node-form node)))
-    `(lambda ,(schemify-formals (cadr form) env)
-       ,(schemify-node (last form) env))))
-
-(define-schemifier 'lambda syntax-type schemify-lambda)
-(define-schemifier 'flat-lambda syntax-type schemify-lambda)
-
-(define (schemify-formals formals env)
-  (cond ((node? formals)
-	 (schemify-node formals env))
-	((pair? formals)
-	 (cons (schemify-node (car formals) env)
-	       (schemify-formals (cdr formals) env)))
-	(else
-	 (schemify-sexp formals))))  ; anything besides '() ?
-
-; let-syntax, letrec-syntax...
-
-(define-schemifier 'letrec syntax-type
-  (lambda (node env)
-    (let ((form (node-form node)))
-      `(letrec ,(map (lambda (spec)
-		       (schemify-nodes spec env))
-		     (cadr form))
-	 ,@(map (lambda (f) (schemify-node f env))
-		(cddr form))))))
-
-(define-schemifier 'loophole syntax-type
-  (lambda (node env)
-    (let ((form (node-form node)))
-      (list 'loophole
-	    (type->sexp (cadr form) #t)
-	    (schemify-node (caddr form) env)))))
-
-(define-schemifier 'lap syntax-type
-  (lambda (node env)
-    (let ((form (node-form node)))
-      `(lap
-	,(cadr form)
-	,(schemify-nodes (caddr form) env)
-	. ,(cdddr form)))))
-
-;----------------
-
-(define (schemify-sexp thing)
-  (cond ((name? thing)
-	 (desyntaxify thing))
-	((pair? thing)
-	 (let ((x (schemify-sexp (car thing)))
-	       (y (schemify-sexp (cdr thing))))
-	   (if (and (eq? x (car thing))
-		    (eq? y (cdr thing)))
-	       thing			;+++
-	       (cons x y))))
-	((vector? thing)
-	 (let ((new (make-vector (vector-length thing) #f)))
-	   (let loop ((i 0) (same? #t))
-	     (if (>= i (vector-length thing))
-		 (if same? thing new)	;+++
-		 (let ((x (schemify-sexp (vector-ref thing i))))
-		   (vector-set! new i x)
-		   (loop (+ i 1)
-			 (and same? (eq? x (vector-ref thing i)))))))))
-	(else thing)))
-
diff --git a/scheme/bcomp/segment.scm b/scheme/bcomp/segment.scm
deleted file mode 100644
index bd62511..0000000
--- a/scheme/bcomp/segment.scm
+++ /dev/null
@@ -1,331 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; The byte code compiler's assembly phase.
-
-(define make-segment cons)
-(define segment-size car);number of bytes that will be taken in the code vector
-(define segment-emitter cdr)
-
-(define (segment->template segment name pc-in-parent parent-data)
-  (let* ((cv (make-code-vector (segment-size segment) 0))
-	 (astate (make-astate cv))
-	 (name (if (if (string? name)	; only files have strings for names
-		       (keep-file-names?)
-		       (keep-procedure-names?))
-		   name
-		   #f))
-	 (debug-data (new-debug-data name parent-data pc-in-parent)))
-    (let-fluid $debug-data debug-data
-      (lambda ()
-	(let* ((maps (emit-with-environment-maps! astate segment))
-	       (cv (check-stack-use cv)))
-	  (set-debug-data-env-maps! debug-data maps)
-	  (make-immutable! cv)
-	  (segment-data->template cv
-				  (debug-data->info debug-data)
-				  (reverse (astate-literals astate))))))))
-
-(define (segment-data->template cv debug-data literals)
-  (let ((template (make-template (+ template-overhead (length literals)) 0)))
-    (set-template-code! template cv)
-    (set-template-info! template debug-data)
-    (do ((lits literals (cdr lits))
-	 (i template-overhead (+ i 1)))
-	((null? lits) template)
-      (template-set! template i (car lits)))
-    template))
-
-; If CV needs more than the default allotment of stack space replace its
-; protocol with one that checks that the needed space is available.  The
-; original protocol is preserved at the end of the new code vector (to
-; preserve the debugging indicies into the original).
-
-(define (check-stack-use cv)
-  (let ((uses (maximum-stack-use cv)))
-    (cond ((<= uses default-stack-space)
-	   cv)
-	  ((<= uses available-stack-space)
-	   (let* ((length (code-vector-length cv))
-		  (new (make-code-vector (+ length 3) 0)))
-	     (do ((i 0 (+ i 1)))
-		 ((= i length))
-	       (code-vector-set! new i (code-vector-ref cv i)))
-	     (code-vector-set! new length (code-vector-ref cv 1))
-	     (code-vector-set! new 1 big-stack-protocol)
-	     (code-vector-set2! new (+ length 1) uses)
-	     new))
-	  (else
-	   (error "VM limit exceeded: procedure requires too much stack space")))))
-
-; "astate" is short for "assembly state"
-
-(define-record-type assembly-state :assembly-state
-  (make-assembly-state cv pc count lits)
-  (cv    astate-code-vector)
-  (pc    astate-pc    set-astate-pc!)
-  (count astate-count set-astate-count!)
-  (lits  astate-literals  set-astate-literals!))
-
-(define (make-astate cv)
-  (make-assembly-state cv 0 template-overhead '()))
-
-(define (emit-byte! a byte)
-  (code-vector-set! (astate-code-vector a) (astate-pc a) byte)
-  (set-astate-pc! a (+ (astate-pc a) 1)))
-
-(define (literal->index a thing)
-  (let ((probe (literal-position thing (astate-literals a)))
-	(count (astate-count a)))
-    (if probe
-	;; +++  Eliminate duplicate entries.
-	;; Not necessary, just a modest space saver [how much?].
-	;; Measurably slows down compilation.
-	;; when 1 thing, lits = (x), count = 3, probe = 0, want 2
-	(- (- count probe) 1)
-	(begin
-	  (if (>= count two-byte-limit)
-	      (error "compiler bug: too many literals"
-		     thing))
-	  (set-astate-literals! a (cons thing (astate-literals a)))
-	  (set-astate-count! a (+ count 1))
-	  count))))
-
-(define (literal-position thing literals)
-  (position (if (thingie? thing)
-		(lambda (thing other-thing)
-		  (and (thingie? other-thing)
-		       (equal? (thingie-name thing)
-			       (thingie-name other-thing))))
-		equal?)
-	    thing
-	    literals))
-
-(define (position pred elt list)
-  (let loop ((i 0) (l list))
-    (cond ((null? l)
-	   #f)
-	  ((pred elt (car l))
-	   i)
-	  (else
-	   (loop (+ i 1) (cdr l))))))
-
-(define (emit-literal! a thing)
-  (let ((index (literal->index a thing)))
-    (emit-byte! a (high-byte index))
-    (emit-byte! a (low-byte index))))
-
-(define (emit-segment! astate segment)
-  ((segment-emitter segment) astate))
-
-; Segment constructors
-
-(define empty-segment
-  (make-segment 0 (lambda (astate) #f)))
-
-(define (instruction opcode . operands)
-  (make-segment (+ 1 (length operands))
-		(lambda (astate)
-		  (emit-byte! astate opcode)
-		  (for-each (lambda (operand)
-			      (emit-byte! astate operand))
-			    operands))))
-
-(define (sequentially . segments)
-  ;;  (reduce sequentially-2 empty-segment segments)
-  ;;+++ this sped the entire compilation process up by several percent
-  (cond ((null? segments)
-         empty-segment)
-        ((null? (cdr segments))
-         (car segments))
-        ((null? (cddr segments))
-         (sequentially-2 (car segments) (cadr segments)))
-        (else
-         (make-segment (let loop ((segs segments) (s 0))
-                         (if (null? segs)
-                             s
-                             (loop (cdr segs) (+ s (segment-size (car segs))))))
-                       (lambda (astate)
-                         (let loop ((segs segments))
-                           (if (not (null? segs))
-                               (begin (emit-segment! astate (car segs))
-                                      (loop (cdr segs))))))))))
-
-(define (sequentially-2 seg1 seg2)
-  (cond ((eq? seg1 empty-segment) seg2) ;+++ speed up the compiler a tad
-	((eq? seg2 empty-segment) seg1) ;+++
-	(else
-	 (make-segment (+ (segment-size seg1)
-			  (segment-size seg2))
-		       (lambda (astate)
-			 (emit-segment! astate seg1)
-			 (emit-segment! astate seg2)))))) ;tail call
-
-; Literals are obtained from the template.
-
-(define (instruction-with-literal opcode thing . operands)
-  (make-segment (+ 3 (length operands))
-		(lambda (astate)
-		  (let ((index (literal->index astate thing)))
-		    (if (and (= opcode (enum op literal))
-                             (< index byte-limit))
-			(begin
-			  (emit-byte! astate (enum op small-literal))
-			  (emit-byte! astate index)
-			  (emit-byte! astate 0))
-			(begin
-			  (emit-byte! astate opcode)
-			  (emit-byte! astate (high-byte index))
-			  (emit-byte! astate (low-byte index))))
-		    (for-each (lambda (operand)
-				(emit-byte! astate operand))
-			      operands)))))
-
-; So are locations.
-
-(define (instruction-with-location opcode binding name want-type)
-  (make-segment 3
-		(lambda (astate)
-		  (emit-byte! astate opcode)
-		  (emit-literal! astate (make-thingie binding name want-type)))))
-
-; Templates for inferior closures are also obtained from the
-; (parent's) template.
-
-(define (template segment name)
-  (make-segment 2
-  		(lambda (astate)
-  		  (emit-literal! astate
-  				 (segment->template segment
-  						    name
-						    (astate-pc astate)
-						    (fluid $debug-data))))))
-
-; Labels.  Each label maintains a list of pairs (location . origin).
-; Instr is the index of the first of two bytes that will hold the jump
-; target offset, and the offset stored will be (- jump-target origin).
-;
-; The car of a forward label is #F, the car of a backward label is the
-; label's PC.
-
-(define (make-label) (list #f))
-
-(define (instruction-using-label opcode label . rest)
-  (let ((segment (apply instruction opcode 0 0 rest)))
-    (make-segment (segment-size segment)
-		  (lambda (astate)
-		    (let* ((origin (astate-pc astate))
-			   (location (+ origin 1)))
-		      (emit-segment! astate segment)
-		      (if (car label)
-			  (insert-label! (astate-code-vector astate)
-					 location
-					 (- (car label) origin))
-			  (set-cdr! label
-				    (cons (cons location origin)
-					  (cdr label)))))))))
-
-; computed-goto
-; # of labels
-; label0
-; label1
-; ...
-
-(define computed-goto-label-size 2)
-
-(define (computed-goto-instruction labels)
-  (let* ((count (length labels))
-	 (segment (instruction (enum op computed-goto) count)))
-    (make-segment (+ (segment-size segment)
-		     (* count computed-goto-label-size))
-		  (lambda (astate)
-		    (let ((base-address (astate-pc astate)))
-		      (emit-segment! astate segment)
-		      (set-astate-pc! astate
-				      (+ (astate-pc astate)
-					 (* count computed-goto-label-size)))
-		      (do ((location (+ base-address 2)
-				     (+ location computed-goto-label-size))
-			   (labels labels (cdr labels)))
-			  ((null? labels))
-			(let ((label (car labels)))
-			  (if (car label)
-			      (warn "backward jumps not supported")
-			      (set-cdr! label
-					(cons (cons location base-address)
-					      (cdr label)))))))))))
-
-; LABEL is the label for SEGMENT.  The current PC is used as the value of LABEL.
-
-(define (attach-label label segment)
-  (make-segment
-     (segment-size segment)
-     (lambda (astate)
-       (let ((pc (astate-pc astate))
-	     (cv (astate-code-vector astate)))
-	 (for-each (lambda (instr+origin)
-		     (insert-label! cv
-				    (car instr+origin)
-				    (- pc (cdr instr+origin))))
-		   (cdr label))
-	 (set-car! label pc)
-	 (emit-segment! astate segment)))))
-
-(define (insert-label! cv location offset)
-  (code-vector-set2! cv location offset))
-
-(define (code-vector-set2! cv i value)
-  (code-vector-set! cv i       (high-byte value))
-  (code-vector-set! cv (+ i 1) (low-byte  value)))
-
-(define two-byte-limit (expt 2 (* 2 bits-used-per-byte)))
-
-(define (high-byte n)
-  (quotient n byte-limit))
-
-(define (low-byte n)
-  (remainder n byte-limit))
-
-; Special segments for maintaining debugging information.  Not
-; essential for proper functioning of compiler.
-
-(define $debug-data (make-fluid #f))
-
-; Keep track of source code at continuations.
-
-(define (note-source-code info segment)
-  (make-segment (segment-size segment)
-		(lambda (astate)
-		  (emit-segment! astate segment)
-		  (let ((dd (fluid $debug-data)))
-		    (set-debug-data-source!
-		     dd
-		     (cons (cons (astate-pc astate) info)
-			   (debug-data-source dd)))))))
-
-; Keep track of variable names from lexical environments.
-; Each environment map has the form
-;    #(pc-before pc-after (var ...) (env-map ...))
-
-(define (note-environment vars segment)
-  (if (keep-environment-maps?)
-      (make-segment (segment-size segment)
-		    (lambda (astate)
-		      (let* ((pc-before (astate-pc astate))
-			     (env-maps
-			      (emit-with-environment-maps! astate segment)))
-			(set-fluid! $environment-maps
-				    (cons (vector pc-before
-						  (astate-pc astate)
-						  (list->vector vars)
-						  env-maps)
-					  (fluid $environment-maps))))))
-      segment))
-
-(define (emit-with-environment-maps! astate segment)
-  (let-fluid $environment-maps '()
-    (lambda ()
-      (emit-segment! astate segment)
-      (fluid $environment-maps))))
-
-(define $environment-maps (make-fluid '()))
diff --git a/scheme/bcomp/stack-check.scm b/scheme/bcomp/stack-check.scm
deleted file mode 100644
index 47c7259..0000000
--- a/scheme/bcomp/stack-check.scm
+++ /dev/null
@@ -1,284 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; This determines the maximum stack depth needed by a code vector.
-
-(define (maximum-stack-use code-vector)
-  (cond ((not (= (code-vector-ref code-vector 0)
-		 (enum op protocol)))
-	 0)
-	((= (code-vector-ref code-vector 1)
-	    nary-dispatch-protocol)		; has unjumped-to targets
-	 (stack-max code-vector
-		    6
-		    0
-		    0
-		    (do ((i 2 (+ i 1))
-			 (r '() (let ((target (code-vector-ref code-vector i)))
-				  (if (= 0 target)
-				      r
-				      (cons (cons target 0) r)))))
-			((= i 6)
-			 r))))
-	(else
-	 (stack-max code-vector
-		    (protocol-skip code-vector)
-		    0
-		    0
-		    '()))))
-
-(define (protocol-skip code-vector)
-  (let ((protocol (code-vector-ref code-vector 1)))
-    (cond ((or (= protocol two-byte-nargs-protocol)
-	       (= protocol two-byte-nargs+list-protocol))
-	   4)
-	  ((= protocol args+nargs-protocol)
-	   3)
-	  (else
-	   2))))
-
-;----------------
-; A vector of procedures, one for each opcode.
-
-(define stack-delta (make-vector op-count #f))
-
-(define-syntax define-delta
-  (syntax-rules ()
-    ((define-delta opcode fun)
-     (vector-set! stack-delta (enum op opcode) fun))))
-
-; Handle the opcode at I.  DEPTH is the current stack depth, MAXIMUM is the
-; maximum so far, and JUMPS is a list of (<index> . <depth>) giving the stack
-; depth at jump targets.
-
-(define (stack-max code-vector i depth maximum jumps)
-  ((vector-ref stack-delta (code-vector-ref code-vector i))
-     code-vector
-     (+ i 1)
-     depth
-     maximum
-     jumps))
-
-; Do nothing and advance BYTE-SIZE bytes.
-
-(define (nothing byte-size)
-  (lambda (code-vector i depth maximum jumps)
-    (stack-max code-vector
-	       (+ i byte-size)
-	       depth
-	       maximum
-	       jumps)))
-
-; Pop COUNT values from the stack and advance BYTE-SIZE bytes.
-
-(define (popper count byte-args)
-  (lambda (code-vector i depth maximum jumps)
-    (stack-max code-vector
-	       (+ i byte-args)
-	       (- depth count)
-	       maximum
-	       jumps)))
-
-; Push COUNT values onto the stack and advance BYTE-SIZE bytes.
-
-(define (pusher count byte-args)
-  (lambda (code-vector i depth maximum jumps)
-    (stack-max code-vector
-	       (+ i byte-args)
-	       (+ depth count)
-	       (imax maximum (+ depth count))
-	       jumps)))
-
-; Continue on at opcode I.  This is used for opcodes that do not fall through
-; to the next instruction.  I is either the end of the code vector or the target
-; of a jump or continuation.
-
-(define (continue code-vector i maximum jumps)
-  (cond ((= i (code-vector-length code-vector))
-	 maximum)
-	((assq i jumps)
-	 => (lambda (pair)
-	      (stack-max code-vector i (cdr pair) maximum jumps)))
-	(else
-	 (error "stack-max: no one jumps to target" i))))
-
-; Skip BYTE-ARGS and then continue.
-
-(define (continuer byte-args)
-  (lambda (code-vector i depth maximum jumps)
-    (continue code-vector (+ i byte-args) maximum jumps)))
-
-;----------------
-; All the special opcodes
-
-(define-delta make-env           (pusher environment-stack-size 2))
-;(define-delta push               (pusher 1 0))
-(define-delta pop                (popper 1 0))
-(define-delta call               (continuer 1))
-(define-delta big-call           (continuer 2))
-(define-delta move-args-and-call (continuer 1))
-(define-delta apply              (continuer 2))
-(define-delta closed-apply       (continuer 0))
-(define-delta with-continuation  (nothing 0))     ; what the compiler requires
-(define-delta call-with-values   (continuer 0))
-(define-delta return             (continuer 0))
-(define-delta values             (continuer 2))
-(define-delta closed-values      (continuer 0))
-(define-delta ignore-values      (nothing 0))
-(define-delta goto-template      (continuer 2))
-(define-delta call-template      (continuer 3))
-
-; We should never reach a PROTOCOL opcode.
-
-(define-delta protocol
-  (lambda stuff
-    (error "looking for protocol's stack delta")))
-
-; Peephole optimizations
-
-(define-delta push
-  (lambda (cv pc depth maximum jumps)
-    (if (= (enum op local0)
-	   (code-vector-ref cv pc))
-	(begin
-	  (code-vector-set! cv (- pc 1) (enum op push-local0))
-	  (code-vector-set! cv pc (code-vector-ref cv (+ pc 1)))
-	  (stack-max cv
-		     (+ pc 2)
-		     (+ depth 1)
-		     (imax maximum (+ depth 1))
-		     jumps))
-	(stack-max cv
-		   pc
-		   (+ depth 1)
-		   (imax maximum (+ depth 1))
-		   jumps))))
-
-(define-delta local0
-  (lambda (cv pc depth maximum jumps)
-    (if (= (enum op push)
-	   (code-vector-ref cv (+ pc 1)))
-	(begin
-	  (code-vector-set! cv (- pc 1) (enum op local0-push))
-	  (stack-max cv
-		     (+ pc 2)
-		     (+ depth 1)
-		     (imax maximum (+ depth 1))
-		     jumps))
-	(stack-max cv
-		   (+ pc 1)
-		   depth
-		   maximum
-		   jumps))))
-
-; Pop the given numbers of stack values.
-
-(define-delta make-stored-object
-  (lambda (cv pc depth maximum jumps)
-    (let ((args (code-vector-ref cv pc)))
-      (stack-max cv (+ pc 2) (- depth (- args 1)) maximum jumps))))
-
-; Skip over the environment specification.
-
-(define-delta make-flat-env
-  (lambda (code-vector i depth maximum jumps)
-    (let ((include-*val*? (= 1 (code-vector-ref code-vector i)))
-	  (count (code-vector-ref code-vector (+ i 1))))
-      (let loop ((i (+ i 2)) (count (if include-*val*? (- count 1) count)))
-	(if (= count 0)
-	    (stack-max code-vector
-		       i
-		       depth maximum jumps)
-	    (let ((level-count (code-vector-ref code-vector (+ i 1))))
-	      (loop (+ i 2 level-count)
-		    (- count level-count))))))))
-
-; Adds the target to the list of jumps.
-; The -1 is to back up over the opcode.
-
-(define (do-make-cont total-bytes)
-  (lambda (code-vector i depth maximum jumps)
-    (let ((target (+ i -1 (get-offset code-vector i))))
-      (stack-max code-vector
-		 (+ i total-bytes)  ; eat offset and size
-		 (+ depth continuation-stack-size)
-		 (max maximum (+ depth continuation-stack-size))
-		 (cons (cons target depth) jumps)))))
-
-(define-delta make-cont (do-make-cont 3))
-(define-delta make-big-cont (do-make-cont 4))
-
-; Add the jump target(s) and either fall-through or not.
-; The -1 is to back up over the opcode.
-
-(define-delta jump-if-false
-  (lambda (code-vector i depth maximum jumps)
-    (let ((target (+ i -1 (get-offset code-vector i))))
-      (stack-max code-vector
-		 (+ i 2) ; eat label
-		 depth
-		 maximum
-		 (cons (cons target depth) jumps)))))
-
-(define-delta jump
-  (lambda (code-vector i depth maximum jumps)
-    (let ((target (+ i -1 (get-offset code-vector i))))
-      (continue code-vector
-		(+ i 2)  ; eat label
-		maximum
-		(cons (cons target depth) jumps)))))
-
-(define-delta computed-goto
-  (lambda (code-vector i depth maximum jumps)
-    (let ((count (code-vector-ref code-vector i))
-	  (base (- i 1))			; back up over opcode
-	  (i (+ i 1)))
-      (let loop ((c 0) (jumps jumps))
-	(if (= c count)
-	    (stack-max code-vector
-		       (+ i (* 2 count))
-		       depth
-		       maximum
-		       jumps)
-	    (loop (+ c 1)
-		  (cons (cons (+ base (get-offset code-vector (+ i (* c 2))))
-			      depth)
-			jumps)))))))
-
-;----------------
-; Fill in the `normal' opcodes using the information in OPCODE-ARG-SPECS.
-
-(define (stack-function arg-specs)
-  (let loop ((specs arg-specs) (skip 0))
-    (cond ((null? specs)
-	   (nothing skip))
-	  ((integer? (car specs))
-	   (if (> (car specs) 1)
-	       (popper (- (car specs) 1) skip)
-	       (nothing skip)))
-	  (else
-	   (loop (cdr specs) (+ skip (arg-spec-size (car specs))))))))
-
-(define (arg-spec-size spec)
-  (case spec
-    ((nargs byte stob junk) 1)
-    ((two-bytes offset small-index index) 2)
-    (else
-     (error "unknown arg-spec" spec))))
-
-(do ((i 0 (+ i 1)))
-    ((= i (vector-length stack-delta)))
-  (if (not (vector-ref stack-delta i))
-      (vector-set! stack-delta i (stack-function (vector-ref opcode-arg-specs i)))))
-
-;----------------
-; Utilities
-
-; Much faster then Scheme's generic function.
-
-(define (imax x y)
-  (if (< x y) y x))
-
-(define (get-offset code pc)
-  (+ (* (code-vector-ref code pc)
-	byte-limit)
-     (code-vector-ref code (+ pc 1))))
diff --git a/scheme/bcomp/state.scm b/scheme/bcomp/state.scm
deleted file mode 100644
index 7564646..0000000
--- a/scheme/bcomp/state.scm
+++ /dev/null
@@ -1,106 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Compiler state, including flags controlling debug data retention.
-
-
-; Package and location uids and the location name table should be here
-; as well...
-
-; Will the use of a fluid variable significantly degrade performance?
-
-(define (new-template-uid)
-  (let ((uid *template-uid*))
-    (set! *template-uid* (+ *template-uid* 1))
-    uid))
-
-(define *template-uid* 5000)  ; 1548 in initial system as of 1/22/94
-
-(define (template-uid) *template-uid*)
-(define (set-template-uid! uid) (set! *template-uid* uid))
-
-
-
-; These variables really ought to be dynamically scoped, not global.
-; Fix this some day.
-
-(define debug-flag-names '(names maps files source tabulate table))
-
-(define type/debug-flags
-  (make-record-type 'debug-flags debug-flag-names))
-
-(define make-debug-flags
-  (record-constructor type/debug-flags debug-flag-names))
-
-(define $debug-flags
-  (make-fluid (make-debug-flags #t	;proc names
-				#f	;env maps
-				#f	;no file names
-				#f	;no cont source
-				#f	;no tabulate
-				(make-table))))
-
-(define (debug-flag-accessor name)
-  (let ((access (record-accessor type/debug-flags name)))
-    (lambda () (access (fluid $debug-flags)))))
-
-(define (debug-flag-modifier name)
-  (let ((modify (record-modifier type/debug-flags name)))
-    (lambda (new) (modify (fluid $debug-flags) new))))
-
-(define keep-source-code?      (debug-flag-accessor 'source))
-(define keep-environment-maps? (debug-flag-accessor 'maps))
-(define keep-procedure-names?  (debug-flag-accessor 'names))
-(define keep-file-names?       (debug-flag-accessor 'files))
-(define tabulate-debug-data?   (debug-flag-accessor 'tabulate))
-(define debug-data-table       (debug-flag-accessor 'table))
-
-
-; Kludge for static linker.
-
-(define (with-fresh-compiler-state template-uid-origin thunk)
-  (let-fluid $debug-flags (make-debug-flags #t ;proc names
-					    #f ;env maps
-					    #f ;no file names
-					    #f ;no cont source
-					    #t ;tabulate       ***
-					    (make-table))
-    (lambda ()
-      (saving-and-restoring (lambda () *template-uid*)
-			    (lambda (s) (set! *template-uid* s))
-			    template-uid-origin
-			    thunk))))
-
-(define (saving-and-restoring fetch store! other thunk)
-  (let ((swap (lambda ()
-		(let ((temp (fetch)))
-		  (store! other)
-		  (set! other temp)))))
-    (dynamic-wind swap thunk swap)))
-
-; --------------------
-; Debug-data stuff
-
-; "Info" means either a debug data record or an integer index into a
-; table of same.  An "info" is stored in a reserved place in every
-; template.
-
-(define (debug-data->info debug-data)
-  (make-immutable! debug-data)
-  (if (tabulate-debug-data?)
-      (begin (note-debug-data! debug-data)
-	     (debug-data-uid debug-data))
-      debug-data))
-
-(define (get-debug-data info)		;info->debug-data
-  (cond ((debug-data? info) info)
-	((integer? info)
-	 (table-ref (debug-data-table) info))
-	(else #f)))
-
-(define (note-debug-data! dd)
-  (table-set! (debug-data-table) (debug-data-uid dd) dd))
-
-
-(define (new-debug-data name parent pc-in-parent)
-  (make-debug-data (new-template-uid) name parent pc-in-parent '() '()))
diff --git a/scheme/bcomp/thingie.scm b/scheme/bcomp/thingie.scm
deleted file mode 100644
index 981d87c..0000000
--- a/scheme/bcomp/thingie.scm
+++ /dev/null
@@ -1,16 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; A thingie (placecard?) is used to hold a spot for a location that is to be
-; found later.  The compiler sticks them in templates and the module system
-; later replaces them with locations.
-;
-; We can't use (BEGIN ...) for this trivial package because it is loaded
-; by flatload, which can't handle them.
-
-(define-record-type thingie :thingie
-  (make-thingie binding name want-type)
-  thingie?
-  (binding thingie-binding)
-  (name thingie-name)
-  (want-type thingie-want-type))
-
diff --git a/scheme/bcomp/type.scm b/scheme/bcomp/type.scm
deleted file mode 100644
index a2b59b2..0000000
--- a/scheme/bcomp/type.scm
+++ /dev/null
@@ -1,53 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; The types.
-
-(define :syntax
-  (loophole :type syntax-type))
-
-(define :values
-  (loophole :type any-values-type))
-
-(define :arguments
-  (loophole :type any-arguments-type))
-
-(define :value
-  (loophole :type value-type))
-
-(define procedure
-  (loophole (proc (:type :type) :type)
-	    (lambda (dom cod) (procedure-type dom cod #t))))
-
-; Use the definitions of PROC and SOME-VALUES from the meta-types module
-
-
-; Various base types
-
-(define :boolean     (loophole :type boolean-type))
-(define :char        (loophole :type char-type))
-(define :null        (loophole :type null-type))
-(define :unspecific  (loophole :type unspecific-type))
-
-(define :number      (loophole :type number-type))
-(define :complex     (loophole :type complex-type))
-(define :real	     (loophole :type real-type))
-(define :rational    (loophole :type rational-type))
-(define :integer     (loophole :type integer-type))
-(define :exact-integer (loophole :type exact-integer-type))
-
-(define :pair        (loophole :type pair-type))
-(define :string      (loophole :type string-type))
-(define :symbol      (loophole :type symbol-type))
-(define :vector	     (loophole :type vector-type))
-(define :procedure   (loophole :type any-procedure-type))
-
-; Temporary
-(define :input-port :value)
-(define :output-port :value)
-
-(define :error       (loophole :type error-type))
-(define :escape	     (loophole :type escape-type))
-
-(define :structure   (loophole :type structure-type))
-(define :type	     (loophole :type value-type))
diff --git a/scheme/bcomp/var-util.scm b/scheme/bcomp/var-util.scm
deleted file mode 100644
index f009697..0000000
--- a/scheme/bcomp/var-util.scm
+++ /dev/null
@@ -1,21 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-(define (number-of-required-args formals)
-  (do ((l formals (cdr l))
-       (i 0 (+ i 1)))
-      ((not (pair? l)) i)))
-    
-(define (n-ary? formals)
-  (cond ((null? formals) #f)
-	((pair? formals) (n-ary? (cdr formals)))
-	(else #t)))
-    
-(define (normalize-formals formals)
-  (cond ((null? formals)
-	 '())
-	((pair? formals)
-	 (cons (car formals)
-	       (normalize-formals (cdr formals))))
-	(else
-	 (list formals))))
-
diff --git a/scheme/big/array.scm b/scheme/big/array.scm
deleted file mode 100644
index 3480796..0000000
--- a/scheme/big/array.scm
+++ /dev/null
@@ -1,319 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-; copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
-
-
-; (make-array <initial-value> <bound1> ...)
-; (array-shape <array>)
-; (array-ref <array> <index1> ...)
-; (array-set! <array> <value> <index1> ...)
-; (make-shared-array <array> <linear-map> <bound1> ...)
-; (copy-array <array>)
-; (array->vector <array>)
-; (array <bounds> . <elements>)
-;
-; All arrays are zero based.
-;
-; The <linear-map> argument to MAKE-SHARED-ARRAY is a linear function
-; that maps indices into the shared array into a list of indices into
-; the original array.  The array returned by MAKE-SHARED-ARRAY shares
-; storage with the original array.
-;
-; (array-ref (make-shared-array a f i1 i2 ... iN) j1 j2 ... jM)
-;   <==>
-; (apply array-ref a (f j1 j2 ... jM))
-;
-; ARRAY->VECTOR returns a vector containing the elements of an array
-; in row-major order.
-
-; An array consists of a vector containing the bounds of the array,
-; a vector containing the elements of the array, and a linear map
-; expressed as a vector of coefficients and one constant.
-; If the map is #(c1 c2 ... cN C0) then the index into the vector of
-; elements for (array-ref a i1 i2 ... iN) is
-; (+ (* i1 c1) (* i2 c2) ... (* iN cN) C0).
-
-; Interface due to Alan Bawden (except for requiring zero-based arrays)
-; Implementation by Richard Kelsey.
-
-(define-record-type array :array
-  (really-make-array bounds map elements)
-  array?
-  (bounds   array-bounds)       ; vector of array bounds
-  (map      array-map)          ; vector of coefficients + one constant
-  (elements array-elements))    ; vector of actual elements
-
-(define-record-discloser :array
-  (lambda (array)
-    (cons 'array (array-shape array))))
-
-(define (array-shape array)
-  (vector->list (array-bounds array)))
-
-; Calculate the index into an array's element vector that corresponds to
-; INDICES.  MAP is the array's linear map.
-
-(define (fast-array-index indices map)
-  (let ((size (- (vector-length map) 1)))
-    (do ((i 0 (+ i 1))
-	 (j (vector-ref map size)
-	    (+ j (* (vector-ref indices i)
-		    (vector-ref map i)))))
-	((>= i size) j))))
-
-; The same thing with bounds checking added.
-
-(define (array-index array indices)
-  (let ((bounds       (array-bounds array))
-	(coefficients (array-map array)))
-    (let loop ((is indices)
-	       (i 0)
-	       (index (vector-ref coefficients (vector-length bounds))))
-      (cond ((null? is)
-	     (if (= i (vector-length bounds))
-		 index
-		 (error "wrong number of array indices" array indices)))
-	    ((>= i (vector-length bounds))
-	     (error "wrong number of array indices" array indices))
-	    (else
-	     (let ((j (car is)))
-	       (if (and (>= j 0)
-			(< j (vector-ref bounds i)))
-		   (loop (cdr is)
-			 (+ i 1)
-			 (+ index (* j (vector-ref coefficients i))))
-		   (error "array index out of range" array indices))))))))
-
-(define (array-ref array . indices)
-  (vector-ref (array-elements array) (array-index array indices)))
-
-(define (array-set! array value . indices)
-  (vector-set! (array-elements array) (array-index array indices) value))
-
-; This is mostly error checking.
-
-(define (make-array initial bound1 . bounds)
-  (let* ((all-bounds (cons bound1 bounds))
-	 (bounds (make-vector (length all-bounds)))
-	 (size (do ((bs all-bounds (cdr bs))
-		    (i 0 (+ i 1))
-		    (s 1 (* s (car bs))))
-		   ((null? bs) s)
-		 (let ((b (car bs)))
-		   (vector-set! bounds i b)
-		   (if (not (and (integer? b)
-				 (exact? b)
-				 (< 0 b)))
-		       (error "illegal array bounds" all-bounds))))))
-    (really-make-array bounds
-		       (bounds->map bounds)
-		       (make-vector size initial))))
-
-(define (array bounds . elts)
-  (let* ((array (apply make-array #f bounds))
-	 (elements (array-elements array))
-	 (size (vector-length elements)))
-    (if (not (= (length elts) size))
-	(error "ARRAY got the wrong number of elements" bounds elts))
-    (do ((i 0 (+ i 1))
-	 (elts elts (cdr elts)))
-	((null? elts))
-      (vector-set! elements i (car elts)))
-    array))
-
-; Determine the linear map that corresponds to a simple array with the
-; given bounds.
-
-(define (bounds->map bounds)
-  (do ((i (- (vector-length bounds) 1) (- i 1))
-       (s 1 (* s (vector-ref bounds i)))
-       (l '() (cons s l)))
-      ((< i 0)
-       (list->vector (reverse (cons 0 (reverse l)))))))
-
-; This is mostly error checking.  Two different procedures are used to
-; check that the shared array does not extend past the original.  The
-; full check does a complete check, but, because it must check every corner
-; of the shared array, it gets very slow as the number of dimensions
-; goes up.  The simple check just verifies that the all elements of
-; the shared array map to elements in the vector of the original.
-
-(define (make-shared-array array linear-map . bounds)
-  (let ((map (make-shared-array-map array linear-map bounds)))
-    (if (if (<= (length bounds) maximum-full-bounds-check)
-	    (full-array-bounds-okay? linear-map bounds (array-bounds array))
-	    (simple-array-bounds-okay? map bounds (vector-length
-						   (array-elements array))))
-	(really-make-array (list->vector bounds)
-			   map
-			   (array-elements array))
-	(error "shared array out of bounds" array linear-map bounds))))
-
-(define maximum-full-bounds-check 5)
-
-; Check that every corner of the array specified by LINEAR and NEW-BOUNDS
-; is within OLD-BOUNDS.  This checks every corner of the new array.
-
-(define (full-array-bounds-okay? linear new-bounds old-bounds)
-  (let ((old-bounds (vector->list old-bounds)))
-    (let label ((bounds (reverse new-bounds)) (args '()))
-      (if (null? bounds)
-	  (let loop ((res (apply linear args)) (bounds old-bounds))
-	    (cond ((null? res)
-		   (null? bounds))
-		  ((and (not (null? bounds))
-			(<= 0 (car res))
-			(< (car res) (car bounds)))
-		   (loop (cdr res) (cdr bounds)))
-		  (else #f)))
-	  (and (label (cdr bounds) (cons 0 args))
-	       (label (cdr bounds) (cons (- (car bounds) 1) args)))))))
-
-; Check that the maximum and minimum possible vector indices possible with
-; the given bounds and map would fit in an array of the given size.
-
-(define (simple-array-bounds-okay? map bounds size)
-  (do ((map (vector->list map) (cdr map))
-       (bounds bounds (cdr bounds))
-       (min 0 (if (> 0 (car map))
-		  (+ min (* (car map) (- (car bounds) 1)))
-		  min))
-       (max 0 (if (< 0 (car map))
-		  (+ max (* (car map) (- (car bounds) 1)))
-		  max)))
-      ((null? bounds)
-       (and (>= 0 (+ min (car map)))
-	    (< size (+ max (car map)))))))
-
-; Determine the coefficients and constant of the composition of
-; LINEAR-MAP and the linear map of ARRAY.  BOUNDS is used only to
-; determine the rank of LINEAR-MAP's domain.
-;
-; The coefficients are determined by applying first LINEAR-MAP and then
-; ARRAY's map to the vectors (1 0 0 ... 0), (0 1 0 ... 0), ..., (0 ... 0 1).
-; Applying them to (0 ... 0) gives the constant of the composition.
-
-(define (make-shared-array-map array linear-map bounds)
-  (let* ((zero (map (lambda (ignore) 0) bounds))
-	 (do-vector (lambda (v)
-		      (or (apply-map array (apply linear-map v))
-			  (error "bad linear map for shared array"
-				 linear-map array bounds))))
-	 (base (do-vector zero)))
-    (let loop ((bs bounds) (ces '()) (unit (cons 1 (cdr zero))))
-      (if (null? bs)
-	  (list->vector (reverse (cons base ces)))
-	  (loop (cdr bs)
-		(cons (- (do-vector unit) base) ces)
-		(rotate unit))))))
-
-; Apply ARRAY's linear map to the indices in the list VALUES and
-; return the resulting vector index.  #F is returned if VALUES is not
-; the correct length or if any of its elements are out of range.
-
-(define (apply-map array values)
-  (let ((map (array-map array))
-	(bounds (array-bounds array)))
-    (let loop ((values values)
-	       (i 0)
-	       (index (vector-ref map (vector-length bounds))))
-      (cond ((null? values)
-	     (if (= i (vector-length bounds))
-		 index
-		 #f))
-	    ((>= i (vector-length bounds))
-	     #f)
-	    (else
-	     (let ((j (car values)))
-	       (if (and (>= j 0)
-			(< j (vector-ref bounds i)))
-		   (loop (cdr values)
-			 (+ i 1)
-			 (+ index (* j (vector-ref map i))))
-		   #f)))))))
-
-; Return LIST with its last element moved to the front.
-
-(define (rotate list)
-  (let ((l (reverse list)))
-    (cons (car l) (reverse (cdr l)))))
-
-; Copy an array, shrinking the vector if this is subarray that does not
-; use all of the original array's elements.
-
-(define (copy-array array)
-  (really-make-array (array-bounds array)
-		     (bounds->map (array-bounds array))
-		     (array->vector array)))
-
-; Make a new vector and copy the elements into it.  If ARRAY's map is
-; the simple map for its bounds, then the elements are already in the
-; appropriate order and we can just copy the element vector.
-
-(define (array->vector array)
-  (let* ((size (array-element-count array))
-	 (new (make-vector size)))
-    (if (and (= size (vector-length (array-elements array)))
-	     (equal? (array-map array) (bounds->map (array-bounds array))))
-	(copy-vector (array-elements array) new)
-	(copy-elements array new))
-    new))
-
-(define (array-element-count array)
-  (let ((bounds (array-bounds array)))
-    (do ((i 0 (+ i 1))
-	 (s 1 (* s (vector-ref bounds i))))
-	((>= i (vector-length bounds))
-	 s))))
-  
-(define (copy-vector from to)
-  (do ((i (- (vector-length to) 1) (- i 1)))
-      ((< i 0))
-    (vector-set! to i (vector-ref from i))))
-
-; Copy the elements of ARRAY into the vector TO.  The copying is done one
-; row at a time.  POSN is a vector containing the index of the row that
-; we are currently copying.  After the row is copied, POSN is updated so
-; that the next row can be copied.  A little more cleverness would make
-; this faster by replacing the call to FAST-ARRAY-INDEX with some simple
-; arithmetic on J.
-
-(define (copy-elements array to)
-  (let ((bounds   (array-bounds array))
-	(elements (array-elements array))
-	(map      (array-map array)))
-    (let* ((size (vector-length bounds))
-	   (posn (make-vector size 0))
-	   (step-size (vector-ref bounds (- size 1)))
-	   (delta (vector-ref map (- size 1))))
-      (let loop ((i 0))
-	(do ((i2 i (+ i2 1))
-	     (j (fast-array-index posn map) (+ j delta)))
-	    ((>= i2 (+ i step-size)))
-	  (vector-set! to i2 (vector-ref elements j)))
-	(cond ((< (+ i step-size) (vector-length to))
-	       (let loop2 ((k (- size 2)))
-		 (cond ((= (+ (vector-ref posn k) 1) (vector-ref bounds k))
-			(vector-set! posn k 0)
-			(loop2 (- k 1)))
-		       (else
-			(vector-set! posn k (+ 1 (vector-ref posn k))))))
-	       (loop (+ i step-size))))))))
-
-; Testing.
-; (define a1 (make-array 0 4 5))
-;  0  1  2  3
-;  4  5  6  7
-;  8  9 10 11
-; 12 13 14 15
-; 16 17 18 19
-; (make-shared-array-map a1 (lambda (x) (list x x)) '(3))
-; 0 5 10, #(5 0)
-; (make-shared-array-map a1 (lambda (x) (list 2 (- 4 x))) '(3))
-; 18 14 10 #(-4 18)
-; (make-shared-array-map a1 (lambda (x y) (list (+ x 1) y)) '(2 4))
-;  1  2
-;  5  6
-;  9 10
-; 13 14
-; #(1 4 1)
-
diff --git a/scheme/big/big-util.scm b/scheme/big/big-util.scm
deleted file mode 100644
index c7ee265..0000000
--- a/scheme/big/big-util.scm
+++ /dev/null
@@ -1,204 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-(define (concatenate-symbol . stuff)
-  (string->symbol
-   (apply string-append
-	  (map (lambda (x)
-		 (cond ((string? x) x)
-		       ((symbol? x) (symbol->string x))
-		       ((number? x) (number->string x))
-		       (else
-			(error "cannot coerce ~S to a string" x))))
-	       stuff))))
-
-(define (error format-string . args)
-  (if #t       ; work around a bug in the type system
-      ((structure-ref signals error)
-       (apply format (cons #f (cons format-string args)))))
-  )
-
-(define (breakpoint format-string . args)
-  ((structure-ref debugging breakpoint) 
-   (apply format (cons #f (cons format-string args)))))
-
-(define (atom? x)
-  (not (pair? x)))
-
-(define (neq? x y)
-  (not (eq? x y)))
-
-(define (n= x y)
-  (not (= x y)))
-
-(define (identity x) x)
-
-(define (no-op x) x)    ; guaranteed not to be in-lined
-
-(define (null-list? x)
-  (cond ((null? x) #t)
-	((pair? x) #f)
-	(else
-	 (error "null-list? got a non-list" x))))
-
-(define (reverse! l)
-  (cond ((or (null? l)
-	     (null? (cdr l)))
-	 l)
-	(else
-	 (let ((rest (cdr l)))
-	   (set-cdr! l '())
-	   (let loop ((l1 l) (l2 rest))
-	     (cond ((null? l2)
-		    l1)
-		   (else
-		    (let ((rest (cdr l2)))
-		      (set-cdr! l2 l1)
-		      (loop l2 rest)))))))))
-
-(define (memq? x l)
-  (let loop ((l l))
-    (cond ((null? l)       #f)
-	  ((eq? x (car l)) #t)
-	  (else            (loop (cdr l))))))
-
-(define (first pred list)
-  (let loop ((list list))
-    (cond ((null? list)
-	   #f)
-          ((pred (car list))
-	   (car list))
-          (else
-	   (loop (cdr list))))))
-
-(define any first)  ; ANY? need not search in order, but it does anyway
-
-(define (any? proc list)
-  (let loop ((list list))
-    (cond ((null? list)
-	   #f)
-          ((proc (car list))
-	   #t)
-          (else
-	   (loop (cdr list))))))
-
-(define (every? pred list)
-  (let loop ((list list))
-    (cond ((null? list)
-	   #t)
-          ((pred (car list))
-	   (loop (cdr list)))
-          (else
-	   #f))))
-
-(define (filter pred l)
-  (let loop ((l l) (r '()))
-    (cond ((null? l)
-	   (reverse r))
-          ((pred (car l))
-	   (loop (cdr l) (cons (car l) r)))
-          (else
-	   (loop (cdr l) r)))))
-
-(define (filter! pred list)
-  (let filter! ((list list))
-    (cond ((null-list? list)
-	   '())
-          ((pred (car list))
-	   (set-cdr! list (filter! (cdr list))) list)
-          (else
-	   (filter! (cdr list))))))
-
-(define (filter-map f l)
-  (let loop ((l l) (r '()))
-    (cond ((null? l)
-	   (reverse r))
-          ((f (car l))
-           => (lambda (x)
-                (loop (cdr l) (cons x r))))
-          (else
-	   (loop (cdr l) r)))))
-
-(define (remove-duplicates list)
-  (do ((list list (cdr list))
-       (res  '()  (if (memq? (car list) res)
-                      res
-                      (cons (car list) res))))
-      ((null-list? list)
-       res)))
-
-(define (partition-list pred l)
-  (let loop ((l l) (yes '()) (no '()))
-    (cond ((null? l)
-           (values (reverse yes) (reverse no)))
-          ((pred (car l))
-           (loop (cdr l) (cons (car l) yes) no))
-          (else
-           (loop (cdr l) yes (cons (car l) no))))))
-
-(define (partition-list! pred l)
-  (let loop ((l l) (yes '()) (no '()))
-    (cond ((null? l)
-           (values (reverse! yes) (reverse! no)))
-          ((pred (car l))
-	   (let ((rest (cdr l)))
-	     (set-cdr! l yes)
-	     (loop rest l no)))
-          (else
-	   (let ((rest (cdr l)))
-	     (set-cdr! l no)
-	     (loop rest yes l))))))
-
-(define (delq! object list)
-  (let loop ((list list))
-    (cond ((null? list)
-	   '())
-	  ((eq? object (car list))
-	   (loop (cdr list)))
-	  (else
-	   (let loop ((next (cdr list)) (prev list))
-	     (cond ((null? next)
-		    list)
-		   ((eq? (car next) object)
-		    (set-cdr! prev (cdr next))
-		    (loop (cdr next) prev))
-		   (else
-		    (loop (cdr next) next))))))))
-
-(define (delq thing list)
-  (delete (lambda (x) (eq? x thing)) list))
-
-(define (delete pred in-list)
-  (let loop ((list in-list) (res '()))
-    (cond ((null? list)
-	   in-list)
-	  ((pred (car list))
-	   (append-reverse! res (delete pred (cdr list))))
-	  (else
-	   (loop (cdr list) (cons (car list) res))))))
-
-(define (append-reverse! l1 l2)
-  (let loop ((list l1) (res l2))
-    (cond ((null? list)
-	   res)
-	  (else
-	   (let ((next (cdr list)))
-	     (set-cdr! list res)
-	     (loop next list))))))
-
-; Copying strings.
-
-(define (copy-string string)
-  (let* ((length (string-length string))
-	 (new (make-string length #\?)))
-    ((structure-ref primitives copy-bytes!) string 0 new 0 length)
-    new))
-
-(define (string->immutable-string string)
-  (if (immutable? string)
-      string
-      (let ((copy (copy-string string)))
-	(make-immutable! copy)
-	copy)))
-
-
-
diff --git a/scheme/big/bigbit.scm b/scheme/big/bigbit.scm
deleted file mode 100644
index 0269f25..0000000
--- a/scheme/big/bigbit.scm
+++ /dev/null
@@ -1,207 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Bitwise logical operators on bignums.
-
-
-(define-opcode-extension bitwise-not &bitwise-not)
-(define-opcode-extension bitwise-and &bitwise-and)
-(define-opcode-extension bitwise-ior &bitwise-ior)
-(define-opcode-extension bitwise-xor &bitwise-xor)
-(define-opcode-extension arithmetic-shift &arithmetic-shift)
-
-
-(define (integer-bitwise-not m)
-  ;; (integer+ (integer-negate m) -1)
-  (integer- -1 m))
-
-(define (integer-bitwise-and m n)
-  (if (or (integer= 0 m) (integer= 0 n))
-      0
-      (integer-bitwise-op bitwise-and m n)))
-
-(define (integer-bitwise-ior m n)
-  (cond ((integer= 0 m) n)
-	((integer= 0 n) m)
-	(else
-	 (integer-bitwise-op bitwise-ior m n))))
-
-(define (integer-bitwise-xor m n)
-  (cond ((integer= 0 m) n)
-	((integer= 0 n) m)
-	(else
-	 (integer-bitwise-op bitwise-xor m n))))
-
-(define (integer-bitwise-op op m n)
-  (let ((m (integer->bignum m))
-	(n (integer->bignum n)))
-    (let ((finish (lambda (sign-bit mag-op)
-		    (let ((mag (mag-op op
-				       (bignum-magnitude m)
-				       (bignum-magnitude n))))
-		      (make-integer (if (= 0 sign-bit) 1 -1)
-				    (if (= 0 sign-bit)
-					mag
-					(negate-magnitude mag)))))))
-      (if (>= (bignum-sign m) 0)
-	  (if (>= (bignum-sign n) 0)
-	      (finish (op 0 0) magnitude-bitwise-binop-pos-pos)
-	      (finish (op 0 1) magnitude-bitwise-binop-pos-neg))
-	  (if (>= (bignum-sign n) 0)
-	      (finish (op 0 1) magnitude-bitwise-binop-neg-pos)
-	      (finish (op 1 1) magnitude-bitwise-binop-neg-neg))))))
-
-(define radix-mask (- radix 1))
-
-(define (magnitude-bitwise-binop-pos-pos op m n)
-  (let recur ((m m) (n n))
-    (if (and (zero-magnitude? m) (zero-magnitude? n))
-	m
-	(adjoin-digit (bitwise-and (op (low-digit m) (low-digit n)) radix-mask)
-		      (recur (high-digits m) (high-digits n))))))
-
-; Same as the above, except that one magnitude is that of a negative number.
-
-(define (magnitude-bitwise-binop-neg-pos op m n)
-  (magnitude-bitwise-binop-pos-neg op n m))
-
-(define (magnitude-bitwise-binop-pos-neg op m n)
-  (let recur ((m m) (n n) (carry 1))
-    (if (and (zero-magnitude? n) (zero-magnitude? m))
-	(integer->magnitude (op 0 carry))
-	(call-with-values
-	 (lambda ()
-	   (negate-low-digit n carry))
-	 (lambda (n-digit carry)
-	   (adjoin-digit (op (low-digit m) n-digit)
-			 (recur (high-digits m)
-				(high-digits n)
-				carry)))))))
-
-; Now both M and N are magnitudes of negative numbers.
-
-(define (magnitude-bitwise-binop-neg-neg op m n)
-  (let recur ((m m) (n n) (m-carry 1) (n-carry 1))
-    (if (and (zero-magnitude? n) (zero-magnitude? m))
-	(integer->magnitude (op m-carry n-carry))
-	(call-with-values
-	 (lambda ()
-	   (negate-low-digit m m-carry))
-	 (lambda (m-digit m-carry)
-	   (call-with-values
-	    (lambda ()
-	      (negate-low-digit n n-carry))
-	    (lambda (n-digit n-carry)
-	      (adjoin-digit (op m-digit n-digit)
-			    (recur (high-digits m)
-				   (high-digits n)
-				   m-carry
-				   n-carry)))))))))
-
-(define (negate-low-digit m carry)
-  (let ((m (+ (bitwise-and (bitwise-not (low-digit m))
-			   radix-mask)
-	      carry)))
-    (if (>= m radix)
-	(values (- m radix) 1)
-	(values m 0))))
-
-(define (negate-magnitude m)
-  (let recur ((m m) (carry 1))
-    (if (zero-magnitude? m)
-	(integer->magnitude carry)
-	(call-with-values
-	 (lambda ()
-	   (negate-low-digit m carry))
-	 (lambda (next carry)
-	   (adjoin-digit next
-			 (recur (high-digits m) carry)))))))
-
-; arithmetic-shift
-
-(define (integer-arithmetic-shift m n)
-  (let ((m (integer->bignum m)))
-    (make-integer (bignum-sign m)
-		  (cond ((> n 0)
-			 (shift-left-magnitude (bignum-magnitude m) n))
-			((= 1 (bignum-sign m))
-			 (shift-right-pos-magnitude (bignum-magnitude m) n))
-			(else
-			 (shift-right-neg-magnitude (bignum-magnitude m) n))))))
-
-(define (shift-left-magnitude mag n)
-  (if (< n log-radix)
-      (let ((mask (- (arithmetic-shift 1 (- log-radix n)) 1)))
-	(let recur ((mag mag)
-		    (low 0))
-	  (if (zero-magnitude? mag)
-	      (adjoin-digit low zero-magnitude)
-	      ;; Split the low digit into left and right parts, and shift
-	      (let ((left (arithmetic-shift (low-digit mag)
-					    (- n log-radix))) ;shift right
-		    (right (arithmetic-shift (bitwise-and (low-digit mag) mask)
-					     n)))
-		(adjoin-digit (bitwise-ior low right)
-			      (recur (high-digits mag)
-				     left))))))
-      (adjoin-digit 0 (shift-left-magnitude mag (- n log-radix)))))
-
-(define (shift-right-pos-magnitude mag n)
-  (if (> n (- 0 log-radix))
-      (let ((mask (- (arithmetic-shift 1 (- 0 n)) 1)))
-	(let recur ((mag mag))
-	  (let ((low (low-digit mag))
-		(high (high-digits mag)))
-	    (adjoin-digit
-	     (bitwise-ior (arithmetic-shift low n)
-			  (arithmetic-shift (bitwise-and mask (low-digit high))
-					    (+ n log-radix)))
-	     (if (zero-magnitude? high)
-		 zero-magnitude
-		 (recur high))))))
-      (shift-right-pos-magnitude (high-digits mag) (+ n log-radix))))
-      
-(define (shift-right-neg-magnitude mag n)
-  (negate-magnitude
-   (let digit-recur ((mag mag) (n n) (carry 1))
-     (call-with-values
-      (lambda ()
-	(negate-low-digit mag carry))
-      (lambda (digits carry)
-	(if (<= n (- 0 log-radix))
-	    (digit-recur (high-digits mag) (+ n log-radix) carry)
-	    (let ((mask (- (arithmetic-shift 1 (- 0 n)) 1)))
-	      (let recur ((mag mag) (low digits) (carry carry))
-		(let ((high-digits (high-digits mag)))
-		  (call-with-values
-		   (lambda ()
-		     (negate-low-digit high-digits carry))
-		   (lambda (high carry)
-		     (adjoin-digit
-		      (bitwise-ior (arithmetic-shift low n)
-				   (arithmetic-shift (bitwise-and mask high)
-						     (+ n log-radix)))
-		      (if (zero-magnitude? high-digits)
-			  (integer->magnitude carry)
-			  (recur high-digits high carry))))))))))))))
-
-;(define (tst)
-;  (let* ((m (random))
-;         (n (bitwise-and m 63))
-;         (m1 (integer-arithmetic-shift
-;              (integer-arithmetic-shift m n)
-;              (- 0 n))))
-;    (list n m m1 (= m m1))))
-;(define random (make-random 17))
-
-
-(define-method &bitwise-not ((n :integer)) (integer-bitwise-not n))
-
-(define-method &bitwise-and ((n1 :exact-integer) (n2 :exact-integer))
-  (integer-bitwise-and n1 n2))
-(define-method &bitwise-ior ((n1 :exact-integer) (n2 :exact-integer))
-  (integer-bitwise-ior n1 n2))
-(define-method &bitwise-xor ((n1 :exact-integer) (n2 :exact-integer))
-  (integer-bitwise-xor n1 n2))
-
-(define-method &arithmetic-shift ((n1 :exact-integer) (n2 :exact-integer))
-  (integer-arithmetic-shift n1 n2))
diff --git a/scheme/big/callback.scm b/scheme/big/callback.scm
deleted file mode 100644
index 3831ac7..0000000
--- a/scheme/big/callback.scm
+++ /dev/null
@@ -1,293 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; This code, along with C code in c/external.c, handles the interaction between
-; callbacks from external code to Scheme functions and uses of continuations in
-; Scheme.  The problem is that Scheme 48 uses multiple continuations while
-; operating with only one process stack.
-;
-; Suppose we have Scheme procedures s1 and s2 and C procedure c1 such that
-; s1 calls c1 and c1 calls s2.  There are two trampoline functions that are
-; used to do this.  The VM uses s48_external_call to call c1 and c1 uses
-; s48_call_scheme to start the VM running s2.  While in s2 the process stack will
-; look like this:
-;
-;  <C frame for VM running s2>
-;  <C frame for s48_call_scheme>
-;  <C frame for c1>
-;  <C frame for s48_external_call>
-;  <C frame for VM running s1>
-;  <base>
-;
-; The C code in c/external.scm keeps a record of the portions of the process
-; stack that are running external code.  Each of these stack portions has an
-; s48_external_call frame at the base and an s48_call_scheme frame at the top.
-; The stack is represented as linked list of records, called `stack-block's,
-; each of which contains the following values:
-;    free?       ; true if this frame is no longer needed
-;    unwind      ; the longjmp target used to skip over this frame
-;    proc-name   ; the name of the procedure this block is executing
-;    placeholder ; either #f or a placeholder, see the section on threads below
-;    next        ; the next stack-block below this one
-; These are Scheme records and are traced by the GC.
-
-(define-record-type stack-block :stack-block
-  (stack-blocks-are-made-from-c)
-  stack-block?
-  (free? stack-block-free? set-stack-block-free?!)
-  (unwind stack-block-unwind)
-  (proc-name stack-block-proc-name)
-  (placeholder stack-block-placeholder set-stack-block-placeholder!)
-  (next stack-block-next))
-
-; Stack-blocks are made from C, so we need to export the type.
-
-(define-exported-binding "s48-stack-block-type" :stack-block)
-
-; There is no need to keep track of the VM frames.  These are all interchangable
-; because 1) the VM's state is kept in top-level variables and 2) we have
-; arranged it so that the relevent VM opcodes, call-external-value and
-; return-from-callback, are all the same length and are always immediately
-; followed by a return instruction.  s48_call_scheme can safely overwrite the
-; template and code-pointer registers in the VM as they always point to a
-; one-byte instruction followed by a return instruction.  When the VM returns
-; from the callback, via a return-from-callback instruction, that too is a
-; one-byte instruction followed by a return instruction.  The VM can proceed,
-; happily ignorant of all this fooling around.
-;
-; On entry, s48_external_call saves a longjump target.  This is used when
-; raising exceptions from with the external code and for unwinding the process
-; stack.  Each invocation of s48_call_scheme creates a new stack-block, saving
-; within it the longjump target of the corresponding s48_external_call.  `Free?'
-; and `placeholder' are initially false and `next' points to existing list of
-; stack-blocks.
-;
-; When a callback returns to s48_call_scheme, the corresponding block is popped
-; off the list of stack-blocks.
-;
-; So far so good, and if that were all that happened there would be no need for
-; all this mechanism.  There are two problems: call/cc and threads.  Call/cc is
-; simpler to deal with.  We have downward continuations in C, as implemented
-; by longjmp(), so we simply limit continuations that cross callbacks to being
-; downwards only.  We also need to arrange for any jumped-over stack portions
-; to be popped off of the stack.
-;
-; The popping off is handled by s48_external_call.  Just before returning to the
-; VM it checks to see if the top stack-block is free.  If so, it loops through
-; the list of stack-blocks to find the first non-free stack portion.  A longjump
-; is performed to the target in the last free block, removing any unneeded frames
-; from the stack.
-;
-; s48_call_scheme starts the VM running the following CALLBACK procedure.  The
-; arguments are BLOCK, the stack-block just created for this callback, and
-; the procedure and arguments for the actual callback.  It prevents jumps back
-; into the callback and frees BLOCK if a throw out occurs.
-;
-; We disable interrupts to ensure that nothing intervenes between setting DONE?
-; and returning from the callback.  BLOCK is then either freed or returned to,
-; but not both or neither.  RETURN-FROM-CALLBACK reenables interrupts.
-
-(define (callback block proc . args)
-  (let ((done? #f))
-    (return-from-callback block
-			  (dynamic-wind
-			   (lambda ()
-			     (if done?
-				 (error "attempt to throw into a callback"
-					(cons proc args))))
-			   (lambda ()
-			     (let ((result (apply proc args)))
-			       (disable-interrupts!)
-			       (set! done? #t)
-			       result))
-			   (lambda ()
-			     (if (not done?)
-				 (begin
-				   (set! done? #t)
-				   (set-stack-block-free?! block #t)
-				   (clear-stack-top!))))))))
-
-(define-exported-binding "s48-callback" callback)
-
-; CLEAR-STACK-TOP! is an empty C procedure.  When it returns, s48_external_call
-; will automatically clear any free frames off of the stack.
-
-(import-lambda-definition clear-stack-top! () "s48_clear_stack_top")
-
-; Dealing with threads.
-;
-; The difficulty here is that each stack-block belongs to some thread.  Thread A
-; can call a C procedures which calls back into Scheme.  At that point a context
-; switch occurs and we start running thread B, which promptly does the same
-; calls.  THe process stack then looks like this:
-; 
-;  <C frame for VM running B1>
-;  <C frame for s48_call_scheme>
-;  <C frame for B's c code>
-;  <C frame for s48_external_call>
-;  <C frame for VM running A1 and then B0>
-;  <C frame for s48_call_scheme>
-;  <C frame for A's c code>
-;  <C frame for s48_external_call>
-;  <C frame for VM running A0>
-;  <base>
-;
-; At this point A cannot return from its callback before B does, because B's
-; portion of the process stack is above A's.  If A does try to return it must
-; block until it again is at the top of the stack.
-;
-; This is handled by s48_call_scheme, which checks to see if the stack-block
-; being returned to is at the top of the stack.  If not, it does a second
-; callback to DELAY-CALLBACK-RETURN, defined below, with the same stack-block.
-; DELAY-CALLBACK-RETURN creates a placeholder, puts it in the stack-block, and
-; then blocks on it.  When the placeholder gets a value the procedure attempts
-; another return-from-callback.
-;
-; This is called with interrupts disabled, as we need to avoid having BLOCK
-; reach the top of the stack before the placeholder is installed.
-
-(define (delay-callback-return block value)
-  (let ((placeholder (make-placeholder)))
-    (set-stack-block-placeholder! block placeholder)
-    (enable-interrupts!)
-    (placeholder-value placeholder)
-    value))
-
-(define-exported-binding "s48-delay-callback-return" delay-callback-return)
-
-; Finally, s48_external_call looks to see if the top stack-block has a
-; placeholder.  If it does, it raises an exception instead of doing a normal
-; return.  The exception handler sets the placeholder's value, allowing the
-; blocked thread to continue.  The handler then returns the external call's
-; value to its own thread, or, if the callback-return-uncovered is piggybacked
-; on another exception, we raise that exception.
-;
-; Because of the all of the games played above, the callback-return-uncovered
-; exception may appear to have come from either the call-external-value, or
-; return-from-callback opcodes.
-
-(define uncovered-return-handler
-  (lambda (opcode reason . args)
-    (if (= reason (enum exception callback-return-uncovered))
-	(call-with-values
-	 (lambda ()
-	   (if (= 2 (length args))
-	       (values (car args)
-		       (cadr args)
-		       #f)
-	       (let ((args (reverse args)))
-		 (values (car args)
-			 (cadr args)
-			 (reverse (cddr args))))))
-	 (lambda (block return-value exception-args)
-	   (let ((placeholder (stack-block-placeholder block)))
-	     (set-stack-block-placeholder! block #f)
-	     (placeholder-set! placeholder #t)
-	     (if exception-args
-		 (apply signal-exception opcode return-value exception-args)
-		 return-value))))
-	(apply signal-exception opcode reason args))))
-
-(define (block-depth block)
-  (if block
-      (+ 1 (block-depth (stack-block-next block)))
-      0))
-
-(for-each (lambda (opcode)
-	    (define-exception-handler opcode uncovered-return-handler))
-	  (list (enum op call-external-value)
-		(enum op return-from-callback)))
-
-;----------------
-; Utility for the common case of calling an imported binding.
-
-(define (call-imported-binding proc . args)
-  (if (and (shared-binding? proc)
-	   (shared-binding-is-import? proc))
-      (let ((value (shared-binding-ref proc)))
-	(if (byte-vector? value)
-	    (apply call-external-value
-		   value
-		   (shared-binding-name proc)
-		   args)
-	    (apply call-error "bad procedure" call-imported-binding proc args)))
-      (apply call-error "bad procedure" call-imported-binding proc args)))
-
-;----------------
-; Helper functions for converting between C longs and Scheme bignums.
-;
-; HIGH and LOW are the two sixteen-bit halves of the negative magnitude of
-; the number.  The negative magnitude is used to avoid problems with two's
-; complement's asymmetry.
-
-(define (long-to-bignum positive? high low)
-  (let ((magnitude (+ (arithmetic-shift high 16)
-                      low)))
-    (if positive?
-        (- magnitude)
-        magnitude)))
-
-; Same again, except that we break the number into the sign and the two halves.
-
-(define (bignum-to-long n)
-  (if (integer? n)
-      (let ((m (abs n)))
-        (vector (>= n 0)
-	        (arithmetic-shift m -16)
-	        (bitwise-and m sixteen-candles)))
-      #f))
-
-(define sixteen-candles (- (arithmetic-shift 1 16) 1))
-
-(define-exported-binding "s48-long-to-bignum" long-to-bignum)
-(define-exported-binding "s48-bignum-to-long" bignum-to-long)
-
-;----------------
-; Testing
-;
-; `s48_trampoline' is a C routine that calls its Scheme argument with between
-; zero and three arguments.  The arguments are 100, 200, and 300.
-;
-;(import-lambda-definition trampoline (proc nargs)
-;                          "s48_trampoline")
-;
-;(define (foo . args)
-;  (for-each display (list "[foo " args "]"))
-;  (newline)
-;  (cons 'foo-return args))
-;
-;; This should return 1100.
-;
-;(define (test0)
-;  (trampoline (lambda ()
-;                (call-with-current-continuation
-;                  (lambda (c)
-;                    (trampoline (lambda (x)
-;                                  (c (+ x 1000)))
-;                                1))))
-;              0))
-;
-;; ,open threads locks debug-messages
-;
-;(define (test1 error?)
-;  (let ((lock (make-lock))
-;        (repl-lock (make-lock)))
-;    (obtain-lock repl-lock)
-;    (spawn (lambda ()
-;             (obtain-lock lock)
-;             (debug-message "A returned "
-;                           (trampoline (lambda ()
-;                                         (obtain-lock lock) ; we block
-;                                         'a)
-;                                       0))
-;             (release-lock repl-lock))
-;           'thread-a)
-;    (spawn (lambda ()
-;             (debug-message "B returned "
-;                           (trampoline (lambda ()
-;                                         (release-lock lock)    ; A can run
-;                                         (relinquish-timeslice) ; let A run
-;                                         (if error? #f 'b))
-;                                       0)))
-;           'thread-b)
-;    (obtain-lock repl-lock)))
diff --git a/scheme/big/compose-cont.scm b/scheme/big/compose-cont.scm
deleted file mode 100644
index c4ec4cf..0000000
--- a/scheme/big/compose-cont.scm
+++ /dev/null
@@ -1,44 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-
-
-(define (compose-continuation proc cont)
-  (primitive-cwcc
-    (lambda (k)
-      (with-continuation cont ;(if cont cont null-continuation)
-        (lambda ()
-          (proc (primitive-cwcc
-                  (lambda (k2) (with-continuation k (lambda () k2))))))))))
-
-
-; Old definition that relies on details of VM architecture:
-
-;(define null-continuation #f)
-
-;(define null-continuation (make-continuation 4 #f)) ;temp kludge
-;(continuation-set! null-continuation 1 0)
-;(continuation-set! null-continuation 2
-;                   ;; op/trap = 140
-;                   (segment-data->template (make-code-vector 1 140) #f '()))
-
-;(put 'primitive-cwcc 'scheme-indent-hook 0)
-;(put 'with-continuation 'scheme-indent-hook 1)
-
-;(define compose-continuation
-;  (let ((tem
-;         (let ((cv (make-code-vector 6 0)))
-;           (code-vector-set! cv 0 op/push) ;push return value
-;           (code-vector-set! cv 1 op/local) ;fetch procedure
-;           (code-vector-set! cv 3 1)    ;over = 1
-;           (code-vector-set! cv 4 op/call)
-;           (code-vector-set! cv 5 1)    ;one argument
-;           (segment-data->template cv 0 '()))))
-;    (lambda (proc parent-cont)
-;      (let ((cont (make-continuation 4 #f)))
-;        (continuation-set! cont 0 parent-cont)
-;        (continuation-set! cont 1 0)    ;pc
-;        (continuation-set! cont 2 tem)  ;template
-;        (continuation-set! cont 3 (vector #f proc)) ;environment
-;        cont))))
-
diff --git a/scheme/big/defrecord.scm b/scheme/big/defrecord.scm
deleted file mode 100644
index 221f750..0000000
--- a/scheme/big/defrecord.scm
+++ /dev/null
@@ -1,147 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Syntax for defining record types
-
-; This knows about the implementation of records and creates the various
-; accessors, mutators, etc. directly instead of calling the procedures
-; from the record structure.  This is done to allow the optional auto-inlining
-; optimizer to inline the accessors, mutators, etc.
-
-; LOOPHOLE is used to get a little compile-time type checking (in addition to
-; the usual complete run-time checking).
-
-; (define-record-type name constructor-fields other-fields)
-
-; Constructor-arguments fields are either <name> or (<name>), the second
-; indicating a field whose value can be modified.
-; Other-fields are one of:
-;  (<name> <expression>) = modifiable field with the given value.
-;  <name>                = modifiable field with no initial value.
-
-;(define-record-type job
-;  ((thunk)
-;   (dynamic-env)
-;   number
-;   inferior-lock
-;   )
-;  ((on-queue  #f)
-;   (superior  #f)
-;   (inferiors '())
-;   (condition #f)
-;   ))
-
-(define-syntax define-record-type
-
-  (let ()
-
-    (define s->s symbol->string)
-    (define s-conc (lambda args (string->symbol (apply string-append args))))
-    (define spec-name (lambda (s) (if (pair? s) (car s) s)))
-    (define (filter pred lst)
-      (if (null? lst)
-	  '()
-	  (if (pred (car lst))
-	      (cons (car lst) (filter pred (cdr lst)))
-	      (filter pred (cdr lst)))))
-    (define (ass compare name list)
-      (cond ((null? list) #f)
-	    ((and (pair? (car list))
-		  (compare name (caar list)))
-	     (car list))
-	    (else
-	     (ass compare name (cdr list)))))
-
-    (lambda (form rename compare)
-      (let* ((name (cadr form))
-	     (arg-fields (caddr form))
-	     (other-fields (cadddr form))
-	     (init-fields (filter pair? other-fields))
-	     (args (map spec-name arg-fields))
-
-	     (field-name (lambda (field-name)
-			   (s-conc (s->s name) "-" (s->s field-name))))
-	     (set-name (lambda (field-name)
-			 (s-conc "set-" (s->s name)
-				 "-" (s->s field-name) "!")))
-	     (pred-name (s-conc (s->s name) "?"))
-	     (maker-name (s-conc (s->s name) "-maker"))
-	     (type-name (s-conc "type/" (s->s name)))
-
-	     (thing (rename 'name))
-	     (%make-record-type   (rename 'make-record-type))
-	     (%record             (rename 'record))
-	     (%define-accessors   (rename 'define-accessors))
-	     (%unspecific	  (rename 'unspecific))
-	     (%loophole		  (rename 'loophole))
-	     (%:value		  (rename ':value))
-	     (%proc		  (rename 'proc))
-	     (%define		  (rename 'define))
-	     (%let		  (rename 'let))
-	     (%lambda		  (rename 'lambda))
-	     (%begin		  (rename 'begin)))
-	`(,%begin
-	   (,%define ,type-name
-	     (,%make-record-type ',name
-				 ',(map spec-name
-					(append arg-fields other-fields))))
-	   (,%define ,maker-name
-	       (,%loophole (,%proc ,(map (lambda (x) %:value) args) ,type-name)
-		 (,%lambda ,args
-			   (,%record ,type-name
-				     ,@args
-				     . ,(map (lambda (field)
-					       (cond ((ass compare
-							   (spec-name field)
-							   other-fields)
-						      => cadr)
-						     (else
-						      `(,%unspecific))))
-					     other-fields)))))
-	   (,%define ,pred-name
-	       (,%lambda (,(rename 'x))
-		   (,(rename 'and)
-		    (,(rename 'record?) ,(rename 'x))
-		    (,(rename 'eq?) ,type-name
-				    (,(rename 'record-ref) ,(rename 'x) 0)))))
-	   (,%define-accessors ,type-name
-			       ,@(map (lambda (spec)
-					(if (pair? spec)
-					    `(,(field-name (car spec))
-					      ,(set-name (car spec)))
-					    `(,(field-name spec))))
-				      arg-fields)
-			       ,@(map (lambda (spec)
-					`(,(field-name (spec-name spec))
-					  ,(set-name (spec-name spec))))
-				      other-fields)))))))
-
-(define-syntax define-accessors
-  (lambda (e r c)
-    (let ((%define-accessor (r 'define-accessor))
-	  (%begin (r 'begin))
-	  (type (cadr e))
-	  (field-specs (cddr e)))
-      (do ((i 1 (+ i 1))
-	   (field-specs field-specs (cdr field-specs))
-	   (ds '()
-	       (cons `(,%define-accessor ,type ,i ,@(car field-specs))
-		     ds)))
-	  ((null? field-specs)
-	   `(,%begin ,@ds)))))
-  (define-accessor begin))
-
-(define-syntax define-accessor
-  (syntax-rules ()
-    ((define-accessor ?type ?index ?accessor)
-     (define ?accessor
-       (loophole (proc (?type) :value)
-		 (lambda (r)
-		   (checked-record-ref (loophole :record r) ?type ?index)))))
-    ((define-accessor ?type ?index ?accessor ?modifier)
-     (begin (define-accessor ?type ?index ?accessor)
-	    (define ?modifier
-	      (loophole (proc (?type :value) :unspecific)
-			(lambda (r new)
-			  (checked-record-set! (loophole :record r) ?type ?index new))))))
-    ((define-accessor ?type ?index)
-     (begin))))
diff --git a/scheme/big/destructure.scm b/scheme/big/destructure.scm
deleted file mode 100644
index 9918f84..0000000
--- a/scheme/big/destructure.scm
+++ /dev/null
@@ -1,63 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; This is a destructuring version of LET.
-; (DESTRUCTURE ((<pattern> <expression>) ...) body ...)
-; The patterns can be:
-;   identifiers, which are bound to the corresponding part of the value
-;   lists of patterns (including dotted pairs)
-;   vectors of patterns
-;
-; Bug (?): (destructure (((a) '(1 2))) ...) works.  The code does not check
-; to see if there are more elements than the minimum number required.
-
-(define-syntax destructure
-  (lambda (form rename compare)
-    (let ((specs (cadr form))
-	  (body (cddr form))
-	  (%car (rename 'car))
-	  (%cdr (rename 'cdr))
-	  (%vref (rename 'vector-ref))
-	  (%let* (rename 'let*))
-	  (gensym (lambda (i)
-		    (rename (string->symbol
-			     (string-append "x" (number->string i))))))
-	  (atom? (lambda (x) (not (pair? x)))))
-      (letrec ((expand-pattern
-		(lambda (pattern value i)
-		  (cond ((or (not pattern) (null? pattern))
-			 '())
-			((vector? pattern)
-			 (let ((xvalue (if (atom? value)
-					   value
-					   (gensym i))))
-			   `(,@(if (eq? value xvalue) '() `((,xvalue ,value)))
-			     ,@(expand-vector pattern xvalue i))))
-			((atom? pattern)
-			 `((,pattern ,value)))
-			(else
-			 (let ((xvalue (if (atom? value)
-					   value
-					   (gensym i))))
-			   `(,@(if (eq? value xvalue) '() `((,xvalue ,value)))
-			     ,@(expand-pattern (car pattern)
-					       `(,%car ,xvalue)
-					       (+ i 1))
-			     ,@(if (null? (cdr pattern))
- 				   '()
-				   (expand-pattern (cdr pattern)
-						   `(,%cdr ,xvalue)
-						   (+ i 1)))))))))
-	       (expand-vector
-		(lambda (vec xvalue i)
-		  (do ((j (- (vector-length vec) 1) (- j 1))
-		       (ps '() (append (expand-pattern (vector-ref vec j)
-						       `(,%vref ,xvalue ,j)
-						       (+ i 1))
-				       ps)))
-		      ((< j 0) ps)))))
-	(do ((specs specs (cdr specs))
-	     (res '() (append (expand-pattern (caar specs) (cadar specs) 0)
-			      res)))
-	    ((null? specs)
-	     `(,%let* ,res . ,body)))))))
-
diff --git a/scheme/big/dump.scm b/scheme/big/dump.scm
deleted file mode 100644
index e8a7790..0000000
--- a/scheme/big/dump.scm
+++ /dev/null
@@ -1,429 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Dump and restore
-
-; Unix has special meanings for
-;  ETX, FS, DEL, ETB, NAK, DC2, EOT, EM (or SUB?), DC3, DC1, SI, SYN,
-;  3    28  127  23   21   18   4    25     26     19   17   15  22
-; so avoid using them.
-
-(define type/null        #\n)
-(define type/true	 #\t)
-(define type/false	 #\f)
-(define type/unspecific #\u)
-(define type/pair        #\p)  ;obj1 obj2
-(define type/string	 #\s)  ;length chars
-(define type/number	 #\i)  ;#chars rep
-(define type/symbol	 #\y)  ;length chars
-(define type/char	 #\c)  ;char
-(define type/vector      #\v)  ;length objects
-(define type/template    #\a)  ;length objects
-(define type/code-vector #\k)  ;length bytes (each byte is 2 hex digits?)
-(define type/location	 #\l)  ;uid
-(define type/closure	 #\q)  ;template-info
-(define type/ellipsis	 #\e)
-(define type/random	 #\r)
-
-
-; Recursive entry
-
-(define (dump obj write-char depth)
-  (cond ((null? obj) (dump-type type/null write-char))
-	((eq? obj #t) (dump-type type/true write-char))
-	((eq? obj #f) (dump-type type/false write-char))
-	((pair? obj) (dump-pair obj write-char depth))
-	;; Template case needs to precede vector case
-	((template? obj) (dump-template obj write-char depth))
-	((vector? obj) (dump-vector obj write-char depth))
-	((symbol? obj) (dump-symbol obj write-char))
-	((number? obj) (dump-number obj write-char))
-	((string? obj) (dump-string obj write-char))
-	((char? obj) (dump-char-literal obj write-char))
-	((code-vector? obj) (dump-code-vector obj write-char))
-	((location? obj) (dump-location obj write-char))
-	((unspecific? obj) (dump-type type/unspecific write-char))
-	((closure? obj) (dump-closure obj write-char))
-	(else (dump-random obj write-char depth))))
-
-(define (restore read-char)
-  (let ((type (restore-type read-char)))
-    ((vector-ref restorers (char->ascii type)) type read-char)))
-    
-(define restorers
-  (make-vector 256 (lambda (type read-char)
-		     ;; Invalid type
-		     (error "invalid type code" type))))
-
-(define (define-restorer! type proc)
-  (vector-set! restorers (char->ascii type) proc))
-
-
-; Particular dumpers & restorers
-
-(define-restorer! type/null  (lambda (c read-char) '()))
-(define-restorer! type/false (lambda (c read-char) #f))
-(define-restorer! type/true  (lambda (c read-char) #t))
-(define-restorer! type/unspecific (lambda (c read-char) (if #f #f)))
-
-; Pairs
-
-(define (dump-pair obj write-char depth)
-  (if (= depth 0)
-      (dump-ellipsis obj write-char)
-      (let ((depth (- depth 1)))
-	(dump-type type/pair write-char)
-	(dump (car obj) write-char depth)
-	(dump (cdr obj) write-char depth))))
-
-(define-restorer! type/pair
-  (lambda (c write-char)
-    c ;ignored
-    (let ((the-car (restore write-char)))
-      (cons the-car (restore write-char)))))
-
-; Symbols
-
-(define (dump-symbol obj write-char)
-  (dump-type type/symbol write-char)
-  (dump-a-string (symbol-case-converter (symbol->string obj)) write-char))
-
-(define-restorer! type/symbol
-  (lambda (c read-char)
-    c ;ignored
-    (string->symbol (symbol-case-converter (restore-a-string read-char)))))
-
-
-; Numbers
-;   <space> ... _   represent  0 ... 63,
-;  {<space> ... {_  represent  64 ... 127,     -- { is ascii 123 
-;  |<space> ... |_  represent  128 ... 191,    -- | is ascii 124
-;  }<space> ... }_  represent  192 ... 256.    -- } is ascii 125
-
-(define (dump-number n write-char)
-  (if (not (communicable-number? n))
-      (error "can't dump this number" n))
-  (if (and (integer? n)
-	   (>= n 0)
-	   (< n 256))
-      (dump-byte n write-char)
-      (begin (dump-type type/number write-char)
-	     ;; Note logarithmic recursion
-	     (dump-a-string (number->string n comm-radix) write-char))))
-
-(define (communicable-number? n) #t)  ;this gets redefined in client
-
-(define (dump-byte n write-char)  ;Dump a number between 0 and 255
-  (if (< n 64)
-      (write-char (ascii->char (+ n ascii-space)))
-      (begin (write-char (ascii->char (+ (arithmetic-shift n -6)
-					 122)))
-	     (write-char (ascii->char (+ (bitwise-and n 63)
-					 ascii-space))))))
-
-(define ascii-space (char->ascii #\space)) ;32
-
-(define (restore-small-integer c read-char)
-  (- (char->ascii c) ascii-space))
-
-(do ((i (+ ascii-space 63) (- i 1)))
-    ((< i ascii-space))
-  (define-restorer! (ascii->char i) restore-small-integer))
-
-(define (restore-medium-integer c read-char)
-  (+ (arithmetic-shift (- (char->ascii c) 122) 6)
-     (- (char->ascii (read-char)) ascii-space)))
-
-(do ((i 123 (+ i 1)))
-    ((> i 125))
-  (define-restorer! (ascii->char i) restore-medium-integer))
-
-(define (restore-number read-char)
-  (let ((c (read-char)))
-    (if (char=? c type/number)
-	(string->number (restore-a-string read-char) comm-radix)
-	(let ((n (char->ascii c)))
-	  (if (> n 122)
-	      (restore-medium-integer c read-char)
-	      (- n ascii-space))))))
-
-(define-restorer! type/number
-  (lambda (c read-char)
-    c ;ignored
-    (string->number (restore-a-string read-char) comm-radix)))
-
-(define comm-radix 16)
-
-
-
-
-; String literals
-
-(define (dump-string obj write-char)
-  (dump-type type/string write-char)
-  (dump-a-string obj write-char))
-
-(define-restorer! type/string
-  (lambda (c read-char)
-    c ;ignored
-    (restore-a-string read-char)))
-
-; Characters
-
-(define (dump-char-literal obj write-char)
-  (dump-type type/char write-char)
-  (dump-a-char obj write-char))
-
-(define-restorer! type/char
-  (lambda (c read-char)
-    c ;ignored
-    (restore-a-char read-char)))
-
-; Vectors
-
-(define (dump-vector obj write-char depth)
-  (dump-vector-like obj write-char depth
-		    type/vector vector-length vector-ref))
-
-(define (dump-template obj write-char depth)
-  (dump-vector-like obj write-char depth
-		    type/template template-length template-ref))
-
-(define (dump-vector-like obj write-char depth type vector-length vector-ref)
-  (if (= depth 0)
-      (dump-ellipsis obj write-char)
-      (let ((depth (- depth 1))
-	    (len (vector-length obj)))
-	(dump-type type write-char)
-	(dump-length len write-char)
-	(do ((i 0 (+ i 1)))
-	    ((= i len) 'done)
-	  (dump (vector-ref obj i) write-char depth)))))
-
-(define (restore-vector-like make-vector vector-set!)
-  (lambda (c read-char)
-    c ;ignored
-    (let* ((len (restore-length read-char))
-	   (v (make-vector len #\?)))
-      (do ((i 0 (+ i 1)))
-	  ((= i len) v)
-	(vector-set! v i (restore read-char))))))
-
-(define-restorer! type/vector
-  (restore-vector-like make-vector vector-set!))
-
-(define-restorer! type/template
-  (restore-vector-like make-template template-set!))
-  
-; Code vectors
-
-(define (dump-code-vector obj write-char)
-  (dump-type type/code-vector write-char)
-  (let ((len (code-vector-length obj)))
-    (dump-length len write-char)
-    (do ((i 0 (+ i 1)))
-	((= i len) 'done)
-      (dump-byte (code-vector-ref obj i) write-char))))
-
-(define-restorer! type/code-vector
-  (lambda (c read-char)
-    c					;ignored
-    (let* ((len (restore-length read-char))
-	   (cv (make-code-vector len 0)))
-      (do ((i 0 (+ i 1)))
-	  ((= i len) cv)
-	(code-vector-set! cv i
-			  (restore-number read-char))))))
-
-; Locations
-
-(define (dump-location obj write-char)
-  (dump-type type/location write-char)
-  (dump-number (location->uid obj) write-char))
-
-(define (location->uid obj)
-  (or ((fluid $dump-index) obj)
-      (location-id obj)))
-
-(define-restorer! type/location
-  (lambda (c read-char)
-    c ;ignored
-    (uid->location (restore-number read-char))))
-
-(define (uid->location uid)
-  (or ((fluid $restore-index) uid)
-      (table-ref uid->location-table uid)
-      (let ((loc (make-undefined-location uid)))
-	(note-location! loc)
-	loc)))
-(define $restore-index (make-fluid (lambda (uid) #f)))
-
-(define uid->location-table (make-table))
-
-(define (note-location! den)
-  (table-set! uid->location-table
-	      (location-id den)
-	      den))
-
-(define $dump-index (make-fluid (lambda (loc) #f)))
-
-; For simulation purposes, it's better for location uid's not to
-; conflict with any that might be in the base Scheme 48 system.  (In the
-; real server system there isn't any base Scheme 48 system, so there's
-; no danger of conflict.)
-
-; (define location-uid-origin 5000)
-
-
-; Closure
-
-(define (dump-closure obj write-char)
-  (dump-type type/closure write-char)
-  (let ((id (template-info (closure-template obj))))
-    (dump-number (if (integer? id) id 0) write-char)))
-
-(define-restorer! type/closure
-  (lambda (c read-char)
-    c ;ignored
-    (make-random (list 'closure (restore-number read-char)))))
-
-
-; Random
-
-(define random-type (make-record-type 'random '(disclosure)))
-(define make-random (record-constructor random-type '(disclosure)))
-(define-record-discloser random-type
-  (let ((d (record-accessor random-type 'disclosure)))
-    (lambda (r) (cons "Remote" (d r)))))
-
-(define (dump-random obj write-char depth)
-  (dump-type type/random write-char)
-  (dump (or (disclose obj) (list '?))
-	    write-char
-	    depth))
-
-(define-restorer! type/random
-  (lambda (c read-char)
-    (make-random (restore read-char))))
-
-
-
-; Ellipsis
-
-(define (dump-ellipsis obj write-char)
-  (dump-type type/ellipsis write-char))
-
-(define-restorer! type/ellipsis
-  (lambda (c read-char) (make-random (list (string->symbol "---")))))
-
-
-
-
-; Auxiliaries:
-
-; Strings (not necessarily preceded by type code)
-
-(define (dump-a-string obj write-char)
-  (let ((len (string-length obj)))
-    (dump-length len write-char)
-    (do ((i 0 (+ i 1)))
-	((= i len) 'done)
-      (dump-a-char (string-ref obj i) write-char))))
-
-(define (restore-a-string read-char)
-  (let* ((len (restore-length read-char))
-	 (str (make-string len #\?)))
-    (do ((i 0 (+ i 1)))
-	((= i len) str)
-      (string-set! str i (restore-a-char read-char)))))
-
-(define (dump-a-char c write-char)
-  (write-char c))
-
-(define (restore-a-char read-char)
-  (read-char))
-
-
-; Type characters
-
-(define (dump-type c write-char)
-  (write-char c))
-(define (restore-type read-char)
-  (read-char))
-
-(define dump-length dump-number)
-(define restore-length restore-number)
-
-;(define char->ascii char->integer)  -- defined in p-features.scm
-;(define ascii->char integer->char)  -- ditto
-
-
-; Miscellaneous support
-
-(define (unspecific? obj)
-  (eq? obj *unspecific*))
-
-(define *unspecific* (if #f #f)) ;foo
-
-;(define (integer->digit-char n)
-;  (ascii->char (+ n (if (< n 10) ascii-zero a-minus-ten))))
-;
-;(define (digit-char->integer c)
-;  (cond ((char-numeric? c)
-;         (- (char->ascii c) ascii-zero))
-;        ((char=? c #\#) 0)
-;        (else
-;         (- (char->ascii (char-downcase c)) a-minus-ten))))
-;
-;(define ascii-zero (char->ascii #\0))
-;
-;(define a-minus-ten (- (char->integer #\a) 10))
-
-; These modified from s48/boot/transport.scm
-
-(define (string-case-converter string)
-  (let ((new (make-string (string-length string) #\?)))
-    (do ((i 0 (+ i 1)))
-	((>= i (string-length new)) new)
-      (string-set! new i (invert-case (string-ref string i))))))
-
-(define (invert-case c)
-  (cond ((char-upper-case? c) (char-downcase c))
-	((char-lower-case? c) (char-upcase c))
-	(else c)))
-
-(define symbol-case-converter
-  (if (char=? (string-ref (symbol->string 't) 0) #\t)
-      (lambda (string) string)
-      string-case-converter))
-
-
-; ASCII
-;   !"#$%&'()*+,-./0123456789:;<=>?
-;  @ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_
-;  `abcdefghijklmnopqrstuvwxyz{|}~
-
-;(define (tst x)
-;  (let ((l '()))
-;    (dump x (lambda (c) (set! l (cons c l))) -1)
-;    (let ((l (reverse l)))
-;      (restore (lambda ()
-;                 (let ((c (car l)))
-;                   (set! l (cdr l))
-;                   c))))))
-
-;(define cwcc call-with-current-continuation)
-;
-;(define (tst x)
-;  (letrec ((write-cont (lambda (ignore)
-;                         (dump x
-;                               (lambda (c)
-;                                 (cwcc (lambda (k)
-;                                         (set! write-cont k)
-;                                         (read-cont c))))
-;                               -1)))
-;           (read-cont #f))
-;    (restore (lambda ()
-;               (cwcc (lambda (k)
-;                       (set! read-cont k)
-;                       (write-cont 'ignore)))))))
diff --git a/scheme/big/filename.scm b/scheme/big/filename.scm
deleted file mode 100644
index 30cd56a..0000000
--- a/scheme/big/filename.scm
+++ /dev/null
@@ -1,115 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Silly file name utilities
-; These try to be operating-system independent, but fail, of course.
-
-; Namelist = ((dir ...) basename type)
-;         or ((dir ...) basename)
-;	  or (dir basename type)
-;	  or (dir basename)
-;	  or basename
-
-(define (namestring namelist dir default-type)
-  (let* ((namelist (if (list? namelist) namelist (list '() namelist)))
-	 (subdirs (if (list? (car namelist))
-		      (car namelist)
-		      (list (car namelist))))
-	 (basename (cadr namelist))
-	 (type (if (null? (cddr namelist))
-		   (if (string? basename)
-		       #f
-		       default-type)
-		   (caddr namelist))))
-    (string-append (or dir "")
-		   (apply string-append
-			  (map (lambda (subdir)
-				 (string-append
-				  (namestring-component subdir)
-				  directory-component-separator))
-			       subdirs))
-		   (namestring-component basename)
-		   (if type
-		       (string-append type-component-separator
-				      (namestring-component type))
-		       ""))))
-
-(define directory-component-separator "/") ;unix sux
-(define type-component-separator ".")
-
-(define (namestring-component x)
-  (cond ((string? x) x)
-	((symbol? x)
-	 (list->string (map file-name-preferred-case
-			    (string->list (symbol->string x)))))
-	(else (error "bogus namelist component" x))))
-
-(define file-name-preferred-case char-downcase)
-
-(define *scheme-file-type* 'scm)
-(define *load-file-type* *scheme-file-type*)  ;#F for Pseudoscheme or T
-
-
-
-; Interface copied from gnu emacs:
-
-;file-name-directory           
-;  Function: Return the directory component in file name NAME.
-;file-name-nondirectory        
-;  Function: Return file name NAME sans its directory.
-;file-name-absolute-p          
-;  Function: Return t if file FILENAME specifies an absolute path name.
-;substitute-in-file-name       
-;  Function: Substitute environment variables referred to in STRING.
-;expand-file-name              
-;  Function: Convert FILENAME to absolute, and canonicalize it.
-
-(define (file-name-directory filename)
-  (substring filename 0 (file-nondirectory-position filename)))
-
-(define (file-name-nondirectory filename)
-  (substring filename
-	     (file-nondirectory-position filename)
-	     (string-length filename)))
-
-(define (file-nondirectory-position filename)
-  (let loop ((i (- (string-length filename) 1)))
-    (cond ((< i 0) 0)
-	  ;; Heuristic.  Should work for DOS, Unix, VMS, MacOS.
-          ((string-posq (string-ref filename i) "/:>]\\") (+ i 1))
-          (else (loop (- i 1))))))
-
-(define (string-posq thing s)
-  (let loop ((i 0))
-    (cond ((>= i (string-length s)) #f)
-          ((eq? thing (string-ref s i)) i)
-          (else (loop (+ i 1))))))
-
-
-
-; Directory translations.
-; E.g. (set-translation! "foo;" "/usr/mumble/foo/")
-
-(define *translations* '())
-
-(define (translations) *translations*)
-
-(define (set-translation! from to)
-  (let ((probe (assoc from *translations*)))
-    (if probe
-	(set-cdr! probe to)
-	(set! *translations* (cons (cons from to) *translations*)))))
-
-(define (translate name)
-  (let ((len (string-length name)))
-    (let loop ((ts *translations*))
-      (if (null? ts)
-	  name
-	  (let* ((from (caar ts))
-		 (to (cdar ts))
-		 (k (string-length from)))
-	    (if (and to
-		     (<= k len)
-		     (string=? (substring name 0 k) from))
-		(string-append to (substring name k len))
-		(loop (cdr ts))))))))
diff --git a/scheme/big/format.scm b/scheme/big/format.scm
deleted file mode 100644
index 20895f5..0000000
--- a/scheme/big/format.scm
+++ /dev/null
@@ -1,154 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Quicky FORMAT
-;
-; (FORMAT port string . args)
-;
-; PORT is one of:
-; an output port, in which case FORMAT prints to the port;
-; #T, FORMAT prints to the current output port;
-; #F, FORMAT returns a string.
-;
-; The following format directives have been implemented:
-; ~~  -prints a single ~
-; ~A  -prints the next argument using DISPLAY
-; ~D  -prints the next argument using NUMBER->STRING (`D'ecimal)
-; ~S  -prints the next argument using WRITE
-; ~%  -prints a NEWLINE character
-; ~&  -prints a NEWLINE character if the previous printed character was not one
-;     (this is implemented using FRESH-LINE)
-; ~?  -performs a recursive call to FORMAT using the next two arguments as the
-;      string and the list of arguments
-;
-; FORMAT is case-insensitive with respect to letter directives (~a and ~A have
-; the same effect).
-
-; The entry point.  Gets the port and writes the output.
-; Get the appropriate writer for the port specification.
-
-(define (format port string . args)
-  (cond ((not port)
- 	 (call-with-string-output-port
-  	   (lambda (port)
-  	     (real-format port string args))))
-	((eq? port #t)
-	 (real-format (current-output-port) string args))
-	((output-port? port)
-	 (real-format port string args))
-	(else
-	 (error "invalid port argument to FORMAT" port))))
-
-; Loop down the format string printing characters and dispatching on directives
-; as required.  Procedures for the directives are in a vector indexed by
-; character codes.  Each procedure takes four arguments: the format string,
-; the index of the next unused character in the format string, the list of
-; remaining arguments, and the writer.  Each should return a list of the unused
-; arguments.
-
-(define (real-format out string all-args)
-  (let loop ((i 0) (args all-args))
-    (cond ((>= i (string-length string))
-	   (if (null? args)
-	       #f
-	       (error "too many arguments to FORMAT" string all-args)))
-	  ((char=? #\~ (string-ref string i))
-	   (if (= (+ i 1) (string-length string))
-	       (error "invalid format string" string i)
-	       (loop (+ i 2)
-		     ((vector-ref format-dispatch-vector
-				  (char->ascii (string-ref string (+ i 1))))
-		      string
-		      (+ i 2)
-		      args
-		      out))))
-	  (else
-	   (write-char (string-ref string i) out)
-	   (loop (+ i 1) args)))))
-
-; One more than the highest integer that CHAR->ASCII may return.
-(define number-of-char-codes ascii-limit)
-
-; The vector of procedures implementing format directives.
-
-(define format-dispatch-vector
-  (make-vector number-of-char-codes
-	       (lambda (string i args out)
-		 (error "illegal format command"
-			string
-			(string-ref string (- i 1))))))
-
-; This implements FORMAT's case-insensitivity.
-
-(define (define-format-command char proc)
-  (vector-set! format-dispatch-vector (char->ascii char) proc)
-  (if (char-alphabetic? char)
-      (vector-set! format-dispatch-vector
-		   (char->ascii (if (char-lower-case? char)
-				    (char-upcase char)
-				    (char-downcase char)))
-		   proc)))
-
-; Write a single ~ character.
-
-(define-format-command #\~
-  (lambda (string i args out)
-    (write-char #\~ out)
-    args))
-
-; Newline
-
-(define-format-command #\%
-  (lambda (string i args out)
-    (newline out)
-    args))
-
-; Fresh-Line
-
-(define-format-command #\&
-  (lambda (string i args out)
-    (fresh-line out)
-    args))
-
-; Display (`A' is for ASCII)
-
-(define-format-command #\a
-  (lambda (string i args out)
-    (check-for-format-arg args)
-    (display (car args) out)
-    (cdr args)))
-
-; Decimals
-
-(define-format-command #\d
-  (lambda (string i args out)
-    (check-for-format-arg args)
-    (if (not (number? (car args)))
-	(error "invalid number argument to ~D in FORMAT" string (car args)))
-    (display (number->string (car args) 10) out)
-    (cdr args)))
-
-; Write (`S' is for S-expression)
-
-(define-format-command #\s
-  (lambda (string i args out)
-    (check-for-format-arg args)
-    (write (car args) out)
-    (cdr args)))
-
-; Recursion
-
-(define-format-command #\?
-  (lambda (string i args out)
-    (check-for-format-arg args)
-    (check-for-format-arg (cdr args))
-    (real-format out (car args) (cadr args))
-    (cddr args)))
-
-; Signal an error if ARGS is empty.
-
-(define (check-for-format-arg args)
-  (if (null? args)
-      (error "insufficient number of arguments to FORMAT")))
-
-
diff --git a/scheme/big/general-table.scm b/scheme/big/general-table.scm
deleted file mode 100644
index 632ead6..0000000
--- a/scheme/big/general-table.scm
+++ /dev/null
@@ -1,270 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Hash table package that allows for different hash and comparison functions.
-;
-; The fields in a table are:
-;  size - the number of entries
-;  data - an a-list or vector of a-lists
-;  ref  - a procedure: [table index] -> value
-;  set  - a procedure: [table index new-value] -> void
-;
-; In small tables the data is stored in an a-list and no hashing is used.
-; In large tables the data is stored in a vector of a-lists, with hashing
-; used to index into the vector.  When a small table grows large the REF
-; and SET fields are replaced with vector-oriented versions.
-
-(define-record-type table :table
-  (really-make-table size data ref set)
-  table?
-  (size table-size set-table-size!)
-  (data table-data set-table-data!)
-  (ref table-ref-procedure set-table-ref-procedure!)
-  (set table-set!-procedure set-table-set!-procedure!))
-
-(define (table-ref table key)
-  ((table-ref-procedure table) table key))
-
-(define (table-set! table key value)
-  ((table-set!-procedure table) table key value))
-
-; This number is a guess
-(define linear-table-size-limit 15)
-
-(define (next-table-size count)		; Figure out next good size for table.
-  (+ (* count 3) 1))
-
-; A table-maker is a thunk that returns a new, empty table each time it is
-; called.  There are four functions involved:
-;   assoc : [key alist] -> entry or #f
-;   ref-proc : [table key] -> entry or #f
-;   x->hash-table! : [assoc hash-function] -> void
-;   set!-proc : [table key value] -> void
-; X->HASH-TABLE! replaces the data, ref, and set fields of the table, making
-; it into a hash table.
-
-(define (make-table-maker comparison-function hash-function)
-  (assoc->table-maker (make-assoc comparison-function)
-		      hash-function))
-
-(define (assoc->table-maker assoc hash-function)
-  (let* ((ref-proc (make-linear-table-ref assoc))
-	 (x->hash-table! (make->hash-table assoc hash-function))
-	 (set!-proc (make-linear-table-set! assoc x->hash-table!)))
-    (lambda ()
-      (really-make-table 0 null-entry ref-proc set!-proc))))
-
-;----------------
-; A-lists.  These are currently actual a-lists, because ASSQ is a VM primitive
-; and thus very fast.
-
-(define null-entry '())  ; #f
-
-(define (new-entry key val others)
-  ;(vector key val others)
-  (cons (cons key val) others))
-
-; This abstraction is violated at times.
-(define entry-value cdr)
-(define entry-key car)
-(define set-entry-value! set-cdr!)
-
-; ENTRIES is known to contain ENTRY.
-
-(define (delete-entry! entries entry)
-  (if (eq? entry (car entries))
-      (cdr entries)
-      (begin
-	(let loop ((entries entries))
-	  (if (eq? entry
-		   (cadr entries))
-	      (set-cdr! entries (cddr entries))
-	      (loop (cdr entries))))
-	entries)))
-
-(define (make-assoc pred)
-  (if (eq? pred eq?)
-      assq
-      (lambda (thing alist)
-	(let loop ((alist alist))
-	  (cond ((null? alist)
-		 #f)
-		((pred thing (caar alist))
-		 (car alist))
-		(else
-		 (loop (cdr alist))))))))
-
-; Using actual a-lists allows us to use ASSQ instead of the following.
-
-;(define eq?-assoc
-;  (lambda (thing alist)
-;    (let loop ((alist alist))
-;      (cond ((not alist)
-;             #f)
-;            ((eq? thing (vector-ref alist 0))
-;             alist)
-;            (else
-;             (loop (vector-ref alist 2)))))))
-
-;----------------
-; Turn some version of ASSOC into a table reference procedure for a-list
-; tables.
-
-(define (make-linear-table-ref assoc)
-  (lambda (table key)
-    (let ((probe (assoc key (table-data table))))
-      (if probe (entry-value probe) #f))))
-
-; Turn some version of ASSOC and a hash function into a table set! procedure
-; for a-list tables.  If the table gets too big it is turned into a hash table.
-
-(define (make-linear-table-set! assoc x->hash-table!)
-  (lambda (table key value)
-    (let* ((data (table-data table))
-	   (probe (assoc key data)))
-      (cond (probe
-	     (if value
-		 (set-entry-value! probe value)
-		 (begin
-		   (set-table-data! table (delete-entry! data probe))
-		   (set-table-size! table (- (table-size table) 1)))))
-	    (value
-	     (set-table-data! table (new-entry key value data))
-	     (let ((size (table-size table)))
-	       (if (< size linear-table-size-limit)
-		   (set-table-size! table (+ size 1))
-		   (x->hash-table! table size))))))))
-
-; Return a function to transform linear tables into hash tables.
-
-(define (make->hash-table assoc hash-function)
-  (let ((hash-table-ref (make-hash-table-ref assoc hash-function))
-	(hash-table-set! (make-hash-table-set! assoc hash-function)))
-    (lambda (table size)
-      (let ((data (table-data table)))
-	(set-table-ref-procedure! table hash-table-ref)
-	(set-table-set!-procedure! table hash-table-set!)
-	(table-expand-table! table (next-table-size size))
-	(table-enter-alist! table data)))))
-
-(define (make-hash-table-ref assoc hash-function)
-  (lambda (table key)
-    (let* ((data (table-data table))
-	   (h (remainder (hash-function key)
-			 (vector-length data)))
-	   (alist (vector-ref data h))
-	   (probe (assoc key alist)))
-      (if probe (entry-value probe) #f))))
-	       
-(define (make-hash-table-set! assoc hash-function)
-  (lambda (table key value)
-    (let* ((data (table-data table))
-	   (h (remainder (hash-function key)
-			 (vector-length data)))
-	   (alist (vector-ref data h))
-	   (probe (assoc key alist)))
-      (cond (probe
-	     (if value
-		 (set-entry-value! probe value)
-		 (begin
-		   (vector-set! data h (delete-entry! alist probe))
-		   (set-table-size! table (- (table-size table) 1)))))
-	    (value
-	     (vector-set! data h (new-entry key value alist))
-	     (let ((size (+ (table-size table) 1)))
-	       (if (< size (vector-length data))
-		   (set-table-size! table size)
-		   (expand-hash-table! table size))))))))
-
-(define (expand-hash-table! table size)
-  (let ((data (table-data table)))
-    (table-expand-table! table (next-table-size size))
-    (do ((i 0 (+ i 1)))
-	((>= i (vector-length data)))
-      (table-enter-alist! table (vector-ref data i)))))
-
-(define (table-enter-alist! table alist)
-  (let ((set!-proc (table-set!-procedure table)))
-    (do ((alist alist (cdr alist)))
-	((null? alist))
-      (set!-proc table (caar alist) (cdar alist)))))
-
-; Reset the size and data of a table.  The size will be incremented as
-; the entries are added back into the table.
-
-(define (table-expand-table! table vector-size)
-  (set-table-size! table 0)
-  (set-table-data! table (make-vector vector-size null-entry)))
-
-(define (table-walk proc table)
-  (really-table-walk (lambda (v)
-		       (proc (entry-key v) (entry-value v)))
-		     table))
-		       
-(define (really-table-walk proc table)
-  (let ((data (table-data table)))
-    (cond ((null? data))
-	  ((pair? data)
-	   (alist-walk proc data))
-	  (else
-	   (do ((i 0 (+ i 1)))
-	       ((>= i (vector-length data)))
-	     (alist-walk proc (vector-ref data i)))))))
-
-(define (alist-walk proc alist)
-  (do ((alist alist (cdr alist)))
-      ((null? alist))
-    (proc (car alist))))
-
-(define (make-table-immutable! table)
-  (really-table-walk make-immutable! table)
-  (make-immutable! (table-data table))
-  (make-immutable! table))
-
-(define (table->entry-list table)
-  (let ((list '()))
-    (table-walk (lambda (k v)
-		  (set! list (cons v list)))
-		table)
-    list))
-
-; Actual tables
-
-; The default hash function only on works on things that would work in
-; a CASE expression.  Even then, numbers don't really "work," since
-; they are compared using eq?.
-
-(define (default-table-hash-function obj)
-  (cond ((symbol? obj) (string-hash (symbol->string obj)))
-	((integer? obj)
-	 (if (< obj 0) (- -1 obj) obj))
-	((char? obj) (+ 333 (char->integer obj)))
-	((eq? obj #f) 3001)
-	((eq? obj #t) 3003)
-	((null? obj) 3005)
-	(else (error "value cannot be used as a table key" obj))))
-
-(define eqv?-assoc (make-assoc eqv?))
-
-(define (default-table-assoc key alist)
-  (if (number? key)
-      (eqv?-assoc key alist)
-      (assq key alist)))
-
-; (define string-hash (structure-ref features string-hash))
-
-(define (symbol-hash symbol)
-  (string-hash (symbol->string symbol)))
-
-(define make-table
-  (let ((make-usual-table (assoc->table-maker default-table-assoc
-					      default-table-hash-function)))
-    (lambda hash-function-option
-      (if (null? hash-function-option)
-	  (make-usual-table)
-	  ((assoc->table-maker default-table-assoc
-			       (car hash-function-option)))))))
-
-(define make-string-table  (make-table-maker string=? string-hash))
-(define make-symbol-table  (make-table-maker eq?      symbol-hash))
-(define make-integer-table (make-table-maker =	      abs))
diff --git a/scheme/big/import-def.scm b/scheme/big/import-def.scm
deleted file mode 100644
index a2108a5..0000000
--- a/scheme/big/import-def.scm
+++ /dev/null
@@ -1,67 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Two macros:
-;
-; (import-definition <id>)
-;   ->
-; (define <id> (lookup-imported-binding "<id with - becoming _>"))
-;
-; (import-definition <id> <string id>)
-;   ->
-; (define <id> (lookup-imported-binding <string-id>))
-;
-; (import-lambda-definition <id> (<formal> ...))
-;   ->
-; (begin
-;   (define temp (lookup-imported-binding "<id with - becoming _>"))
-;   (define <id>
-;     (lambda (<formal> ...)
-;       (call-imported-binding temp <formal> ...))))
-;
-; (import-lambda-definition <id> (<formal> ...) <string id>)
-;   ->
-; ...same again using <string id> as the imported name...
-
-(define-syntax import-definition
-  (lambda (exp rename compare)
-    (let ((id (cadr exp))
-	  (%define (rename 'define))
-	  (%lookup-imported-binding (rename 'lookup-imported-binding)))
-      (let ((external-id (if (null? (cddr exp))
-			     (list->string (map (lambda (ch)
-						  (if (char=? ch #\-)
-						      #\_
-						      ch))
-						(string->list
-						 (symbol->string id))))
-			     (caddr exp))))
-	`(,%define ,id
-	    (,%lookup-imported-binding ,external-id))))))
-
-; (import-lambda-definition id (formal ...) [external name])
-
-(define-syntax import-lambda-definition
-  (lambda (exp rename compare)
-    (let ((id (cadr exp))
-	  (formals (caddr exp))
-	  (%define (rename 'define))
-	  (%begin (rename 'begin))
-	  (%lambda (rename 'lambda))
-	  (%call-imported-binding   (rename 'call-imported-binding))
-	  (%lookup-imported-binding (rename 'lookup-imported-binding))
-	  (%binding 		(rename 'binding)))
-      (let ((external-id (if (null? (cdddr exp))
-			     (list->string (map (lambda (ch)
-						  (if (char=? ch #\-)
-						      #\_
-						      ch))
-						(string->list
-						 (symbol->string id))))
-			     (cadddr exp))))
-	`(,%begin
-	   (,%define ,%binding
-	    (,%lookup-imported-binding ,external-id))
-	   (,%define ,id
-	    (,%lambda ,formals
-	      (,%call-imported-binding ,%binding . ,formals))))))))
-
diff --git a/scheme/big/linked-queue.scm b/scheme/big/linked-queue.scm
deleted file mode 100644
index 3a291f5..0000000
--- a/scheme/big/linked-queue.scm
+++ /dev/null
@@ -1,74 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; This file is no longer used.
-
-; Queues implemented as doubly linked lists (because the thread package needs
-; to delete queue entries quickly).
-
-; The exported procedures are those of the simpler queue package, with the
-; addition of DELETE-QUEUE-ENTRY!.  ENQUEUE! returns a queue-entry which can
-; then be passed to DELETE-QUEUE-ENTRY! to remove the thing from the queue.
-
-(define-record-type q-entry :q-entry
-  (make-q-entry data prev next)
-  q-entry?
-  (data q-entry-data)
-  (prev q-entry-prev set-q-entry-prev!)
-  (next q-entry-next set-q-entry-next!))
-
-(define queue? q-entry?)
-
-(define (make-queue)
-  (let ((e (make-q-entry #f #f #f)))
-    (set-q-entry-prev! e e)
-    (set-q-entry-next! e e)
-    e))
-
-(define (queue-empty? q)
-  (eq? (q-entry-next q) q))
-
-(define (enqueue! q thing)
-  (let* ((prev (q-entry-prev q))
-	 (e (make-q-entry thing prev q)))
-    (set-q-entry-prev! q e)
-    (set-q-entry-next! prev e)
-    e))
-
-(define (queue-head q)
-  (let ((e (q-entry-next q)))
-    (if (eq? q e)	;(queue-empty? q)
-	(error "empty queue" q)
-	(q-entry-data e))))
-
-(define (dequeue! q)
-  (let ((e (q-entry-next q)))
-    (cond ((eq? q e)	;(queue-empty? q)
-	   (error "empty queue" q))
-	  (else
-	   (set-q-entry-next! q (q-entry-next e))
-	   (set-q-entry-prev! (q-entry-next q) q)
-	   (q-entry-data e)))))
-
-(define (delete-queue-entry! e)
-  (let ((next (q-entry-next e))
-	(prev (q-entry-prev e)))
-    (set-q-entry-next! prev next)
-    (set-q-entry-prev! next prev)))
-
-(define (queue->list q)
-  (do ((e (q-entry-prev q) (q-entry-prev e))
-       (l '() (cons (q-entry-data e) l)))
-      ((eq? q e) l)))
-
-(define (queue-length q)
-  (do ((e (q-entry-prev q) (q-entry-prev e))
-       (l 0 (+ l 1)))
-      ((eq? q e) l)))
-
-(define (delete-from-queue! q v)
-  (let loop ((e (q-entry-next q)))
-    (cond ((eq? e q))
-	  ((eq? (q-entry-data e) v)
-	   (delete-queue-entry! e))
-	  (else
-	   (loop (q-entry-next e))))))
diff --git a/scheme/big/lu-decomp.scm b/scheme/big/lu-decomp.scm
deleted file mode 100644
index 146e628..0000000
--- a/scheme/big/lu-decomp.scm
+++ /dev/null
@@ -1,144 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; LU Decomposition (a rewriting of a Pascal program from `Numerical Recipes
-; in Pascal'; look there for a detailed description of what is going on).
-
-; A is an NxN matrix that is updated in place.
-; This returns a row permutation vector and the sign of that vector.
-
-(define *lu-decomposition-epsilon* 1.0e-20)
-
-(define (lu-decomposition a)
-  (let* ((n (car (array-shape a)))
-	 (indx (make-vector n))
-	 (sign 1.0)
-	 (vv (make-vector n)))
-
-    (do ((i 0 (+ i 1)))
-	((>= i n))
-      (do ((j 0 (+ j 1))
-	   (big 0.0 (max big (abs (array-ref a i j)))))
-	  ((>= j n)
-	   (if (= big 0.0)
-	       (error "lu-decomposition matrix has a zero row" a i))
-	   (vector-set! vv i (/ big)))))
-
-    (do ((j 0 (+ j 1)))
-	((>= j n))
-      (let ()
-	(define (sum-elts i end)	  
-	  (do ((k 0 (+ k 1))
-	       (sum (array-ref a i j)
-		    (- sum (* (array-ref a i k)
-			      (array-ref a k j)))))
-	      ((>= k end)
-	       sum)))
-
-	(do ((i 0 (+ i 1)))
-	    ((>= i j))
-	  (array-set! a (sum-elts i i) i j))
-
-	(receive (big imax)
-	    (let loop ((i j) (big 0.0) (imax 0))
-	      (if (>= i n)
-		  (values big imax)
-		  (let ((sum (sum-elts i j)))
-		    (array-set! a sum i j)
-		    (let ((temp (* (vector-ref vv i) (abs sum))))
-		      (if (>= temp big)
-			  (loop (+ i 1) temp i)
-			  (loop (+ i 1) big imax))))))
-	
-	  (if (not (= j imax))
-	      (begin
-		(do ((k 0 (+ k 1)))
-		    ((>= k n))
-		  (let ((temp (array-ref a imax k)))
-		    (array-set! a (array-ref a j k) imax k)
-		    (array-set! a temp j k)))
-		(set! sign (- sign))
-		(vector-set! vv imax (vector-ref vv j))))
-	  
-	  (vector-set! indx j imax)
-	  
-	  (if (= (array-ref a j j) 0.0)
-	      (array-set! a *lu-decomposition-epsilon* j j))
-	  
-	  (if (not (= j (- n 1)))
-	      (let ((temp (/ (array-ref a j j))))
-		(do ((i (+ j 1) (+ i 1)))
-		    ((>= i n))
-		  (array-set! a (* (array-ref a i j) temp) i j)))))))
-      
-      (values indx sign)))
-
-(define (lu-back-substitute a indx b)
-  (let ((n (car (array-shape a))))
-	  
-    (let loop ((i 0) (ii #f))
-      (if (< i n)
-	  (let* ((ip (vector-ref indx i))
-		 (temp (vector-ref b ip)))
-	    (vector-set! b ip (vector-ref b i))
-	    (let ((new (if ii
-			   (do ((j ii (+ j 1))
-				(sum temp (- sum (* (array-ref a i j)
-						    (vector-ref b j)))))
-			       ((>= j i)
-				sum))
-			   temp)))
-	      (vector-set! b i new)
-	      (loop (+ i 1)
-		    (if (or ii (= temp 0.0)) ii i))))))
-
-    (do ((i (- n 1) (- i 1)))
-	((< i 0))
-      (do ((j (+ i 1) (+ j 1))
-	   (sum (vector-ref b i) (- sum (* (array-ref a i j)
-					   (vector-ref b j)))))
-	  ((>= j n)
-	   (vector-set! b i (/ sum (array-ref a i i))))))))
-
-;(define m
-;  (array '(4 4)
-;         1.0  2.0 3.0 -2.0
-;         8.0 -6.0 6.0  1.0
-;         3.0 -2.0 0.0 -7.0
-;         4.0  7.0 2.0 -1.0))
-;
-;(define b '#(2.0 1.0 3.0 -2.0))
-;
-;(define (test m b)
-;  (let* ((a (copy-array m))
-;         (n (car (array-shape m)))
-;         (x (make-vector n)))
-;
-;    (do ((i 0 (+ i 1)))
-;        ((>= i n))
-;      (vector-set! x i (vector-ref b i)))
-;
-;    (display "b = ")
-;    (display b)
-;    (newline)
-;
-;    (call-with-values
-;     (lambda ()
-;       (lu-decomposition a))
-;     (lambda (indx sign)
-;       (lu-back-substitute a indx x)
-;
-;       (display "x = ")
-;       (display x)
-;       (newline)
-;
-;       (let ((y (make-vector (vector-length b))))
-;         (do ((i 0 (+ i 1)))
-;             ((>= i n))
-;           (do ((j 0 (+ j 1))
-;                (t 0.0 (+ t (* (array-ref m i j) (vector-ref x j)))))
-;               ((>= j n)
-;                (vector-set! y i t))))
-;
-;         (display "a * x =")
-;         (display y)
-;         (newline))))))
diff --git a/scheme/big/pipe.scm b/scheme/big/pipe.scm
deleted file mode 100644
index 79a38e3..0000000
--- a/scheme/big/pipe.scm
+++ /dev/null
@@ -1,413 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Pipes.
-;
-; This would be easy except that we have to deal with threads (and who else
-; would be using pipes?).
-;
-; Pipes either have a fixed set of buffers which are continually recycled or
-; create new buffers as needed.  Having a fixed buffer supply keeps readers
-; and writers more-or-less synchronised, while creating buffers as needed allows
-; the writers to get arbitrarily far ahead of the readers.
-;
-; A fixed-buffer pipe has two buffers.  At any point one is acting as the
-; input buffer and the other as the output buffer.  When the input buffer is
-; empty the two are swapped.
-;
-; The complexity of the code below comes from having to deal with the two
-; blocking situations:
-;  - a read is done when all buffers are empty
-;  - a write is done when the output buffer is full and the input buffer
-;    is non-empty (and we aren't allowed to make more buffers)
-; 
-; If a read occurs when all buffers are empty we swap a zero-length buffer in
-; for the output-buffer and block on a condition variable.  The zero-length
-; buffer guarantees that the reading thread will be woken when the next write
-; occurs.  When a write occurs with a zero-length buffer we swap in the real
-; buffer, do the write, and then set the input condition variable.
-;
-; When a write occurs with the write buffer full for a pipe without a fixed
-; set of buffers the full buffer is added to a queue.
-;
-; For a pipe with only two buffers, if a write occurs with the write buffer
-; full and the read buffer non-empty, we set the read-limit to be one shorter
-; than its real value and block on a condition variable.  The bogus read-limit
-; means that the writing thread will be woken when a read empties the buffer
-; and not have to wait until the following read.  When a read reaches the
-; read-limit we check to see if there are waiting output threads.  If so, we
-; write one more character and then wake the sleepers.
-;
-; If this were a little more integrated with the threads package pipes
-; could use queues instead of making new condition variables all the time.
-
-(define-record-type pipe-data :pipe-data
-  (make-pipe-data lock in-condvar out-condvar queue out-buffer)
-  pipe-data?
-  (lock pipe-lock)   ; a lock for keeping this pipe single threaded
-  (in-condvar        ; waiting for a non-empty buffer
-   pipe-in-condvar
-   set-pipe-in-condvar!)
-  (out-condvar       ; waiting for an empty buffer
-   pipe-out-condvar
-   set-pipe-out-condvar!)
-  (queue             ; queue of full buffers, or #f for a pipe with a fixed
-   pipe-buffer-queue);   buffer set
-  (out-buffer        ; stashed output buffer
-   pipe-out-buffer
-   set-pipe-out-buffer!))
-    
-(define (lock pipe)
-  (obtain-lock (pipe-lock (port-data pipe))))
-
-(define (unlock pipe)
-  (release-lock (pipe-lock (port-data pipe))))
-
-; Swap the buffers and initialize the various buffer pointers.
-
-(define (swap-buffers! port)
-  (let ((temp (port-in-buffer port)))
-    (set-port-in-buffer! port (port-out-buffer port))
-    (set-port-out-buffer! port temp)
-    (set-port-in-limit! port (port-out-index port))
-    (set-port-in-index! port 0)
-    (set-port-out-index! port 0)))
-
-; Get a full buffer from the queue.
-
-(define (use-buffer-from-queue port)
-  (let ((queue (pipe-buffer-queue (port-data port))))
-    (if (and queue (not (queue-empty? queue)))
-	(let ((buffer (dequeue! queue)))
-	  (set-port-in-buffer! port buffer)
-	  (set-port-in-index! port 0)
-	  (set-port-in-limit! port (code-vector-length buffer))
-	  #t)
-	#f)))
-
-;----------------------------------------------------------------
-; Input buffers
-
-; Get a non-empty input buffer, if possible.  We have five options:
-;  1. The current buffer isn't empty.
-;  2. The current buffer looks empty but really isn't; the limit was
-;     decremented by a writer who wants an empty buffer.
-;  3. There is a queue and it has a full buffer.
-;  4. The output buffer isn't empty.
-;  5. The output port is still open and may produce characters in the future.
-; If there are no characters and the output port is closed we lose.
-
-(define (get-in-buffer port)
-  (cond ((> (port-in-limit port)
-	    (port-in-index port))
-	 #t)
-	((pipe-out-condvar (port-data port))
-	 (set-port-in-limit! port (+ 1 (port-in-limit port)))
-	 #t)
-	((use-buffer-from-queue port)
-	 #t)
-	((< 0 (port-out-index port))
-	 (swap-buffers! port)
-	 #t)
-	((open-output-port? port)
-	 (wait-for-input port)
-	 (get-in-buffer port))
-	(else
-	 #f)))
-
-; Wait on the input condition variable.  If there isn't one, we make a
-; new condition variable and swap in a zero-length write buffer to get the
-; condition variable set as soon as a write occurs.
-
-(define (wait-for-input port)
-  (let* ((data (port-data port))
-	 (cv (if (pipe-in-condvar data)
-		 (pipe-in-condvar data)
-		 (let ((cv (make-condvar)))
-		   (set-pipe-out-buffer! (port-data port) (port-out-buffer port))
-		   (set-port-out-buffer! port (make-code-vector 0 0))
-		   (set-pipe-in-condvar! data cv)
-		   cv))))
-    (release-lock (pipe-lock data))
-    (condvar-ref cv)
-    (obtain-lock (pipe-lock data))))
-
-; Wake any threads waiting for input if there are characters available.
-
-(define (wake-any-input-waiters port)
-  (let ((data (port-data port)))
-    (let ((cv (pipe-in-condvar data)))
-      (if (and cv
-	       (or (< 0 (port-out-index port))
-		   (not (open-output-port? port))))
-	  (begin
-            (set-pipe-in-condvar! data #f)
-	    (condvar-set! cv (unspecific)))))))
-
-;----------------------------------------------------------------
-; Output buffers
-
-; Get a non-full output buffer, if possible.  We have five options:
-;  1. The current buffer has room.
-;  2. The current buffer looks full but really isn't; it is a zero-length
-;     buffer swapped in by a reader who wants characters.
-;  3. There is a queue for full buffers.
-;  4. The input buffer is empty.
-;  5. The input port is still open and may empty its buffer later on.
-; If there are no empty buffers and the input port is closed we lose.
-
-(define (get-out-buffer port)
-  (let ((len (code-vector-length (port-out-buffer port))))
-    (cond ((< (port-out-index port) len)
-           #t)
-	  ((= 0 len)
-	   (set-port-out-buffer! port (pipe-out-buffer (port-data port)))
-	   #t)
-	  ((pipe-buffer-queue (port-data port))
-	   (make-new-out-buffer port)
-	   #t)
-	  ((= (port-in-index port) (port-in-limit port))
-           (swap-buffers! port)
-	   #t)
-	  ((open-input-port? port)
-	   (wait-for-output port)
-	   (get-out-buffer port))
-	  (else
-	   #f))))
-
-; Make a new output buffer and put the full one on the queue.
-
-(define (make-new-out-buffer port)
-  (let* ((old (port-out-buffer port))
-	 (new (make-code-vector (code-vector-length old) 0)))
-    (enqueue! (pipe-buffer-queue (port-data port)) old)
-    (set-port-out-buffer! port new)
-    (set-port-out-index! port 0)))
-
-; Same as above, on a different condition variable and with a different
-; wakeup method.
-
-(define (wait-for-output port)
-  (let* ((data (port-data port))
-	 (cv (if (pipe-out-condvar data)
-                 (pipe-out-condvar data)
-                 (let ((cv (make-condvar)))
-		   (set-port-in-limit! port (- (port-in-limit port) 1))
-		   (set-pipe-out-condvar! data cv)
-		   cv))))
-    (release-lock (pipe-lock data))
-    (condvar-ref cv)
-    (obtain-lock (pipe-lock data))))
-
-(define (wake-any-output-waiters port)
-  (let ((data (port-data port)))
-    (let ((cv (pipe-out-condvar data)))
-      (if (and cv
-	       (or (= (port-in-limit port) (port-in-index port))
-		   (not (open-output-port? port))))
-	  (begin
-            (set-pipe-out-condvar! data #f)
-	    (condvar-set! cv (unspecific)))))))
-
-; Used by PEEK-CHAR to reset the wakeup limit.
-
-(define (do-not-disturb-output-waiters port)
-  (if (pipe-out-condvar (port-data port))
-      (set-port-in-limit! port (- (port-in-limit port) 1))))
-
-; Close both ports and wake up any sleepers.
-
-(define (close-pipe port close-input?)
-  (lock port)
-  (if close-input? 
-      (make-input-port-closed! port))
-  (make-output-port-closed! port)
-  (wake-any-input-waiters port)
-  (wake-any-output-waiters port)
-  (unlock port))
-
-;----------------------------------------------------------------
-; The actual handler
-
-(define pipe-handler
-  (make-port-handler
-
-   ;; discloser
-   (lambda (port)
-     (list 'pipe))
-
-   ;; input port methods --------------------------
-
-   ;; close-input-port
-   (lambda (port)
-     (close-pipe port #t))
-
-   ;; The next three methods are called when the input buffer is empty
-   ;; read-char
-   (lambda (port)
-     (lock port)
-     (cond ((get-in-buffer port)
-	    (let ((c (read-char port)))
-	      (wake-any-output-waiters port)
-	      (unlock port)
-	      c))
-	   (else
-            (unlock port)
-	    (eof-object))))
-
-   ;; peek-char
-   (lambda (port)
-     (lock port)
-     (cond ((get-in-buffer port)
-	    (let ((c (peek-char port)))
-	      (do-not-disturb-output-waiters port)
-	      (unlock port)
-	      c))
-	   (else
-            (unlock port)
-	    (eof-object))))
-
-   ;; char-ready?
-   (lambda (port)
-     (> (port-out-index port) 0))
-
-   ;; read-block - the buffer has fewer than COUNT characters
-   (lambda (thing start count port)
-     (lock port)
-     (let loop ((start start) (count count))
-       (let* ((index (port-in-index port))
-	      (have (min (- (port-in-limit port) index)
-			 count)))
-	 (cond ((> have 0)
-		(copy! (port-in-buffer port) index thing start have)
-		(set-port-in-index! port (+ index have))))
-	 (wake-any-output-waiters port)
-	 (cond ((= have count)
-		(unlock port))
-	       ((get-in-buffer port)
-                (loop (+ start have) (- count have)))
-	       (else
-		(unlock port)
-		(eof-object))))))
-
-   ;; output port methods -------------------------
-
-   ;; close-output-port
-   (lambda (port)
-     (close-pipe port #f))
-
-   ;; write-char got a full buffer
-   (lambda (char port)
-     (lock port)
-     (cond ((get-out-buffer port)
-	    (write-char char port)
-	    (wake-any-input-waiters port)
-	    (unlock port))
-	   (else
-            (unlock port)
-	    (error "writing to a broken pipe"))))
-
-   ;; write-block couldn't fit COUNT characters into the buffer
-   (lambda (thing start count port)
-     (lock port)
-     (let loop ((start start) (count count))
-       (cond ((get-out-buffer port)
-	      (let* ((buffer (port-out-buffer port))
-		     (index (port-out-index port))
-		     (have (min (- (code-vector-length buffer) index)
-				count)))
-                (cond ((> have 0)
-		       (copy! thing start buffer index have)
-		       (set-port-out-index! port (+ index have))))
-		(wake-any-input-waiters port)
-		(if (= have count)
-		    (unlock port)
-		    (loop (+ start have) (- count have)))))
-	     (else
-	      (unlock port)
-	      (error "writing to a broken pipe")))))
-
-   ;; force-output
-   (lambda (port)
-     (values))))
-
-(define pipe-buffer-size 1024)
-
-; Takes an optional size to use for the buffers.  A size of #f indicates
-; that buffers should be made as needed (we really need omega).
-
-(define (make-pipe . maybe-buffer-size)
-  (call-with-values
-   (lambda ()
-     (parse-make-pipe-args maybe-buffer-size))
-   (lambda (size queue)
-     (make-port pipe-handler
-		(bitwise-ior open-input-port-status
-			     open-output-port-status)
-		(make-pipe-data (make-lock) ; the lock
-				#f	    ; input condition variable
-				#f	    ; output condition variable
-				queue       ; full buffer queue
-				#f)	    ; stashed output buffer
-		(make-code-vector size 0)   ; input buffer
-		0			    ; input index
-		0			    ; input limit
-		(make-code-vector size 0)   ; output buffer
-		0))))			    ; output limit
-  
-(define (parse-make-pipe-args maybe-buffer-size)
-  (if (null? maybe-buffer-size)
-      (values pipe-buffer-size #f)
-      (let ((size (car maybe-buffer-size)))
-	(cond ((not size)
-	       (values pipe-buffer-size (make-queue)))
-	      ((and (integer? size)
-		    (exact? size)
-		    (< 0 size))
-	       (values size #f))
-	      (else
-	       (call-error "invalid pipe buffer size" make-pipe size))))))
-
-; These should probably be moved to I/O
-
-(define (open-input-port? port)
-  (= (bitwise-and open-input-port-status
-		  (port-status port))
-     open-input-port-status))
-
-(define (open-output-port? port)
-  (= (bitwise-and open-output-port-status
-		  (port-status port))
-     open-output-port-status))
-
-; Won't do string->string copies.
-
-(define (copy! from i to j count)
-  (if (code-vector? from)
-      (if (code-vector? to)
-	  (copy-bytes! from i to j count)
-	  (copy-bytes->chars! from i to j count))
-      (copy-chars->bytes! from i to j count)))
-
-; Copied from more-port.scm.
-
-(define (copy-bytes! from i to j count)
-  (let ((limit (+ count i)))
-    (do ((i i (+ i 1))
-	 (j j (+ j 1)))
-	((= i limit))
-      (code-vector-set! to j (code-vector-ref from i)))))
-
-(define (copy-chars->bytes! from i to j count)
-  (let ((limit (+ count i)))
-    (do ((i i (+ i 1))
-	 (j j (+ j 1)))
-	((= i limit))
-      (code-vector-set! to j (char->ascii (string-ref from i))))))
-
-(define (copy-bytes->chars! from i to j count)
-  (let ((limit (+ count i)))
-    (do ((i i (+ i 1))
-	 (j j (+ j 1)))
-	((= i limit))
-      (string-set! to j (ascii->char (code-vector-ref from i))))))
-
diff --git a/scheme/big/pp.scm b/scheme/big/pp.scm
deleted file mode 100644
index e6c2f27..0000000
--- a/scheme/big/pp.scm
+++ /dev/null
@@ -1,431 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-;;;; A pretty-printer
-
-; This isn't exactly in the spirit of the rest of the Scheme 48
-; system.  It's too hairy, and it has unexploited internal generality.
-; It really ought to be rewritten.  In addition, it seems to be buggy
-; -- it sometimes prints unnecessarily wide lines.  Usually it's
-; better than no pretty printer at all, so we tolerate it.
-
-; From: ramsdell@linus.mitre.org
-; Date:  Wed, 12 Sep 1990 05:14:49 PDT
-;
-; As you noted in your comments, pp.scm is not a straight forward
-; program.  You could add some comments that would greatly ease the task
-; of figuring out what his going on.  In particular, you should describe
-; the interface of various objects---most importantly the interface of a
-; formatter.  You might also add some description as to what protocol
-; they are to follow.
-
-; Other things to implement some day:
-;  - LET, LET*, LETREC binding lists should be printed vertically if longer
-;    than about 30 characters
-;  - COND clauses should all be printed vertically if the COND is vertical
-;  - Add an option to lowercase or uppercase symbols and named characters.
-;  - Parameters controlling behavior of printer should be passed around
-;  - Do something about choosing between #f and ()
-;  - Insert line breaks intelligently following head of symbol-headed list,
-;    when necessary
-;  - Some equivalents of *print-level*, *print-length*, *print-circle*.
-
-; Possible strategies:
-;   (foo x y z)     Horizontal = infinity sticky 
-;   (foo x y        One sticky + one + body (e.g. named LET)
-;     z
-;     w)
-;   (foo x          One + body
-;     y
-;     z)
-;   (foo x          Two + body
-;        y
-;     z)
-;   (foo x          Big ell = infinity + body (combination)
-;	 y
-;	 z)
-;   (foo            Little ell, zero + body (combination)
-;     x
-;     y)
-;   (foo            Vertical
-;    x
-;    y)
-;
-; Available height/width tradeoffs:
-;   Combination:
-;     Horizontal, big ell, or little ell.
-;   Special form:
-;     Horizontal, or M sticky + N + body.
-;   Random (e.g. vector, improper list, non-symbol-headed list):
-;     Horizontal, or vertical.  (Never zero plus body.)
-
-(define (p x . port-option)
-  (let ((port (if (pair? port-option) (car port-option)
-		  (current-output-port))))
-    (pretty-print x port 0)
-    (newline port)))
-
-(define *line-width* 80)
-
-(define *single-line-special-form-limit* 30)
-
-; Stream primitives
-
-(define head car)
-(define (tail s) (force (cdr s)))
-
-(define (map-stream proc stream)
-  (cons (proc (head stream))
-	(delay (map-stream proc (tail stream)))))
-
-(define (stream-ref stream n)
-  (if (= n 0)
-      (head stream)
-      (stream-ref (tail stream) (- n 1))))
-
-; Printer
-
-(define (pretty-print obj port pos)
-  (let ((node (pp-prescan obj 0)))
-;    (if (> (column-of (node-dimensions node)) *line-width*)
-;        ;; Eventually add a pass to change format of selected combinations
-;        ;; from big-ell to little-ell.
-;        (begin (display ";** too wide - ")
-;               (write (node-dimensions node))
-;               (newline)))
-    (print-node node port pos)))
-
-(define make-node list)
-
-(define (node-dimensions node)
-  ((car node)))
-
-(define (node-pass-2 node pos)
-  ((cadr node) pos))
-
-(define (print-node node port pos)
-  ((caddr node) port pos))
-
-(define (pp-prescan obj hang)
-  (cond ((symbol? obj)
-         (make-leaf (string-length (symbol->string obj))
-                    obj hang))
-        ((number? obj)
-         (make-leaf (string-length (number->string obj))
-                    obj hang))
-        ((boolean? obj)
-         (make-leaf 2 obj hang))
-        ((string? obj)
-         ;;++ Should count number of backslashes and quotes
-         (make-leaf (+ (string-length obj) 2) obj hang))
-        ((char? obj)
-         (make-leaf (case obj
-                      ((#\space) 7)
-                      ((#\newline) 9)
-                      (else 3))
-                    obj hang))
-        ((pair? obj)
-         (pp-prescan-pair obj hang))
-        ((vector? obj)
-         (pp-prescan-vector obj hang))
-	(else
-	 (pp-prescan-random obj hang))))
-
-(define (make-leaf width obj hang)
-  (let ((width (+ width hang)))
-    (make-node (lambda () width)
-	       (lambda (pos)
-		 (+ pos width))
-	       (lambda (port pos)
-		 (write obj port)
-		 (do ((i 0 (+ i 1)))
-		     ((>= i hang) (+ pos width))
-		   (write-char #\) port))))))
-
-(define (make-prefix-node string node)
-  (let ((len (string-length string)))
-    (make-node (lambda ()
-		 (+ (node-dimensions node) len))
-	       (lambda (pos)
-		 (node-pass-2 node (+ pos len)))
-	       (lambda (port pos)
-		 (display string port)
-		 (print-node node port (+ pos len))))))
-
-(define (pp-prescan-vector obj hang)
-  (if (= (vector-length obj) 0)
-      (make-leaf 3 obj hang)
-      (make-prefix-node "#" (pp-prescan-list (vector->list obj) #t hang))))
-
-; Improve later.
-
-(define (pp-prescan-random obj hang)
-  (let ((l (disclose obj)))
-    (if (list? l)
-	(make-prefix-node "#." (pp-prescan-list l #t hang))
-	(make-leaf 25 obj hang))))  ;Very random number
-
-(define (pp-prescan-pair obj hang)
-  (cond ((read-macro-inverse obj)
-         =>
-         (lambda (inverse)
-	   (make-prefix-node inverse (pp-prescan (cadr obj) hang))))
-        (else
-         (pp-prescan-list obj #f hang))))
-
-(define (pp-prescan-list obj random? hang)
-  (let loop ((l obj) (z '()))
-    (if (pair? (cdr l))
-	(loop (cdr l)
-	      (cons (pp-prescan (car l) 0) z))
-	(make-list-node
-	  (reverse
-	    (if (null? (cdr l))
-		(cons (pp-prescan (car l) (+ hang 1)) z)
-		(cons (make-prefix-node ". " (pp-prescan (cdr l) (+ hang 1)))
-		      (cons (pp-prescan (car l) 0) z))))
-	  obj
-	  (or random? (not (null? (cdr l))))))))
-
-; Is it sufficient to tell parent node:
-;  At a cost of X line breaks, I can make myself narrower by Y columns. ?
-; Then how do we decide whether we narrow ourselves or some of our children?
-
-(define (make-list-node node-list obj random?)
-  (let* ((random? (or random?
-		      ;; Heuristic for things like do, cond, let, ...
-		      (not (symbol? (car obj)))
-		      (eq? (car obj) 'else)))
-	 (probe (if (not random?)
-		    (indentation-for (car obj))
-		    #f))
-	 (format horizontal-format)
-	 (dimensions (compute-dimensions node-list format))
-	 (go-non-horizontal
-	  (lambda (col)
-	    (set! format
-		  (cond (random? vertical-format)
-			(probe (probe obj))
-			(else big-ell-format)))
-	    (let* ((start-col (+ col 1))
-		   (col (node-pass-2 (car node-list) start-col))
-		   (final-col
-		       (format (cdr node-list) 
-			       (lambda (node col target-col)
-				 (node-pass-2 node target-col))
-			       start-col
-			       (+ col 1)
-			       col)))
-	      (set! dimensions (compute-dimensions node-list format))
-	      final-col))))
-    (if (> dimensions
-	   (if probe
-	       *single-line-special-form-limit*
-	       *line-width*))
-	(go-non-horizontal 0))
-    (make-node (lambda () dimensions)
-	       (lambda (col) ;Pass 2: if necessary, go non-horizontal
-		 (let ((defacto (+ col (column-of dimensions))))
-		   (if (> defacto *line-width*)
-		       (go-non-horizontal col)
-		       defacto)))
-	       (lambda (port pos)
-		 (write-char #\( port)
-		 (let* ((pos (+ pos 1))
-			(start-col (column-of pos))
-			(pos (print-node (car node-list) port pos)))
-		   (format (cdr node-list) 
-			   (lambda (node pos target-col)
-			     (let ((pos (go-to-column target-col
-						      port pos)))
-			       (print-node node port pos)))
-			   start-col
-			   (+ (column-of pos) 1)
-			   pos))))))
-
-(define (compute-dimensions node-list format)
-  (let* ((start-col 1)			;open paren
-	 (pos (+ (make-position start-col 0)
-		 (node-dimensions (car node-list)))))
-    (format (cdr node-list)
-	    (lambda (node pos target-col)
-	      (let* ((dims (node-dimensions node))
-		     (lines (+ (line-of pos) (line-of dims)))
-		     (width (+ target-col (column-of dims))))
-		(if (>= (column-of pos) target-col)
-		    ;; Line break required
-		    (make-position
-		     (max (column-of pos) width)
-		     (+ lines 1))
-		    (make-position width lines))))
-	    start-col
-	    (+ (column-of pos) 1)	;first-col
-	    pos)))
-
-; Three positions are significant
-;   (foo baz ...)
-;    ^   ^  ^
-;    |   |  +--- (column-of pos)
-;    |   +------ first-col
-;    +---------- start-col
-
-; Separators
-
-(define on-same-line
-  (lambda (start-col first-col pos)
-    start-col first-col ;ignored
-    (+ (column-of pos) 1)))
-
-(define indent-under-first
-  (lambda (start-col first-col pos)
-    start-col ;ignored
-    first-col))
-
-(define indent-for-body
-  (lambda (start-col first-col pos)
-    first-col ;ignored
-    (+ start-col 1)))
-
-(define indent-under-head
-  (lambda (start-col first-col pos)
-    first-col ;ignored
-    start-col))
-
-; Format constructors
-
-(define (once separator format)
-  (lambda (tail proc start-col first-col pos)
-    (if (null? tail)
-	pos
-	(let ((target-col (separator start-col first-col pos)))
-	  (format (cdr tail)
-		  proc
-		  start-col
-		  first-col
-		  (proc (car tail) pos target-col))))))
-
-(define (indefinitely separator)
-  (letrec ((self (once separator	;eta
-		       (lambda (tail proc start-col first-col pos)
-			 (self tail proc start-col first-col pos)))))
-    self))
-
-(define (repeatedly separator count format)
-  (do ((i 0 (+ i 1))
-       (format format
-	       (once separator format)))
-      ((>= i count) format)))
-
-; Particular formats
-
-(define vertical-format
-  (indefinitely indent-under-head))
-
-(define horizontal-format
-  (indefinitely on-same-line))
-
-(define big-ell-format
-  (indefinitely indent-under-first))
-
-(define little-ell-format
-  (indefinitely indent-for-body))
-
-(define format-for-named-let
-  (repeatedly on-same-line 2 (indefinitely indent-for-body)))
-
-(define hook-formats
-  (letrec ((stream (cons little-ell-format
-			 (delay (map-stream (lambda (format)
-					      (once indent-under-first format))
-					    stream)))))
-    stream))
-
-; Hooks for special forms.
-; A hook maps an expression to a format.
-
-(define (compute-let-indentation exp)
-  (if (and (not (null? (cdr exp)))
-	   (symbol? (cadr exp)))
-      format-for-named-let
-      (stream-ref hook-formats 1)))
-
-(define hook
-  (let ((hooks (map-stream (lambda (format)
-			     (lambda (exp) exp ;ignored
-			       format))
-			   hook-formats)))
-    (lambda (n)
-      (stream-ref hooks n))))
-
-
-; Table of indent hooks.
-
-(define indentations (make-table))
-
-(define (indentation-for name)
-  (table-ref indentations name))
-
-(define (define-indentation name n)
-  (table-set! indentations
-	      name
-	      (if (integer? n) (hook n) n)))
-
-; Indent hooks for Revised^n Scheme.
-
-(for-each (lambda (name)
-	    (define-indentation name 1))
-	  '(lambda define define-syntax let* letrec let-syntax letrec-syntax
-	    case call-with-values call-with-input-file
-	    call-with-output-file with-input-from-file
-	    with-output-to-file syntax-rules))
-
-(define-indentation 'do            2)
-(define-indentation 'call-with-current-continuation 0)
-
-(define-indentation 'let           compute-let-indentation)
-
-; Kludge to force vertical printing (do AND and OR as well?)
-(define-indentation 'if            (lambda (exp) big-ell-format))
-(define-indentation 'cond          (lambda (exp) big-ell-format))
-
-
-; Other auxiliaries
-
-(define (go-to-column target-col port pos) ;=> pos
-  ;; Writes at least one space or newline
-  (let* ((column (column-of pos))
-	 (line (if (>= column target-col)
-		   (+ (line-of pos) 1)
-		   (line-of pos))))
-    (do ((column (if (>= column target-col)
-		     (begin (newline port) 0)
-		     column)
-		 (+ column 1)))
-	((>= column target-col)
-	 (make-position column line))
-      (write-char #\space port))))
-
-(define (make-position column line)
-  (+ column (* line 1000)))
-
-(define (column-of pos)
-  (remainder pos 1000))
-
-(define (line-of pos)
-  (quotient pos 1000))
-
-(define (read-macro-inverse x)
-  (cond ((and (pair? x)
-              (pair? (cdr x))
-              (null? (cddr x)))
-         (case (car x)
-           ((quote)            "'")
-           ((quasiquote)       "`")
-           ((unquote)          ",")
-           ((unquote-splicing) ",@")
-           (else #f)))
-        (else #f)))
-
-; For the command processor:
-
-;(define-command 'p "<exp>" "pretty-print" '(expression)
-;  (p (eval expression (user-package)) (command-output)))
diff --git a/scheme/big/random.scm b/scheme/big/random.scm
deleted file mode 100644
index ec026e9..0000000
--- a/scheme/big/random.scm
+++ /dev/null
@@ -1,61 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Random number generator, extracted from T sources.  Original
-; probably by Richard Kelsey.
-
-; Tests have shown that this is not particularly random.
-
-(define half-log 14)
-(define full-log (* half-log 2))
-(define half-mask (- (arithmetic-shift 1 half-log) 1))
-(define full-mask (- (arithmetic-shift 1 full-log) 1))
-(define index-log 6)
-(define random-1 (bitwise-and 314159265 full-mask))
-(define random-2 (bitwise-and 271828189 full-mask))
-
-; (MAKE-RANDOM <seed>) takes an integer seed and returns a procedure of no
-; arguments that returns a new pseudo-random number each time it is called.
-; <Seed> should be between 0 and 2**28 - 1 (exclusive).
-
-(define (make-random seed)
-  (if (and (integer? seed)
-	   (< 0 seed)
-	   (<= seed full-mask))
-      (make-random-vector seed
-        (lambda (vec a b)
-	  (lambda ()
-	    (set! a (randomize a random-1 random-2))
-	    (set! b (randomize b random-2 random-1))
-	    (let* ((index (arithmetic-shift a (- index-log full-log)))
-		   (c (vector-ref vec index)))
-	      (vector-set! vec index b)
-	      c))))
-      (call-error "invalid argument" make-random seed)))
-
-(define (randomize x mult ad)
-  (bitwise-and (+ (low-bits-of-product x mult) ad)
-               full-mask))
-
-(define (make-random-vector seed return)
-  (let* ((size (arithmetic-shift 1 index-log))
-         (vec (make-vector size 0)))
-    (do ((i 0 (+ i 1))
-         (b seed (randomize b random-2 random-1)))
-        ((>= i size)
-         (return vec seed b))
-      (vector-set! vec i b))))
-
-; Compute low bits of product of two fixnums using only fixnum arithmetic.
-; [x1 x2] * [y1 y2] = [x1y1 (x1y2+x2y1) x2y2]
-
-(define (low-bits-of-product x y)
-  (let ((x1 (arithmetic-shift x (- 0 half-log)))
-        (y1 (arithmetic-shift y (- 0 half-log)))
-        (x2 (bitwise-and x half-mask))
-        (y2 (bitwise-and y half-mask)))
-     (bitwise-and (+ (* x2 y2)
-                     (arithmetic-shift (bitwise-and (+ (* x1 y2) (* x2 y1))
-                                                    half-mask)
-                                       half-log))
-                  full-mask)))
diff --git a/scheme/big/receive.scm b/scheme/big/receive.scm
deleted file mode 100644
index 7332091..0000000
--- a/scheme/big/receive.scm
+++ /dev/null
@@ -1,8 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-(define-syntax receive
-  (syntax-rules ()
-    ((receive ?vars ?producer . ?body)
-     (call-with-values (lambda () ?producer)
-       (lambda ?vars . ?body)))))
diff --git a/scheme/big/search-tree.scm b/scheme/big/search-tree.scm
deleted file mode 100644
index f776682..0000000
--- a/scheme/big/search-tree.scm
+++ /dev/null
@@ -1,441 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Red-Black binary search trees as described in Introduction to Algorithms
-; by Cormen, Leiserson, and Rivest.  Look there if you want to understand
-; the algorithm.
-;
-; These are like tables in that the value of a key defaults to #f.
-;
-; (make-search-tree key-= key-<)      -> tree
-;
-; (search-tree? value)                -> boolean
-;
-; (search-tree-ref tree key)          -> value
-;
-; (search-tree-set! tree key value)
-;
-; (search-tree-modify! tree key proc)
-;   == (search-tree-set! tree key (proc (search-tree-ref tree key)))
-;
-; (search-tree-max tree)              -> key + value
-; (pop-search-tree-max! tree)         -> key + value  (removes entry)
-;
-; (search-tree-min tree)              -> key + value
-; (pop-search-tree-min! tree)         -> key + value  (removes entry)
-;
-; (walk-search-tree proc tree)
-;   applies PROC in order to all key + value pairs with a non-#f value
-
-(define-record-type tree :tree
-  (make-tree lookup nil root)
-  search-tree?
-  (lookup tree-lookup)
-  (nil    tree-nil)                  ; node marker for missing leaf nodes
-  (root   tree-root set-tree-root!))
-
-(define (make-search-tree = <)
-  (let ((nil (make-node #f #f #f)))
-    (set-node-red?! nil #f)
-    (make-tree (make-lookup = <) nil #f)))
-
-(define-record-type node :node
-  (really-make-node key value parent red? left right)
-  node?
-  (key    node-key    set-node-key!)
-  (value  node-value  set-node-value!)
-  (parent node-parent set-node-parent!)    ; #f in the root node
-  (red?   node-red?   set-node-red?!)      ; for balancing the tree
-  (left   node-left   set-node-left!)      ; left and
-  (right  node-right  set-node-right!))    ;          right subtrees
-
-(define (make-node key value parent)
-  (really-make-node key value parent #t #f #f))
-
-(define-record-discloser :node
-  (lambda (node)
-    (list 'node (node-key node))))
-
-; Lookup up KEY and return its value.
-
-(define (search-tree-ref tree key)
-  (call-with-values
-   (lambda ()
-     ((tree-lookup tree) tree key))
-   (lambda (node parent left?)
-     (if node
-	 (node-value node)
-	 #f))))
-
-; Adding and modifying entries.
-
-(define (search-tree-set! tree key value)
-  (search-tree-modify! tree key (lambda (ignore) value)))
-
-(define (search-tree-modify! tree key proc)
-  (call-with-values
-   (lambda ()
-     ((tree-lookup tree) tree key))
-   (lambda (node parent left?)
-     (let ((new-value (proc (if node (node-value node) #f))))
-       (cond ((and node new-value)
-	      (set-node-value! node new-value))
-	     (new-value
-	      (really-insert! tree parent left? (make-node key new-value parent)))
-	     (node
-	      (really-delete! tree node)))))))
-  
-; Min and max entries.
-
-(define (search-tree-max tree)
-  (real-search-tree-max tree #f))
-
-(define (pop-search-tree-max! tree)
-  (real-search-tree-max tree #t))
-
-(define (real-search-tree-max tree delete?)
-  (let ((node (tree-root tree)))
-    (if node
-	(let loop ((node node))
-	  (cond ((node-right node)
-		 => loop)
-		(else
-		 (if delete?
-		     (really-delete! tree node))
-		 (values (node-key node) (node-value node)))))
-	(values #f #f))))
-
-(define (search-tree-min tree)
-  (real-search-tree-min tree #f))
-
-(define (pop-search-tree-min! tree)
-  (real-search-tree-min tree #t))
-
-(define (real-search-tree-min tree delete?)
-  (let ((node (tree-root tree)))
-    (if node
-	(let loop ((node node))
-	  (cond ((node-left node)
-		 => loop)
-		(else
-		 (if delete?
-		     (really-delete! tree node))
-		 (values (node-key node) (node-value node)))))
-	(values #f #f))))
-
-(define (walk-search-tree proc tree)
-  (let recur ((node (tree-root tree)))
-    (cond (node
-	   (recur (node-left node))
-	   (proc (node-key node) (node-value node))
-	   (recur (node-right node))))))
-
-; Lookup up an entry.  Easy.
-;
-; Hack of checking common case reduced lookup time in a 1000 element search
-; tree by a third.
-
-(define (make-lookup tree-= tree-<)
-  (if (and (eq? tree-= =)
-	   (eq? tree-< <))
-      default-lookup
-      (lambda (tree key)
-	(let loop ((node (tree-root tree))
-		   (parent #f)
-		   (left? #f))
-	  (cond ((not node)
-		 (values #f parent left?))
-		((tree-= (node-key node) key)
-		 (values node #f #f))
-		((tree-< key (node-key node))
-		 (loop (node-left node) node #t))
-		(else
-		 (loop (node-right node) node #f)))))))
-
-(define (default-lookup tree key)
-  (let loop ((node (tree-root tree))
-	     (parent #f)
-	     (left? #f))
-    (cond ((not node)
-	   (values #f parent left?))
-	  ((= (node-key node) key)
-	   (values node #f #f))
-	  ((< key (node-key node))
-	   (loop (node-left node) node #t))
-	  (else
-	   (loop (node-right node) node #f)))))
-
-;----------------------------------------------------------------
-; Little utilities.
-
-; Parameterized node access
-
-(define (node-child node left?)
-  (if left?
-      (node-left node)
-      (node-right node)))
-
-(define (set-node-child! node left? child)
-  (if left?
-      (set-node-left! node child)
-      (set-node-right! node child)))
-
-; Empty leaf slots are considered black.
-
-(define (node-black? node)
-  (not (and node (node-red? node))))
-
-; The next node (used in REALLY-DELETE!)
-
-(define (successor node)
-  (cond ((node-right node)
-	 => (lambda (node)
-	      (let loop ((node node))
-		(cond ((node-left node)
-		       => loop)
-		      (else node)))))
-	(else
-	 (let loop ((node node) (parent (node-parent node)))
-	   (if (and parent
-		    (eq? node (node-right parent)))
-	       (loop parent (node-parent parent))
-	       parent)))))
-
-;----------------------------------------------------------------
-; Add NODE as the LEFT? child of PARENT and balance the tree.
-
-(define (really-insert! tree parent left? node)
-  (if (not parent)
-      (set-tree-root! tree node)
-      (set-node-child! parent left? node))
-  (fixup-insertion! node tree))
-
-; Balance the tree after NODE has been inserted.
-
-(define (fixup-insertion! node tree)
-  (let loop ((node node))
-    (let ((parent (node-parent node)))
-      (if (and parent (node-red? parent))
-	  (let* ((grand (node-parent parent))
-		 (left? (eq? parent (node-left grand)))
-		 (y (node-child grand (not left?))))
-	    (cond ((node-black? y)
-		   (let* ((node (cond ((eq? node (node-child parent (not left?)))
-				       (rotate! parent left? tree)
-				       parent)
-				      (else node)))
-			  (parent (node-parent node))
-			  (grand (node-parent parent)))
-		     (set-node-red?! parent #f)
-		     (set-node-red?! grand  #t)
-		     (rotate! grand (not left?) tree)
-		     (loop node)))
-		  (else
-		   (set-node-red?! parent #f)
-		   (set-node-red?! y      #f)
-		   (set-node-red?! grand  #t)
-		   (loop grand)))))))
-  (set-node-red?! (tree-root tree) #f))
-
-;        A                                 B
-;       / \    =(rotate! A #f tree)=>     / \
-;      B   k                             i   A
-;     / \      <=(rotate! B #t tree)=       / \
-;    i   j                                 j   k
-
-(define (rotate! node left? tree)
-  (let* ((y (node-child node (not left?)))
-	 (y-left (node-child y left?))
-	 (parent (node-parent node)))
-    (set-node-child! node (not left?) y-left)
-    (if y-left
-	(set-node-parent! y-left node))
-    (replace! parent y node tree)
-    (set-node-child! y left? node)
-    (set-node-parent! node y)))
-		
-; Replace CHILD (of PARENT) with NEW-CHILD
-
-(define (replace! parent new-child child tree)
-    (set-node-parent! new-child parent)
-    (cond ((eq? child (tree-root tree))
-	   (set-tree-root! tree new-child))
-	  ((eq? child (node-left parent))
-	   (set-node-left! parent new-child))
-	  (else
-	   (set-node-right! parent new-child))))
-
-; Remove NODE from tree.
-
-(define (really-delete! tree node)
-  (let* ((y (cond ((or (not (node-left node))
-		       (not (node-right node)))
-		   node)
-		  (else
-		   (let ((y (successor node)))
-		     (set-node-key!   node (node-key y))
-		     (set-node-value! node (node-value y))
-		     y))))
-	 (x (or (node-left y)
-		(node-right y)
-		(let ((x (tree-nil tree)))
-		  (set-node-right! y x)
-		  x)))
-	 (parent (node-parent y)))
-    (replace! parent x y tree)
-    (if (not (node-red? y))
-	(fixup-delete! x tree))
-    (let ((nil (tree-nil tree)))
-      (cond ((node-parent nil)
-	     => (lambda (p)
-		  (if (eq? (node-right p) nil)
-		      (set-node-right! p #f)
-		      (set-node-left! p #f))
-		  (set-node-parent! (tree-nil tree) #f)))
-	    ((eq? nil (tree-root tree))
-	     (set-tree-root! tree #f))))))
-
-(define (fixup-delete! x tree)
-  (let loop ((x x))
-    (if (or (eq? x (tree-root tree))
-	    (node-red? x))
-	(set-node-red?! x #f)
-	(let* ((parent (node-parent x))
-	       (left? (eq? x (node-left parent)))
-	       (w (node-child parent (not left?)))
-	       (w (cond ((node-red? w)
-			 (set-node-red?! w #f)
-			 (set-node-red?! parent #t)
-			 (rotate! parent left? tree)
-			 (node-child (node-parent x) (not left?)))
-			(else
-			 w))))
-	  (cond ((and (node-black? (node-left w))
-		      (node-black? (node-right w)))
-		 (set-node-red?! w #t)
-		 (loop (node-parent x)))
-		(else
-		 (let ((w (cond ((node-black? (node-child w (not left?)))
-				 (set-node-red?! (node-child w left?) #f)
-				 (set-node-red?! w #t)
-				 (rotate! w (not left?) tree)
-				 (node-child (node-parent x) (not left?)))
-				(else
-				 w))))
-		   (let ((parent (node-parent x)))
-		     (set-node-red?! w (node-red? parent))
-		     (set-node-red?! parent #f)
-		     (set-node-red?! (node-child w (not left?)) #f)
-		     (rotate! parent left? tree)
-		     (set-node-red?! (tree-root tree) #f)))))))))
-		 
-; Verify that the coloring is correct
-;
-;(define (okay-tree? tree)
-;  (receive (okay? red? count)
-;      (let recur ((node (tree-root tree)))
-;        (if (not node)
-;            (values #t #f 0)
-;            (receive (l-ok? l-r? l-c)
-;                (recur (node-left node))
-;              (receive (r-ok? r-r? r-c)
-;                  (recur (node-right node))
-;                (values (and l-ok?
-;                             r-ok?
-;                             (not (and (node-red? node)
-;                                       (or l-r? r-r?)))
-;                             (= l-c r-c))
-;                        (node-red? node)
-;                        (if (node-red? node)
-;                            l-c
-;                            (+ l-c 1)))))))
-;    okay?))
-;
-;
-;(define (walk-sequences proc list)
-;  (let recur ((list list) (r '()))
-;    (if (null? list)
-;        (proc (reverse r))
-;        (let loop ((list list) (done '()))
-;          (if (not (null? list))
-;              (let ((next (car list)))
-;                (recur (append (reverse done) (cdr list)) (cons next r))
-;                (loop (cdr list) (cons next done))))))))
-;           
-;(define (tree-test n)
-;  (let ((iota (do ((i n (- i 1))
-;                   (l '() (cons i l)))
-;                  ((<= i 0) l))))
-;    (walk-sequences (lambda (in)
-;                      (walk-sequences (lambda (out)
-;                                        (do-tree-test in out))
-;                                      iota))
-;                    iota)
-;    #t))
-;
-;(define (do-tree-test in out)
-;  (let ((tree (make-search-tree = <)))
-;    (for-each (lambda (i)
-;                (search-tree-set! tree i (- 0 i)))
-;              in)
-;    (if (not (okay-tree? tree))
-;        (breakpoint "tree ~S is not okay" in))
-;    (if (not (tree-ordered? tree (length in)))
-;        (breakpoint "tree ~S is not ordered" in))
-;    (for-each (lambda (i)
-;                (if (not (= (search-tree-ref tree i) (- 0 i)))
-;                    (breakpoint "looking up ~S in ~S lost" i in)))
-;              in)
-;    (do ((o out (cdr o)))
-;        ((null? o))
-;      (search-tree-set! tree (car o) #f)
-;      (if (not (okay-tree? tree))
-;          (breakpoint "tree ~S is not okay after deletions ~S" in out)))))
-;
-;(define (tree-ordered? tree count)
-;  (let ((l '()))
-;    (walk-search-tree (lambda (key value)
-;                        (set! l (cons (cons key value) l)))
-;                      tree)
-;    (let loop ((l l) (n count))
-;      (cond ((null? l)
-;             (= n 0))
-;            ((and (= (caar l) n)
-;                  (= (cdar l) (- 0 n)))
-;             (loop (cdr l) (- n 1)))
-;            (else #f)))))
-;
-;(define (do-tests tester)
-;  (do ((i 0 (+ i 1)))
-;      (#f)
-;    (tester i)
-;    (format #t " done with ~D~%" i)))
-;
-;(define (another-test n)
-;  (let ((iota (do ((i n (- i 1))
-;                   (l '() (cons i l)))
-;                  ((<= i 0) l))))
-;    (walk-sequences (lambda (in)
-;                      (do ((i 1 (+ i 1)))
-;                          ((> i n))
-;                        (let ((tree (make-search-tree = <)))
-;                          (for-each (lambda (i)
-;                                      (search-tree-set! tree i (- 0 i)))
-;                                    in)
-;                          (if (not (okay-tree? tree))
-;                              (breakpoint "tree ~S is not okay" in))
-;                          (if (not (tree-ordered? tree (length in)))
-;                              (breakpoint "tree ~S is not ordered" in))
-;                          (for-each (lambda (i)
-;                                      (if (not (= (search-tree-ref tree i) (- 0 i)))
-;                                          (breakpoint "looking up ~S in ~S lost" i in)))
-;                                    in)
-;                          (search-tree-set! tree i #f)
-;                          (if (not (okay-tree? tree))
-;                              (breakpoint "tree ~S is not okay after deletion ~S"
-;                                          in i))
-;                          (for-each (lambda (j)
-;                                      (let ((ref (search-tree-ref tree j)))
-;                                        (if (not (eq? ref (if (= j i) #f (- 0 j))))
-;                                            (breakpoint "looking up ~S in ~S lost" i in))))
-;                                    in))))
-;                    iota)))
diff --git a/scheme/big/socket.scm b/scheme/big/socket.scm
deleted file mode 100644
index 1c1abda..0000000
--- a/scheme/big/socket.scm
+++ /dev/null
@@ -1,117 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Server interface
-;   (open-socket [socket-number]) -> socket
-;   (close-socket socket)
-;   (socket-accept socket) -> [input-port output-port]
-;   (get-host-name) -> string
-;   (socket-port-number socket) -> integer
-
-; Client interface
-;   (socket-client host-name socket-number) -> [input-port output-port]
-
-; Old calls I would like to get rid off.
-;   (socket-listen socket) -> [input-port output-port]
-;   (socket-listen-channels socket) -> [input-channel output-channel]
-;   (socket-client-channels host-name socket-number) -> [input-channels output-channels]
-
-;--------------------
-; Socket type
-;
-; A socket has a channel (for accepting connections) and a port number.
-; These are only used for servers; clients don't need them.
-
-(define-record-type socket :socket
-  (make-socket channel port-number)
-  socket?
-  (channel socket-channel)
-  (port-number socket-port-number))
-
-(define-record-discloser :socket
-  (lambda (s) `(socket ,(socket-port-number s))))
-
-(define (close-socket socket)
-  (close-channel (socket-channel socket)))
-
-; Makes a server socket.
-
-(define (open-socket . maybe-number)
-  (let ((channel (new-socket #t)))
-    (bind-socket channel (if (or (null? maybe-number)
-				 (= (car maybe-number) 0))  ; old, crappy spec
-			     #f
-			     (car maybe-number)))
-    (real-socket-listen channel)
-    (make-socket channel (socket-number channel))))
-
-(define (socket-accept socket)
-  (call-with-values
-   (lambda ()
-     (socket-listen-channels socket))
-   (lambda (in out)
-     (values (input-channel+closer->port in close-socket-input-channel)
-	     (output-channel+closer->port out close-socket-output-channel)))))
-  
-(define socket-listen socket-accept)
-
-(define (socket-listen-channels socket)
-  (let ((channel (socket-channel socket)))
-    (let loop ()
-      (disable-interrupts!)
-      (let ((channels (real-socket-accept channel)))
-	(cond (channels
-	       (enable-interrupts!)
-	       (values (car channels)
-		       (cdr channels)))
-	      (else
-	       (wait-for-channel channel)		; enables interrupts
-	       (loop)))))))
-
-; Connect to the socket and return input and output ports.
-
-(define (socket-client host-name port-number)
-  (call-with-values
-   (lambda ()
-     (socket-client-channels host-name port-number))
-   (lambda (in out)
-     (values (input-channel+closer->port in close-socket-input-channel)
-	     (output-channel+closer->port out close-socket-output-channel)))))
-
-(define (socket-client-channels host-name port-number)
-  (let ((channel (new-socket #f)))
-    (let loop ()
-      (disable-interrupts!)
-      (let ((output-channel (real-socket-connect channel host-name port-number)))
-	(cond ((channel? output-channel)
-	       (enable-interrupts!)
-	       (values channel output-channel))
-	      ; This should never happen.
-	      ((eq? output-channel #t)
-	       (error "client socket already connected" host-name port-number))
-	      (else
-	       (wait-for-channel channel) ; enables interrupts
-	       (loop)))))))
-
-; We need to explicitly close the channel.
-
-(define (close-socket-input-channel channel)
-  (close-socket-half channel #t)
-  (close-channel channel))
-
-(define (close-socket-output-channel channel)
-  (close-socket-half channel #f)
-  (close-channel channel))
-
-; The C calls we use.  These are in c/unix/socket.c.
-
-(import-lambda-definition new-socket (server?) "s48_socket")
-(import-lambda-definition bind-socket (socket number) "s48_bind")
-(import-lambda-definition socket-number (socket) "s48_socket_number")
-(import-lambda-definition real-socket-listen (socket) "s48_listen")
-(import-lambda-definition real-socket-accept (socket) "s48_accept")
-(import-lambda-definition real-socket-connect (socket machine port-number)
-			  "s48_connect")
-(import-lambda-definition close-socket-half (socket input?)
-			  "s48_close_socket_half")
-(import-lambda-definition get-host-name () "s48_get_host_name")
diff --git a/scheme/big/strong.scm b/scheme/big/strong.scm
deleted file mode 100644
index 838ccf6..0000000
--- a/scheme/big/strong.scm
+++ /dev/null
@@ -1,152 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Code to find the strongly connected components of a graph.
-; (TO <vertex>) are the vertices that have an edge to <vertex>.
-; (SLOT <vertex>) and (SET-SLOT! <vertex> <value>) is a settable slot
-; used by the algorithm.
-;
-; The components are returned in a backwards topologically sorted list.
-
-(define (strongly-connected-components vertices to slot set-slot!)
-  (make-vertices vertices to slot set-slot!)
-  (let loop ((to-do vertices) (index 0) (stack #t) (comps '()))
-    (let ((to-do (find-next-vertex to-do slot)))
-      (cond ((null? to-do)
-	     (for-each (lambda (n) (set-slot! n #f)) vertices)
-	     comps)
-	    (else
-	     (call-with-values
-	      (lambda () 
-		(do-vertex (slot (car to-do)) index stack comps))
-	      (lambda (index stack comps)
-		(loop to-do index stack comps))))))))
-
-(define (find-next-vertex vertices slot)
-  (do ((vertices vertices (cdr vertices)))
-      ((or (null? vertices)
-           (= 0 (vertex-index (slot (car vertices)))))
-       vertices)))
-  
-(define-record-type vertex :vertex
-  (really-make-vertex data edges stack index parent lowpoint)
-  vertex?
-  (data vertex-data)    ; user's data
-  (edges vertex-edges set-vertex-edges!)    ; list of vertices
-  (stack vertex-stack set-vertex-stack!)    ; next vertex on the stack
-  (index vertex-index set-vertex-index!)    ; time at which this vertex was
-                                            ; reached in the traversal
-  (parent vertex-parent set-vertex-parent!) ; a vertex pointing to this one
-  (lowpoint vertex-lowpoint set-vertex-lowpoint!)) ; lowest index in this
-                                     ; vertices strongly connected component
-
-(define (make-vertex data)
-  (really-make-vertex data '() #f 0 #f #f))
-
-(define (make-vertices vertices to slot set-slot!)
-  (let ((maybe-slot (lambda (n)
-		      (let ((s (slot n)))
-			(if (vertex? s)
-			    s
-			    (error "graph edge points to non-vertex" n))))))
-    (for-each (lambda (n)
-		(set-slot! n (make-vertex n)))
-	      vertices)
-    (for-each (lambda (n)
-		(set-vertex-edges! (slot n) (map maybe-slot (to n))))
-	      vertices)
-    (values)))
-
-; The numbers are the algorithm step numbers from page 65 of Graph Algorithms,
-; Shimon Even, Computer Science Press, 1979.
-
-; 2
-
-(define (do-vertex vertex index stack comps)
-  (let ((index (+ index '1)))
-    (set-vertex-index!    vertex index)
-    (set-vertex-lowpoint! vertex index)
-    (set-vertex-stack!    vertex stack)
-    (get-strong vertex index vertex comps)))
-
-; 3
-
-(define (get-strong vertex index stack comps)
-  (if (null? (vertex-edges vertex))
-      (end-vertex    vertex index stack comps)
-      (follow-edge vertex index stack comps)))
-
-; 7
-
-(define (end-vertex vertex index stack comps)
-  (call-with-values
-   (lambda ()
-     (if (= (vertex-index vertex) (vertex-lowpoint vertex))
-	 (unwind-stack vertex stack comps)
-	 (values stack comps)))
-   (lambda (stack comps)
-     (cond ((vertex-parent vertex)
-	    => (lambda (parent)
-		 (if (> (vertex-lowpoint parent) (vertex-lowpoint vertex))
-		     (set-vertex-lowpoint! parent (vertex-lowpoint vertex)))
-		 (get-strong parent index stack comps)))
-	   (else
-	    (values index stack comps))))))
-
-(define (unwind-stack vertex stack comps)
-  (let loop ((n stack) (c '()))
-    (let ((next (vertex-stack n))
-          (c (cons (vertex-data n) c)))
-      (set-vertex-stack! n #f)
-      (if (eq? n vertex)
-          (values next (cons c comps))
-          (loop next c)))))
-
-; 4
-
-(define (follow-edge vertex index stack comps)
-  (let* ((next (pop-vertex-edge! vertex))
-         (next-index (vertex-index next)))
-    (cond ((= next-index 0)
-           (set-vertex-parent! next vertex)
-           (do-vertex next index stack comps))
-          (else
-           (if (and (< next-index (vertex-index vertex))
-                    (vertex-stack next)
-                    (< next-index (vertex-lowpoint vertex)))
-               (set-vertex-lowpoint! vertex next-index))
-           (get-strong vertex index stack comps)))))
-
-(define (pop-vertex-edge! vertex)
-  (let ((edges (vertex-edges vertex)))
-    (set-vertex-edges! vertex (cdr edges))
-    (car edges)))
-
-; GRAPH is ((<symbol> . <symbol>*)*)
-             
-;(define (test-strong graph)
-;  (let ((vertices (map (lambda (n)
-;                         (vector (car n) #f #f))
-;                       graph)))
-;    (for-each (lambda (data vertex)
-;                (vector-set! vertex 1 (map (lambda (s)
-;                                             (first (lambda (v)
-;                                                      (eq? s (vector-ref v 0)))
-;                                                    vertices))
-;                                           (cdr data))))
-;              graph
-;              vertices)
-;    (map (lambda (l)
-;           (map (lambda (n) (vector-ref n 0)) l))
-;         (strongly-connected-components vertices
-;                                        (lambda (v) (vector-ref v 1))
-;                                        (lambda (v) (vector-ref v 2))
-;                                        (lambda (v val)
-;                                          (vector-set! v 2 val))))))
-
-
-
-
-
-
-
diff --git a/scheme/debug-packages.scm b/scheme/debug-packages.scm
deleted file mode 100644
index de88de2..0000000
--- a/scheme/debug-packages.scm
+++ /dev/null
@@ -1,133 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Handy things for debugging the run-time system, byte code compiler,
-; and linker.
-
-
-; Alternative command processor.  Handy for debugging the bigger one.
-
-(define (make-mini-command scheme)
-  (define-structure mini-command (export command-processor)
-    (open scheme
-	  signals conditions handle
-	  display-conditions
-	  i/o)   ; current-error-port
-    (files (debug mini-command)))
-  mini-command)
-
-; Miniature EVAL, for debugging runtime system sans package system.
-
-(define-structures ((mini-eval evaluation-interface)
-		    (mini-environments
-		     (export interaction-environment
-			     scheme-report-environment
-			     set-interaction-environment!
-			     set-scheme-report-environment!)))
-  (open scheme-level-2
-	signals)		;error
-  (files (debug mini-eval)))
-
-(define (make-scheme environments evaluation) ;cf. initial-packages.scm
-  (define-structure scheme scheme-interface
-    (open scheme-level-2
-	  environments
-	  evaluation))
-  scheme)
-
-; Stand-alone system that doesn't contain a byte-code compiler.
-; This is useful for various testing purposes.
-
-(define mini-scheme (make-scheme mini-environments mini-eval))
-
-(define mini-command (make-mini-command mini-scheme))
-
-(define-structure little-system (export start)
-  (open scheme-level-1
-	mini-command
-	usual-resumer)
-  (begin (define start
-	   (usual-resumer
-	    (lambda (args) (command-processor #f args))))))
-
-(define (link-little-system)
-  (link-simple-system '(scheme/debug little)
-		      'start
-		      little-system))
-
-
-
-; --------------------
-; Hack: smallest possible reified system.
-
-(define-structures ((mini-for-reification for-reification-interface)
-		    (mini-packages (export make-simple-package)))
-  (open scheme-level-2
-	features		;contents
-	locations
-	signals)		;error
-  (files (debug mini-package)))
-
-(define-structure mini-system (export start)
-  (open mini-scheme
-	mini-command
-	mini-for-reification
-	mini-packages
-	mini-environments		;set-interaction-environment!
-        usual-resumer
-	conditions handle		;error? with-handler
-	signals)			;error
-  (files (debug mini-start)))
-
-(define (link-mini-system)
-  (link-reified-system (list (cons 'scheme mini-scheme)
-			     (cons 'write-images write-images)
-			     (cons 'primitives primitives) ;just for fun
-			     (cons 'usual-resumer usual-resumer)
-			     (cons 'command mini-command))
-		       '(scheme/debug mini)
-		       'start
-		       mini-system mini-for-reification))
-
-
-
-; --------------------
-; S-expression (nodes, really) interpreter
-
-(define-structure run evaluation-interface
-  (open scheme-level-2
-	packages        	;package-uid package->environment link!
-	compiler-envs		;bind-source-filename
-	reading-forms		;read-forms $note-file-package
-	syntactic		;scan-forms expand-forms
-	signals
-	fluids)
-  (files (debug run)))
-
-
-; Hack: an interpreter-based system.
-
-(define (link-medium-system)		;cf. initial.scm
-
-  (def medium-scheme (make-scheme environments run))
-
-  (let ()
-
-    (def command (make-mini-command medium-scheme))
-
-    (let ()
-
-      (def medium-system
-	;; Cf. initial-packages.scm
-	(make-initial-system medium-scheme command))
-
-      (let ((structs (list (cons 'scheme medium-scheme)
-			   (cons 'primitives primitives) ;just for fun
-			   (cons 'usual-resumer usual-resumer)
-			   (cons 'command command))))
-
-	(link-reified-system structs
-			     '(scheme/debug medium)
-			     `(start ',(map car structs))
-			     medium-system for-reification)))))
-
diff --git a/scheme/debug/bench.scm b/scheme/debug/bench.scm
deleted file mode 100644
index d671780..0000000
--- a/scheme/debug/bench.scm
+++ /dev/null
@@ -1,23 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Tiny benchmarking image.
-
-; This returns the result of calling recursive FIB on its first argument.
-
-(define (start arg in out error)
-  (fib (string->integer (vector-ref arg 0))))
-
-(define (string->integer s)
-  (letrec ((loop (lambda (i r)
-		   (if (= i (string-length s))
-		       r
-		       (loop (+ i 1)
-			     (+ (- (char->ascii (string-ref s i))
-				   (char->ascii #\0))
-				(* 10 r)))))))
-    (loop 0 0)))
-
-(define (fib n)
-  (if (< n 2)
-      1
-      (+ (fib (- n 1)) (fib (- n 2)))))
diff --git a/scheme/debug/byte-code-test.scm b/scheme/debug/byte-code-test.scm
deleted file mode 100644
index c031843..0000000
--- a/scheme/debug/byte-code-test.scm
+++ /dev/null
@@ -1,85 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Test various of the byte-codes
-
-;(let ((system (make-system '("~/s48/x48/boot/byte-code-test.scm") 'resume #f)))
-;  (write-system system "~/s48/x48/boot/byte-code-test.image"))
-
-(define *tests* '())
-(define *output-channel* #f)
-
-(define (make-test . args)
-  (set! *tests* (cons args *tests*)))
-
-(define (run-test string compare result proc)
-  (write-string string *output-channel*)
-  (write-string "..." *output-channel*)
-  (write-string (if (compare (proc) result) "OK" "failed") *output-channel*)
-  (newline *output-channel*))
-
-(make-test "testing test mechanism" (lambda (x y) (eq? x y)) 0 (lambda () 0))
-(make-test "primitive catch and throw" (lambda (x y) (eq? x y)) 10
-	   (lambda ()
-	     (* 10 (primitive-catch (lambda (k)
-				      (my-primitive-throw k 1)
-				      (message "after throw???")
-				      2)))))
-
-
-(define (my-primitive-throw cont value)
-  (with-continuation cont (lambda () value)))
-
-(define (message string)
-  (write-string string *output-channel*)
-  (newline channel))
-
-(define (write-string string channel)
-  (channel-write string
-		 0
-		 (string-length string)
-		 channel))
-
-(define (newline channel)
-  (write-string "
-" channel))
-
-(define (resume arg in out error)
-  (set! *output-channel* out)
-  (do ((tests (do ((tests *tests* (cdr tests))
-		   (r '() (cons (car tests) r)))
-		  ((eq? '() tests) r))
-	      (cdr tests)))
-      ((eq? '() tests))
-    (apply run-test (car tests)))
-  (write-string "done" *output-channel*)
-  (newline *output-channel*)
-  (halt 0))
-
-(define *initial-bindings* '())
-
-(define (initial-env name)
-  (let ((probe (assq name *initial-bindings*)))
-    (if probe (cdr probe) (error "unbound" name))))
-
-(define (define-initial name val)
-  (let* ((probe (assq name *initial-bindings*))
-	 (loc (if probe
-		  (cdr probe)
-		  (let ((loc (make-undefined-location name)))
-		    (set! *initial-bindings*
-			  (cons (cons name loc) *initial-bindings*))
-		    loc))))
-    ;; (set-location-defined?! loc #t)  - obsolescent?
-    (set-contents! loc val)))
-
-(for-each (lambda (name val)
-	    (define-initial name val))
-          '(    cons car cdr + - * < = > list map append reverse)
-	  (list cons car cdr + - * < = > list map append reverse))
-
-(make-test "little env-lookup test" eq? car
-	   (lambda ()
-	     (contents (initial-env 'car))))
-
-(define (error string . stuff) (message string))
diff --git a/scheme/debug/check.scm b/scheme/debug/check.scm
deleted file mode 100644
index 12278e1..0000000
--- a/scheme/debug/check.scm
+++ /dev/null
@@ -1,315 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; The barest skeleton of a test suite.
-; Mostly it makes sure that many of the external packages load without
-; error.
-
-; ,exec ,load debug/check.scm
-; (done)
-
-(load-package 'testing)
-
-(config '(run 
-	  (define-structure bar (export)
-	    (open scheme testing))))
-
-(in 'bar '(bench off))
-(in 'bar '(run (define (foo) (cadr '(a b)))))
-(in 'bar '(run (define cadr list)))
-(in 'bar '(run (test "non-bench" equal? '((a b)) (foo))))
-
-(in 'bar '(bench on))
-(in 'bar '(run (define (foo) (car '(a b)))))
-(in 'bar '(run (define car list)))
-(in 'bar '(run (test "bench" equal? 'a (foo))))
-
-(config '(run
-	  (define-structure test1 (export x)
-	    (open scheme testing)
-	    (begin (define x 10)
-		   (define (z) x)))))
-(config '(run 
-	  (define-structure test2 (export)
-	    (open scheme test1 testing)
-	    (begin (define (z) x)))))
-(config '(run
-	  (define-structure test3 (export)
-	    (open scheme test1 testing)
-	    (begin (define (z) x)))))
-(load-package 'test2)
-(load-package 'test3)
-(in 'test3 '(run (define x 20)))
-(in 'test3 '(open test2))
-(in 'test2 '(run (test "shadowing" = 10 (z))))
-(in 'test3 '(run (test "shadowing" = 20 (z))))
-(in 'test1 '(run (test "shadowing" = 10 (z))))
-
-(config '(run 
-(define-structure foo (export)
-  (open scheme testing
-	assembler
-	code-vectors
-	ports
-	queues
-	random
-	sort
-	big-scheme
-	arrays
-	dump/restore
-	search-trees
-	threads
-	placeholders
-	locks
-	interrupts
-	sockets
-	sicp)
-  (begin
-
-(test "1000 args"
-      equal?
-      '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 
-	100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 
-	200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 
-	300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 
-	400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 
-	500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 
-	600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 
-	700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 
-	800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 
-	900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 
-	)
-      (let ((f (lambda (x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40 x41 x42 x43 x44 x45 x46 x47 x48 x49 x50 x51 x52 x53 x54 x55 x56 x57 x58 x59 x60 x61 x62 x63 x64 x65 x66 x67 x68 x69 x70 x71 x72 x73 x74 x75 x76 x77 x78 x79 x80 x81 x82 x83 x84 x85 x86 x87 x88 x89 x90 x91 x92 x93 x94 x95 x96 x97 x98 x99 
-			x100 x101 x102 x103 x104 x105 x106 x107 x108 x109 x110 x111 x112 x113 x114 x115 x116 x117 x118 x119 x120 x121 x122 x123 x124 x125 x126 x127 x128 x129 x130 x131 x132 x133 x134 x135 x136 x137 x138 x139 x140 x141 x142 x143 x144 x145 x146 x147 x148 x149 x150 x151 x152 x153 x154 x155 x156 x157 x158 x159 x160 x161 x162 x163 x164 x165 x166 x167 x168 x169 x170 x171 x172 x173 x174 x175 x176 x177 x178 x179 x180 x181 x182 x183 x184 x185 x186 x187 x188 x189 x190 x191 x192 x193 x194 x195 x196 x197 x198 x199 
-			x200 x201 x202 x203 x204 x205 x206 x207 x208 x209 x210 x211 x212 x213 x214 x215 x216 x217 x218 x219 x220 x221 x222 x223 x224 x225 x226 x227 x228 x229 x230 x231 x232 x233 x234 x235 x236 x237 x238 x239 x240 x241 x242 x243 x244 x245 x246 x247 x248 x249 x250 x251 x252 x253 x254 x255 x256 x257 x258 x259 x260 x261 x262 x263 x264 x265 x266 x267 x268 x269 x270 x271 x272 x273 x274 x275 x276 x277 x278 x279 x280 x281 x282 x283 x284 x285 x286 x287 x288 x289 x290 x291 x292 x293 x294 x295 x296 x297 x298 x299 
-			x300 x301 x302 x303 x304 x305 x306 x307 x308 x309 x310 x311 x312 x313 x314 x315 x316 x317 x318 x319 x320 x321 x322 x323 x324 x325 x326 x327 x328 x329 x330 x331 x332 x333 x334 x335 x336 x337 x338 x339 x340 x341 x342 x343 x344 x345 x346 x347 x348 x349 x350 x351 x352 x353 x354 x355 x356 x357 x358 x359 x360 x361 x362 x363 x364 x365 x366 x367 x368 x369 x370 x371 x372 x373 x374 x375 x376 x377 x378 x379 x380 x381 x382 x383 x384 x385 x386 x387 x388 x389 x390 x391 x392 x393 x394 x395 x396 x397 x398 x399 
-			x400 x401 x402 x403 x404 x405 x406 x407 x408 x409 x410 x411 x412 x413 x414 x415 x416 x417 x418 x419 x420 x421 x422 x423 x424 x425 x426 x427 x428 x429 x430 x431 x432 x433 x434 x435 x436 x437 x438 x439 x440 x441 x442 x443 x444 x445 x446 x447 x448 x449 x450 x451 x452 x453 x454 x455 x456 x457 x458 x459 x460 x461 x462 x463 x464 x465 x466 x467 x468 x469 x470 x471 x472 x473 x474 x475 x476 x477 x478 x479 x480 x481 x482 x483 x484 x485 x486 x487 x488 x489 x490 x491 x492 x493 x494 x495 x496 x497 x498 x499 
-			x500 x501 x502 x503 x504 x505 x506 x507 x508 x509 x510 x511 x512 x513 x514 x515 x516 x517 x518 x519 x520 x521 x522 x523 x524 x525 x526 x527 x528 x529 x530 x531 x532 x533 x534 x535 x536 x537 x538 x539 x540 x541 x542 x543 x544 x545 x546 x547 x548 x549 x550 x551 x552 x553 x554 x555 x556 x557 x558 x559 x560 x561 x562 x563 x564 x565 x566 x567 x568 x569 x570 x571 x572 x573 x574 x575 x576 x577 x578 x579 x580 x581 x582 x583 x584 x585 x586 x587 x588 x589 x590 x591 x592 x593 x594 x595 x596 x597 x598 x599 
-			x600 x601 x602 x603 x604 x605 x606 x607 x608 x609 x610 x611 x612 x613 x614 x615 x616 x617 x618 x619 x620 x621 x622 x623 x624 x625 x626 x627 x628 x629 x630 x631 x632 x633 x634 x635 x636 x637 x638 x639 x640 x641 x642 x643 x644 x645 x646 x647 x648 x649 x650 x651 x652 x653 x654 x655 x656 x657 x658 x659 x660 x661 x662 x663 x664 x665 x666 x667 x668 x669 x670 x671 x672 x673 x674 x675 x676 x677 x678 x679 x680 x681 x682 x683 x684 x685 x686 x687 x688 x689 x690 x691 x692 x693 x694 x695 x696 x697 x698 x699 
-			x700 x701 x702 x703 x704 x705 x706 x707 x708 x709 x710 x711 x712 x713 x714 x715 x716 x717 x718 x719 x720 x721 x722 x723 x724 x725 x726 x727 x728 x729 x730 x731 x732 x733 x734 x735 x736 x737 x738 x739 x740 x741 x742 x743 x744 x745 x746 x747 x748 x749 x750 x751 x752 x753 x754 x755 x756 x757 x758 x759 x760 x761 x762 x763 x764 x765 x766 x767 x768 x769 x770 x771 x772 x773 x774 x775 x776 x777 x778 x779 x780 x781 x782 x783 x784 x785 x786 x787 x788 x789 x790 x791 x792 x793 x794 x795 x796 x797 x798 x799 
-			x800 x801 x802 x803 x804 x805 x806 x807 x808 x809 x810 x811 x812 x813 x814 x815 x816 x817 x818 x819 x820 x821 x822 x823 x824 x825 x826 x827 x828 x829 x830 x831 x832 x833 x834 x835 x836 x837 x838 x839 x840 x841 x842 x843 x844 x845 x846 x847 x848 x849 x850 x851 x852 x853 x854 x855 x856 x857 x858 x859 x860 x861 x862 x863 x864 x865 x866 x867 x868 x869 x870 x871 x872 x873 x874 x875 x876 x877 x878 x879 x880 x881 x882 x883 x884 x885 x886 x887 x888 x889 x890 x891 x892 x893 x894 x895 x896 x897 x898 x899 
-			x900 x901 x902 x903 x904 x905 x906 x907 x908 x909 x910 x911 x912 x913 x914 x915 x916 x917 x918 x919 x920 x921 x922 x923 x924 x925 x926 x927 x928 x929 x930 x931 x932 x933 x934 x935 x936 x937 x938 x939 x940 x941 x942 x943 x944 x945 x946 x947 x948 x949 x950 x951 x952 x953 x954 x955 x956 x957 x958 x959 x960 x961 x962 x963 x964 x965 x966 x967 x968 x969 x970 x971 x972 x973 x974 x975 x976 x977 x978 x979 x980 x981 x982 x983 x984 x985 x986 x987 x988 x989 x990 x991 x992 x993 x994 x995 x996 x997 x998 x999 
-			)
-		 (list x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40 x41 x42 x43 x44 x45 x46 x47 x48 x49 x50 x51 x52 x53 x54 x55 x56 x57 x58 x59 x60 x61 x62 x63 x64 x65 x66 x67 x68 x69 x70 x71 x72 x73 x74 x75 x76 x77 x78 x79 x80 x81 x82 x83 x84 x85 x86 x87 x88 x89 x90 x91 x92 x93 x94 x95 x96 x97 x98 x99 
-		       x100 x101 x102 x103 x104 x105 x106 x107 x108 x109 x110 x111 x112 x113 x114 x115 x116 x117 x118 x119 x120 x121 x122 x123 x124 x125 x126 x127 x128 x129 x130 x131 x132 x133 x134 x135 x136 x137 x138 x139 x140 x141 x142 x143 x144 x145 x146 x147 x148 x149 x150 x151 x152 x153 x154 x155 x156 x157 x158 x159 x160 x161 x162 x163 x164 x165 x166 x167 x168 x169 x170 x171 x172 x173 x174 x175 x176 x177 x178 x179 x180 x181 x182 x183 x184 x185 x186 x187 x188 x189 x190 x191 x192 x193 x194 x195 x196 x197 x198 x199 
-		       x200 x201 x202 x203 x204 x205 x206 x207 x208 x209 x210 x211 x212 x213 x214 x215 x216 x217 x218 x219 x220 x221 x222 x223 x224 x225 x226 x227 x228 x229 x230 x231 x232 x233 x234 x235 x236 x237 x238 x239 x240 x241 x242 x243 x244 x245 x246 x247 x248 x249 x250 x251 x252 x253 x254 x255 x256 x257 x258 x259 x260 x261 x262 x263 x264 x265 x266 x267 x268 x269 x270 x271 x272 x273 x274 x275 x276 x277 x278 x279 x280 x281 x282 x283 x284 x285 x286 x287 x288 x289 x290 x291 x292 x293 x294 x295 x296 x297 x298 x299 
-		       x300 x301 x302 x303 x304 x305 x306 x307 x308 x309 x310 x311 x312 x313 x314 x315 x316 x317 x318 x319 x320 x321 x322 x323 x324 x325 x326 x327 x328 x329 x330 x331 x332 x333 x334 x335 x336 x337 x338 x339 x340 x341 x342 x343 x344 x345 x346 x347 x348 x349 x350 x351 x352 x353 x354 x355 x356 x357 x358 x359 x360 x361 x362 x363 x364 x365 x366 x367 x368 x369 x370 x371 x372 x373 x374 x375 x376 x377 x378 x379 x380 x381 x382 x383 x384 x385 x386 x387 x388 x389 x390 x391 x392 x393 x394 x395 x396 x397 x398 x399 
-		       x400 x401 x402 x403 x404 x405 x406 x407 x408 x409 x410 x411 x412 x413 x414 x415 x416 x417 x418 x419 x420 x421 x422 x423 x424 x425 x426 x427 x428 x429 x430 x431 x432 x433 x434 x435 x436 x437 x438 x439 x440 x441 x442 x443 x444 x445 x446 x447 x448 x449 x450 x451 x452 x453 x454 x455 x456 x457 x458 x459 x460 x461 x462 x463 x464 x465 x466 x467 x468 x469 x470 x471 x472 x473 x474 x475 x476 x477 x478 x479 x480 x481 x482 x483 x484 x485 x486 x487 x488 x489 x490 x491 x492 x493 x494 x495 x496 x497 x498 x499 
-		       x500 x501 x502 x503 x504 x505 x506 x507 x508 x509 x510 x511 x512 x513 x514 x515 x516 x517 x518 x519 x520 x521 x522 x523 x524 x525 x526 x527 x528 x529 x530 x531 x532 x533 x534 x535 x536 x537 x538 x539 x540 x541 x542 x543 x544 x545 x546 x547 x548 x549 x550 x551 x552 x553 x554 x555 x556 x557 x558 x559 x560 x561 x562 x563 x564 x565 x566 x567 x568 x569 x570 x571 x572 x573 x574 x575 x576 x577 x578 x579 x580 x581 x582 x583 x584 x585 x586 x587 x588 x589 x590 x591 x592 x593 x594 x595 x596 x597 x598 x599 
-		       x600 x601 x602 x603 x604 x605 x606 x607 x608 x609 x610 x611 x612 x613 x614 x615 x616 x617 x618 x619 x620 x621 x622 x623 x624 x625 x626 x627 x628 x629 x630 x631 x632 x633 x634 x635 x636 x637 x638 x639 x640 x641 x642 x643 x644 x645 x646 x647 x648 x649 x650 x651 x652 x653 x654 x655 x656 x657 x658 x659 x660 x661 x662 x663 x664 x665 x666 x667 x668 x669 x670 x671 x672 x673 x674 x675 x676 x677 x678 x679 x680 x681 x682 x683 x684 x685 x686 x687 x688 x689 x690 x691 x692 x693 x694 x695 x696 x697 x698 x699 
-		       x700 x701 x702 x703 x704 x705 x706 x707 x708 x709 x710 x711 x712 x713 x714 x715 x716 x717 x718 x719 x720 x721 x722 x723 x724 x725 x726 x727 x728 x729 x730 x731 x732 x733 x734 x735 x736 x737 x738 x739 x740 x741 x742 x743 x744 x745 x746 x747 x748 x749 x750 x751 x752 x753 x754 x755 x756 x757 x758 x759 x760 x761 x762 x763 x764 x765 x766 x767 x768 x769 x770 x771 x772 x773 x774 x775 x776 x777 x778 x779 x780 x781 x782 x783 x784 x785 x786 x787 x788 x789 x790 x791 x792 x793 x794 x795 x796 x797 x798 x799 
-		       x800 x801 x802 x803 x804 x805 x806 x807 x808 x809 x810 x811 x812 x813 x814 x815 x816 x817 x818 x819 x820 x821 x822 x823 x824 x825 x826 x827 x828 x829 x830 x831 x832 x833 x834 x835 x836 x837 x838 x839 x840 x841 x842 x843 x844 x845 x846 x847 x848 x849 x850 x851 x852 x853 x854 x855 x856 x857 x858 x859 x860 x861 x862 x863 x864 x865 x866 x867 x868 x869 x870 x871 x872 x873 x874 x875 x876 x877 x878 x879 x880 x881 x882 x883 x884 x885 x886 x887 x888 x889 x890 x891 x892 x893 x894 x895 x896 x897 x898 x899 
-		       x900 x901 x902 x903 x904 x905 x906 x907 x908 x909 x910 x911 x912 x913 x914 x915 x916 x917 x918 x919 x920 x921 x922 x923 x924 x925 x926 x927 x928 x929 x930 x931 x932 x933 x934 x935 x936 x937 x938 x939 x940 x941 x942 x943 x944 x945 x946 x947 x948 x949 x950 x951 x952 x953 x954 x955 x956 x957 x958 x959 x960 x961 x962 x963 x964 x965 x966 x967 x968 x969 x970 x971 x972 x973 x974 x975 x976 x977 x978 x979 x980 x981 x982 x983 x984 x985 x986 x987 x988 x989 x990 x991 x992 x993 x994 x995 x996 x997 x998 x999 
-		       ))))
-	(f 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 
-	   100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 
-	   200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 
-	   300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 
-	   400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 
-	   500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 
-	   600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 
-	   700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 
-	   800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 
-	   900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 
-	   )))
-
-(test "* 1" = 6 (* 1 2 3))
-(test "* 2" = (* 214760876 10) 2147608760)
-(test "* 3" = (* 47123 46039) 2169495797)
-
-(test "internal define" equal? '(20 20 20 20)
-      (list (let ()
-	      (define a 5)
-	      (define b 15)
-	      (+ a b))
-      
-	    (let ((b 10))
-	      (define (a) b)
-	      (define b 20)
-	      (a))
-
-	    (let ((b 10))
-	      (define b 20)
-	      (define (a) b)
-	      (a))
-
-	    (let ((b 10)
-		  (a (lambda () 20))
-		  (define (lambda args 30)))
-	      (define b 40)
-	      (define (a) b)
-	      (a))))
-
-(define (identity x) x)		; handy for preventing inlining
-
-(let ((port (make-port #f -1 0 #f 0 (make-code-vector 1024 25) 0 1023 #f)))
-  (set-port-index! port 0)
-  (test "read-char0" = 25 (char->ascii (read-char port)))
-  (test "read-char1" = 25 (char->ascii ((identity read-char) port))))
-
-(test "apply" equal? '(1 2 3 4) (apply list 1 2 '(3 4)))
-
-(test "char<->integer" eq? #\a (integer->char (char->integer #\a)))
-
-(test "number->string" equal?
-      '("12" "14" "-12" "-14")
-      (list (number->string 12)
-	    (number->string 12 8)
-	    (number->string -12)
-	    (number->string -12 8)))
-
-(test "string->number" equal?
-      '(12 10 -12 -10)
-      (list (string->number "12")
-	    (string->number "12" 8)
-	    (string->number "-12")
-	    (string->number "-12" 8)))
-
-(test "lap" equal? #f ((lap #f () (protocol 0) (false) (return))))
-(let ((q (make-queue)))
-  (enqueue! q 'a)
-  (test "q" eq? 'a (dequeue! q)))
-
-(test "random" <= 0 ((make-random 7)))
-
-(test "sort" equal? '(1 2 3 3) (sort-list '(2 3 1 3) <))
-
-(test "bigbit" = (expt 2 100) (arithmetic-shift 1 100))
-
-(test "format" string=? "x(1 2)" (format #f "x~s" '(1 2)))
-
-(test "fancy input ports" equal? '(3 5)
-      (let ((p1 (make-tracking-input-port (make-string-input-port "
-
-
-    2 3"))))
-	(read p1)
-	(list (current-row p1) (current-column p1))))
-
-(test "fancy output ports" equal? '(1 4 "8
-   9")
-      (let* ((r 0)
-	     (c 0)
-	     (s (call-with-string-output-port
-		 (lambda (out)
-		   (let ((out (make-tracking-output-port out)))
-		     (write 8 out)
-		     (fresh-line out)
-		     (fresh-line out)
-		     (display "   9" out)
-		     (set! r (current-row out))
-		     (set! c (current-column out))
-		     (close-output-port out))))))
-	(list r c s)))
-
-(test "write-one-line" string=? "(1 2 3 4 5"
-      (call-with-string-output-port
-       (lambda (out)
-	 (write-one-line out
-			 10
-			 (lambda (out)
-			   (display '(1 2 3 4 5 6) out))))))
-
-(test "destructure" eq? 'a (destructure (((x (y) z) '(b (a) c))) y))
-
-(test "array" eq? 'a
-      (let ((a (make-array 'b 3 4)))
-	(array-set! a 'a 1 2)
-	(array-ref a 1 2)))
-
-(test "R4RS delay" = 3 (letrec ((p (delay (if c 3 (begin (set! c #t)
-							 (+ (force p) 1)))))
-				(c #f))
-			 (force p)))
-
-(test "receive" equal? '(a b) (receive stuff (values 'a 'b) stuff))
-(let ((z '(a "b" 3 #t)))
-  (test "dump" equal? z
-	(let ((q (make-queue)))
-	  (dump z (lambda (c) (enqueue! q c)) -1)
-	  (restore (lambda () (dequeue! q))))))
-(let ((r 0)
-      (l1 (make-lock))
-      (l2 (make-lock))
-      (ph (make-placeholder)))
-  (let ((f (lambda (i lock)
-	     (spawn (lambda ()
-		      (let ((v (placeholder-value ph)))
-			(with-interrupts-inhibited
-			 (lambda ()
-			   (set! r (+ i v r))))
-			(release-lock lock)))))))
-    (obtain-lock l1)
-    (obtain-lock l2)
-    (f 1 l1)
-    (f 2 l2)
-    (placeholder-set! ph 10)
-    (obtain-lock l1)
-    (obtain-lock l2)
-    (test "placeholders" = r 23)))
-
-(test "explode" equal? 'ab3 (implode (explode 'ab3)))
-
-(test "get/put" equal? 'a (begin (put 'foo 'prop 'a)
-				 (get 'foo 'prop)))
-
-(test "search-trees" eq? 'a
-      (let ((t (make-search-tree = <)))
-	(search-tree-set! t 3 'b)
-	(search-tree-set! t 4 'a)
-	(search-tree-set! t 5 'c)
-	(search-tree-ref t 4)))
-
-(test "sockets" equal? '(303 202 101)
-      (let ((server (open-socket))
-	    (name (get-host-name)))
-	(spawn (lambda ()
-		 (let loop ((i 100))
-		   (if (= i 400)
-		       (close-socket server)
-		       (call-with-values (lambda ()
-					   (socket-accept server))
-					 (lambda (in out)
-					   (spawn (lambda ()
-						    (write (+ i (read in)) out)
-						    (write-char #\space out)
-						    (close-input-port in)
-						    (close-output-port out)))
-					   (loop (+ i 100))))))))
-	(let loop ((i 1) (result '()))
-	  (if (= i 4)
-	      result
-	      (call-with-values
-	       (lambda ()
-		 (socket-client name (socket-port-number server)))
-	       (lambda (in out)
-		 (write i out)
-		 (write-char #\space out)
-		 (let ((result (cons (read in) result)))
-		   (close-input-port in)
-		   (close-output-port out)
-		   (loop (+ i 1) result))))))))
-
-))))
-
-(load-package 'foo)
-
-(load-package 'floatnums)
-
-(in 'foo '(run (let* ((one (exact->inexact 1))
-		      (three (exact->inexact 3))
-		      (third (/ one three))
-		      (xthird (inexact->exact third)))
-		 (test "float" eq? #f (= 1/3 xthird))
-		 (test "exact<->inexact" = third (exact->inexact xthird)))))
-
-
-; All done.
-
-(if (in 'testing '(run (lost?)))
-    (display "Some tests failed.")
-    (display "All tests succeeded."))
-(newline)
-
-(define (done)
-  (exit (if (in 'testing '(run (lost?))) 1 0)))
diff --git a/scheme/debug/describe.scm b/scheme/debug/describe.scm
deleted file mode 100644
index 66e0c64..0000000
--- a/scheme/debug/describe.scm
+++ /dev/null
@@ -1,41 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-(define (describe x)
-  (if (and (stob? x)
-	   (< (stob-type x) least-b-vector-type))
-      (let ((tag (string-append (number->string x) ": "))
-	    (len (bytes->cells (stob-length-in-bytes x))))
-	(do ((i -1 (+ i 1)))
-	    ((= i len))
-	  (describe-1 (stob-ref x i) tag)))
-      (describe-1 x "")))
-
-
-
-(define (describe-1 x addr)
-  (cond ((fixnum? x) (display " fixnum ") (write (extract-fixnum x)))
-	((header? x)
-	 (display addr)
-	 (if (immutable-header? x)
-	     (display " immutable"))
-	 (display " header ")
-	 (let ((type (header-type x)))
-	   (if (< type stob-count)
-	       (write (vector-ref stob type))
-	       (write type)))
-	 (display " ")
-	 (write (header-length-in-bytes x)))
-	((immediate? x)
-	 (cond (else
-		(display " immediate ")
-		(let ((type (immediate-type x)))
-		  (if (< type imm-count)
-		      (write (vector-ref imm type))
-		      (write type)))
-		(display " ")
-		(write (immediate-info x)))))
-	((stob? x)
-	 (display " stob ") (write x))
-	(else (display " ? ") (write x)))
-  (newline))
diff --git a/scheme/debug/fact.scm b/scheme/debug/fact.scm
deleted file mode 100644
index 2b12ea0..0000000
--- a/scheme/debug/fact.scm
+++ /dev/null
@@ -1,9 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; don't copyright this, silly shell script
-
-
-(define (fact n)
-  (if (= n 0)
-      1
-      (* n (fact (- n 1)))))
diff --git a/scheme/debug/fix-low.scm b/scheme/debug/fix-low.scm
deleted file mode 100644
index 6fe9376..0000000
--- a/scheme/debug/fix-low.scm
+++ /dev/null
@@ -1,72 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-(define-structure low-structures low-structures-interface
-  ;; Flatloaded
-  (open ))
-
-(define ascii (structure-ref built-in-structures ascii))
-(define signals (structure-ref built-in-structures signals))
-(define loopholes (structure-ref built-in-structures loopholes))
-(define escapes (structure-ref built-in-structures escapes))
-(define vm-exposure (structure-ref built-in-structures vm-exposure))
-
-; (define-structure locations locations-interface
-;   (open scheme-level-2 ...))
-(define locations (structure-ref built-in-structures locations))
-
-(define closures (structure-ref built-in-structures closures))
-(define bitwise (structure-ref built-in-structures bitwise))
-
-;; For initial system
-(define write-images (structure-ref built-in-structures write-images))
-(define structure-refs (structure-ref built-in-structures structure-refs))
-(define low-level (structure-ref built-in-structures low-level))
-
-;; For compiler
-(define features (structure-ref built-in-structures features))
-(define code-vectors (structure-ref built-in-structures code-vectors))
-(define source-file-names
-  (structure-ref built-in-structures source-file-names))
-
-(define true-scheme (structure-ref built-in-structures scheme))
-
-
-(define-structure scheme-level-0 scheme-level-0-interface
-  (open true-scheme
-	primitives		; only for extended-number?
-	structure-refs)
-  (access true-scheme)
-  (files level-0))
-
-(define-structure silly (export reverse-list->string)
-  (open true-scheme)
-  (begin (define (reverse-list->string l n)
-	   (list->string (reverse l)))))
-
-(define-structure cont-primitives
-    (export make-continuation
-	    continuation-length
-	    continuation-ref
-	    continuation-set!
-	    continuation?)
-  (open (structure-ref built-in-structures primitives)))
-
-(define-structures ((primitives primitives-interface)
-		    (primitives-internal (export maybe-handle-interrupt
-						 raise-exception
-						 get-exception-handler
-						 ?start)))
-  (open true-scheme
-        cont-primitives
-        (structure-ref built-in-structures bitwise)
-        (structure-ref built-in-structures records)
-        (structure-ref built-in-structures signals)
-        (structure-ref built-in-structures features)
-        (structure-ref built-in-structures templates)
-	)
-  (files ("../alt" primitives)
-	 ("../alt" weak)))
-
-; How about signals?
-
diff --git a/scheme/debug/for-debugging.scm b/scheme/debug/for-debugging.scm
deleted file mode 100644
index 4e8a840..0000000
--- a/scheme/debug/for-debugging.scm
+++ /dev/null
@@ -1,59 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; --------------------
-
-; Fake interrupt and exception system.
-; This needs to be reconciled with alt/primitives.scm.
-
-(define (with-exceptions thunk)
-  (with-handler
-       (lambda (c punt)
-	 (cond ((and (exception? c)
-		     (procedure? (get-exception-handler)))
-		(handle-exception-carefully c))
-	       ((interrupt? c)
-		(if (not (deal-with-interrupt c))
-		    (punt)))
-	       ;; ((vm-return? c)
-	       ;;  (vm-return (cadr c)))
-	       (else
-		(punt))))
-     thunk))
-
-(define (handle-exception-carefully c)
-  (display "(Exception: ") (write c) (display ")") (newline)
-  (noting-exceptional-context c
-    (lambda ()
-      (raise-exception (exception-opcode c)
-		       (exception-arguments c)))))
-
-(define (noting-exceptional-context c thunk)
-  (call-with-current-continuation
-    (lambda (k)
-      ;; Save for future inspection, just in case.
-      (set! *exceptional-context* (cons c k))
-      (thunk))))
-
-(define *exceptional-context* #f)
-
-(define (deal-with-interrupt c)
-  (noting-exceptional-context c
-    (lambda ()
-      (maybe-handle-interrupt
-       (if (and (pair? (cdr c)) (integer? (cadr c)))
-	   (cadr c)
-	   (enum interrupt keyboard))))))
-
-; (define (poll-for-interrupts) ...)
-
-
-; Get the whole thing started
-
-(define (?start-with-exceptions entry-point arg)
-  (with-exceptions
-   (lambda ()
-     (?start entry-point arg))))
-
-(define (in struct form)
-  (eval form (structure-package struct)))
diff --git a/scheme/debug/graph.scm b/scheme/debug/graph.scm
deleted file mode 100644
index 9c74e98..0000000
--- a/scheme/debug/graph.scm
+++ /dev/null
@@ -1,142 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Code to print out module dependencies in a format readable by the
-; graph layout program AT&T DOT Release 1.0. (for information on DOT call
-; the AT&T Software Technology Center Common Support Hotline (908) 582-7009)
-
-; Follow link script up to the actual linking
-;(load-configuration "scheme/interfaces.scm") 
-;(load-configuration "scheme/packages.scm") 
-;(flatload initial-structures) 
-;(load "build/initial.scm")
-;
-; Load this and run it
-;(load "scheme/debug/graph.scm")
-;(dependency-graph (initial-packages)
-; (map structure-package (list scheme-level-1 scheme-level-0))
-; "graph.dot")
-;
-; Run the graph layout program
-; setenv SDE_LICENSE_FILE /pls/local/lib/DOT/LICENSE.dot
-; /pls/local/lib/DOT/dot -Tps graph.dot -o graph.ps
-
-; Returns a list of the packages in the initial system.
-
-(define (initial-packages)
-  (map (lambda (p)
-	 (structure-package (cdr p)))
-       (append (struct-list scheme
-			    environments
-			    module-system
-			    ensures-loaded
-			    packages
-			    packages-internal)
-	       (desirable-structures))))
-
-; Write the dependency graph found by rooting from PACKAGES to FILENAME.
-; Packages in the list IGNORE are ignored.
-;
-; Each configuration file's packages are done as a separate subgraph.
-
-(define (dependency-graph packages ignore filename)
-  (call-with-output-file filename
-    (lambda (out)
-      (display prelude out)
-      (newline out)
-      (let ((subgraphs (do-next-package packages ignore '() ignore out)))
-	(for-each (lambda (sub)
-		    (note-subgraph sub out))
-		  subgraphs)
-	(display "}" out)
-	(newline out)))))
-
-; Do the first not-yet-done package, returning the subgraphs if there are
-; no packages left.  TO-DO, DONE, and IGNORE are lists of packages.
-; SUBGRAPHS is an a-list indexed by source-file-name.
-
-(define (do-next-package to-do done subgraphs ignore out)
-  (let loop ((to-do to-do))
-    (if (null? to-do)
-	subgraphs
-	(let ((package (car to-do)))
-	  (if (memq package done)
-	      (loop (cdr to-do))
-	      (do-package package (cdr to-do) (cons package done)
-			  subgraphs ignore out))))))
-
-; Find the correct subgraph, add PACKAGE to it, note any edges, and continue
-; with the rest of the graph.
-
-(define (do-package package to-do done subgraphs ignore out)
-  (let* ((source-file (package-file-name package))
-	 (opens (map structure-package
-		     ((package-opens-thunk package))))
-	 (old-subgraph (assq source-file subgraphs))
-	 (subgraph (or old-subgraph
-		       (list source-file))))
-    (set-cdr! subgraph (cons package (cdr subgraph)))
-    (do-edges package opens source-file ignore out)
-    (do-next-package (append opens to-do)
-		     done
-		     (if old-subgraph
-			 subgraphs
-			 (cons subgraph subgraphs))
-		     ignore
-		     out)))
-
-; Add an edge from each package in OPENS to PACKAGE, provided that the
-; two were defined in the same file.
-
-(define (do-edges package opens source-file ignore out)
-  (let loop ((opens opens) (done ignore))
-    (if (not (null? opens))
-	(loop (cdr opens)
-	      (let ((p (car opens)))
-		(if (or (memq p done)
-			(not (string=? source-file (package-file-name p))))
-		    done
-		    (begin
-		      (note-edge p package out)
-		      (cons p done))))))))
-
-; Writing out the package name as a string (actually, its the name of
-; the first of the package's clients).
-
-(define (package-name package out)
-  (let ((clients (population->list (package-clients package))))
-    (write-char #\" out)
-    (display (structure-name (car clients)) out)
-    (write-char #\" out)))
-
-; Header for DOT files
-
-(define prelude
-  "digraph G {
-   orientation=landscape;
-   size =\"10,7.5\";
-   page =\"8.5,11\";
-   ratio =fill;")
-
-; Writing out edges and subgraphs
-
-(define (note-edge from to out)
-  (display "   " out)
-  (package-name from out)
-  (display " -> " out)
-  (package-name to out)
-  (write-char #\; out)
-  (newline out))
-
-(define (note-subgraph subgraph out)
-  (display "   subgraph \"cluster_" out)
-  (display (car subgraph) out)
-  (display "\" { label=\"" out)
-  (display (car subgraph) out)
-  (display "\"; " out)
-  (for-each (lambda (p)
-	      (package-name p out)
-	      (display "; " out))
-	    (cdr subgraph))
-  (display "}" out)
-  (newline out))
-
diff --git a/scheme/debug/level-0.scm b/scheme/debug/level-0.scm
deleted file mode 100644
index 39e52cd..0000000
--- a/scheme/debug/level-0.scm
+++ /dev/null
@@ -1,30 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Redefinitions of some usual Scheme things so as to make the new
-; exception system kick in when it needs to.
-
-(define (number? n)
-  (or ((structure-ref true-scheme number?) n)
-      (extended-number? n)))
-
-;(define (integer? n)
-;  (if ((structure-ref true-scheme number?) n)
-;      ((structure-ref true-scheme integer?) n)
-;      (and (extended-number? n)
-;           ... raise exception ...)))
-
-(define (+ x y) ((structure-ref true-scheme +) x y))
-(define (* x y) ((structure-ref true-scheme *) x y))
-(define (- x y) ((structure-ref true-scheme -) x y))
-(define (/ x y) ((structure-ref true-scheme /) x y))
-(define (= x y) ((structure-ref true-scheme =) x y))
-(define (< x y) ((structure-ref true-scheme <) x y))
-(define (make-vector x y) ((structure-ref true-scheme make-vector) x y))
-(define (make-string x y) ((structure-ref true-scheme make-string) x y))
-(define (apply x y) ((structure-ref true-scheme apply) x y))
-
-(define (read-char x) ((structure-ref true-scheme read-char) x))
-(define (peek-char x) ((structure-ref true-scheme peek-char) x))
-(define (char-ready? x) ((structure-ref true-scheme char-ready?) x))
-(define (write-char x y) ((structure-ref true-scheme write-char) x y))
diff --git a/scheme/debug/link-debug.scm b/scheme/debug/link-debug.scm
deleted file mode 100644
index d9fbbb5..0000000
--- a/scheme/debug/link-debug.scm
+++ /dev/null
@@ -1,36 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-
-
-; Stuff for debugging new images:
-
-(define (ev form package)
-  (invoke-template (compile-form form package)
-		   (package-uid package)))
-
-; If desired, this definition of invoke-template can be replaced by
-; something that starts up a different virtual machine.
-
-(define (invoke-template template env . args)
-  (apply (make-closure template env)
-	 args))
-
-; Utility for tracking down uses of variables
-
-(define (who-uses name proc)
-  (let recur ((tem (closure-template proc))
-              (path '()))
-    (let loop ((i 0))
-      (if (< i (template-length tem))
-          (let ((thing (template-ref tem i))
-                (down (lambda (tem)
-                        (recur tem (cons (or (template-ref tem 1) i) path)))))
-            (cond ((template? thing)
-                   (down thing))
-                  ((location? thing)
-                   (if (eq? (location-name thing) name)
-                       (begin (write path) (newline))))
-                  ((closure? thing)
-                   (down (closure-template thing))))
-            (loop (+ i 1)))))))
diff --git a/scheme/debug/linker.scm b/scheme/debug/linker.scm
deleted file mode 100644
index 84fe02a..0000000
--- a/scheme/debug/linker.scm
+++ /dev/null
@@ -1,34 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-(define (link-simple-system filename resumer-exp . structs)
-  (link-system structs (lambda () resumer-exp) filename))
-
-(define (link-reified-system some filename make-resumer-exp . structs)
-  (link-system (append structs (map cdr some))
-	       (lambda ()
-		 (display "Reifying") (newline)
-		 `(,make-resumer-exp
-		   (lambda ()
-		     ,(reify-structures some
-					(lambda (loc) loc)
-					`(lambda (loc) loc)))))
-	       filename))
-
-
-(define (link-system structs make-resumer filename)
-  (for-each ensure-loaded structs)
-  (let* ((p (make-simple-package structs eval #f))
-	 (r (eval (make-resumer) p)))
-    ;; (check-package p)
-    r))
-
-;(define (check-package p)
-;  (let ((names (undefined-variables p)))
-;    (if (not (null? names))
-;        (begin (display "Undefined: ") 
-;               (write names) (newline)))))
-
-(define-syntax struct-list
-  (syntax-rules ()
-    ((struct-list name ...) (list (cons 'name name) ...))))
diff --git a/scheme/debug/low-test-packages.scm b/scheme/debug/low-test-packages.scm
deleted file mode 100644
index ee51203..0000000
--- a/scheme/debug/low-test-packages.scm
+++ /dev/null
@@ -1,7 +0,0 @@
-; no copyright
-
-; (link-simple-system '(debug low-test) 'start low-test-system)
-
-(define-structure low-test-system (export start)
-  (define-all-operators)
-  (files low-test))
diff --git a/scheme/debug/low-test.scm b/scheme/debug/low-test.scm
deleted file mode 100644
index 3de71af..0000000
--- a/scheme/debug/low-test.scm
+++ /dev/null
@@ -1,312 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Tests for many of the primitives, both inlined and close-compiled.
-
-; This prints `Hello' three times and then the first command argument, if any,
-; and finally reads a line from standard input and prints it to standard output.
-
-(define (start arg in out error-out)
-  (call-with-values
-    (lambda ()
-      (values "H" "e" "ll" "o" " "))
-    (lambda (h e ll o sp)
-      (write-string h out)
-      (write-string e out)
-      (write-string ll out)
-      (write-string o out)
-      (write-string sp out)))
-  (call-with-values
-    (lambda ()
-      (apply values "H" "e" '("ll" "o" " ")))
-    (lambda (h e ll o sp)
-      (write-string h out)
-      (write-string e out)
-      (write-string ll out)
-      (write-string o out)
-      (write-string sp out)))
-  (call-with-values
-    (lambda ()
-      (values "H" "e" "ll" "o" " "))
-    (lambda (h e . more)
-      (write-string h out)
-      (write-string e out)
-      (letrec ((loop (lambda (more)
-		       (if (eq? '() more)
-			   0
-			   (begin
-			     (write-string (car more) out)
-			     (loop (cdr more)))))))
-	(loop more))))
-  (if (vector? arg)
-      (if (< 0 (vector-length arg))
-	  (write-string (vector-ref arg 0) out)))
-  (newline out)
-
-  (bool-test (= 1 1) "(= 1 1)" #t out)
-  (bool-test (= 1 2) "(= 1 2)" #f out)
-  (bool-test (= 1 1 1) "(= 1 1 1)" #t out)
-  (bool-test (= 1 2 3) "(= 1 2 3)" #f out)
-  (bool-test (= 1 1 1 3) "(= 1 1 1 3)" #f out)
-  (bool-test (= 1 1 1 1) "(= 1 1 1 1)" #t out)
-  (bool-test (= 1 1 2 3) "(= 1 1 2 3)" #f out)
-  (bool-test (= 1 1 1 3) "(= 1 1 1 3)" #f out)
-  ((lambda (=)
-     (bool-test (= 1 1) "(= 1 1)" #t out)
-     (bool-test (= 1 2) "(= 1 2)" #f out)
-     (bool-test (= 1 1 1) "(= 1 1 1)" #t out)
-     (bool-test (= 1 2 3) "(= 1 2 3)" #f out)
-     (bool-test (= 1 1 3) "(= 1 1 3)" #f out)
-     (bool-test (= 1 1 1 3) "(= 1 1 1 3)" #f out)
-     (bool-test (= 1 1 1 1) "(= 1 1 1 1)" #t out)
-     (bool-test (= 1 1 2 3) "(= 1 1 2 3)" #f out)
-     (bool-test (= 1 1 1 3) "(= 1 1 1 3)" #f out))
-   =)
-  (bool-test (< 1 1) "(< 1 1)" #f out)
-  (bool-test (< 1 2) "(< 1 2)" #t out)
-  (bool-test (< 1 1 1) "(< 1 1 1)" #f out)
-  (bool-test (< 1 2 3) "(< 1 2 3)" #t out)
-  (bool-test (< 1 2 2) "(< 1 2 2)" #f out)
-  ((lambda (<)
-     (bool-test (< 1 1) "(< 1 1)" #f out)
-     (bool-test (< 1 2) "(< 1 2)" #t out)
-     (bool-test (< 1 1 1) "(< 1 1 1)" #f out)
-     (bool-test (< 1 2 3) "(< 1 2 3)" #t out)
-     (bool-test (< 1 2 2) "(< 1 2 2)" #f out))
-   <)
-  (bool-test (<= 1 1) "(<= 1 1)" #t out)
-  (bool-test (<= 1 2) "(<= 1 2)" #t out)
-  (bool-test (<= 2 1) "(<= 2 1)" #f out)
-  (bool-test (<= 1 1 1) "(<= 1 1 1)" #t out)
-  (bool-test (<= 1 2 3) "(<= 1 2 3)" #t out)
-  (bool-test (<= 1 2 2) "(<= 1 2 2)" #t out)
-  (bool-test (<= 1 2 1) "(<= 1 2 1)" #f out)
-  ((lambda (<=)
-     (bool-test (<= 1 1) "(<= 1 1)" #t out)
-     (bool-test (<= 1 2) "(<= 1 2)" #t out)
-     (bool-test (<= 2 1) "(<= 2 1)" #f out)
-     (bool-test (<= 1 1 1) "(<= 1 1 1)" #t out)
-     (bool-test (<= 1 2 3) "(<= 1 2 3)" #t out)
-     (bool-test (<= 1 2 2) "(<= 1 2 2)" #t out)
-     (bool-test (<= 1 2 1) "(<= 1 2 1)" #f out))
-   <=)
-  (bool-test (> 1 1) "(> 1 1)" #f out)
-  (bool-test (> 2 1) "(> 2 1)" #t out)
-  (bool-test (> 1 1 1) "(> 1 1 1)" #f out)
-  (bool-test (> 3 2 1) "(> 3 2 1)" #t out)
-  (bool-test (> 2 1 1) "(> 2 1 1)" #f out)
-  ((lambda (>)
-     (bool-test (> 1 1) "(> 1 1)" #f out)
-     (bool-test (> 2 1) "(> 2 1)" #t out)
-     (bool-test (> 1 1 1) "(> 1 1 1)" #f out)
-     (bool-test (> 3 2 1) "(> 3 2 1)" #t out)
-     (bool-test (> 2 1 1) "(> 2 1 1)" #f out))
-   >)
-  (bool-test (>= 1 1) "(>= 1 1)" #t out)
-  (bool-test (>= 2 1) "(>= 2 1)" #t out)
-  (bool-test (>= 1 2) "(>= 1 2)" #f out)
-  (bool-test (>= 1 1 1) "(>= 1 1 1)" #t out)
-  (bool-test (>= 3 2 1) "(>= 3 2 1)" #t out)
-  (bool-test (>= 2 1 1) "(>= 2 1 1)" #t out)
-  (bool-test (>= 2 1 2) "(>= 2 1 2)" #f out)
-  ((lambda (>=)
-     (bool-test (>= 1 1) "(>= 1 1)" #t out)
-     (bool-test (>= 2 1) "(>= 2 1)" #t out)
-     (bool-test (>= 1 2) "(>= 1 2)" #f out)
-     (bool-test (>= 1 1 1) "(>= 1 1 1)" #t out)
-     (bool-test (>= 3 2 1) "(>= 3 2 1)" #t out)
-     (bool-test (>= 2 1 1) "(>= 2 1 1)" #t out)
-     (bool-test (>= 2 1 2) "(>= 2 1 2)" #f out))
-   >=)
-  (arith-test (vector-length (make-vector 3)) "make-vector0" 3 out)
-  (arith-test (vector-length (make-vector 3 4)) "make-vector1" 3 out)
-  (arith-test (vector-ref (make-vector 3 4) 2) "make-vector2" 4 out)
-  ((lambda (make-vector)
-     (arith-test (vector-length (make-vector 3)) "make-vector3" 3 out)
-     (arith-test (vector-length (make-vector 3 4)) "make-vector4" 3 out)
-     (arith-test (vector-ref (make-vector 3 4) 2) "make-vector5" 4 out))
-   make-vector)
-  (arith-test (string-length (make-string 3)) "make-string0" 3 out)
-  (arith-test (string-length (make-string 3 #\a)) "make-string1" 3 out)
-  (arith-test (- (char->ascii (string-ref (make-string 3) 2))
-		 (char->ascii #\?))
-	      "make-string2" 0 out)
-  (arith-test (- (char->ascii (string-ref (make-string 3 #\a) 2))
-		 (char->ascii #\a))
-	      "make-string3" 0 out)
-  ((lambda (make-string)
-     (arith-test (string-length (make-string 3)) "make-string4" 3 out)
-     (arith-test (string-length (make-string 3 #\a)) "make-string5" 3 out)
-     (arith-test (- (char->ascii (string-ref (make-string 3) 2))
-		    (char->ascii #\?))
-		 "make-string6" 0 out)
-     (arith-test (- (char->ascii (string-ref (make-string 3 #\a) 2))
-		    (char->ascii #\a))
-		 "make-string7" 0 out))
-   make-string)
-  (arith-test (apply + '()) "(apply + '())" 0 out)
-  (arith-test (apply + '(1)) "(apply + '(1))" 1 out)
-  (arith-test (apply + 1 '()) "(apply + 1 '())" 1 out)
-  (arith-test (apply + '(1 2)) "(apply + '(1 2))" 3 out)
-  (arith-test (apply + 1 '(2)) "(apply + 1 '(2))" 3 out)
-  (arith-test (apply + 1 2 '()) "(apply + 1 2 '())" 3 out)
-  (arith-test (apply + '(1 2 3)) "(apply + '(1 2 3))" 6 out)
-  (arith-test (apply + 1 2 '(3)) "(apply + 1 2 '(3))" 6 out)
-  (bool-test (apply < '(1 2)) "(apply < '(1 2))" #t out)
-  (bool-test (apply < 1 '(2)) "(apply < 1 '(2))" #t out)
-  (bool-test (apply < 1 2 '()) "(apply < 1 2 '())" #t out)
-  (bool-test (apply < '(1 2 3)) "(apply < '(1 2 3))" #t out)
-  (bool-test (apply < 1 2 '(3)) "(apply < 1 2 '(3))" #t out)
-  (arith-test (apply apply (list + '(1 2 3)))
-	      "(apply apply (list + '(1 2 3)))" 6 out)
-  (arith-test (apply apply (list + 1 2 '(3)))
-	      "(apply apply (list + 1 2 '(3)))" 6 out)
-  (arith-test (apply apply (list + 1 2 3 '()))
-	      "(apply apply (list + 1 2 3 '()))" 6 out)
-  (arith-test (apply apply + 1 '(2 3 ())) "(apply apply + 1 '(2 3 ())" 6 out)
-  (arith-test (apply apply + 1 '(2 (3))) "(apply apply + 1 '(2 3 ())" 6 out)
-  (arith-test (apply apply + 1 2 3 '(())) "(apply + 1 2 3 '(()))" 6 out)
-  ((lambda (apply)
-     (arith-test (apply + '(1 2 3)) "(apply + '(1 2 3))" 6 out)
-     (arith-test (apply + 1 2 '(3)) "(apply + 1 2 '(3))" 6 out)
-     (arith-test (apply apply (list + '(1 2 3)))
-		 "(apply apply (list + '(1 2 3)))" 6 out)
-     (arith-test (apply apply (list + 1 2 '(3)))
-		 "(apply apply (list + 1 2 '(3)))" 6 out)
-     (arith-test (apply apply (list + 1 2 3 '()))
-		 "(apply apply (list + 1 2 3 '()))" 6 out)
-     (arith-test (apply apply + 1 '(2 3 ())) "(apply apply + 1 '(2 3 ())" 6 out)
-     (arith-test (apply apply + 1 '(2 (3))) "(apply apply + 1 '(2 3 ())" 6 out)
-     (arith-test (apply apply + 1 2 3 '(())) "(apply + 1 2 3 '(()))" 6 out))
-   apply)
-  (arith-test (+) "(+)" 0 out)
-  (arith-test (+ 3) "(+ 3)" 3 out)
-  (arith-test (+ 3 4) "(+ 3 4)" 7 out)
-  (arith-test (+ 3 4 5) "(+ 3 4 5)" 12 out)
-  (arith-test (+ 1 2 3 4 5 6 7 8 9 10 -50) "(+ 1 2 3 ... 10 -50) = 5" 5 out)
-  ((lambda (+)
-     (arith-test (+) "(+) closed" 0 out)
-     (arith-test (+ 3) "(+ 3) closed" 3 out)
-     (arith-test (+ 3 4) "(+ 3 4) closed" 7 out)
-     (arith-test (+ 3 4 5) "(+ 3 4 5) closed" 12 out)
-     (arith-test (+ 3 4 5 6) "(+ 3 4 5 6) closed" 18 out)
-     (arith-test (+ 3 4 5 6 7) "(+ 3 4 5 6 7) closed" 25 out)
-     (arith-test (+ 1 2 3 4 5 6 7 8 9 10 -50) "(+ 1 2 3 ... 10 -50) = 5 closed" 5 out))
-   +)
-  (arith-test (*) "(*)" 1 out)
-  (arith-test (* 3) "(* 3)" 3 out)
-  (arith-test (* 3 4) "(* 3 4)" 12 out)
-  (arith-test (* 3 4 2) "(* 3 4 2)" 24 out)
-  ((lambda (*)
-     (arith-test (*) "(*)" 1 out)
-     (arith-test (* 3) "(* 3)" 3 out)
-     (arith-test (* 3 4) "(* 3 4)" 12 out)
-     (arith-test (* 3 4 2) "(* 3 4 2)" 24 out))
-   *)
-  (arith-test (- -3) "(- -3)" 3 out)
-  (arith-test (- 3 -4) "(- 3 -4)" 7 out)
-  ((lambda (-)
-     (arith-test (- -3) "(- -3)" 3 out)
-     (arith-test (- 3 -4) "(- 3 -4)" 7 out))
-   -)
-  (arith-test (/ 1) "(/ 1)" 1 out)
-  (arith-test (/ 12 4) "(/ 12 4)" 3 out)
-  ((lambda (/)
-     (arith-test (/ 1) "(/ 1)" 1 out)
-     (arith-test (/ 12 4) "(/ 12 4)" 3 out))
-   /)
-  (arith-test (bitwise-ior) "(bitwise-ior)" 0 out)
-  (arith-test (bitwise-ior 5) "(bitwise-ior 5)" 5 out)
-  (arith-test (bitwise-ior 5 3) "(bitwise-ior 5 3)" 7 out)
-  (arith-test (bitwise-ior 5 3 16) "(bitwise-ior 5 3 16)" 23 out)
-  (arith-test (bitwise-xor) "(bitwise-xor)" 0 out)
-  (arith-test (bitwise-xor 5) "(bitwise-xor 5)" 5 out)
-  (arith-test (bitwise-xor 5 3) "(bitwise-xor 5 3)" 6 out)
-  (arith-test (bitwise-xor 5 3 16) "(bitwise-xor 5 3 16)" 22 out)
-  (arith-test (- (bitwise-and)) "(- (bitwise-and))" 1 out)
-  (arith-test (bitwise-and 5) "(bitwise-and 5)" 5 out)
-  (arith-test (bitwise-and 7 3) "(bitwise-and 7 3)" 3 out)
-  (arith-test (bitwise-and 7 3 17) "(bitwise-and 7 3 17)" 1 out)
-  (apply write-string (read-string in) (cons out '()))
-  (newline out)
-  0)
-
-(define (length l n)
-  (if (eq? l '()) n (length (cdr l) (+ n 1))))
-
-(define (list . x) x)
-
-(define numbers
-  '#("0" "1" "2" "3" "4" "5" "6" "7" "8" "9"
-     "10" "11" "12" "13" "14" "15" "16" "17" "18" "19"
-     "20" "21" "22" "23" "24" "25" "26" "27" "28" "29"))
-
-(define (number->string n)
-  (vector-ref numbers n))
-	 
-(define (arith-test n s a out)
-  (if (= n a)
-      #t
-      (begin
-	(write-string "Failure: " out)
-	(write-string s out)
-	(write-string " = " out)
-	(write-string (number->string n) out)
-	(write-string " and not " out)
-	(write-string (number->string a) out)
-	(newline out))))
-
-(define (bool-test n s a out)
-  (if (eq? n a)
-      #t
-      (begin
-	(write-string "Failure: " out)
-	(write-string s out)
-	(write-string " => " out)
-	(write-string (if n "#t" "#f") out)
-	(newline out))))
-
-(define (write-string string . channel-option)  ; test n-ary procedures
-  (channel-maybe-write string
-		       0
-		       (string-length string)
-		       (car channel-option)))
-
-(define (newline channel)
-  (write-string "
-" channel))
-
-(define (read-string in)
-  ((lambda (buffer)
-     (letrec ((loop (lambda (have)
-		      ((lambda (got)
-			 (if (eq? got (eof-object))
-			     "eof"
-			     ((lambda (len)
-				(if len
-				    ((lambda (string)
-				       (copy-string! buffer string len)
-				       string)
-				     (make-string len #\space))
-				    (loop (+ have got))))
-			      (has-newline buffer have got))))
-		       (channel-maybe-read buffer have (- 80 have) #f in)))))
-       (loop 0)))
-   (make-string 80 #\space)))
-
-(define (has-newline string start count)
-  (letrec ((loop (lambda (i)
-		   (if (= i count)
-		       #f
-		       (if (char=? #\newline
-				   (string-ref string (+ start i)))
-			   (+ start i)
-			   (loop (+ i 1)))))))
-    (loop 0)))
-
-(define (copy-string! from to count)
-  (letrec ((loop (lambda (i)
-		   (if (< i count)
-		       (begin
-			 (string-set! to i (string-ref from i))
-			 (loop (+ i 1)))))))
-    (loop 0)))
diff --git a/scheme/debug/mini-command.scm b/scheme/debug/mini-command.scm
deleted file mode 100644
index 3faf206..0000000
--- a/scheme/debug/mini-command.scm
+++ /dev/null
@@ -1,67 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Miniature command processor.
-
-(define (command-processor ignore args)
-  (let ((in (current-input-port))
-	(out (current-output-port))
-	(err (current-error-port))
-	(batch? (member "batch" args)))
-    (let loop ()
-      ((call-with-current-continuation
-	 (lambda (go)
-	   (with-handler
-	       (lambda (c punt)
-		 (cond ((or (error? c) (interrupt? c))
-			(display-condition c err)
-			(go (if batch?
-				(lambda () 1)
-				loop)))
-		       ((warning? c)
-			(display-condition c err))
-		       (else (punt))))
-	     (lambda ()
-	       (if (not batch?)
-		   (display "- " out))
-	       (let ((form (read in)))
-		 (cond ((eof-object? form)
-			(newline out)
-			(go (lambda () 0)))
-		       ((and (pair? form) (eq? (car form) 'unquote))
-			(case (cadr form)
-			  ((load)
-			   (mini-load in)
-			   (go loop))
-			  ((go)
-			   (let ((form (read in)))
-			     (go (lambda ()
-				   (eval form (interaction-environment))))))
-			  (else (error "unknown command" (cadr form)))))
-		       (else
-			(call-with-values
-			    (lambda () (eval form (interaction-environment)))
-			  (lambda results
-			    (for-each (lambda (result)
-					(write result out)
-					(newline out))
-				      results)
-			    (go loop))))))))))))))
-
-(define (mini-load in)
-  (let ((c (peek-char in)))
-    (cond ((char=? c #\newline) (read-char in) #t)
-	  ((char-whitespace? c) (read-char in) (mini-load in))
-	  (else
-	   (let ((filename (read-string in char-whitespace?)))
-	     (load filename)
-	     (mini-load in))))))
-
-(define (read-string port delimiter?)
-  (let loop ((l '()) (n 0))
-    (let ((c (peek-char port)))
-      (cond ((or (eof-object? c)
-                 (delimiter? c))
-             (list->string (reverse l)))
-            (else
-             (loop (cons (read-char port) l) (+ n 1)))))))
diff --git a/scheme/debug/mini-eval.scm b/scheme/debug/mini-eval.scm
deleted file mode 100644
index 4513782..0000000
--- a/scheme/debug/mini-eval.scm
+++ /dev/null
@@ -1,113 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Miniature evaluator.
-
-(define (eval form package)
-  (evil form package))
-
-(define (evil exp env)
-  (cond ((symbol? exp) (env exp))
-	((not (pair? exp)) exp)
-	((eq? (car exp) 'quote) (cadr exp))
-	((eq? (car exp) 'lambda)
-	 (lambda args
-	   (evil-begin (cddr exp) (bind (cadr exp) args env))))
-	((eq? (car exp) 'if)
-	 (evil (if (evil (cadr exp) env)
-		   (caddr exp)
-		   (cadddr exp))
-	       env))
-	((eq? (car exp) 'define)
-	 (let* ((pat (cadr exp))
-		(lhs (if (pair? pat) (car pat) pat))
-		(rhs (if (pair? pat)
-			 `(lambda ,(cdr pat) ,@(cddr exp))
-			 (caddr exp))))
-	   ((env '%%define%%) lhs (evil rhs env))))
-	(else
-	 (apply (evil (car exp) env)
-		(map (lambda (arg) (evil arg env)) (cdr exp))))))
-
-(define (evil-begin exp-list env)
-  (if (null? (cdr exp-list))
-      (evil (car exp-list) env)
-      (begin (evil (car exp-list) env)
-	     (evil-begin (cdr exp-list) env))))
-
-(define (bind names vals env)
-  (let ((alist (map cons names vals)))
-    (lambda (name)
-      (let ((probe (assq name alist)))
-	(if probe (cdr probe) (env name))))))
-
-; Initial package
-
-(define (initial-package name)
-  (let ((probe (assq name *initial-bindings*)))
-    (if probe (cdr probe) (error "unbound" name))))
-
-(define (define-initial name val)
-  (let ((probe (assq name *initial-bindings*)))
-    (if probe
-	(set-cdr! probe val)
-	(set! *initial-bindings*
-	      (cons (cons name val) *initial-bindings*)))))
-
-(define *initial-bindings*
-  (list (cons '%%define%% define-initial)))
-
-(define-syntax define-initial-stuff
-  (syntax-rules ()
-    ((define-initial-stuff ?name ...)
-     (for-each define-initial
-	       '(?name ...)
-	       (list ?name ...)))))
-
-(define-initial-stuff
-  cons car cdr + - * / < = > list map append reverse
-  make-vector vector-ref vector-set! vector-length
-  apply)
-
-
-; LOAD
-
-(define (load filename)
-  (load-into filename (interaction-environment)))
-
-(define (load-into filename env)
-  (call-with-input-file filename
-    (lambda (port)
-      (let loop ()
-	(let ((form (read port)))
-	  (cond ((eof-object? form))
-		(else
-		 (eval form env)
-		 (loop))))))))
-
-(define (eval-from-file forms env filename)
-  (for-each (lambda (form) (eval form env)) forms))
-(define (eval-scanned-forms forms env filename)
-  (for-each (lambda (form) (eval form env)) forms))
-
-
-; Interaction environment
-
-(define (set-interaction-environment! package)
-  (set! *interaction-environment* package))
-
-(define (interaction-environment)
-  *interaction-environment*)
-
-(define *interaction-environment* initial-package)
-
-(define (set-scheme-report-environment! n package)
-  (set! *scheme-report-environment* package))
-
-(define (scheme-report-environment n)
-  *scheme-report-environment*)
-
-(define (null-environment n)
-  *scheme-report-environment*)
-
-(define *scheme-report-environment* #f)
diff --git a/scheme/debug/mini-package.scm b/scheme/debug/mini-package.scm
deleted file mode 100644
index 1a4a2f3..0000000
--- a/scheme/debug/mini-package.scm
+++ /dev/null
@@ -1,75 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Miniature package system.  This links mini-eval up to the output of
-; the package reifier.
-
-(define (package names locs get-location uid) ;Reified package
-  (lambda (name)
-    (let loop ((i (- (vector-length names) 1)))
-      (if (< i 0)
-	  (error "unbound" name)
-	  (if (eq? name (vector-ref names i))
-	      (contents (get-location (vector-ref locs i)))
-	      (loop (- i 1)))))))
-
-(define (make-simple-package opens foo1 foo2 name)
-  
-  (define bindings
-    (list (cons '%%define%%
-		(lambda (name val)
-		  (set! bindings (cons (cons name val) bindings))))))
-
-  (lambda (name)
-    (let ((probe (assq name bindings)))
-      (if probe
-	  (cdr probe)
-	  (let loop ((opens opens))
-	    (if (null? opens)
-		(error "unbound" name)
-		(if (memq name (structure-interface (car opens)))
-		    ((structure-package (car opens)) name)
-		    (loop (cdr opens)))))))))
-
-; Structures
-
-(define (make-structure package interface . name-option)
-  (cons package (vector->list interface)))
-
-(define structure-interface cdr)
-(define structure-package car)
-
-
-; Things used by reification forms
-
-(define (operator name type-exp)
-  `(operator ,name ,type-exp))
-
-(define (simple-interface names type) names)
-
-; Etc.
-
-(define (transform . rest) (cons 'transform rest))
-(define (usual-transform . rest)
-  (cons 'usual-transform rest))
-
-(define (transform-for-structure-ref . rest)
-  (cons 'transform-for-structure-ref rest))
-(define (inline-transform . rest)
-  (cons 'inline-transform rest))
-(define (primop . rest)
-  (cons 'primop rest))
-
-(define (package-define-static! package name op) 'lose)
-
-; --------------------
-; ???
-
-; (define (integrate-all-primitives! . rest) 'lose)
-
-;(define (package-lookup p name)
-;  ((p '%%lookup-operator%%) name))
-
-;(define (package-ensure-defined! p name)
-;  (package-define! p name (make-location 'defined name)))
-
diff --git a/scheme/debug/mini-start.scm b/scheme/debug/mini-start.scm
deleted file mode 100644
index 7a65cb2..0000000
--- a/scheme/debug/mini-start.scm
+++ /dev/null
@@ -1,19 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Start up a system that has reified packages.
-; COMMAND-PROCESSOR might be either the miniature one or the real one.
-
-(define (start structs-thunk)
-  (usual-resumer
-   (lambda (arg)
-     (initialize-interaction-environment! (structs-thunk))
-     (command-processor #f arg))))
-
-(define (initialize-interaction-environment! structs)
-  (let ((scheme (cdr (assq 'scheme structs))))
-    (let ((tower (delay (cons eval (scheme-report-environment 5)))))
-      (set-interaction-environment!
-         (make-simple-package (map cdr structs) #t tower 'interaction))
-      (set-scheme-report-environment!
-         5
-	 (make-simple-package (list scheme) #t tower 'r5rs)))))
diff --git a/scheme/debug/mumble-packages.scm b/scheme/debug/mumble-packages.scm
deleted file mode 100644
index dea9b0f..0000000
--- a/scheme/debug/mumble-packages.scm
+++ /dev/null
@@ -1,73 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; This is for version 0.28
-; We define these two because they aren't reified:
-;   scheme-level-0
-;   silly
-
-; We redefine these two so as not to compromise the security of the
-; built-in exception and interrupt systems:
-;   primitives
-;   signals
-
-
-; Suppose you have just done "make image" to build the scheme48 heap image.
-; Suppose that the linker produces an initial.image, but that when that
-; image is resumed you get the error
-;     exception handler is not a closure
-; This is not informative.  To find out what really happened, you have
-; two choices:
-;   (1) Run the image under the VM running in Scheme.
-;   (2) Run the image using the following handy dandy tool.
-; For choice (2), you would do something like the following:
-;
-;  ,translate =scheme48/ ./
-;  ,config ,load debug/mumble-packages.scm
-;  ,in link-config
-;  y
-;  ;; Cf. Makefile rule for initial.image
-;  ,load interfaces.scm packages.scm debug/fix-low.scm
-;  (flatload initial-structures)
-;  ,load initial.scm
-;  (define test (link-initial-system))
-
-; primitives-internal
-; ,open ##
-
-; Replacement for the structure defined in link-packages.scm
-(define-structure linker (export link-simple-system
-				 link-reified-system
-				 (struct-list :syntax))
-  (open scheme
-        packages		;make-simple-package
-        reification
-        ensures-loaded
-	)		; (enum interrupt keyboard)
-  (files linker))
-
-; Copied from link-packages.scm
-(define-structure loadc (export load-configuration
-				(structure-ref :syntax))
-  (open scheme
-	environments		; *structure-ref
-	fluids)
-  (files ((".." link) loadc)))
-
-; Replacement for the structure defined in link-packages.scm
-
-(define-structure link-config (export )  ;dummy structure...
-  (open scheme
-	linker
-	;; low-structures
-	;; start-debugging
-	defpackage
-	types
-	analysis
-	structure-refs    ;the real one
-	loadc		  ;defines structure-ref, but not the one we want
-	flatloading
-	ensures-loaded
-	interfaces)
-  (access built-in-structures)
-  (begin 0))
diff --git a/scheme/debug/mutation.scm b/scheme/debug/mutation.scm
deleted file mode 100644
index 22ffa48..0000000
--- a/scheme/debug/mutation.scm
+++ /dev/null
@@ -1,130 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-
-; Package mutation tests
-
-"
-,translate =scheme48/ ./
-,open packages compiler built-in-structures handle condition
-,open interfaces table defpackage package-mutation
-"
-
-(define (try exp env . should-return-option)
-  (let ((val (ignore-errors (lambda () (eval exp env)))))
-    (if (if (null? should-return-option)
-	    (error? val)
-	    (not (if (eq? (car should-return-option) 'error)
-		     (error? val)
-		     (eq? val (car should-return-option)))))
-	(begin (write `(lost: ,exp => ,val))
-	       (newline)))))
-
-(define p1 (make-simple-package (list scheme) eval #f 'p1))
-
-(try 'a p1 'error)
-
-(try '(define a 'aa) p1)
-(try 'a p1 'aa)
-
-(try '(define (foo) b) p1)
-(try '(foo) p1 'error)
-
-(try '(define b 'bb) p1)
-(try 'b p1 'bb)
-(try '(foo) p1 'bb)
-
-
-(define s1-sig (make-simple-interface 's1-sig '(((a b c d e f) value))))
-(define s1 (make-structure p1 (lambda () s1-sig) 's1))
-
-(define p2 (make-simple-package (list s1 scheme) eval #f 'p2))
-
-(try 'b p2 'bb)
-(try 'c p2 'error)
-(try 'z p2 'error)
-
-(try '(define (bar) c) p2)
-(try '(bar) p2 'error)
-(try '(define c 'cc) p1)
-(try 'c p2 'cc)
-(try '(bar) p2 'cc)
-
-(try '(define (baz1) d) p1)
-(try '(define (baz2) d) p2)
-(try '(baz1) p1 'error)
-(try '(baz2) p2 'error)
-(try '(define d 'dd) p1)
-(try '(baz1) p1 'dd)
-(try '(baz2) p2 'dd)
-
-; Shadow
-(try '(define d 'shadowed) p2)
-(try '(baz1) p1 'dd)
-(try '(baz2) p2 'shadowed)
-
-; Shadow undefined
-(try '(define (moo1) f) p1)
-(try '(define (moo2) f) p2)
-(try '(define f 'ff) p2)
-(try '(moo1) p1 'error)
-(try '(moo2) p2 'ff)
-
-
-(try '(define (quux1) e) p1)
-(try '(define (quux2) e) p2)
-(try '(define (quux3 x) (set! e x)) p1)
-(try '(define (quux4 x) (set! e x)) p2)
-;
-(try '(quux1) p1 'error)
-(try '(quux2) p2 'error)
-(try '(quux3 'q3) p1 'error)
-(try '(quux4 'q4) p2 'error)
-;
-(try '(define e 'ee) p1)
-(try '(quux1) p1 'ee)
-(try '(quux2) p2 'ee)
-(try '(quux3 'q3) p1)
-(try '(quux1) p1 'q3)
-(try '(quux2) p2 'q3)
-(try '(quux4 'q4) p2 'error)
-;
-(try '(define e 'ee2) p2)
-(try '(quux1) p1 'q3)
-(try '(quux2) p2 'ee2)
-(try '(quux3 'qq3) p1)
-(try '(quux4 'qq4) p2)
-(try '(quux1) p1 'qq3)
-(try '(quux2) p2 'qq4)
-
-
-; (set-verify-later! really-verify-later!)
-
-(define-interface s3-sig (export a b x y z))
-
-(define s3
-  (make-structure p1 (lambda () s3-sig) 's3))
-
-(define p4 (make-simple-package (list s3 scheme) eval #f 'p4))
-
-(try '(define (fuu1) a) p4)
-(try '(define (fuu2) d) p4)
-(try '(fuu1) p4 'aa)
-(try '(fuu2) p4 'error)
-
-; Remove a, add d
-(define-interface s3-sig (export b d x y z))
-;(package-system-sentinel)
-
-(try 'a p4 'error)
-(try 'd p4 'dd)
-(try '(fuu2) p4 'dd)
-(try '(fuu1) p4 'error)    ; Foo.
-
-
-
-(define (table->alist t)
-  (let ((l '()))
-    (table-walk (lambda (key val) (set! l (cons (cons key val) l))) t)
-    l))
-
diff --git a/scheme/debug/profile.scm b/scheme/debug/profile.scm
deleted file mode 100644
index f25adf9..0000000
--- a/scheme/debug/profile.scm
+++ /dev/null
@@ -1,107 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; This was a fun hack, but I didn't get much useful information out of
-; it -- a profiler that only samples at points allowed by the VM's
-; interrupt mechanism doesn't tell you what you want to know.  The
-; only information available at that point is the continuation; what
-; we really want to know is where the PC has been.  In particular, the
-; only procedures that show up in the table at all are those that call
-; other procedures.    JAR 12/92
-
-'
-(define-structure profiler (export profile)
-  (open scheme-level-2 handle exception ;interrupts
-	architecture continuation signals condition template
-	table structure-refs debug-data sort
-	clock) ;schedule-interrupt
-  (files (misc profile)))
-
-(define (profile thunk frequency)
-  (let ((table (make-table template-uid))
-	(dt (round (/ (expt 10 6) frequency))))
-    (primitive-catch
-      (lambda (k0)
-	(let ((foo (continuation-template k0)))
-	  (with-handler
-	      (lambda (c punt)
-		(if (and (interrupt? c)
-			 (eq? (interrupt-type c) interrupt/alarm))
-		    (primitive-catch
-		      (lambda (k)
-			(record-profile-information! k foo table)
-			(schedule-interrupt dt)))
-		    (punt)))
-	    (lambda ()
-	      (dynamic-wind (lambda () (schedule-interrupt dt -6))
-			    thunk
-			    (lambda () (schedule-interrupt 0 1))))))))
-    table))
-
-(define (record-profile-information! k k0-template table)
-  (let ((k1 (continuation-cont (continuation-cont k))))
-    (let ((z (get-counts table k1)))
-      (set-car! z (+ (car z) 1))
-      (set-cdr! z (+ (cdr z) 1)))
-    (do ((k (continuation-parent k1) (continuation-parent k)))
-	((or (not (continuation? k))
-	     (eq? (continuation-template k) k0-template)))
-      (let ((z (get-counts table k)))
-	(set-cdr! z (+ (cdr z) 1))))))
-
-(define (get-counts table k)
-  (let ((info (template-info (continuation-template k))))
-    (or (table-ref table info)
-	(let ((z (cons 0 0)))
-	  (table-set! table info z)
-	  z))))
-
-(define (template-uid info)
-  (cond ((integer? info)
-	 info)
-	((debug-data? info)
-	 (debug-data-uid info))
-	(else 0)))  ;??
-
-(define interrupt-type cadr)
-(define interrupt/alarm (enum interrupt alarm))
-
-(define (dump t)
-  (let ((l '()))
-    (table-walk (lambda (key count)
-		  (let ((dd (if (integer? key)
-				(table-ref debug-data-table key)
-				key)))
-		    (set! l (cons (cons count
-					(if (debug-data? dd)
-					    (debug-data-names dd)
-					    `(? ,key)))
-				  l))))
-		t)
-    (do ((l (sort-list l more-interesting?)
-	    (cdr l))
-	 (i 0 (+ i 1)))
-	((or (null? l) (> i *prefix*)))
-      (let* ((counts+names (car l))
-	     (leaf-count (caar counts+names))
-	     (total-count (cdar counts+names))
-	     (names (cdr counts+names)))
-	(display (pad-left total-count 6)) (display #\space)
-	(display (pad-left leaf-count 6)) (display #\space)
-	(write names)
-	(newline)))))
-
-(define (more-interesting? x y)
-  (let ((c1 (cdar x))
-	(c2 (cdar y)))
-    (or (> c1 c2)
-	(and (= c1 c2)
-	     (> (caar x) (caar y))))))
-
-
-(define *prefix* 60)
-(define (pad-left s n)
-  (let ((s (cond ((number? s) (number->string s))
-		 ((symbol? s) (symbol->string s))
-		 (else s))))
-    (string-append (make-string (- n (string-length s)) #\space)
-		   s)))
diff --git a/scheme/debug/r5-system.scm b/scheme/debug/r5-system.scm
deleted file mode 100644
index 1180133..0000000
--- a/scheme/debug/r5-system.scm
+++ /dev/null
@@ -1,22 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Link script.
-
-(define (link-revised^5-system)
-  (let ((structures-to-open (struct-list scheme)))
-    (link-reified-system structures-to-open
-			 'revised^5
-			 `(start ',(map car structures-to-open))
-			 initial-system
-			 for-reification
-			 ;; Extra stuff (from more-packages.scm)
-			 disclosers
-			 package-mutation shadowing
-			 bignums ratnums floatnums
-			 )))
-
-(define scheme (make-scheme environments evaluation))
-
-(define initial-system
-  (make-initial-system scheme (make-mini-command scheme)))
diff --git a/scheme/debug/read-image.scm b/scheme/debug/read-image.scm
deleted file mode 100644
index 9e2bb19..0000000
--- a/scheme/debug/read-image.scm
+++ /dev/null
@@ -1,223 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-
-;(define-syntax assert
-;  (lambda ignore
-;    ''assert))
-
-(define debugging? #t)
-
-; ,bench
-; ,load rts/defenum.scm
-; ,for-syntax ,load my-vm/for-syntax.scm
-; ,load my-vm/s48-prescheme.scm my-vm/util.scm my-vm/memory.scm
-; ,load my-vm/arch.scm my-vm/data.scm my-vm/struct.scm
-; ,load link/s48-features.scm link/read-image.scm
-; ,load-into extended-numbers misc/bigbit.scm
-
-(define (resume filename arg)
-  (call-startup-procedure (extract (read-image filename)) arg))
-
-(define (call-startup-procedure proc arg)
-  (proc arg (current-input-port) (current-output-port)))
-
-(define level 14)
-
-(define (read-image filename)
-  (call-with-input-file filename
-    (lambda (port)
-      (read-page port) ; read past any user cruft at the beginning of the file
-      (let* ((old-level          (read-number port))
-             (old-bytes-per-cell (read-number port))
-             (old-begin (cells->a-units (read-number port)))
-             (old-hp    (cells->a-units (read-number port)))
-             (startup-proc       (read-number port)))
-        (read-page port)
-        (if (not (= old-level level))
-            (error "format of image is incompatible with this version of system"
-                   old-level level))
-        (if (not (= old-bytes-per-cell bytes-per-cell))
-            (error "incompatible bytes-per-cell"
-                   old-bytes-per-cell bytes-per-cell))
-
-	;; ***CHANGED***
-	(create-memory (a-units->cells (- (addr1+ old-hp) old-begin))
-		       quiescent)
-	(set! *hp* 0)
-
-        (let* ((delta (- *hp* old-begin))
-               (new-hp (+ old-hp delta)))
-	  (let ((reverse? (check-image-byte-order port)))
-	    (read-block port *memory* *hp* (- old-hp old-begin))
-	    (if reverse?
-		(reverse-byte-order new-hp))
-	    (if (= delta 0)
-		(set! *hp* new-hp)
-		(relocate-image delta new-hp))
-	    (set! *extracted* (make-vector (a-units->cells *memory-end*) #f))
-	    (adjust startup-proc delta)))))))
-
-(define (check-image-byte-order port)
-  (read-block port *memory* *hp* (cells->a-units 1))
-  (cond ((= (fetch *hp*) 1)
-	 #f)
-	(else
-	 (reverse-descriptor-byte-order! *hp*)
-	 (if (= (fetch *hp*) 1)
-	     #t
-	     (begin (error "unable to correct byte order" (fetch *hp*))
-		    #f)))))
-
-(define *hp* 0)
-
-(define *extracted* #f)
-
-(define (extract obj)
-  (cond ((vm-fixnum? obj) (extract-vm-fixnum obj))
-	((stob? obj)
-	 (let ((index (a-units->cells (address-after-header obj))))
-	   (or (vector-ref *extracted* index)
-	       (extract-stored-object obj
-				      (lambda (new)
-					(vector-set! *extracted* index new)
-					new)))))
-	((vm-char? obj) (extract-char obj))
-	((vm-eq? obj null) '())
-	((vm-eq? obj false) #f)
-	((vm-eq? obj true) #t)
-	((vm-eq? obj vm-unspecific) (if #f 0))
-	((vm-eq? obj unbound-marker) '<unbound>)
-	((vm-eq? obj unassigned-marker) '<unassigned>)
-	(else (error "random descriptor" obj))))
-
-(define (extract-stored-object old store-new!)
-  ((vector-ref stored-object-extractors (header-type (stob-header old)))
-   old store-new!))
-
-(define stored-object-extractors
-  (make-vector stob-count (lambda rest (apply error "no extractor" rest))))
-
-(define (define-extractor which proc)
-  (vector-set! stored-object-extractors which proc))
-
-(define-extractor stob/pair
-  (lambda (old store-new!)
-    (let ((new (cons #f #f)))
-      (store-new! new)
-      (set-car! new (extract (vm-car old)))
-      (set-cdr! new (extract (vm-cdr old)))
-      new)))
-
-(define-extractor stob/vm-closure
-  (lambda (old store-new!)
-    (store-new! (make-closure (extract (vm-closure-template old))
-			      (extract (vm-closure-env old))))))
-
-(define-extractor stob/symbol
-  (lambda (obj store-new!)
-    (store-new! (string->symbol (extract (vm-symbol->string obj))))))
-
-(define-extractor stob/vm-location
-  (lambda (obj store-new!)
-    (let ((new (store-new! (make-undefined-location
-			        (+ 10000
-				   (extract (vm-location-id obj))))))
-	  (val (vm-contents obj)))
-      (if (not (vm-eq? val unbound-marker))
-	  (begin (set-location-defined?! new #t)
-		 (if (not (vm-eq? val unassigned-marker))
-		     (set-contents! new (extract val)))))
-      new)))
-
-(define-extractor stob/string
-  (lambda (obj store-new!)
-    (store-new! (extract-string obj))))
-
-(define-extractor stob/vm-code-vector
-  (lambda (obj store-new!)
-    (store-new! (extract-code-vector obj))))
-
-(define-extractor stob/vector
-  (lambda (obj store-new!)
-    (let* ((z (vm-vector-length obj))
-	   (v (make-vector z)))
-      (store-new! v)
-      (do ((i 0 (+ i 1)))
-	  ((= i z) v)
-	(vector-set! v i (extract (vm-vector-ref obj i)))))))
-
-;(define-extractor stob/record
-;  (lambda (obj store-new!)
-;    (let* ((z (vm-record-length obj))
-;           (v (make-record z)))
-;      (store-new! v)
-;      (do ((i 0 (+ i 1)))
-;          ((= i z) v)
-;        (record-set! v i (extract (vm-record-ref obj i)))))))
-
-(define-extractor stob/port
-  (lambda (obj store-new!)
-    (store-new!
-     (case (extract-vm-fixnum (port-index obj))
-       ((0) (current-input-port))
-       ((1) (current-output-port))
-       (else (error "unextractable port" obj))))))
-
-
-
-(define (extract-code-vector x)
-  (let ((z (vm-code-vector-length x)))
-    (let ((v (make-code-vector z 0)))
-      (do ((i 0 (+ i 1)))
-          ((>= i z) v)
-        (code-vector-set! v i (vm-code-vector-ref x i))))))
-
-
-
-; Various things copied from vm/gc.scm
-
-(define (store-next! descriptor)
-  (store! *hp* descriptor)
-  (set! *hp* (addr1+ *hp*)))
-
-(define (reverse-descriptor-byte-order! addr)
-  (let ((x (fetch-byte addr)))
-    (store-byte! addr (fetch-byte (addr+ addr 3)))
-    (store-byte! (addr+ addr 3) x))
-  (let ((x (fetch-byte (addr+ addr 1))))
-    (store-byte! (addr+ addr 1) (fetch-byte (addr+ addr 2)))
-    (store-byte! (addr+ addr 2) x)))
-
-(define (reverse-byte-order end)
-  (write-string "Correcting byte order of resumed image."
-		 (current-output-port))
-  (newline (current-output-port))
-  (let loop ((ptr *hp*))
-    (reverse-descriptor-byte-order! ptr)
-    (let ((value (fetch ptr)))
-      (if (addr< ptr end)
-	  (loop (if (b-vector-header? value)
-		    (addr+ (addr1+ ptr) (header-a-units value))
-		    (addr1+ ptr)))))))
-
-(define (adjust descriptor delta)
-  (if (stob? descriptor)
-      (make-stob-descriptor (addr+ (address-after-header descriptor) delta))
-      descriptor))
-
-(define (relocate-image delta new-hp)
-  (let loop ()
-    (cond ((addr< *hp* new-hp)
-	   (let ((d (adjust (fetch *hp*) delta)))
-	     (store-next! d)
-	     (cond ;;((eq? d the-primitive-header)
-	       ;; Read symbolic label name.
-	       ;;(store-next!
-	       ;;  (label->fixnum (name->label (read port)))))
-	       ((b-vector-header? d)
-		(set! *hp* (addr+ *hp*
-				  (cells->bytes
-				   (bytes->cells
-				    (header-length-in-bytes d)))))))
-	     (loop))))))
diff --git a/scheme/debug/run.scm b/scheme/debug/run.scm
deleted file mode 100644
index c761356..0000000
--- a/scheme/debug/run.scm
+++ /dev/null
@@ -1,281 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; These are the four entry points (cf. rts/eval.scm):
-
-; EVAL
-
-(define (eval form package)
-  (compile-and-run (list form) package #f))
-
-; LOAD-INTO - load file into package.
-
-(define (load-into filename package)
-  (compile-and-run (read-forms filename package)
-		   package
-		   filename))
-
-; Evaluate forms as if they came from the given file.
-
-(define (eval-from-file forms package filename)
-  (if filename
-      ((fluid $note-file-package)
-        filename package))
-  (compile-and-run forms package filename))
-
-; LOAD
-
-(define (load filename . package-option)
-  (let ((package (if (null? package-option)
-		     (interaction-environment)
-		     (car package-option))))
-    (load-into filename package)))
-
-;----------------
-
-(define (compile-and-run forms package maybe-filename)
-  (let* ((env (if maybe-filename
-		  (bind-source-file-name maybe-filename
-					 (package->environment package))
-		  (package->environment package)))
-	 (nodes (map (lambda (form)
-		       (expand-scanned-form form env))
-		     (scan-forms forms env))))
-    (if (not (null? nodes))
-	(run-nodes nodes env))))
-
-(define (run-nodes nodes env)
-  (do ((nodes nodes (cdr nodes)))
-      ((null? (cdr nodes))
-       (run-node (car nodes) env))
-    (run-node (car nodes) env)))
-
-(define (run-node node env)
-  (cond ((define-node? node)
-	 (let* ((form (node-form node))
-		(loc (binding-place (lookup env (cadr form))))
-		(value (run (caddr form) env)))
-	   (set-location-defined?! loc #t)
-	   (set-contents! loc value)))
-	((not (define-syntax-node? node))
-	 (run node env))))
-
-; Main dispatch for a single expression.
-
-(define (run node env)
-  ((operator-table-ref interpreters (node-operator-id node))
-     node
-     env))
-
-(define interpreters
-  (make-operator-table (lambda (node env)
-			 (run-call (node-form node) env))))
-
-(define (define-interpreter name type proc)
-  (operator-define! interpreters name type proc))
-
-(define-interpreter 'name #f
-  (lambda (node env)
-    (let ((binding (name-node-binding node env)))
-      (cond ((binding? binding)
-	     (if (and (compatible-types? (binding-type binding) value-type)
-		      (location? (binding-place binding)))
-		 (let ((loc (binding-place binding)))
-		   (if (location-defined? loc)
-		       (contents loc)
-		       (error "uninitialized variable" (schemify node env))))
-		 (error "invalid variable reference" (schemify node env))))
-	    ((unbound? binding)
-	     (error "unbound variable" (schemify node env)))
-	    (else
-	     (error "peculiar binding" node binding))))))
-
-(define (name-node-binding node env)
-  (or (node-ref node 'binding)
-      (lookup env (node-form node))))
-
-(define-interpreter 'literal #f
-  (lambda (node env)
-    (node-form node)))
-
-(define-interpreter 'call #f
-  (lambda (node env)
-    (run-call (node-form node) env)))
-
-(define (run-call exp env)
-  (let ((proc (run (car exp) env)))	;Doing this first aids debugging
-    (apply proc
-	   (map (lambda (arg-exp)
-		  (run arg-exp env))
-		(cdr exp)))))
-
-(define-interpreter 'quote syntax-type
-  (lambda (node env)
-    (cadr (node-form node))))
-
-(define-interpreter 'lambda syntax-type
-  (lambda (node env)
-    (let ((exp (node-form node)))
-      (make-interpreted-closure (cadr exp) (cddr exp) env))))
-
-(define (make-interpreted-closure formals body env)
-  (lambda args
-    (run-body body (bind-vars formals args env))))
-
-(define (run-body body env)
-  (scan-body
-      body
-      env
-      (lambda (defs exps)
-	(if (null? defs)
-	    (run-begin exps env)
-	    (run-letrec (map (lambda (def) (cdr (node-form def))) defs)
-			exps
-			env)))))
-
-
-(define-interpreter 'begin syntax-type
-  (lambda (node env)
-    (let ((exp (node-form node)))
-      (run-begin (cdr exp) env))))
-
-(define (run-begin exp-list env)
-  (if (null? exp-list)
-      (syntax-error "null begin")
-      (let loop ((exp-list exp-list))
-	(if (null? (cdr exp-list))
-	    (run (car exp-list) env)
-	    (begin (run (car exp-list) env)
-		   (loop (cdr exp-list)))))))
-
-(define-interpreter 'set! syntax-type
-  (lambda (node env)
-    (let* ((exp (node-form node))
-	   (probe (name-node-binding (cadr exp) env)))
-      (cond ((and (binding? probe)
-		  (location? (binding-place probe)))
-	     (if (and (location-defined? (binding-place probe))
-		      (variable-type? (binding-type probe)))
-		 (set-contents! (binding-place probe)
-				(run (caddr exp) env))
-		 (error "invalid assignment" (schemify node env))))
-	    ((unbound? probe) (error "unbound variable" exp))
-	    (else (error "peculiar assignment" exp))))))
-
-(define-interpreter 'if syntax-type
-  (lambda (node env)
-    (let ((exp (node-form node)))
-      (if (null? (cdddr exp))
-	  (if (run (cadr exp) env)
-	      (run (caddr exp) env))	;hack
-	  (if (run (cadr exp) env)
-	      (run (caddr exp) env)
-	      (run (cadddr exp) env))))))
-
-; (reverse specs) in order to try to catch unportabilities
-
-(define-interpreter 'letrec syntax-type
-  (lambda (node env)
-    (let ((exp (node-form node)))
-      (run-letrec (cadr exp) (cddr exp) env))))
-
-(define (run-letrec specs body env)
-  (let* ((bindings (map (lambda (spec)
-			  (make-binding usual-variable-type
-					(make-undefined-location (car spec))
-					#f))
-			specs))
-	 (env (bind (map car specs)
-		    bindings
-		    env)))
-    (for-each (lambda (binding val)
-		(let ((loc (binding-place binding)))
-		  (set-location-defined?! loc #t)
-		  (set-contents! loc val)))
-	      bindings
-	      (map (lambda (spec) (run (cadr spec) env)) specs))
-    (run-body body env)))
-
-
-(let ((bad (lambda (node env)
-	     (error "not valid in expression context" (node-form node)))))
-  (define-interpreter 'define syntax-type bad)
-  (define-interpreter 'define-syntax syntax-type bad))
-
-
-; Primitive procedures
-
-(define-interpreter 'primitive-procedure syntax-type
-  (lambda (node env)
-    (let ((name (cadr (node-form node))))
-      (or (table-ref primitive-procedures name)
-	  (lambda args
-	    (error "unimplemented primitive procedure" name))))))
-
-(define primitive-procedures (make-table))
-
-(define (define-a-primitive name proc)
-  (table-set! primitive-procedures name proc)
-  (define-interpreter name any-procedure-type
-    (lambda (node env)
-      (apply proc (map (lambda (arg) (run arg env))
-		       (cdr (node-form node)))))))
-
-(define-a-primitive 'unspecific
-  (lambda () (if #f #f)))		;For COND
-
-(define-syntax define-some-primitives
-  (syntax-rules ()
-    ((define-some-primitives name ...)
-     (begin (define-a-primitive 'name name) ...))))
-
-(define-some-primitives
-  + - * quotient remainder = <
-  eq? car cdr cons
-  pair?
-  vector? vector-ref string? string-ref
-  symbol?
-  char<? char=?)
-
-
-; --------------------
-; Environments
-
-(define (bind-var name arg env)
-  (let ((loc (make-undefined-location name)))
-    (set-location-defined?! loc #t)
-    (set-contents! loc arg)
-    (bind1 name (make-binding usual-variable-type loc #f) env)))
-
-(define (bind-vars names args env)
-  (cond ((null? names)
-	 (if (null? args)
-	     env
-	     (error "too many arguments" args)))
-	((not (pair? names))
-	 (bind-var names args env))
-	((null? args)
-	 (error "too few arguments" names))
-	(else
-	 (bind-var (car names) (car args)
-		   (bind-vars (cdr names) (cdr args) env)))))
-
-
-; LOAD
-
-(define (load filename . package-option)
-  (load-into filename (if (null? package-option)
-			  (interaction-environment)
-			  (car package-option))))
-
-(define (load-into filename package)
-  (eval-nodes (read-forms filename package)
-	      (package->environment package)
-	      filename))
-
-
-(define (eval-from-file forms package file)	;Scheme 48 internal thing
-  (eval-forms forms package file))
-
-
-; (scan-structures (list s) (lambda (p) #t) (lambda (stuff) #f))
diff --git a/scheme/debug/small-packages.scm b/scheme/debug/small-packages.scm
deleted file mode 100644
index 76a884a..0000000
--- a/scheme/debug/small-packages.scm
+++ /dev/null
@@ -1,8 +0,0 @@
-; no copyright
-
-; (link-simple-system '(debug small) 'start tiny-system)
-
-(define-structure small-system (export start)
-  (define-all-operators)
-  (usual-transforms and cond do let let* or)
-  (files (rts defenum) (rts arch) (debug small)))
diff --git a/scheme/debug/small.scm b/scheme/debug/small.scm
deleted file mode 100644
index 96eda0c..0000000
--- a/scheme/debug/small.scm
+++ /dev/null
@@ -1,153 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Minimal full-I/O test system
-
-(define (start arg in-channel out-channel error-channel)
-  (set! *error-channel* error-channel)
-  (set-exception-handlers! exception-handlers)
-  (let* ((ch (open-channel "small-test.image"
-			   (enum open-channel-option input-file)))
-	 (out (output-channel->port out-channel))
-	 (in (input-channel->port in-channel)))
-    (write-string "Hello " out)
-    (collect)
-    (if (< 0 (vector-length arg))
-	(write-block (vector-ref arg 0)
-		     0
-		     (string-length (vector-ref arg 0))
-		     out))
-    (newline out)
-    (force-output out)
-    (let ((b (make-string 12 #\space)))
-      (channel-read b 0 12 ch)
-      (close-channel ch)
-      (write-string b out)
-      (newline out)
-      (force-output out))
-    (write-string "Eight chars> " out)
-    (force-output out)
-    (do ((i 0 (+ i 1)))
-	((= i 8))
-      (write-char (peek-char in) out)
-      (read-char in))
-    (newline out)
-    (force-output out)
-    (write-image "small-test.image" start "A small image")
-    0))
-
-(define buffer-size 4)  ; for testing
-
-(define (output-channel->port channel)
-  (make-port #f
-	     (bitwise-ior (arithmetic-shift 1 (enum port-status-options
-						    output))
-			  (arithmetic-shift 1 (enum port-status-options
-						    open-for-output)))
-	     channel
-	     #f #f #f ; input stuff
-	     (make-code-vector buffer-size 0)
-	     0))
-
-(define (input-channel->port channel)
-  (make-port #f
-	     (bitwise-ior (arithmetic-shift 1 (enum port-status-options
-						    input))
-			  (arithmetic-shift 1 (enum port-status-options
-						    open-for-input)))
-	     channel
-	     (make-code-vector buffer-size 0)
-	     0
-	     0
-	     #f #f))  ; ouput stuff
-
-(define *error-channel* #f)
-
-(define (error string . stuff)
-  (channel-write-string string *error-channel*)
-  (channel-newline *error-channel*)
-  (exit -1))
-
-(define (message string)
-  (channel-write-string string *error-channel*)
-  (channel-newline *error-channel*))
-
-(define (channel-write-string string channel)
-  (channel-write string
-		 0
-		 (string-length string)
-		 channel))
-
-(define (channel-newline channel)
-  (channel-write-string "
-" channel))
-
-(define (define-exception-handler opcode proc)
-  (vector-set! exception-handlers opcode proc))
-
-(define exception-handlers
-  (make-vector op-count #f))
-
-(define-exception-handler (enum op write-char)
-  (lambda (opcode reason char port)
-    (cond ((= reason (enum exception buffer-full/empty))
-	   (force-output port)
-	   (message "[overflow]")
-	   (write-char char port))
-	  (else
-	   (apply signal-exception opcode reason args)))))
-
-(define-exception-handler (enum op read-char)
-  (lambda (opcode reason port)
-    (cond ((= reason (enum exception buffer-full/empty))
-	   (fill-buffer port)
-	   (message "[underflow]")
-	   (read-char port))
-	  (else
-	   (apply signal-exception opcode reason args)))))
-
-(define-exception-handler (enum op peek-char)
-  (lambda (opcode reason port)
-    (cond ((= reason (enum exception buffer-full/empty))
-	   (fill-buffer port)
-	   (message "[underflow]")
-	   (peek-char port))
-	  (else
-	   (apply signal-exception opcode reason args)))))
-
-(define-exception-handler (enum op write-block)
-  (lambda (opcode reason thing start count port)
-    (cond ((= reason (enum exception buffer-full/empty))
-	   (force-output port)
-	   (write-buffer thing start count (port-data port)))
-	  (else
-	   (apply signal-exception opcode reason args)))))
-
-(define (force-output port)
-  (write-buffer (port-out-buffer port) 0 (port-out-index port) (port-data port))
-  (set-port-out-index! port 0))
-
-(define (write-buffer buffer start count channel)
-  (let loop ((start start) (count count))
-    (let ((sent (channel-write buffer start count channel)))
-      (if (< sent count)
-	  (loop (+ start sent) (- count sent))))))
-
-(define (fill-buffer port)
-  (let ((got (channel-read (port-in-buffer port)
-			   0
-			   (code-vector-length (port-in-buffer port))
-			   (port-data port))))
-    (cond ((= got 0)
-	   (fill-buffer port))
-	  (else
-	   (set-port-in-index! port 0)
-	   (set-port-in-limit! port got)))))
-
-(define (write-string string port)
-  (let ((l (string-length string)))
-    (do ((i 0 (+ i 1)))
-	((= i l))
-      (write-char (string-ref string i) port))))
-
-(define (newline port)
-  (write-char #\newline port))
diff --git a/scheme/debug/spatial-hack.scm b/scheme/debug/spatial-hack.scm
deleted file mode 100644
index d0395c2..0000000
--- a/scheme/debug/spatial-hack.scm
+++ /dev/null
@@ -1,63 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; load into initial image
-
-(init-defpackage! eval
-		  (lambda ()
-		    (delay (make-simple-package (list scheme-level-1)
-						#t (delay #f) 'for-syntax))))
-
-(define-structures ((assembler (export (lap syntax))))
-  (open scheme-level-2 compiler architecture
-	signals				;error
-	enumerated			;name->enumerand
-	code-vectors
-	locations)			;location?
-  (specials lap)
-  (files (env assem)))
-
-(ensure-loaded assembler)
-
-(define-structures ((spatial (export space init-space)))
-   (open scheme-level-2 architecture primitives packages)
-   (files (debug space)))
-
-(ensure-loaded spatial)
-
-((*structure-ref spatial 'init-space) eval assembler)
-
-(define-interface define-record-types-interface
-  (export (define-record-type syntax)
-	  define-record-discloser))
-(define-structures ((define-record-types define-record-types-interface))
-  (open scheme-level-1 record)
-  (files (rts jar-defrecord)))
-(define-interface queue-interface
-  (export make-queue enqueue! dequeue! queue-empty?
-	  queue? queue->list queue-length delete-from-queue!))
-(define-structures ((queues queue-interface))
-  (open scheme-level-1 define-record-types signals)
-  (files (big queue))
-  (optimize auto-integrate))
-(define-structure traverse
-    (export traverse-depth-first traverse-breadth-first trail
-	    set-leaf-predicate! usual-leaf-predicate)
-  (open scheme-level-2
-	primitives			; ?
-	queues table
-	bitwise locations closures code-vectors
-	features			; string-hash
-	low-level)			; flush-the-symbol-table!
-  (files (env traverse)))
-
-(ensure-loaded traverse)
-
-(define foo
-  (make-simple-package (list scheme-level-2
-			     spatial traverse vm-exposure)
-		       eval (delay #f) 'foo))
-
-; (define command-processor (*structure-ref command 'command-processor))
-
-; (set-interaction-environment! foo)
diff --git a/scheme/debug/test-generic.scm b/scheme/debug/test-generic.scm
deleted file mode 100644
index 31c138b..0000000
--- a/scheme/debug/test-generic.scm
+++ /dev/null
@@ -1,34 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-(define g-methods (make-method-table 'g))
-
-(define g (make-generic g-methods))
-
-(define foo-family (make-family 'foo 1))
-
-(define-method g-methods foo-family
-  (lambda (x)
-    (if (even? x)
-	'win
-	(fail))))
-
-(define bar-family (make-family 'bar 2))  ;More specific
-
-(define-method g-methods bar-family
-  (lambda (x)
-    (case x
-      ((1 3 5) 'ok)
-      (else (fail)))))
-
-(define-method g-methods (make-family 'baz 2)  ;Same priority as bar-family
-  (lambda (x)
-    (case x
-      ((3) 'great)
-      (else (fail)))))
-
-; (g 0) => 'win
-; (g 1) => 'ok
-; (g 3) => 'great
-; (g 9) => error
-
diff --git a/scheme/debug/test-methods.scm b/scheme/debug/test-methods.scm
deleted file mode 100644
index 10c4c06..0000000
--- a/scheme/debug/test-methods.scm
+++ /dev/null
@@ -1,37 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-(define-generic g &g)
-
-(define-method &g ((x :number)) 'win)
-
-(define-method &g ((n :integer))
-  (if (= n 13)
-      (next-method)
-      'ok))
-
-(define-method &g ((s :symbol))
-  (if (= s 13)
-      (next-method)
-      'ok))
-
-; (g 1/2) => 'win
-; (g 10) => 'ok
-; (g 13) => 'win
-
-
-(define-generic elt &elt)
-
-(define-method &elt ((x :vector) y)
-  (vector-ref x y))
-
-(define-method &elt ((x :string) y)
-  (string-ref x y))
-
-(define-method &elt ((x :list) y)
-  (list-ref x y))
-
-; Generic length
-
-; (define-generic-function glength ((s :sequence)))
-
diff --git a/scheme/debug/test.scm b/scheme/debug/test.scm
deleted file mode 100644
index 6d0cde3..0000000
--- a/scheme/debug/test.scm
+++ /dev/null
@@ -1,34 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; ,config ,load debug/test.scm
-
-(define-structure testing (export (test :syntax) lost?)
-  (open scheme signals handle conditions)
-  (begin
-
-(define *lost?* #f)
-(define (lost?) *lost?*)
-
-(define (run-test string compare want thunk)
-  (let ((result
-	 (call-with-current-continuation
-	   (lambda (k)
-	     (with-handler (lambda (condition punt)
-			     (if (error? condition)
-				 (k condition)
-				 (punt)))
-	       thunk)))))
-    (if (not (compare want result))
-	(begin (display "Test ") (write string) (display " failed.") (newline)
-	       (display "Wanted ") (write want)
-	       (display ", but got ") (write result) (display ".")
-	       (newline)
-	       (set! *lost?* #t)))))
-
-(define-syntax test
-  (syntax-rules ()
-    ((test ?string ?compare ?want ?exp)
-     (run-test ?string ?compare ?want (lambda () ?exp)))))
-
-))
diff --git a/scheme/debug/thread-socket.scm b/scheme/debug/thread-socket.scm
deleted file mode 100644
index 576f6e5..0000000
--- a/scheme/debug/thread-socket.scm
+++ /dev/null
@@ -1,60 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Code to check the interaction between threads and sockets.
-
-(define (run-server)
-  (with-multitasking server))
-
-(define (server)
-  (call-with-values socket-server
-    (lambda (port-number accept)
-      (display "Port number is ") (write port-number) (newline)
-      (let loop ()
-	(call-with-values accept
-	  (lambda (i-port o-port)
-	    (spawn (service i-port o-port))
-	    (loop)))))))
-
-(define (service i-port o-port)
-  (lambda ()
-    (let loop ((total 0))
-      (let ((next (read i-port)))
-	(cond ((eof-object? next)
-	       (close-input-port i-port)
-	       (close-output-port o-port))
-	      (else
-	       (let ((total (+ total next)))
-		 (write total o-port)
-		 (newline o-port)
-		 (loop total))))))))
-
-(define (run-users machine port-number . data)
-  (with-multitasking
-   (lambda ()
-     (do ((i 0 (+ i 1))
-	  (d data (cdr d)))
-	 ((null? d))
-       (let ((l (car d)))
-	 (spawn (lambda ()
-		  (user (make-name i) (car l) (cadr l) machine port-number))))))))
-
-(define (make-name i)
-  (list->string (list (string-ref "ABCDEFGHIJKLMNOPQRSTUVWXYZ" i))))
-
-(define (user id count delay machine port-number)
-  (call-with-values
-   (lambda ()
-     (socket-client machine port-number))
-   (lambda (i-port o-port)
-     (let loop ((count count))
-       (cond ((= 0 count)
-	      (close-input-port i-port)
-	      (close-output-port o-port))
-	     (else
-	      (write 1 o-port)
-	      (newline o-port)
-	      (for-each display (list id " got " (read i-port)))
-	      (newline)
-	      (sleep delay)
-	      (loop (- count 1))))))))
diff --git a/scheme/debug/tiny-packages.scm b/scheme/debug/tiny-packages.scm
deleted file mode 100644
index 69fe8c1..0000000
--- a/scheme/debug/tiny-packages.scm
+++ /dev/null
@@ -1,7 +0,0 @@
-; no copyright
-
-; (link-simple-system '(debug tiny) 'start tiny-system)
-
-(define-structure tiny-system (export start)
-  (define-all-operators)
-  (files tiny))
diff --git a/scheme/debug/tiny.scm b/scheme/debug/tiny.scm
deleted file mode 100644
index 2640dcc..0000000
--- a/scheme/debug/tiny.scm
+++ /dev/null
@@ -1,66 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Tiny image and simple I/O test system
-
-; This prints `Hello' and the first command argument, if any, then reads
-; a line from standard input and prints it to standard output.
-
-(define (start arg in out error-out resumer-records)
-  (write-string "Hello " out)
-  (if (vector? arg)
-      (if (< 0 (vector-length arg))
-	  (write-string (vector-ref arg 0) out)))
-  (collect)
-  (collect)
-  (newline out)
-  (write-string (read-string in) out)
-  (newline out)
-  0)
-
-(define first? #t)
-
-(define (write-string string . channel-option)  ; test n-ary procedures
-  (channel-maybe-write string
-		       0
-		       (string-length string)
-		       (car channel-option)))
-
-(define (newline channel)
-  (write-string "
-" channel))
-
-(define (read-string in)
-  ((lambda (buffer)
-     (letrec ((loop (lambda (have)
-		      ((lambda (got)
-			 (if (eq? got (eof-object))
-			     "eof"
-			     ((lambda (len)
-				(if len
-				    ((lambda (string)
-				       (copy-string! buffer string len)
-				       string)
-				     (make-string len #\space))
-				    (loop (+ have got))))
-			      (has-newline buffer have got))))
-		       (channel-maybe-read buffer have (- 80 have) #f in)))))
-       (loop 0)))
-   (make-string 80 #\space)))
-
-(define (has-newline string start count)
-  (letrec ((loop (lambda (i)
-		   (if (= i count)
-		       #f
-		       (if (char=? #\newline
-				   (string-ref string (+ start i)))
-			   (+ start i)
-			   (loop (+ i 1)))))))
-    (loop 0)))
-
-(define (copy-string! from to count)
-  (letrec ((loop (lambda (i)
-		   (if (< i count)
-		       (begin
-			 (string-set! to i (string-ref from i))
-			 (loop (+ i 1)))))))
-    (loop 0)))
diff --git a/scheme/debug/vector-space.scm b/scheme/debug/vector-space.scm
deleted file mode 100644
index c6c5756..0000000
--- a/scheme/debug/vector-space.scm
+++ /dev/null
@@ -1,132 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-
-; ,open architecture primitives low-level locations debug-data syntactic
-
-; July 5th
-;total number of 3-vectors: 10896
-;probably table entries: 10381
-;symbol keys: 7363
-;integer keys: 3018
-;symbol values: 3793
-;location values: 2062
-;pair values: 1723
-;operator values: 989
-;debug-data values: 1208
-;transform values: 510
-;            pair   4039   48468
-;          symbol   1067    8536
-;          vector   4477  124132
-;         closure   1541   18492
-;        location    807    9684
-;            port      2      40
-;           ratio      0       0
-;          record    579   16732
-;    continuation      6     136
-; extended-number      0       0
-;        template    985   23916
-;    weak-pointer     33     264
-;        external      0       0
-;unused-d-header1      0       0
-;unused-d-header2      0       0
-;          string   1207   19338
-;     code-vector    986   51097
-;          double      0       0
-;          bignum      0       0
-;           total  15729  320835
-
-
-(define (analyze-3-vectors)
-  (collect)
-  (let ((vs (find-all (enum stob vector)))
-	(total 0)
-	(table-entries 0)
-	(symbol-keys 0)
-	(int-keys 0)
-	(symbols 0)
-	(locations 0)
-	(debug-datas 0)
-	(pairs 0)
-	(operators 0))
-    (set! *foo* '())
-    (vector-for-each
-     (lambda (v)
-       (if (= (vector-length v) 3)
-	   (let ((x (vector-ref v 2)))
-	     (set! total (+ total 1))
-	     (cond ((or (vector? x) (eq? x #f))
-		    (set! table-entries (+ table-entries 1))
-		    (let ((key (vector-ref v 0)))
-		      (cond ((symbol? key)
-			     (set! symbol-keys (+ symbol-keys 1)))
-			    ((integer? key)
-			     (set! int-keys (+ int-keys 1)))))
-		    (let ((val (vector-ref v 1)))
-		      (cond ((symbol? val)
-			     (set! symbols (+ symbols 1)))
-			    ((location? val)
-			     (set! locations (+ locations 1)))
-			    ((pair? val)
-			     (set! pairs (+ pairs 1)))
-			    ((transform? val)
-			     (set! operators (+ operators 1)))
-			    ((debug-data? val)
-			     (set! debug-datas (+ debug-datas 1)))
-			    (else (set! *foo* (cons v *foo*))))))))))
-     vs)
-    (display "total number of 3-vectors: ") (write total) (newline)
-    (display "probably table entries: ") (write table-entries) (newline)
-    (display "symbol keys: ") (write symbol-keys) (newline)
-    (display "integer keys: ") (write int-keys) (newline)
-    (display "symbol values: ") (write symbols) (newline)
-    (display "location values: ") (write locations) (newline)
-    (display "pair values: ") (write pairs) (newline)
-    (display "transform values: ") (write operators) (newline)
-    (display "debug-data values: ") (write debug-datas) (newline)))
-
-(define *foo* '())
-
-(define (bar)
-  (collect)
-  (vector-size-histogram (find-all (enum stob vector))))
-
-(define (vector-size-histogram vs)
-  (write (vector-length vs)) (display " vectors") (newline)
-  (let ((n 0))
-    (vector-for-each (lambda (v)
-		       (if (eq? v vs) 'foo
-			   (if (> (vector-length v) n)
-			       (set! n (vector-length v)))))
-		     vs)
-    (display "longest: ") (write n) (newline)
-    (let ((hist (make-vector (+ n 1) 0)))
-      (vector-for-each (lambda (v)
-			 (let ((l (vector-length v)))
-			   (vector-set! hist l (+ (vector-ref hist l) 1))))
-		       vs)
-      (let loop ((i 0))
-	(if (< i n)
-	    (let ((m (vector-ref hist i)))
-	      (if (> m 0)
-		  (begin (write-padded i 6)
-			 (write-padded m 7)
-			 (write-padded (* (+ (* i m) 1) 4) 7)
-			 (newline)))
-	      (loop (+ i 1))))))))
-
-(define (write-padded x pad)
-  (let ((s (if (symbol? x)
-	       (symbol->string x)
-	       (number->string x))))
-    (do ((i (- pad (string-length s)) (- i 1)))
-	((<= i 0) (display s))
-      (write-char #\space))))
-
-
-(define (vector-for-each proc v)
-  (let ((z (vector-length v)))
-    (do ((i (- z 1) (- i 1)))
-	((< i 0) #f)
-      (if (not (vector-unassigned? v i))
-	  (proc (vector-ref v i))))))
diff --git a/scheme/debug/wind-test.scm b/scheme/debug/wind-test.scm
deleted file mode 100644
index de44e93..0000000
--- a/scheme/debug/wind-test.scm
+++ /dev/null
@@ -1,52 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-"
-The correct output looks something like this:
-
-wind-1  f: 1
-wind-2  f: 2
-before-throw-out  f: 3
-unwind-2  f: 2
-unwind-1  f: 1
-after-throw-out  f: top
-wind-1  f: 1
-wind-2  f: 2
-after-throw-in  f: 3
-unwind-2  f: 2
-unwind-1  f: 1
-done  f: top
-"
-
-(define (wind-test)
-  (let* ((f (make-fluid 'top))
-	 (report (lambda (foo)
-		   (write foo)
-		   (display "  f: ")
-		   (write (fluid f))
-		   (newline))))
-    ((call-with-current-continuation
-       (lambda (k1)
-	 (let-fluid f 1
-	   (lambda ()
-	     (dynamic-wind
-	      (lambda () (report 'wind-1))
-	      (lambda ()
-		(let-fluid f 2
-		  (lambda ()
-		    (dynamic-wind
-		     (lambda () (report 'wind-2))
-		     (lambda ()
-		       (let-fluid f 3
-			 (lambda ()
-			   (report 'before-throw-out)
-			   (call-with-current-continuation
-			     (lambda (k2)
-			       (k1 (lambda ()
-				     (report 'after-throw-out)
-				     (k2 #f)))))
-			   (report 'after-throw-in)
-			   (lambda () (report 'done)))))
-		     (lambda () (report 'unwind-2))))))
-	      (lambda () (report 'unwind-1))))))))))
-
diff --git a/scheme/env/assem.scm b/scheme/env/assem.scm
deleted file mode 100644
index 4cb16a8..0000000
--- a/scheme/env/assem.scm
+++ /dev/null
@@ -1,420 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Byte-code assembler (Richard's version)
-;
-; This assembler can assemble the output of the disassembler (as long as you
-; add the identifier and the list of free names).
-;
-; (lap <identifier> (<free name> ...) <insts>*)
-; <inst> ::= (<op-code> . <operands>) |
-;            <label> |
-;            (global <identifier>) |
-;            (set-global! <identifier>) |
-;            (local <identifer>) |
-;            (set-local! <identifier>) |
-;            (literal <anything>) | (literal (quote <anything>)) |
-;            (computed-goto <label>* <default-label>)  ; not yet implemented
-; <operand> ::= <number> | <label> | <stob-name> |
-;               (lap <spec> <insts>*) ; only where a template is expected
-;
-; (<free name> ...) is a list of all names used in GLOBAL and SET-GLOBAL!
-; instructions.  These names are required.
-;              
-; QUOTE is optional for literals, unless the value is itself quoted.
-;
-; The assembler uses opcode-arg-specs to check the number and type of arguments
-; to the opcodes.
-
-; ENV is an a-list mapping names to bindings.
-
-(define-compilator 'lap syntax-type
-  (lambda (node level depth cont)
-    (let* ((exp (node-form node))
-	   (bindings (map (lambda (name-node)
-			    (cons (node-form name-node)
-				  (node-ref name-node 'binding)))
-			  (caddr exp)))
-	   (template (compile-lap (cadr exp)
-				  (cdddr exp)
-				  bindings)))
-      (fixup-template-refs! template)
-      (deliver-value (instruction-with-literal (enum op closure) template 0)
-		     cont))))
-
-;----------------
-; To allow for circular templates, templates can be referred to by name
-; (the <identifier> in <spec> above).  This code fixes up the references
-; after assembly is otherwise complete.
-; 
-; The first LABEL recursively finds all named templates.  The second
-; replaces template markers with the appropriate template.
-
-(define (fixup-template-refs! template)
-  (let ((templates '()))
-    (let label ((template template))
-      (if (symbol? (template-info template))
-	  (set! templates (cons (cons (template-info template) template)
-				templates)))
-      (do ((i 0 (+ i 1)))
-	  ((>= i (template-length template)))
-	(if (template? (template-ref template i))
-	    (label (template-ref template i)))))
-    (let label ((template template))
-      (do ((i 0 (+ i 1)))
-	  ((>= i (template-length template)))
-	(let ((x (template-ref template i)))
-	  (cond ((template? x)
-		 (label x))
-		((not (template-marker? x)))
-		((assq (template-marker-name x) templates)
-		 => (lambda (t)
-		      (template-set! template i (cdr t))))
-		(else
-		 (error "no template of this name available"
-			(template-marker-name x)))))))))
-
-; Marking where a template should be inserted.
-
-(define template-marker (cons #f #f))
-
-(define (make-template-marker name)
-  (cons template-marker name))
-
-(define (template-marker? x)
-  (and (pair? x)
-       (eq? (car x) template-marker)))
-
-(define template-marker-name cdr)
-
-;----------------
-
-(define (compile-lap id insts bindings)
-  (segment->template (really-compile-lap insts bindings) id #f #f))
-    
-; Assemble each instruction, keeping track of which ones use labels.
-; STUFF is a list of lists of the form (<inst> <offset> . <preceding-insts>)
-; which indicates that <inst> uses a label, that it begins at <offset>, and is
-; preceded by <preceding-insts>.
-
-(define (really-compile-lap insts bindings)
-  (let loop ((insts insts) (segments '()) (stuff '()) (offset 0) (labels '()))
-    (cond ((null? insts)
-	   (fixup-lap-labels segments stuff labels))
-	  ((pair? (car insts))
-	   (call-with-values
-	    (lambda ()
-	      (assemble-instruction (car insts) bindings))
-	    (lambda (segment label-use?)
-	      (let ((new-offset (+ offset (segment-size segment))))
-		(if label-use?
-		    (loop (cdr insts)
-			  '()
-			  `((,(car insts) ,offset . ,segments) . ,stuff)
-			  new-offset
-			  labels)
-		    (loop (cdr insts)
-			  (cons segment segments)
-			  stuff
-			  new-offset
-			  labels))))))
-	  ((or (symbol? (car insts))
-	       (integer? (car insts)))
-	   (loop (cdr insts) segments stuff offset
-		 (cons (cons (car insts) offset) labels)))
-	  (else
-	   (error "bad LAP instruction" (car insts))))))
-
-; Reassemble the instruction at the beginning of each STUFF list to resolve
-; the label reference and glue everything together using SEQUENTIALLY.  The
-; label code assumes that the machine calculates the label from the end of
-; the instruction.
-
-(define (fixup-lap-labels segments stuff labels)
-  (let loop ((stuff stuff) (segment (apply sequentially (reverse segments))))
-    (if (null? stuff)
-	segment
-	(let* ((data (car stuff))
-	       (inst (car data))
-	       (offset (cadr data))
-	       (segments (cddr data)))
-	  (loop (cdr stuff)
-		(sequentially (apply sequentially (reverse segments))
-			      (reassemble-instruction inst offset labels)
-			      segment))))))
-
-; This returns two values, the assembled instruction and a flag indicating
-; whether or not the instruction used a label.
-
-(define (assemble-instruction inst bindings)
-  (really-assemble-instruction inst bindings (lambda (label) (values 0 0))))
-
-; Same as the above, except that labels are resolved and no flag is returned.
-
-(define (reassemble-instruction inst offset labels)
-  (call-with-values
-   (lambda ()
-     (really-assemble-instruction inst #f (resolve-label offset labels)))
-   (lambda (inst ignore)
-     inst)))
-
-; Return the high and low bytes of the distance between OFFSET and LABEL,
-; using the known label offsets in LABELS.
-
-(define (resolve-label offset labels)
-  (lambda (label)
-    (cond ((assoc label labels)
-	   => (lambda (p)
-		(let ((delta (- (cdr p) offset)))
-		  (values (quotient delta byte-limit)
-			  (remainder delta byte-limit)))))
-	  (else
-	   (error "LAP label is not defined" label)))))
-
-;----------------
-; Actually do some assembly.  A few opcodes need special handling; most just
-; use the argument specifications from the architecture.
-
-(define (really-assemble-instruction inst bindings labels)
-  (let ((opname (car inst))
-	(args (cdr inst)))
-    (cond ((assemble-special-op opname args bindings)
-	   => (lambda (inst)
-		(values inst #f)))
-	  ((name->enumerand opname op)
-	   => (lambda (opcode)
-		(assemble-general-instruction opcode inst bindings labels)))
-	  (else
-	   (error "unknown LAP instruction" inst)))))
-
-; The optional ' is optionally stripped off the argument to LITERAL.
-
-(define (assemble-special-op opname args bindings)
-  (case opname
-    ((literal small-literal)
-     (let* ((arg (car args))
-	    (arg (if (and (pair? arg)
-			  (eq? (car arg) 'quote))
-		     (cadr arg)
-		     arg)))
-       (instruction-with-literal (enum op literal) arg)))
-    ((global)
-     (lap-global #f (car args) bindings))
-    ((set-global!)
-     (lap-global #t (car args) bindings))
-;    ((local)
-;     (if (null? (cdr args))
-;         (lap-local (car args) bindings)
-;         #f))
-;    ((set-local!)
-;     (if (null? (cdr args))
-;         (lap-set-local! (car args) bindings)
-;         #f))
-    ((protocol)
-     (apply instruction
-	    (enum op protocol)
-	    (assemble-protocol args)))
-    (else
-     #f)))
-
-; Lookup NAME in BINDINGS to the location.
-
-(define (lap-global assign? name bindings)
-  (let ((binding (assq bindings name)))
-    (if (not binding)
-	(error "LAP variable is not in free list" name)
-	(let ((binding (cdr binding)))
-	  (cond ((and (binding?  binding)
-		      (pair? (binding-place binding)))
-		 (error "LAP variable is not global" name))
-		(assign?
-		 (instruction-with-location (enum op set-global!)
-					    binding
-					    name
-					    usual-variable-type))
-		(else
-		 (instruction-with-location (enum op global)
-					    binding
-					    name
-					    value-type)))))))
-
-; This no longer works and I doubt if anyone uses it.  To fix it the
-; assembler should fix-up BINDINGS to incorporate LEVEL passed to the
-; compilator.
-
-;; Lookup NAME in BINDINGS and pick out the appropriate local op.
-;
-;(define (lap-local name bindings)
-;  (let ((binding (lookup bindings name)))
-;    (if (and (binding? binding)
-;             (pair? (binding-place binding)))
-;        (let* ((level+over (binding-place binding))
-;               (back (- (environment-level bindings)
-;                        (car level+over)))
-;               (over (cdr level+over)))
-;          (case back
-;            ((0) (instruction (enum op local0) over))
-;            ((1) (instruction (enum op local1) over))
-;            ((2) (instruction (enum op local2) over))
-;            (else (instruction (enum op local) back over))))
-;        (error "LAP local variable is not locally bound" name))))
-;          
-;; Same thing, except that there is only one opcode.
-;
-;(define (lap-set-local! name bindings)
-;  (let ((binding (lookup bindings name)))
-;    (if (and (binding? binding)
-;             (pair? (binding-place binding)))
-;        (let* ((level+over (binding-place binding))
-;               (back (- (environment-level bindings)
-;                        (car level+over)))
-;               (over (cdr level+over)))
-;          (instruction (enum op set-local!)
-;                       back
-;                       (quotient over byte-limit)
-;                       (remainder over byte-limit)))
-;        (error "LAP local variable is not locally bound" name))))
-
-; Assembling protocols.
-
-(define (assemble-protocol args)
-  (if (integer? (car args))
-      (let ((count (car args)))
-	(cond ((not (null? (cdr args)))
-	       (if (not (eq? (cadr args) '+))
-		   (error "unknown assembly protocol" args))
-	       (list two-byte-nargs+list-protocol
-		     (quotient count byte-limit)
-		     (remainder count byte-limit)))
-	      ((<= count maximum-stack-args)
-	       (list count))
-	      (else
-	       (list two-byte-nargs-protocol
-		     (quotient count byte-limit)
-		     (remainder count byte-limit)))))
-      (case (car args)
-	((args+nargs)
-	 (cons args+nargs-protocol (cdr args)))
-	((nary-dispatch)
-	 (cons nary-dispatch-protocol
-	       (parse-nary-dispatch (cdr args))))
-	((big-stack)
-	 (error "can't assemble big-stack protocol"))
-	(else
-	 (error "unknown assembly protocol" args)))))
-
-; This is fairly bogus, because it uses the targets as addresses instead
-; of treating them as labels.  Fixing this is too much work, seeing as
-; no one is likely to use it.
-
-(define (parse-nary-dispatch targets)
-  (let ((results (vector 0 0 0 0)))
-    (warn "LAP compiler treats nary-dispatch targets as addresses, not as labels.")
-    (for-each (lambda (target)
-		(if (and (pair? target)
-			 (pair? (cdr target))
-			 (pair? (cddr target))
-			 (or (eq? (car target) '>2)
-			     (and (integer? (car target))
-				  (<= 0 (car target) 2)))
-			 (eq? (cadr target) '=>)
-			 (integer? (caddr target)))
-		    (vector-set! results
-				 (if (eq? (car target) '>2)
-				     3
-				     (car target))
-				 (caddr target))
-		    (error "bad nary-dispatch label in LAP" target)))
-	      targets)
-    (vector->list results)))
-
-;----------------
-; This returns two values, the assembled instruction and a flag indicating
-; whether or not the instruction used a label.
-
-(define (assemble-general-instruction opcode inst bindings labels)
-  (let ((specs (vector-ref opcode-arg-specs opcode))
-	(args (cdr inst))
-	(finish (lambda (ops label-use?)
-		  (values (apply instruction opcode (reverse ops))
-			  label-use?))))
-    (let loop ((specs specs) (args args) (ops '()) (label-use? #f))
-      (if (null? specs)
-	  (finish ops label-use?)
-	  (case (car specs)
-	    ((index) ; segment.scm allows no other operands if an index is used.
-                     ; All non-template indexed operands should have been taken
-                     ; care of above (probably should fix arch.scm).
-	     (let ((template (if (null? (cdr args))
-				 (make-template-marker (car args))
-				 (compile-lap (car args) (cdr args) bindings))))
-	       (values (instruction-with-final-literal opcode
-						       (reverse ops)
-						       template)
-		       label-use?)))
-	    ((offset)
-	     (let ((label (check-lap-arg args 'label inst)))
-	       (call-with-values
-		(lambda () (labels label))
-		(lambda (high low)
-		  (loop (cdr specs) (cdr args) `(,low ,high . ,ops) #t)))))
-	    ((stob)
-	     (let ((byte (check-lap-arg args 'stob inst)))
-	       (loop (cdr specs) (cdr args) (cons byte ops) label-use?)))
-	    ((nargs byte)
-	     (let ((byte (check-lap-arg args 'byte inst)))
-	       (loop (cdr specs) (cdr args) (cons byte ops) label-use?)))
-	    ((two-bytes)
-	     (let ((number (check-lap-arg args 'byte inst)))
-	       (loop (cdr specs) (cdr args)
-		     `(,(remainder number byte-limit)
-		       ,(quotient number byte-limit)
-		       . ,ops)
-		     label-use?)))
-	    ((junk)
-	     (loop (cdr specs) args (cons 0 ops) label-use?))
-	    (else
-	     (if (or (eq? (car specs) '+)
-		     (integer? (car specs)))
-		 (finish ops label-use?)
-		 (error "LAP internal error, unknown opcode argument specification" (car specs)))))))))
-
-; Compiler doesn't provide this so we hack it up.
-
-(define (instruction-with-final-literal opcode operands literal)
-  (cond ((null? operands)
-	 (instruction-with-literal opcode literal))
-	(else
-	 (sequentially (apply instruction
-			      opcode
-			      (reverse (cdr (reverse operands))))
-		       (instruction-with-literal (car (reverse operands))
-						 literal)))))
-
-; Check that the car of ARGS is an argument of the appropriate type and
-; return it.
-
-(define (check-lap-arg args type inst)
-  (if (null? args)
-      (error "not enough arguments in LAP instruction" inst))
-  (let ((arg (car args)))
-    (case type
-      ((byte)
-       (if (integer? arg)
-	   arg
-	   (error "numeric operand expected in LAP instruction" inst)))
-      ((stob)
-       (cond ((name->enumerand arg stob)
-	      => (lambda (x) x))
-	     (else
-	      (error "unknown STOB argument in LAP instruction" inst))))
-      ((label)
-       (cond ((symbol? arg)
-	      arg)
-	     ((and (pair? arg)
-		   (eq? (car arg) '=>))
-	      (cadr arg))
-	     (else
-	      (error "bad label in LAP instruction" inst))))
-      (else
-       (error "LAP internal error, unknown LAP argument specifier" type)))))
-	    
diff --git a/scheme/env/basic-command.scm b/scheme/env/basic-command.scm
deleted file mode 100644
index dddcad0..0000000
--- a/scheme/env/basic-command.scm
+++ /dev/null
@@ -1,68 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; run
-
-(define-command-syntax 'run "<exp>" "evaluate an expression" '(expression))
-
-(define (run exp)
-  (evaluate-and-select exp (environment-for-commands)))
-
-; exit-when-done
-
-(define-command-syntax 'exit-when-done "[<status>]"
-  "leave Scheme after all threads finish"
-  '(&opt expression))
-
-(define (exit-when-done . exp-option)
-  (let ((status (if (null? exp-option)
-                    0
-                    (eval (car exp-option) (environment-for-commands)))))
-    (terminate-command-processor! status)))
-
-(define-command-syntax 'exit
-		       "[<status>]"
-		       "leave Scheme now"
-		       '(&opt expression))
-
-(define (exit . exp-option)
-  (let ((status (if (null? exp-option)
-                    0
-                    (eval (car exp-option) (environment-for-commands)))))
-    (scheme-exit-now status)))
-
-; go
-
-(define-command-syntax 'go "<exp>" "leave Scheme via tail recursion"
-  '(expression))
-
-(define (go exp)
-  (let ((env (environment-for-commands)))
-    (exit-command-processor (lambda () (eval exp env)))))
-
-; load
-
-(define-command-syntax 'load "<filename> ..."
-  "load Scheme source file(s)"
-  '(&rest filename))
-
-(define (load . filenames)
-  (let ((env (environment-for-commands)))
-    ;; (with-interaction-environment env
-      ;; (lambda ()
-	(noting-undefined-variables env
-	  (lambda ()
-	    (for-each (lambda (filename)
-			(load-into filename env))
-		      filenames)))));; ))
-
-; help
-
-(define ? help)
-
-(define-command-syntax 'help
-  "[<command-name>]"
-  "list all commands, or give help on a specific command"
-  '(&opt name))
-
-(define-command-syntax '? "[<command-name>]" "same as ,help" '(&opt name))
diff --git a/scheme/env/build.scm b/scheme/env/build.scm
deleted file mode 100644
index 8886e0d..0000000
--- a/scheme/env/build.scm
+++ /dev/null
@@ -1,74 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Commands for writing images.
-
-; A heap image written using ,dump or ,build can be invoked with
-;    s48 -i <filename> [-h <heap size>] [-a <argument>]
-; For images made with ,build <exp> <filename>, <argument> is passed as
-; a string to the procedure that is the result of <exp>.
-
-
-; dump <filename>
-
-(define-command-syntax 'dump "<filename>"
-  "write the current heap to an image file"
-  '(filename &opt form))
-
-(define (dump filename . maybe-info)
-  (let ((info (if (null? maybe-info) "(suspended image)" (car maybe-info)))
-	(context (user-context))
-	(env (environment-for-commands)))
-    (build-image (lambda (arg)
-		   (with-interaction-environment env
-		     (lambda ()
-		       (restart-command-processor arg
-						  context
-						  (lambda ()
-						    (greet-user info))))))
-		 filename)))
-
-; build <exp> <filename>
-
-(define-command-syntax 'build "<exp> <filename>"
-  "build a heap image file with <exp> as entry procedure"
-  '(expression filename))
-
-(define (build exp filename)
-  (build-image (eval exp (environment-for-commands)) filename))
-
-; build-image
-
-(define (build-image start filename)
-  (let ((filename (translate filename)))
-    (write-line (string-append "Writing " filename) (command-output))
-    (write-image filename
-		 (stand-alone-resumer start)
-		 "")
-    #t))
-
-(define (stand-alone-resumer start)
-  (usual-resumer  ;sets up exceptions, interrupts, and current input & output
-   (lambda (arg)
-     (call-with-current-continuation
-       (lambda (halt)
-	 (with-handler (simple-condition-handler halt (current-error-port))
-	   (lambda ()
-	     (start arg))))))))
-
-; Simple condition handler for stand-alone programs.
-
-(define (simple-condition-handler halt port)
-  (lambda (c punt)
-    (cond ((error? c)
-	   (display-condition c port)
-	   (halt 1))
-	  ((warning? c)
-	   (display-condition c port))		;Proceed
-	  ((interrupt? c)
-	   ;; (and ... (= (cadr c) interrupt/keyboard)) ?
-	   (halt 2))
-	  (else
-	   (punt)))))
-
-;(define interrupt/keyboard (enum interrupt keyboard))
diff --git a/scheme/env/debuginfo.scm b/scheme/env/debuginfo.scm
deleted file mode 100644
index d238068..0000000
--- a/scheme/env/debuginfo.scm
+++ /dev/null
@@ -1,76 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Reading/writing debugging info
-
-(define (write-debug-info location-info file)
-  (call-with-output-file file
-    (lambda (port)
-
-      (display "Writing ") (display file) (newline)
-      (let ((write-table
-	     (lambda (table comment)
-	       (display "; " port) (display comment port) (newline port)
-	       (table-walk (lambda (key datum)
-			     (write (list key datum) port)
-			     (newline port))
-			   table)
-	       (write '- port) (newline port))))
-	(write-table package-name-table "Package uid -> name")
-	(write-table location-info "Location uid -> (name . package-uid)"))
-
-      (display "; Template uid -> name, parent, pc in parent, env maps" port)
-      (newline port)
-      (table-walk (lambda (id data)
-		    ;; Fields: (uid name parent pc-in-parent
-		    ;;	        env-maps source)
-		    (write (list id
-				 (let ((name (debug-data-name data)))
-				   (if (generated? name)
-				       (name->symbol name)
-				       name))
-				 (let ((p (debug-data-parent data)))
-				   ;; we'd like to (note-debug-data! p)
-				   (if (debug-data? p)
-				       (debug-data-uid p)
-				       p))
-				 (debug-data-pc-in-parent data)
-				 (debug-data-env-maps data)
-				 ;; Don't retain source code, right?
-				 )
-			   port)
-		    (newline port))
-		  (debug-data-table))
-      (write '- port) (newline port))))
-
-(define (read-debug-info file)
-  (call-with-input-file file
-    (lambda (port)
-
-      (display "Reading ") (display file) (newline)
-
-      (let ((read-table
-	     (lambda (table)
-	       (let loop ()
-		 (let ((z (read port)))
-		   (if (pair? z)
-		       (begin (table-set! table
-					  (car z)
-					  (make-immutable! (cadr z)))
-			      ;; (set! *location-uid*
-			      ;;       (max *location-uid* (+ (car z) 1)))
-			      (loop))))))))
-	(read-table package-name-table)
-	(read-table location-info-table))
-
-      (let loop ()
-	(let ((z (read port)))
-	  (if (pair? z)
-	      (begin ;; (set! *template-uid*
-		     ;;	      (max *template-uid* (+ (car z) 1)))
-		     (table-set! (debug-data-table)
-				 (car z)
-				 (make-immutable!
-				  (apply make-debug-data
-					 (append z '(())))))
-		     (loop))))))))
diff --git a/scheme/env/disasm.scm b/scheme/env/disasm.scm
deleted file mode 100644
index 18c07cd..0000000
--- a/scheme/env/disasm.scm
+++ /dev/null
@@ -1,249 +0,0 @@
-; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; This is file assem.scm.
-
-;;;; Disassembler
-
-; This defines a command processor command
-;      dis <expression>
-; that evaluates <expression> to obtain a procedure or lambda-expression,
-; which is then disassembled.
-
-; Needs:
-;   template? template-name template-code
-;   closure? closure-template
-;   code-vector-...
-;   location-name
-
-; The assembly language is designed to be rereadable.  See env/assem.scm.
-
-(define-command-syntax 'dis "[<exp>]" "disassemble procedure"
-  '(&opt expression))
-
-; The command.  The thing to be disassembled defaults to the focus object (##).
-
-(define (dis . maybe-exp)
-  (disassemble (if (null? maybe-exp)
-		   (focus-object)
-		   (eval (car maybe-exp) (environment-for-commands)))))
-
-(define (disassemble obj)
-  (really-disassemble (coerce-to-template obj) 0)
-  (newline))
-
-; Instruction loop.  WRITE-INSTRUCTION returns the new program counter.
-
-(define (really-disassemble tem level)
-  (write (template-name tem))
-  (let ((length (template-code-length (template-code tem))))
-    (let loop ((pc 0))
-      (if (< pc length)
-	  (loop (write-instruction tem pc level #t))))))
-
-; The protocol used for procedures that require extra stack space uses three
-; bytes at the end of the code vector.
-
-(define (template-code-length code)
-  (if (and (= (enum op protocol)
-	      (code-vector-ref code 0))
-	   (= big-stack-protocol
-	      (code-vector-ref code 1)))
-      (- (code-vector-length code) 3)
-      (code-vector-length code)))
-
-; Write out the intstruction at PC in TEMPLATE.  LEVEL is the nesting depth
-; of TEMPLATE.  If WRITE-SUB-TEMPLATES? is false we don't write out any
-; templates found.
-;
-; Special handling is required for the few instructions that do not use a
-; fixed number of code-stream arguments.
-
-(define (write-instruction template pc level write-sub-templates?)
-  (let* ((code (template-code template))
-         (opcode (code-vector-ref code pc)))
-    (newline-indent (* level 3))
-    (write-pc pc)
-    (display " (")
-    (write (enumerand->name opcode op))
-    (let ((pc (cond ((= opcode (enum op computed-goto))
- 		     (display-computed-goto pc code))
- 		    ((= opcode (enum op make-flat-env))
- 		     (display-flat-env (+ pc 1) code))
-		    ((= opcode (enum op protocol))
-		     (display-protocol (code-vector-ref code (+ pc 1)) pc code))
- 		    (else
- 		     (print-opcode-args opcode pc code template
- 					level write-sub-templates?)))))
-      (display #\))
-      pc)))
-
-; Write out all of the branches of a computed goto.
-
-(define (display-computed-goto start-pc code)
-  (display #\space)
-  (let ((count (code-vector-ref code (+ start-pc 1))))
-    (write count)
-    (do ((pc (+ start-pc 2) (+ pc 2))
-	 (count count (- count 1)))
-	((= count 0) pc)
-      (display #\space)
-      (write `(=> ,(+ start-pc (get-offset pc code) 2))))))
-
-; Write out the environment specs for the make-flat-env opcode.
-  
-(define (display-flat-env pc code)
-  (let ((total-count (code-vector-ref code (+ 1 pc))))
-    (display #\space) (write total-count)
-    (let loop ((pc (+ pc 2)) (count 0) (old-back 0))
-      (if (= count total-count)
-	  pc
-	  (let ((back (+ (code-vector-ref code pc)
-			 old-back))
-		(limit (+ pc 2 (code-vector-ref code (+ pc 1)))))
-	    (do ((pc (+ pc 2) (+ pc 1))
-		 (count count (+ count 1))
-		 (offsets '() (cons (code-vector-ref code pc) offsets)))
-		((= pc limit)
-		 (display #\space)
-		 (write `(,back ,(reverse offsets)))
-		 (loop pc count back))))))))
-
-; Display a protocol, returning the number of bytes of instruction stream that
-; were consumed.
-
-(define (display-protocol protocol pc code)
-  (display #\space)
-  (+ pc (cond ((<= protocol maximum-stack-args)
-	       (display protocol)
-	       2)
-	      ((= protocol two-byte-nargs-protocol)
-	       (display (get-offset (+ pc 2) code))
-	       4)
-	      ((= protocol two-byte-nargs+list-protocol)
-	       (display (get-offset (+ pc 2) code))
-	       (display " +")
-	       4)
-	      ((= protocol args+nargs-protocol)
-	       (display "args+nargs")
-	       3)
-	      ((= protocol nary-dispatch-protocol)
-	       (display "nary-dispatch")
-	       (do ((i 0 (+ i 1)))
-		   ((= i 4))
-		 (let ((offset (code-vector-ref code (+ pc 2 i))))
-		   (if (not (= offset 0))
-		       (begin
-			 (display #\space)
-			 (display (list (if (= i 3) '>2 i)
-					'=>
-					(+ pc offset)))))))
-	       6)
-	      ((= protocol big-stack-protocol)
-	       (display "big-stack")
-	       (let ((size (display-protocol (code-vector-ref code
-							      (- (code-vector-length code)
-								 3))
-					     pc
-					     code)))
-		 (display #\space)
-		 (display (get-offset (- (code-vector-length code) 2) code))
-		 size))
-	      (else
-	       (error "unknown protocol" protocol)))))
-
-; Generic opcode argument printer.
-
-(define (print-opcode-args op start-pc code template level write-templates?)
-  (let ((specs (vector-ref opcode-arg-specs op)))
-    (let loop ((specs specs) (pc (+ start-pc 1)))
-      (cond ((or (null? specs)
- 		 (= 0 (arg-spec-size (car specs) pc code)))
-  	     pc)
-  	    ((eq? (car specs) 'junk)  ; avoid printing a space
-	     (loop (cdr specs) (+ pc 1)))
-	    (else
-  	     (display #\space)
-  	     (print-opcode-arg specs pc start-pc code template level write-templates?)
- 	     (loop (cdr specs) (+ pc (arg-spec-size (car specs) pc code))))))))
-  
-; The number of bytes required by an argument.
-
-(define (arg-spec-size spec pc code)
-  (case spec
-    ((nargs byte stob junk) 1)
-    ((offset index small-index two-bytes) 2)
-    ((env-data) (+ 1 (* 2 (code-vector-ref code pc))))
-    (else 0)))
-
-; Print out the particular type of argument.
-
-(define (print-opcode-arg specs pc start-pc code template level write-templates?)
-  (case (car specs)
-    ((nargs byte)
-     (write (code-vector-ref code pc)))
-    ((two-bytes)
-     (write (get-offset pc code)))
-    ((index)
-     (let ((thing (template-ref template (get-offset pc code))))
-       (write-literal-thing thing level write-templates?)))
-    ((small-index)
-     (let ((thing (template-ref template (code-vector-ref code pc))))
-       (write-literal-thing thing level write-templates?)))
-    ((offset)
-     (write `(=> ,(+ start-pc (get-offset pc code)))))
-    ((stob)
-     (write (enumerand->name (code-vector-ref code pc) stob)))
-    ((env-data)
-     (let ((nobjects (code-vector-ref code pc)))
-       (let loop ((offset (+ pc 1)) (n nobjects))
- 	 (cond ((not (zero? n))
- 		(display (list (code-vector-ref code offset)
- 			       (code-vector-ref code (+ offset 1))))
- 		(if (not (= n 1))
- 		    (write-char #\space))
- 		(loop (+ offset 2) (- n 1)))))))))
-
-(define (write-literal-thing thing level write-templates?)
-  (cond ((location? thing)
-	 (write (or (location-name thing)
-		    `(location ,(location-id thing)))))
-	((not (template? thing))
-	 (display #\')
-	 (write thing))
-	(write-templates?
-	 (really-disassemble thing (+ level 1)))
-	(else
-	 (display "..."))))
-
-;----------------
-; Utilities.
-
-; Turn OBJ into a template, if possible.
-
-(define (coerce-to-template obj)
-  (cond ((template? obj) obj)
-	((closure? obj) (closure-template obj))
-	((continuation? obj) (continuation-template obj))
-	(else (error "expected a procedure or continuation" obj))))
-
-; Fetch the two-byte value at PC in CODE.
-
-(define (get-offset pc code)
-  (+ (* (code-vector-ref code pc)
-	byte-limit)
-     (code-vector-ref code (+ pc 1))))
-
-; Indenting and aligning the program counter.
-
-(define (newline-indent n)
-  (newline)
-  (do ((i n (- i 1)))
-      ((= i 0))
-    (display #\space)))
-
-(define (write-pc pc)
-  (if (< pc 100) (display " "))
-  (if (< pc 10) (display " "))
-  (write pc))
diff --git a/scheme/env/dispcond.scm b/scheme/env/dispcond.scm
deleted file mode 100644
index 422f578..0000000
--- a/scheme/env/dispcond.scm
+++ /dev/null
@@ -1,77 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-
-; Displaying conditions
-
-(define display-condition
-  (let ((display display) (newline newline))
-    (lambda (c port)
-      (if (ignore-errors (lambda ()
-			   (newline port)
-			   (really-display-condition c port)
-			   #f))
-	  (begin (display "<Error while displaying condition.>" port)
-		 (newline port))))))
-
-(define (really-display-condition c port)
-  (let* ((stuff (disclose-condition c))
-	 (stuff (if (and (list? stuff)
-			 (not (null? stuff))
-			 (symbol? (car stuff)))
-		    stuff
-		    (list 'condition stuff))))
-    (display-type-name (car stuff) port)
-    (if (not (null? (cdr stuff)))
-	(begin (display ": " port)
-	       (let ((message (cadr stuff)))
-		 (if (string? message)
-		     (display message port)
-		     (limited-write message port *depth* *length*)))
-	       (let ((spaces
-		      (make-string (+ (string-length
-				       (symbol->string (car stuff)))
-				      2)
-				   #\space)))
-		 (for-each (lambda (irritant)
-			     (newline port)
-			     (display spaces port)
-			     (limited-write irritant port *depth* *length*))
-			   (cddr stuff)))))
-    (newline port)))
-
-(define *depth* 5)
-(define *length* 6)
-
-(define-generic disclose-condition &disclose-condition)
-
-(define-method &disclose-condition (c) c)
-
-
-
-(define (limited-write obj port max-depth max-length)
-  (let recur ((obj obj) (depth 0))
-    (if (and (= depth max-depth)
-	     (not (or (boolean? obj)
-		      (null? obj)
-		      (number? obj)
-		      (symbol? obj)
-		      (char? obj)
-		      (string? obj))))
-	(display "#" port)
-	(call-with-current-continuation
-	  (lambda (escape)
-	    (recurring-write obj port
-	      (let ((count 0))
-		(lambda (sub)
-		  (if (= count max-length)
-		      (begin (display "---" port)
-			     (write-char
-			      (if (or (pair? obj) (vector? obj))
-				  #\)
-				  #\})
-			      port)
-			     (escape #t))
-		      (begin (set! count (+ count 1))
-			     (recur sub (+ depth 1))))))))))))
-
diff --git a/scheme/env/flatload.scm b/scheme/env/flatload.scm
deleted file mode 100644
index fff14b2..0000000
--- a/scheme/env/flatload.scm
+++ /dev/null
@@ -1,107 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; flatloaded -> load
-
-(define *noisy?* #f)
-
-(define (flatload struct . env-option)
-  (let ((env (if (null? env-option)
-		 (interaction-environment)
-		 (car env-option)))
-	(l '())
-	(set-package-loaded?! set-package-loaded?!))
-    (walk-packages (list struct)
-		   (lambda (p)
-		     (not (package-loaded? p)))
-		   (lambda (file p)
-		     (let* ((fn (package-file-name p))
-			    (file (namestring file
-					      (if fn
-						  (file-name-directory fn)
-						  #f)
-					     *load-file-type*)))
-		       (if *noisy?*
-			   (begin (display #\space) (display file)))
-		       (set! l (cons (lambda () (apply fload file env-option))
-				     l))))
-		   (lambda (forms p)
-		     (set! l (cons (lambda ()
-				     (for-each (lambda (form)
-						 (eval form env))
-					       forms))
-				   l)))
-		   (lambda (p)
-		     (set! l (cons (lambda ()
-				     (set-package-loaded?! p #t))
-				   l))))
-    (for-each (lambda (thunk) (thunk)) (reverse l))
-    (newline)))
-
-(define *source-file-name* "")    ;Cf. alt/config.scm
-(define (fload filename . rest)
-  (let ((save filename))
-    (dynamic-wind (lambda () (set! *source-file-name* filename))
-		  (lambda ()
-		    (apply load filename rest))
-		  (lambda () (set! *source-file-name* save)))))
-
-(define (walk-packages structs process? file-action forms-action after-action)
-  (let ((seen '()))
-    (letrec ((recur
-	      (lambda (s)
-		(let ((p (structure-package s)))
-		  (if (not (memq p seen))
-		      (begin 
-			(set! seen (cons p seen))
-			(if (process? p)
-			    (begin
-			      (if *noisy?*
-				  (begin (newline)
-					 (display "[")
-					 (write (structure-name s))))
-			      ;; (write (structure-name s)) (display " ")
-			      (for-each recur (package-opens p))
-			      (for-each (lambda (name+struct)
-					  (recur (cdr name+struct)))
-					(package-accesses p))
-			      (for-each (lambda (clause)
-					  (case (car clause)
-					    ((files)
-					     (for-each (lambda (f)
-							 (file-action f p))
-						       (cdr clause)))
-					    ((begin)
-					     (forms-action (cdr clause) p))))
-					(package-clauses p))
-			      (after-action p)
-			      (if *noisy?* (display "]"))))))))))
-      (for-each recur structs))
-    (if *noisy?* (newline))
-    seen))
-
-
-; Return list of names of all files needed to build a particular structure.
-; This is handy for creating dependency lists for "make".
-
-(define (all-file-names struct . base-option)
-  (let ((l '())
-	(b '()))
-    (walk-packages base-option
-		   (lambda (p) #t)
-		   (lambda (filename p) #f)
-		   (lambda (forms p) #f)
-		   (lambda (p)
-		     (set! b (cons p b))))
-    (walk-packages (list struct)
-		   (lambda (p)
-		     (not (memq p b)))
-		   (lambda (filename p)
-		     (let ((dir (file-name-directory (package-file-name p))))
-		       (set! l (cons (namestring filename dir *load-file-type*)
-				     l))))
-		   (lambda (forms p)
-		     (display "Package contains (begin ...) clause: ")
-		     (write forms)
-		     (newline))
-		   (lambda (p) #f))
-    (reverse l)))
diff --git a/scheme/env/inspect.scm b/scheme/env/inspect.scm
deleted file mode 100644
index 0b2dbec..0000000
--- a/scheme/env/inspect.scm
+++ /dev/null
@@ -1,479 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; A dirty little inspector.
-; This breaks abstractions left and right.
-; Look and feel shamelessly plagiarized from the Lucid Lisp inspector.
-
-; Inspector state:
-;    thing    ; object currently being inspected, obtained as (focus-object)
-;    menu     ; cached result of (prepare-menu thing).  This is a list of
-;               lists (<name-or-#f> <value>).
-;    position ; position within menu; modified by M (more) command
-;    stack    ; list of other things
-
-(define-record-type inspector-state inspector-state?
-  (make-inspector-state menu position stack)
-  (menu inspector-state-menu)
-  (position inspector-state-position set-inspector-state-position!)
-  (stack inspector-state-stack))
-
-; The inspector is a distinct REPL with its own state.  This allows the
-; user to continue with the same inspection stack after an error.
-
-(define inspector-state repl-data)
-(define set-inspector-state! set-repl-data!)
-
-(define *menu-limit* 15)	; maximum menu entries
-(define *write-depth* 3)	; limit for recursive writes
-(define *write-length* 5)       ; ditto
-
-; There are three commands for invoking the inspector with different
-; initial objects:
-;   ,inspect           -> focus object
-;   ,inspect <exp>     -> value of <exp>
-;   ,debug             -> continuation of stopped thread(s), preferentially
-;                         chooses the thread with the most recent error
-;   ,threads           -> list of current command level's threads
-
-(define-command-syntax 'inspect "[<exp>]" "invoke the inspector"
-  '(&opt form))
-
-(define-command-syntax 'debug "" "inspect the current continuation" '())
-
-(define-command-syntax 'threads "" "inspect stopped threads" '())
-
-(define (debug)
-  (showing-focus-object
-   (lambda ()
-     (set-focus-object! (or (command-continuation)
-			    (command-threads)))))
-  (inspect))
-
-(define (threads)
-  (showing-focus-object
-   (lambda ()
-     (set-focus-object! (command-threads))))
-  (inspect))
-
-(define (inspect . maybe-exp)
-  (if (not (null? maybe-exp))
-      (with-limited-output
-       (lambda ()
-	 (showing-focus-object
-	  (lambda ()
-	    (evaluate-and-select (car maybe-exp)
-				 (environment-for-commands)))))))
-  (push-command-level inspector
-		      (make-inspector-state (prepare-menu (focus-object))
-					    0
-					    '())))
-
-;----------------
-; Actual entry point for the inspector.  We print the menu and then loop
-; reading commands.
-
-(define (inspector)
-  (present-menu)
-  (let loop ()
-    (let ((command (read-command-carefully "inspect: "
-					   #f  ; command preferred
-					   (command-input)
-					   inspector-commands)))
-      (cond ((eof-object? command)
-	     (newline (command-output))
-	     (proceed-with-command-level (cadr (command-levels))))
-	    ((not command)   ; read command error
-	     (loop))
-	    (else
-	     (with-limited-output
-	      (lambda ()
-		(execute-inspector-command command)))
-	     (loop))))))
-
-(define (present-menu)
-  (let ((state (inspector-state)))
-    (display-menu (inspector-state-menu state)
-		  (inspector-state-position state)
-		  (command-output))))
-
-; Go to a new thing by making a new inspector state.
-
-(define (new-selection thing stack)
-  (set-inspector-state!
-     (make-inspector-state (prepare-menu thing) 0 stack)))
-
-; Selection commands are either an integer, which selects a menu item,
-; or `u' to move up the stack, `d' to move to the next continuation
-; (only valid when the current object is a continuation), or `t' which
-; moves to a procedure's template (only valid when the current object
-; is a template).
-
-(define (read-selection-command port)
-  (let ((x (read port)))
-    (if (or (integer? x)
-	    (memq x '(u d t)))
-	x
-	(read-command-error port "invalid selection command" x))))
-
-(define selection-command-syntax (list '&rest read-selection-command))
-
-(define (inspector-commands name)
-  (if (integer? name)
-      selection-command-syntax
-      (case name
-	((? m q) '())               ; no arguments
-	((u d t) selection-command-syntax)
-	(else #f))))
-
-; Execute a command.
-;
-; We save the current object and state to compare to the new ones to see
-; if we need to display a new menu.  The old object is pushed on the stack
-; only if nothing has been popped off.
-
-(define (execute-inspector-command command)
-  (let ((result-before (focus-object))
-	(state-before (inspector-state)))
-    (showing-focus-object
-     (lambda ()
-       (let ((name (car command)))
-	 (if (integer? name)
-	     (execute-selection-command command)
-	     (case name
-	       ((u d t)
-		(execute-selection-command command))
-	       ((m) (inspect-more))
-	       ((q) (proceed-with-command-level (cadr (command-levels))))
-	       ((?) (inspect-help))
-	       (else (execute-command command)))))))
-    (let ((result-after (focus-object))
-	  (state-after (inspector-state)))
-      (if (not (eq? result-after result-before))
-	  (begin (if (eq? state-after state-before)
-		     (new-selection result-after
-				    (cons result-before
-					  (inspector-state-stack state-before))))
-		 (present-menu))))))
-
-; Choose a new object.
-
-(define (execute-selection-command command)
-  (if (not (null? command))
-      (let ((name (car command)))
-	(if (integer? name)
-	    (let ((menu (inspector-state-menu (inspector-state))))
-	      (if (and (>= name 0)
-		       (< name (length menu)))
-		  (move-to-object! (menu-ref menu name))
-		  (write-line "Invalid choice." (command-output))))
-	    (case name
-	      ((u) (pop-inspector-stack))
-	      ((d) (inspect-next-continuation))
-	      ((t) (select-template))
-	      (else (error "bad selection command" name))))
-	(execute-selection-command (cdr command)))))
-
-; Procedures for the various commands.
-
-(define (move-to-object! object)
-  (new-selection object
-		 (cons (focus-object)
-		       (inspector-state-stack (inspector-state))))
-  (set-focus-object! object))
-
-(define (pop-inspector-stack)
-  (let ((stack (inspector-state-stack (inspector-state))))
-    (if (pair? stack)
-	(begin (new-selection (car stack) (cdr stack))
-	       (set-focus-object! (car stack)))
-	(write-line "Can't go up from here." (command-output)))))
-
-(define (inspect-next-continuation)
-  (if (continuation? (focus-object))
-      (move-to-object! (continuation-parent (focus-object)))
-      (write-line "Can't go down from a non-continuation." (command-output))))
-
-(define (inspect-more)
-  (let* ((state (inspector-state))
-	 (menu (inspector-state-menu state))
-	 (position (inspector-state-position state)))
-    (if (> (length menu) (+ *menu-limit* position))
-	(let ((position (- (+ position *menu-limit*) 1)))
-	  (set-inspector-state-position! state position)
-	  (present-menu))
-	(write-line "There is no more." (command-output)))))
-
-(define (select-template)
-  (move-to-object! (coerce-to-template (focus-object))))
-
-(define (inspect-help)
-  (let ((o-port (command-output)))
-    (for-each (lambda (s) (display s o-port) (newline o-port))
-	      '("q          quit"
-		"u          up stack (= go to previous object)"
-		"d          down stack"
-		"t          template"
-		"<integer>  menu item"
-		"or any command processor command"
-		"multiple u d t <integer> commands can be put on one line"))))
-
-;----------------
-; Menus.
-;
-; A menu is a list of lists (<name-or-#f> <thing>).
-
-(define (menu-ref menu n)
-  (cadr (list-ref menu n)))
-
-; Get a menu for THING.  We know about a fixed set of types.
-
-(define (prepare-menu thing)
-  (cond ((list? thing)
-         (map (lambda (x)
-		(list #f x))
-              thing))
-
-        ((pair? thing)
-         `((car ,(car thing)) (cdr ,(cdr thing))))
-
-        ((vector? thing)
-         (prepare-menu (vector->list thing)))
-
-        ((closure? thing)
-         (prepare-environment-menu
-              (closure-env thing)
-              (get-shape (template-debug-data (closure-template thing))
-                         0)))
-
-	((template? thing)
-	 (prepare-menu (template->list thing)))
-
-        ((continuation? thing)
-         (prepare-continuation-menu thing))
-
-        ((record? thing)
-         (prepare-record-menu thing))
-
-        ((location? thing)
-         `((id ,(location-id thing))
-           (contents ,(contents thing))))
-
-	((weak-pointer? thing)
-	 `((ref ,(weak-pointer-ref thing))))
-
-        (else '())))
-
-(define (template->list template)
-  (do ((i (- (template-length template) 1) (- i 1))
-       (r '() (cons (template-ref template i) r)))
-      ((< i 0) r)))
-
-; Continuation menus have the both the saved operand stack and the
-; save environment, for which names may be available.
-
-(define (prepare-continuation-menu thing)
-  (let ((next (continuation-parent thing)))
-    `(,@(let recur ((c thing))
-	  (if (eq? c next)
-	      '()
-	      (let ((z (continuation-arg-count c)))
-		(do ((i (- z 1) (- i 1))
-		     (l (recur (continuation-cont c))
-			(cons (list #f (continuation-arg c i))
-			      l)))
-		    ((< i 0) l)))))
-      ,@(prepare-environment-menu (continuation-env thing)
-				  (get-shape (continuation-debug-data thing)
-					     (continuation-pc thing))))))
-
-(define (continuation-debug-data thing)
-  (template-debug-data (continuation-template thing)))
-
-; Records that have record types get printed with the names of the fields.
-
-(define (prepare-record-menu thing)
-  (let ((rt (record-type thing))
-        (z (record-length thing)))
-    (if (record-type? rt)
-        (do ((i (- z 1) (- i 1))
-             (f (reverse (record-type-field-names rt)) (cdr f))
-             (l '() (cons (list (car f) (record-ref thing i)) l)))
-            ((< i 1) l))
-        (do ((i (- z 1) (- i 1))
-             (l '() (cons (list #f (record-ref thing i)) l)))
-            ((< i 0) l)))))
-
-; We may have the names (`shape') for environments, in which case they
-; are used in the menus.
-
-(define (prepare-environment-menu env shape)
-  (if (vector? env)
-      (let ((values (rib-values env)))
-        (if (pair? shape)
-            (append (map list (car shape) values)
-                    (prepare-environment-menu (vector-ref env 0)
-                                              (cdr shape)))
-            (append (map (lambda (x)
-			   (list #f x))
-			 values)
-                    (prepare-environment-menu (vector-ref env 0)
-					      shape))))
-      '()))
-
-(define (rib-values env)
-  (let ((z (vector-length env)))
-    (do ((i 1 (+ i 1))
-	 (l '() (cons (if (vector-unassigned? env i)
-			  'unassigned
-			  (vector-ref env i))
-		      l)))
-	((>= i z) l))))
-
-; Returns a list of proper lists describing the environment in effect
-; at the given pc with the given template's code vector.
-;
-; Entries in the environment-maps table (one per template) have the form
-;   #(parent-uid pc-in-parent (env-map ...))
-;
-; Each environment map (one per let or lambda-expression) has the form
-;   #(pc-before pc-after (var ...) (env-map ...))
-;
-; Cf. procedure (note-environment vars segment) in comp.scm.
-
-(define (get-shape dd pc)
-  (if (debug-data? dd)
-      (let loop ((emaps (debug-data-env-maps dd))
-                 (shape (get-shape (get-debug-data
-                                    (debug-data-parent dd))
-                                   (debug-data-pc-in-parent dd))))
-        (if (null? emaps)
-            shape
-            (let ((pc-before (vector-ref (car emaps) 0))
-                  (pc-after  (vector-ref (car emaps) 1))
-                  (vars      (vector-ref (car emaps) 2))
-                  (more-maps (vector-ref (car emaps) 3)))
-              (if (and (>= pc pc-before)
-                       (< pc pc-after))
-                  (loop more-maps
-                        (cons (vector->list vars) shape))
-                  (loop (cdr emaps) shape)))))
-      '()))
-
-;----------------
-; Printing menus.
-;
-; If the current thing is a continuation we print its source code first.
-; Then we step down the menu until we run out or we reach the menu limit.
-
-
-(define (display-menu menu start port)
-  (newline port)
-  (maybe-display-source (focus-object) #f)
-  (let ((menu (list-tail menu start))
-	(limit (+ start *menu-limit*)))
-    (let loop ((i start) (menu menu))
-      (with-limited-output
-       (lambda ()
-	 (cond ((null? menu))
-	       ((and (>= i limit)
-		     (not (null? (cdr menu))))
-		(display " [m] more..." port) (newline port))
-	       (else
-		(let ((item (car menu)))
-		  (display " [" port)
-		  (write i port)
-		  (if (car item)
-		      (begin (display ": " port)
-			     (write-carefully (car item) port)))
-		  (display "] " port)
-		  (write-carefully
-		   (value->expression (cadr item))
-		   port)
-		  (newline port)
-		  (loop (+ i 1) (cdr menu))))))))))
-
-; Exception continuations don't have source, so we get the source from
-; the next continuation if it is from the same procedure invocation.
-
-(define (maybe-display-source thing exception?)
-  (cond ((not (continuation? thing))
-	 (values))
-	((exception-continuation? thing)
-	 (let ((next (continuation-cont thing)))
-	   (if (not (eq? next (continuation-parent thing)))
-	       (maybe-display-source next #t))))
-	(else
-	 (let ((dd (continuation-debug-data thing)))
-	   (if dd
-	       (let ((source (assoc (continuation-pc thing)
-				    (debug-data-source dd))))
-		 (if source
-		     (display-source-info (cdr source) exception?))))))))
-  
-; Show the source code for a continuation, if we have it.
-
-(define (display-source-info info exception?)
-  (if (pair? info)
-      (let ((o-port (command-output))
-	    (i (car info))
-	    (exp (cdr info)))
-	(if (and (integer? i) (list? exp))
-	    (begin
-	      (display (if exception?
-			   "Next call is "
-			   "Waiting for ")
-		       o-port)
-	      (limited-write (list-ref exp i) o-port
-			     *write-depth* *write-length*)
-	      (newline o-port)
-	      (display "  in " o-port)
-	      (limited-write (append (sublist exp 0 i)
-				     (list '^^^)
-				     (list-tail exp (+ i 1)))
-			     o-port
-			     *write-depth* *write-length*)
-	      (newline o-port))))))
-
-;----------------
-; A command to print out the file in which a procedure is defined.
-; Why is this here and not in debug.scm?
-
-(define-command-syntax 'where "[<procedure>]"
-  "show procedure's source file name"
-  '(&opt expression))
-
-(define (where . maybe-exp)
-  (let ((proc (if (null? maybe-exp)
-		  (focus-object)
-		  (eval (car maybe-exp) (environment-for-commands))))
-	(port (command-output)))
-    (if (procedure? proc)
-	(let ((probe (where-defined proc)))
-	  (if probe
-	      (display probe port)
-	      (display "Source file not recorded" port)))
-	(display "Not a procedure" port))
-    (newline port)))
-
-(define (where-defined thing)
-  (let loop ((dd (template-debug-data (closure-template thing))))
-    (if (debug-data? dd)
-	(if (string? (debug-data-name dd))
-	    (debug-data-name dd)
-	    (loop (debug-data-parent dd)))
-	#f)))
-
-;----------------
-; Utilities
-
-(define (coerce-to-template obj)
-  (cond ((template? obj) obj)
-	((closure? obj) (closure-template obj))
-	((continuation? obj) (continuation-template obj))
-	(else (error "expected a procedure or continuation" obj))))
-
-(define (with-limited-output thunk)
-  (let-fluids $write-depth *write-depth*
-              $write-length *write-length*
-    thunk))
-
diff --git a/scheme/env/jar-assem.scm b/scheme/env/jar-assem.scm
deleted file mode 100644
index a827f34..0000000
--- a/scheme/env/jar-assem.scm
+++ /dev/null
@@ -1,132 +0,0 @@
-; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; This is file assem.scm.
-
-;;;; Assembler
-
-; Courtesy John Ramsdell.
-
-; LAP syntax is much like that of the output of the disassembler except
-; that global and set-global! take a symbol as an argument, 
-; statements may be labeled, and jump, jump-if-false, and make-cont 
-; may make a forward reference to a label to give an offset.
-;
-; Example: a translation of (define (dog) (if x 0 1)).
-; (define dog
-;   (lap dog
-;     (check-nargs= 0)
-;     (global x)
-;     (jump-if-false 8)
-;     (literal '0)
-;   8 (jump out)
-;     (literal '1)
-; out (return)))
-
-(define-compilator '(lap syntax)
-  (let ((op/closure (enum op closure)))
-    (lambda (node cenv depth cont)
-      (let ((exp (node-form node)))
-	(deliver-value
-	 (instruction-with-template op/closure
-				    (compile-lap (cddr exp) cenv)
-				    (cadr exp))
-	 cont)))))
-
-; Assembler label environments are simply a-lists.
-(define assembler-empty-env '())
-(define (assembler-extend sym val env) (cons (cons sym val) env))
-(define (assembler-lookup sym env)
-  (let ((val (assv sym env)))
-    (if (pair? val) (cdr val) #f)))
-
-(define (compile-lap instruction-list cenv)
-  (assemble instruction-list
-	    assembler-empty-env
-	    cenv))
-
-; ASSEMBLE returns a segment.
-
-(define (assemble instruction-list lenv cenv)
-  (if (null? instruction-list)
-      (sequentially)
-      (let ((instr (car instruction-list))
-	    (instruction-list (cdr instruction-list)))
-	(cond ((pair? instr)		; Instruction
-	       (sequentially
-		(assemble-instruction instr lenv cenv)
-		(assemble instruction-list
-			  lenv
-			  cenv)))
-	      ((or (symbol? instr)	; Label
-		   (number? instr))
-	       (let ((label (make-label)))
-		 (attach-label
-		  label
-		  (assemble instruction-list
-			    (assembler-extend instr label lenv)
-			    cenv))))
-	      (else (error "invalid instruction" instr))))))
-
-; ASSEMBLE-INSTRUCTION returns a segment.
-
-(define (assemble-instruction instr lenv cenv)
-  (let* ((opcode (name->enumerand (car instr) op))
-	 (arg-specs (vector-ref opcode-arg-specs opcode)))
-    (cond ((or (not (pair? arg-specs))
-	       (not (pair? (cdr instr))))
-	   (instruction opcode))
-	  ((eq? (car arg-specs) 'index)
-	   (assemble-instruction-with-index opcode arg-specs (cdr instr) cenv))
-	  ((eq? (car arg-specs) 'offset)
-	   (let ((operand (cadr instr)))
-	     (apply instruction-using-label
-		    opcode
-		    (let ((probe (assembler-lookup operand lenv)))
-		      (if probe
-			  probe
-			  (begin
-			    (syntax-error "can't find forward label reference"
-					  operand)
-			    empty-segment)))
-		    (assemble-operands (cddr instr) arg-specs))))
-	  (else
-	   (apply instruction
-		  opcode
-		  (assemble-operands (cdr instr) arg-specs))))))
-
-; <index> ::= (quote <datum>) | (lap <name> <instr>) | <name>
-
-(define (assemble-instruction-with-index opcode arg-specs operands cenv)
-  (let ((operand (car operands)))
-    (if (pair? operand)
-	(case (car operand)
-	  ((quote)
-	   (instruction-with-literal opcode
-				     (cadr operand)))
-	  ((lap)
-	   (instruction-with-template opcode
-				      (compile-lap (cddr operand))
-				      (cadr operand)))
-	  (else
-	   (syntax-error "invalid index operand" operand)
-	   empty-segment))
-	;; Top-level variable reference
-	(instruction-with-location
-	 opcode
-	 (get-location (lookup cenv operand)
-		       cenv
-		       operand
-		       value-type)))))
-
-(define (assemble-operands operands arg-specs)
-  (map (lambda (operand arg-spec)
-	 (case arg-spec
-	   ((stob) (or (name->enumerand operand stob)
-		       (error "unknown stored object type" operand)))
-	   ((byte nargs) operand)
-	   (else (error "unknown operand type" operand arg-spec))))
-       operands
-       arg-specs))
-
diff --git a/scheme/env/load-package.scm b/scheme/env/load-package.scm
deleted file mode 100644
index b17af4f..0000000
--- a/scheme/env/load-package.scm
+++ /dev/null
@@ -1,22 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-(define (ensure-loaded . structs)
-  (force-output (current-output-port))		; avoid interleaved output
-  (let ((out (current-noise-port)))
-    (for-each (lambda (package)
-		(display #\[ out)
-		(display (package-name package) out)
-		(with-interaction-environment package
-		  (lambda ()
-		    (invoke-closure
-		      (make-closure (compile-package package)
-				    (package-uid package)))))
-		(set-package-loaded?! package #t)
-		(walk-population check-structure
-				 (package-clients package))
-		(display #\] out)
-		(newline out))
-	      (collect-packages structs
-				(lambda (package)
-				  (not (package-loaded? package)))))))
-
diff --git a/scheme/env/profile.scm b/scheme/env/profile.scm
deleted file mode 100644
index 56c5328..0000000
--- a/scheme/env/profile.scm
+++ /dev/null
@@ -1,173 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Profiling
-
-; NOTE: the sampling rate is set at the beginning of each run.  Different
-; machines and loadings will produce different tick rates.
-
-(define (profile command)
-  (let ((thunk (if (eq? (car command) 'run)
-		   (evaluate `(lambda () ,(cadr command))
-			     (environment-for-commands))
-		   (lambda () (execute-command command)))))
-    (call-with-values
-     (lambda () (run-with-profiling thunk (command-output)))
-     (lambda (results hits running on-stack)
-       (let ((port (command-output)))
-	 (display hits port)
-	 (display " samples" port)
-	 (newline port)
-	 (display "Running:" port)
-	 (newline port)
-	 (display-counts running hits - port)
-	 (display "Waiting:" port)
-	 (newline port)
-	 (display-counts on-stack hits (lambda (total next) next) port)
-	 (set-focus-values! results))))))
-
-(define-command-syntax 'profile "<command>" "profile execution"
-  '(command))
-
-(define (display-counts counts hits combine port)
-  (let ((limit (quotient hits 10)))
-    (do ((counts counts (cdr counts))
-	 (total hits (combine total (cdar counts))))
-	((or (<= total limit)
-	     (null? counts)
-	     (<= (cdar counts) 1)))
-      (display " " port)
-      (display (cdar counts) port)
-      (display " " port)
-      (display (caar counts) port)
-      (newline port))))
-
-; Strategy:
-; Request periodic interrupts.
-; At each interrupt save the current (raw) continuation.
-; Either at the end of the run or every so many interrupts, stop the
-; timer interrupts and walk the continuations adding the templates to
-; a table, with a count of how many times each has been seen.
-
-(define (run-with-profiling thunk port)
-  (calculate-tick-rate! port)
-  (call-with-values
-   (lambda ()
-     (dynamic-wind
-      (lambda ()
-	(vector-set! interrupt-handlers
-		     (enum interrupt alarm)
-		     handle-timer-interrupt)
-	(start-periodic-interrupts!))
-      (lambda ()
-	(primitive-cwcc
-	 (lambda (top)
-	   (set! *top-continuation* (continuation-parent top))
-	   (set! *hits* 0)
-	   (set! *conts* '())
-	   (set! *templates* '())
-	   (set! *template-counts* (make-template-table))
-	   (set! *cont-counts* (make-template-table))
-	   (set! *cont-count* cont-limit)
-	   (thunk))))
-      reset-timer-interrupts!))
-   (lambda results
-     (for-each add-cont-data! *conts*)
-     (let ((templates (gather-template-table-data *template-counts*))
-	   (conts (gather-template-table-data *cont-counts*)))
-       (set! *top-continuation* #f)  ; drop pointer
-       (set! *conts* '())
-       (values results *hits* templates conts)))))
-
-(define *quantum-mantissa* #f)
-(define *quantum-exponent* #f)
-
-; For checking how fast the machine is.
-
-(define (fib x)
-  (if (< x 2)
-      1
-      (+ (fib (- x 1)) (fib (- x 2)))))
-
-(define (calculate-tick-rate! port)
-  (let ((start-time (run-time)))
-    (fib 17)  ; chosen more or less at random.
-    (let ((end-time (run-time)))
-      (set! *quantum-mantissa* (quotient (- end-time start-time) 4))
-      (set! *quantum-exponent* (tick-exponent))
-      (display (round (/ (* *quantum-mantissa* (expt 10 *quantum-exponent*)))) port)
-      (display " ticks per second" port)
-      (newline port))))
-
-(define (start-periodic-interrupts!)
-  (schedule-interrupt *quantum-mantissa* *quantum-exponent* #t))
-
-(define (stop-periodic-interrupts!)
-  (schedule-interrupt 0 0 #f))
-
-(define cont-limit 100)
-
-(define *cont-count* cont-limit)
-
-(define (handle-timer-interrupt template ei)
-  (set! *cont-count* (- *cont-count* 1))
-  (if (= 0 *cont-count*)
-      (begin
-	(stop-periodic-interrupts!)
-	(for-each add-template-data! *templates*)
-	(for-each add-cont-data! *conts*)
-	(set! *cont-count* cont-limit)
-	(set! *templates* '())
-	(set! *conts* '())
-	(start-periodic-interrupts!)))
-  (set! *templates* (cons template *templates*))
-  (set! *hits* (+ *hits* 1))
-  (primitive-cwcc (lambda (cont)
-		    (set! *conts* (cons cont *conts*)))))
-
-(define *top-continuation* #f)
-(define *conts* '())
-(define *templates* '())
-(define *hits* 0)
-
-(define make-template-table (make-table-maker eq? template-id))
-
-(define *template-counts* (make-template-table))
-(define *cont-counts* (make-template-table))
-
-(define (okay-cont? cont)
-  (and cont (not (eq? cont *top-continuation*))))
-
-(define (add-template-data! template)
-  (let ((p (table-ref *template-counts* template)))
-    (if (not p)
-	(table-set! *template-counts*
-		    template
-		    (cons 1 '()))
-	(set-car! p (+ (car p) 1)))))
-
-(define (add-cont-data! cont)
-  (let loop ((cont (continuation-parent cont)))
-    (if (and (okay-cont? cont)
-	     (okay-cont? (continuation-parent cont)))
-	(let* ((template (continuation-template cont))
-	       (p (table-ref *cont-counts* template)))
-	  (if (not p)
-	      (table-set! *cont-counts*
-			  template
-			  (cons 1 '()))
-	      (set-car! p (+ (car p) 1)))
-	  (loop (continuation-parent cont))))))
-
-(define (gather-template-table-data table)
-  (let ((counts '()))
-    (table-walk (lambda (template p)
-		  (set! counts
-			(cons (cons (debug-data-names
-				     (template-debug-data template))
-				    (car p))
-			      counts)))
-		table)
-    (sort-list counts
-	       (lambda (p1 p2)
-		 (>= (cdr p1) (cdr p2))))))
diff --git a/scheme/env/read-command.scm b/scheme/env/read-command.scm
deleted file mode 100644
index 6dea3f3..0000000
--- a/scheme/env/read-command.scm
+++ /dev/null
@@ -1,194 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Read a command.  No command name completion, yet.
-
-(define (read-command prompt form-preferred? i-port)
-  (really-read-command prompt form-preferred? i-port no-more-commands))
-
-(define (really-read-command prompt form-preferred? i-port more-commands)
-  (let ((o-port (command-output)))
-    (let prompt-loop ()
-      (if (and prompt (not (batch-mode?)))
-	  (display prompt o-port))
-      (force-output o-port)		;foo
-      (let loop ()
-        (let ((c (peek-char i-port)))
-          (cond ((eof-object? c)
-                 (read-char i-port))
-                ((char-whitespace? c)
-                 (read-char i-port)
-                 (if (char=? c #\newline)
-                     (prompt-loop)
-                     (loop)))
-                ((char=? c #\;)      ;Comment
-		 (gobble-line i-port)
-		 (prompt-loop))
-                ((char=? c command-prefix)
-                 (read-char i-port)
-                 (read-named-command i-port more-commands form-preferred?))
-		((or form-preferred?
-		     (and (not (char-alphabetic? c))
-			  (not (char-numeric? c))
-			  (not (char=? c #\?))))
-		 (read-evaluation-command i-port))
-		(else
-		 (read-named-command i-port more-commands form-preferred?))))))))
-
-(define (read-command-carefully prompt form-preferred? i-port . more-commands)
-  (call-with-current-continuation
-    (lambda (k)
-      (with-handler
-        (lambda (c punt)
-	  (cond ((batch-mode?)
-		 (punt))
-		((or (read-error? c)
-		     (read-command-error? c))
-		 (let ((port (last (condition-stuff c))))
-		   (if (eq? port i-port)
-		       (eat-until-newline i-port))
-		   (display-condition c (command-output))
-		   (k #f)))
-		((reset-command-input? c)
-		 (k #f))
-		(else
-		 (punt))))
-	(lambda ()
-	  (really-read-command prompt form-preferred? i-port
-			       (if (null? more-commands)
-				   no-more-commands
-				   (car more-commands))))))))
-
-(define (eat-until-newline port)
-  (do ()
-      ((or (not (char-ready? port))
-	   (let ((c (read-char port)))
-	     (or (eof-object? c)
-		 (char=? c #\newline)))))))
-
-(define (read-evaluation-command i-port)
-  (let ((form (read-form i-port)))
-    (if (eq? (skip-over horizontal-space? i-port) #\newline)
-	(read-char i-port))
-    (make-command 'run (list form))))
-
-(define (no-more-commands name)
-  #f)
-
-; Read a single form, allowing ## as a way to refer to last command
-; output.
-
-(define (read-form port)
-  (with-sharp-sharp (make-node (get-operator 'quote)
-			       (list 'quote (focus-object)))
-    (lambda () (read port))))
-
-; Read a command line:  <name> <arg> ... <newline>
-
-(define (read-named-command port more-commands form-preferred?)
-  (let ((c-name (read port)))
-    (let ((syntax (or (more-commands c-name)
-		      (get-command-syntax c-name))))
-      (cond (syntax
-	     (make-command c-name
-			   (read-command-arguments syntax #f port
-						   more-commands
-						   form-preferred?)))
-	    (else
-	     (read-command-arguments '(&rest form) #f port #f #f) ; flush junk
-	     (write-line "Unrecognized command name." (command-output))
-	     #f)))))
-
-(define (read-command-arguments ds opt? port more-commands form-preferred?)
-  (let recur ((ds ds) (opt? opt?))
-    (let ((c (skip-over horizontal-space? port)))
-      (cond ((and (not (null? ds))
-		  (eq? (car ds) '&opt))
-	     (recur (cdr ds) #t))
-	    ((or (eof-object? c)
-		 (char=? c #\newline)
-		 (if (char=? c #\;)    ;Comment
-			     (begin (gobble-line port)
-				    #t)
-			     #f))
-		 (cond ((or (null? ds)
-			    (eq? (car ds) '&rest)
-			    opt?)
-			(read-char port)
-			'())
-		       (else
-			(read-command-error port
-					    "too few command arguments"))))
-	    ((null? ds)
-	     (read-command-error port "too many command arguments"))
-	    ((eq? (car ds) '&rest)
-	     (let ((arg (read-command-argument (cadr ds) port)))
-	       (cons arg (recur ds #f))))
-	    ((eq? (car ds) 'command)	; must be the last argument
-	     (if (not (null? (cdr ds)))
-		 (error "invalid argument descriptions" ds))
-	     (list (really-read-command #f form-preferred? port more-commands)))
-	    (else
-	     (let ((arg (read-command-argument (car ds) port)))
-	       (cons arg (recur (cdr ds) opt?))))))))
-
-(define (read-command-argument d port)
-  (if (procedure? d)
-      (d port)
-      (case d
-	((filename)
-	 (read-string port char-whitespace?))
-	((expression form)
-	 (read-form port))
-	((name)
-	 (let ((thing (read port)))
-	   (if (symbol? thing)
-	       thing
-	       (read-command-error port "invalid name" thing))))
-	(else (error "invalid argument description" d)))))
-
-(define-condition-type 'read-command-error '(error))
-(define read-command-error? (condition-predicate 'read-command-error))
-
-(define (read-command-error port message . rest)
-  (apply signal 'read-command-error message (append rest (list port))))
-
-
-; Utilities.
-
-(define (horizontal-space? c)
-  (and (char-whitespace? c)
-       (not (char=? c #\newline))))
-
-(define (read-string port delimiter?)
-  (let loop ((l '()))
-    (let ((c (peek-char port)))
-      (cond ((or (eof-object? c)
-                 (delimiter? c))
-             (list->string (reverse l)))
-            (else
-             (loop (cons (read-char port) l)))))))
-
-(define (skip-over pred port)
-  (let ((c (peek-char port)))
-    (cond ((eof-object? c) c)
-	  ((pred c) (read-char port) (skip-over pred port))
-	  (else c))))
-
-
-
-; ## should evaluate to the last REP-loop result.
-(define-sharp-macro #\#
-  (lambda (c port)
-    (read-char port)
-    ((fluid $sharp-sharp) port)))
-
-(define $sharp-sharp
-  (make-fluid (lambda (port) (reading-error port "## in invalid context"))))
-
-(define (with-sharp-sharp form body)
-  (let-fluid $sharp-sharp (lambda (port) form) body))
-
-(define make-command cons)      ;(name . args)
-
-; (put 'with-sharp-sharp 'scheme-indent-hook 1)
diff --git a/scheme/env/shadow.scm b/scheme/env/shadow.scm
deleted file mode 100644
index 2fcb849..0000000
--- a/scheme/env/shadow.scm
+++ /dev/null
@@ -1,73 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Deal with shadowed variables.
-
-; When a variable is shadowed by a variable, split the existing shared
-; location into two replacement locations.
-
-; name (structure-ref p name) (define name ...) within a single template
-; will lose big.
-
-;(define *replaced-locations* '()) ;alist of (old rep ((uid ...) . new))
-
-(define (shadow-location! old p-uids new replacement)
-  (if (location-defined? old)
-      (set-contents! replacement (contents old)))
-  (set-location-id! old
-		    (vector replacement p-uids new))
-  (set-location-defined?! old #f))  ;so that exceptions will be raised
-
-(define maybe-replace-location
-  (let ((memv memv))
-    (lambda (loc p-uid)			;Package's unique id
-      (let ((foo (location-id loc)))
-	(if (vector? foo)
-	    (maybe-replace-location
-	     (if (memv p-uid (vector-ref foo 1))
-		 (vector-ref foo 2)
-		 (vector-ref foo 0))
-	     p-uid)
-	    loc)))))
-
-; Exception handler:
-
-(define (deal-with-replaced-variables succeed)
-  (lambda (opcode reason loc . rest)
-    (if (= reason (enum exception undefined-global))
-	(deal-with-replaced-variable opcode reason loc rest succeed)
-	(apply signal-exception opcode reason loc rest))))
-
-(define (deal-with-replaced-variable opcode reason loc rest succeed)
-  (primitive-catch
-   (lambda (cont)
-     (let* ((tem (continuation-template cont))
-	    (index (+ (code-vector-ref (template-code tem)
-				       (+ (continuation-pc cont) 2))
-		      (* (code-vector-ref (template-code tem)
-					  (+ (continuation-pc cont) 1))
-			 byte-limit))))
-       (if (eq? (template-ref tem index) loc)
-	   (let* ((p-uid (do ((env (continuation-env cont)
-				   (vector-ref env 0)))
-			     ((not (vector? env)) env)))
-		  (new (maybe-replace-location loc p-uid)))
-	     (if (eq? new loc)
-		 (apply signal-exception opcode reason loc rest)
-		 (begin (template-set! tem index new)
-			;(signal 'note "Replaced location" loc new p-uid)
-			(if (location-defined? new)
-			    (succeed new rest)
-			    (apply signal-exception opcode reason new rest)))))
-	   (error "lossage in deal-with-replaced-variables"
-		  loc index))))))
-
-(define-exception-handler (enum op global)
-  (deal-with-replaced-variables
-   (lambda (loc more-args)
-     (contents loc))))
-
-(define-exception-handler (enum op set-global!)
-  (deal-with-replaced-variables
-   (lambda (loc more-args)
-     (set-contents! loc (car more-args)))))
diff --git a/scheme/env/start.scm b/scheme/env/start.scm
deleted file mode 100644
index 02839df..0000000
--- a/scheme/env/start.scm
+++ /dev/null
@@ -1,67 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-(define (start structs-to-open)
-  (lambda (structs-thunk)
-    (usual-resumer
-     (lambda (arg)
-       (let* ((structs (structs-thunk))
-	      (b (make-built-in-structures structs)))
-	 (initialize-interaction-environment! b)
-	 (with-interaction-environment
-	     (make-initial-package b structs-to-open)
-	   (lambda ()
-	     (command-processor (cond ((assq 'usual-commands structs)
-				       => (lambda (z)
-					    (structure-package (cdr z))))
-				      (else #f))
-				arg))))))))
-
-; The structs argument is an a-list of (name . structure), as computed
-; by the expression returned by reify-structures.
-
-(define (make-built-in-structures structs)
-  (let* ((p (make-simple-package '() #f #f 'built-in-structures))
-	 (s (make-structure p
-		  (lambda ()
-		    (make-simple-interface
-		       #f			;name
-		       (cons 'built-in-structures (map car structs))))
-		  'built-in-structures)))
-    (for-each (lambda (name+struct)
-		(environment-define! p
-				     (car name+struct)
-				     (cdr name+struct)))
-	      structs)
-    (environment-define! p 'built-in-structures s)
-    s))
-
-(define (initialize-interaction-environment! built-in-structures)
-  (let ((scheme (*structure-ref built-in-structures 'scheme))
-	(tower (make-tower built-in-structures 'interaction)))
-    (set-interaction-environment!
-      (make-simple-package (list scheme) #t tower 'interaction))
-
-    (set-scheme-report-environment!
-      5
-      (make-simple-package (list scheme) #t tower 'r5rs))))
-
-; Intended for bootstrapping the command processor.
-
-(define (make-initial-package built-in-structures structs-to-open)
-  (let ((p (make-simple-package
-	    (cons built-in-structures
-		  (map (lambda (name)
-			 (*structure-ref built-in-structures name))
-		       structs-to-open))
-	    eval
-	    (make-tower built-in-structures 'initial)
-	    'initial)))
-    (environment-define! p 'built-in-structures built-in-structures)
-    p))
-
-(define (make-tower built-in-structures id)
-  (make-reflective-tower eval
-			 (list (*structure-ref built-in-structures
-					       'scheme))
-			 id))
diff --git a/scheme/env/version-info.scm b/scheme/env/version-info.scm
deleted file mode 100644
index 79416cc..0000000
--- a/scheme/env/version-info.scm
+++ /dev/null
@@ -1,3 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-(define version-info "0.53")
diff --git a/scheme/initial-packages.scm b/scheme/initial-packages.scm
deleted file mode 100644
index 01bc6a6..0000000
--- a/scheme/initial-packages.scm
+++ /dev/null
@@ -1,105 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Packages involved in building the initial system.
-
-
-; Access to values from packages and structures 
-
-(define-structure environments environments-interface
-  (open scheme-level-2
-	packages bindings meta-types
-	fluids
-	locations	; contents location-assigned?
-	signals)	; error
-  (files (rts env)))
-
-; EVAL and LOAD
-
-(define-structure evaluation evaluation-interface
-  (open scheme-level-2
-	packages        	;package-uid package->environment link!
-	environments		;package-for-load
-	compiler-envs		;bind-source-filename
-	reading-forms		;read-forms $note-file-package
-	syntactic		;scan-forms expand-forms
-	compiler		;compile-forms
-	closures		;make-closure
-	vm-exposure		;invoke-closure
-	features		;current-noise-port force-output
-	signals fluids)
-  (files (rts eval)))
-
-; Scheme = scheme-level-2 plus EVAL and friends
-
-(define-module (make-scheme environments evaluation)
-  (define-structure scheme scheme-interface
-    (open scheme-level-2
-	  environments
-	  evaluation))
-  scheme)
-
-
-; Command processor.
-
-(define-module (make-mini-command scheme) ;copied from debug-packages.scm
-  (define-structure mini-command (export command-processor)
-    (open scheme
-	  signals conditions handle
-	  display-conditions
-	  i/o)                 ;current-error-port
-    (files (debug mini-command)))
-  mini-command)
-
-
-; For building systems.
-
-(define-module (make-initial-system scheme command)
-
-  (define-structure initial-system (export start)
-    (open scheme
-	  command
-	  interfaces		;make-simple-interface
-	  packages		;make-simple-package
-	  environments		;with-interaction-environment, etc.
-	  usual-resumer
-	  conditions handle	;error? with-handler
-	  signals)		;error
-    (files (env start)))
-
-  initial-system)
-
-
-; Utility to load packages following dependency links (OPEN and ACCESS)
-;Cf. (link-initial-system) and Makefile
-
-(define-structure ensures-loaded (export ensure-loaded)
-  (open scheme-level-2
-	features		;current-noise-port
-	packages		;package-uid package-clients
-	packages-internal	;package-loaded? set-package-loaded?!
-	scan-package		;collect-packages check-structure
-	compile-packages	;compile-package
-	closures		;make-closure
-	vm-exposure		;invoke-closure
-	environments		;with-interaction-environment
-	weak			;walk-population
-	)
-  (files (env load-package)))
-
-; Things needed by the expression generated by REIFY-STRUCTURES.
-
-(define-structure for-reification for-reification-interface
-  (open scheme-level-1
-	packages packages-internal
-	signals
-	meta-types			;sexp->type structure-type
-	interfaces			;make-simple-interface
-	bindings
-	nodes				;get-operator operator? operator-type
-	primops				;get-primop primop? primop-type
-	usual-macros			;usual-transform
-	inline				;inline-transform
-	transforms			;make-transform transform? transform-type
-	tables)
-  (files (bcomp for-reify)))
diff --git a/scheme/link-packages.scm b/scheme/link-packages.scm
deleted file mode 100644
index 85fd92d..0000000
--- a/scheme/link-packages.scm
+++ /dev/null
@@ -1,86 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Static linker.  Doesn't work very well this way (debug info is
-; screwed up), so it's probably better to continue using linker.image
-; instead.
-
-(define-structure linker linker-interface
-  (open scheme-level-2
-	compiler write-images
-	debuginfo
-	segments		;with-fresh-compiler-state
-	packages
-	packages-internal       ;set-package-integrate?!
-	names			;name->symbol
-	scan-package		;collect-packages
-	compile-packages	;compile-package
-	reification
-	closures		;make closure to pass to write-image
-	filenames
-	debug-data		;with-fresh-compiler-state
-	locations
-	tables fluids signals util)
-  (files (link link)))
-
-(define-structure reification (export reify-structures)
-  (open scheme-level-2
-	packages
-	packages-internal ;?
-	usual-macros		;find-free-names-in-syntax-rules
-	names bindings
-	meta-types		;usual-variable-type
-	locations
-	primops
-	tables records
-	signals			;error
-	features		;force-output
-	util			;filter
-	inline)			;name->extrinsic
-  (files (link reify)))
-
-; Database of procedure names 'n' stuff.
-; (copy in more-packages.scm ...)
-
-(define-structure debuginfo debuginfo-interface
-  (open scheme-level-2
-	tables
-	debug-data
-	packages
-	packages-internal
-	syntactic
-	segments	;debug-data-table
-	features)       ;make-immutable!
-  (files (env debuginfo)))
-
-
-; Mumble.
-
-(define-structure flatloading (export flatload all-file-names)
-  (open scheme packages packages-internal filenames)
-  (files (env flatload)))
-
-(define-structure loadc (export load-configuration
-				;; (structure-ref :syntax)
-				)
-  (open scheme
-	environments		; *structure-ref
-	syntactic		; $source-file-name
-	fluids)
-  (files (link loadc)))
-
-
-; Everything.
-
-(define-structure link-config (export )  ;dummy structure...
-  (open scheme-level-2
-	linker
-	defpackage
-	types
-	analysis
-	loadc
-	flatloading
-	interfaces
-	signals)    ;warn
-  ;; (files (alt init-defpackage.scm))  -- or (env ...), depending
-  )
diff --git a/scheme/link/data.scm b/scheme/link/data.scm
deleted file mode 100644
index 0e23fc0..0000000
--- a/scheme/link/data.scm
+++ /dev/null
@@ -1,139 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Scheme 48's data representations, for writing heap images.
-; Defines things needed by TRANSPORT (which is called by WRITE-IMAGE, which
-; is called by the static linker).
-; Adapted from vm/util.scm and vm/data.scm.
-
-
-(define (low-bits n k)
-  (bitwise-and n (- (arithmetic-shift 1 k) 1)))
-
-(define (high-bits n k)
-  (arithmetic-shift n (- 0 k)))
-
-(define (adjoin-bits high low width)
-  (bitwise-ior (arithmetic-shift high width) low))
-
-
-; Essential constants
-
-(define level          17)
-(define little-endian? #t)
-(define bits-per-byte  8)
-(define bytes-per-cell 4)
-(define bits-per-cell  (* bits-per-byte bytes-per-cell))
-(define addressing-units-per-cell 4)
-
-; This is actually the mimimum for the different PreScheme implementations.
-; The Scheme version of PreScheme leaves 30 bits for PreScheme's fixnums.
-; There have to be enough bits to represent the largest fixnum in the system.
-; USEFUL-BITS-PER-WORD is not written in the image.
-(define useful-bits-per-word      30)
-
-(define unused-field-width 2)
-
-(define tag-field-width 2)
-
-(define immediate-type-field-width
-  (- 8 tag-field-width))
-
-; Data descriptions copied from DATA.SCM
-
-(define-enumeration tag
-  (fixnum
-   immediate
-   header
-   stob))
-
-(define-enumeration imm
-  (false      ; #f
-   true       ; #t
-   char
-   unspecific
-   undefined
-   eof
-   null))
-
-(define bits-per-fixnum
-  (- (if (< bits-per-cell useful-bits-per-word)
-	 bits-per-cell
-	 useful-bits-per-word)
-     tag-field-width))
-
-(define	   least-fixnum-value (- 0 (arithmetic-shift 1 (- bits-per-fixnum 1))))
-(define greatest-fixnum-value (-   (arithmetic-shift 1 (- bits-per-fixnum 1))
-				   1))
-
-(define (fixnum? x)
-  (and (integer? x)
-       (>= x least-fixnum-value)
-       (<= x greatest-fixnum-value)))
-
-(define (immediate? x)
-  (or (fixnum? x)
-      (char? x)
-      (eq? x #t)
-      (eq? x '())    ; I think order is important here as () is a literal while
-      (eq? x #f)     ; #F is generated with an instruction.  If () = #f then
-		     ; we still lose on something like '(#F) (which is
-		     ; present in the system). 
-      ;; (eq? thing (unspecific))
-      ))
-
-(define car-offset 0)
-(define cdr-offset 1)
-
-(define closure-template-offset 0)
-(define closure-env-offset	1)
-
-(define location-contents-offset 1)
-(define location-id-offset     0)
-
-; Procedures for manipulating bits
-
-(define (make-descriptor tag data)
-  (adjoin-bits data tag tag-field-width))
-
-(define (make-immediate type info)
-  (make-descriptor (enum tag immediate)
-		   (adjoin-bits info type immediate-type-field-width)))
-
-(define vm-true	 (make-immediate (enum imm true)  0))
-(define vm-false (make-immediate (enum imm false) 0))
-(define vm-null	 (make-immediate (enum imm null)  0))
-(define vm-unspecific  (make-immediate (enum imm unspecific) 0))
-(define vm-unbound     (make-immediate (enum imm undefined) 1))
-(define vm-unassigned  (make-immediate (enum imm undefined) 2))
-
-(define header-type-field-width (- immediate-type-field-width 1))
-
-(define (make-header type length-in-bytes)
-  (make-descriptor (enum tag header) (adjoin-bits length-in-bytes
-					   type
-					   (+ 1 header-type-field-width))))
-
-(define (make-header-immutable header)
-  (bitwise-ior header (arithmetic-shift 1 (+ tag-field-width
-					     header-type-field-width))))
-
-(define (make-stob-descriptor addr)
-  (make-descriptor (enum tag stob) (a-units->cells addr)))
-
-(define (bytes->cells bytes)
-  (quotient (+ bytes (- bytes-per-cell 1))
-	    bytes-per-cell))
-
-(define (cells->bytes cells)
-  (* cells bytes-per-cell))
-
-(define (cells->a-units cells)
-  (adjoin-bits cells 0 unused-field-width))
-
-(define (a-units->cells cells)
-  (high-bits cells unused-field-width))
-
-(define (bytes->a-units byte-count)
-  (cells->a-units (bytes->cells byte-count)))
-
diff --git a/scheme/link/generate-old-c-header.scm b/scheme/link/generate-old-c-header.scm
deleted file mode 100644
index 7a46667..0000000
--- a/scheme/link/generate-old-c-header.scm
+++ /dev/null
@@ -1,160 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; This for compatibility with pre-0.53 code.
-
-; [This is a kludge.  Richard is loathe to include it in the
-; distribution.]
-
-; Reads arch.scm and data.scm and writes out a C .h file with constants
-; and macros for dealing with Scheme 48 data structures.
-
-; Needs Big Scheme.
-
-; (make-c-header-file "scheme48.h" "vm/arch.scm" "vm/data.scm")
-
-(define (make-c-header-file c-file arch-file data-file)
-  (receive (stob-list stob-data)
-      (search-file arch-file
-		   '("stob enumeration" "(define stob-data ...)")
-		   (defines-enum? 'stob)
-		   enum-definition-list
-		   (lambda (x)
-		     (and (eq? (car x) 'define)
-			  (eq? (cadr x) 'stob-data)))
-		   (lambda (x) (cadr (caddr x))))
-    (receive (tag-list immediate-list)
-	(search-file data-file
-		     '("tag enumeration" "imm enumeration")
-		     (defines-enum? 'tag)
-		     enum-definition-list
-		     (defines-enum? 'imm)
-		     enum-definition-list)
-      (with-output-to-file c-file
-	(lambda ()
-	  (format #t "typedef long scheme_value;~%~%")
-	  (tag-stuff tag-list)
-	  (newline)
-	  (immediate-stuff immediate-list)
-	  (newline)
-	  (stob-stuff stob-list stob-data))))))
-	  
-(define (tag-stuff tag-list)
-  (do ((tags tag-list (cdr tags))
-       (i 0 (+ i 1)))
-      ((null? tags))
-    (let ((name (upcase (car tags))))
-      (c-define "~A_TAG ~D" name i)
-      (c-define "~AP(x) (((long)(x) & 3L) == ~A_TAG)" name name)))
-  (newline)
-  (c-define "ENTER_FIXNUM(n)   ((scheme_value)((n) << 2))")
-  (c-define "EXTRACT_FIXNUM(x) ((long)(x) >> 2)"))
-
-(define (immediate-stuff imm-list)
-  (c-define "MISC_IMMEDIATE(n) (scheme_value)(IMMEDIATE_TAG | ((n) << 2))")
-  (do ((imm imm-list (cdr imm))
-       (i 0 (+ i 1)))
-      ((null? imm))
-    (let ((name (upcase (car imm))))
-      (c-define "SCH~A    MISC_IMMEDIATE(~D)" name i)))
-  (c-define "UNDEFINED SCHUNDEFINED")
-  (c-define "UNSPECIFIC SCHUNSPECIFIC")
-  (newline)
-  (c-define "ENTER_BOOLEAN(n) ((n) ? SCHTRUE : SCHFALSE)")
-  (c-define "EXTRACT_BOOLEAN(x) ((x) != SCHFALSE)")
-  (newline)
-  (c-define "ENTER_CHAR(c) (SCHCHAR | ((c) << 8))")
-  (c-define "EXTRACT_CHAR(x) ((x) >> 8)")
-  (c-define "CHARP(x) ((((long) (x)) & 0xff) == SCHCHAR)"))
-
-(define (stob-stuff stob-list stob-data)
-  (let ((type-mask (let ((len (length stob-list)))
-		     (do ((i 2 (* i 2)))
-			 ((>= i len) (- i 1))))))
-    (c-define "ADDRESS_AFTER_HEADER(x, type) ((type *)((x) - STOB_TAG))")
-    (c-define "STOB_REF(x, i) ((ADDRESS_AFTER_HEADER(x, long))[i])")
-    (c-define "STOB_TYPE(x)   ((STOB_HEADER(x)>>2)&~D)" type-mask)
-    (c-define "STOB_HEADER(x) (STOB_REF((x),-1))")
-    (c-define "STOB_BLENGTH(x) (STOB_HEADER(x) >> 8)")
-    (c-define "STOB_LLENGTH(x) (STOB_HEADER(x) >> 10)")
-    (newline)
-    (do ((stob stob-list (cdr stob))
-	 (i 0 (+ i 1)))
-	((null? stob))
-      (let ((name (upcase (if (eq? (car stob) 'byte-vector)
-			      'code-vector
-			      (car stob)))))
-	(c-define "STOBTYPE_~A ~D" name i)
-	(c-define "~AP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_~A))"
-		  name name)))
-    (newline)
-    (for-each (lambda (data)
-		(do ((accs (cdddr data) (cdr accs))
-		     (i 0 (+ i 1)))
-		    ((null? accs))
-		  (let ((name (upcase (caar accs))))
-		    (c-define "~A(x) STOB_REF(x, ~D)" name i))))
-	      stob-data)
-    (newline)
-    (c-define "VECTOR_LENGTH(x) STOB_LLENGTH(x)")
-    (c-define "VECTOR_REF(x, i) STOB_REF(x, i)")
-    (c-define "CODE_VECTOR_LENGTH(x)  STOB_BLENGTH(x)")
-    (c-define "CODE_VECTOR_REF(x, i)  (ADDRESS_AFTER_HEADER(x, unsigned char)[i])")
-    (c-define "STRING_LENGTH(x)  (STOB_BLENGTH(x)-1)")
-    (c-define "STRING_REF(x, i)  (ADDRESS_AFTER_HEADER(x, char)[i])")))
-
-; - becomes _ > becomes TO_ (so -> turns into _TO_)
-; ? becomes P
-
-(define (upcase symbol)
-  (do ((chars (string->list (symbol->string symbol)) (cdr chars))
-       (res '() (case (car chars)
-		  ((#\>) (append (string->list "_OT") res))
-		  ((#\-) (cons #\_ res))
-		  ((#\?) (cons #\P res))
-		  (else (cons (char-upcase (car chars)) res)))))
-      ((null? chars)
-       (list->string (reverse res)))))
-
-(define (c-define string . stuff)
-  (format #t "#define ~?~%" string stuff))
-    
-(define (defines-enum? name)
-  (lambda (x)
-    (and (eq? (car x) 'define-enumeration)
-	 (eq? (cadr x) name))))
-
-(define enum-definition-list caddr)
-
-; STUFF is list of ((predicate . extract) . name).  <name> is replaced
-; with the value when it is found.
-
-(define (search-file file what-for . pred+extract)
-  (let ((stuff (do ((p+e pred+extract (cddr p+e))
-		    (names what-for (cdr names))
-		    (ps '() (cons (cons (cons (car p+e) (cadr p+e))
-					(car names))
-				  ps)))
-		   ((null? p+e) (reverse ps)))))
-
-    (define (search next not-found)
-      (let loop ((n-f not-found) (checked '()))
-	(cond ((null? n-f)
-	       #f)
-	      (((caaar n-f) next)
-	       (set-cdr! (car n-f) ((cdaar n-f) next))
-	       (append (reverse checked) (cdr n-f)))
-	      (else
-	       (loop (cdr n-f) (cons (car n-f) checked))))))
-
-    (with-input-from-file file
-      (lambda ()
-	(let loop ((not-found stuff))
-	  (let ((next (read)))
-	    (cond ((null? not-found)
-		   (apply values (map cdr stuff)))
-		  ((eof-object? next)
-		   (error "file ~S doesn't have ~A" file (cdar not-found)))
-		  (else
-		   (loop (or (and (pair? next)
-				  (search next not-found))
-			     not-found))))))))))
diff --git a/scheme/link/link.scm b/scheme/link/link.scm
deleted file mode 100644
index f23cf94..0000000
--- a/scheme/link/link.scm
+++ /dev/null
@@ -1,150 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; The static linker.
-
-; link-simple-system:
-; resumer-exp should evaluate to a procedure
-;   (lambda (arg i-port o-port ...) ...)
-
-(define (link-simple-system filename resumer-exp . structs)
-  (link-system structs (lambda () resumer-exp) filename))
-
-
-; resumer-exp should evaluate to a procedure
-;   (lambda (structs-thunk) ... (lambda (arg i-port o-port ...) ...))
-
-(define (link-reified-system some filename make-resumer-exp . structs)
-  (link-system (append structs (map cdr some))
-	       (lambda ()
-		 `(,make-resumer-exp
-		   (lambda ()
-		     ,(call-with-values
-			  (lambda () (reify-structures some))
-			(lambda (exp locs least-uid)
-			  `(,exp (lambda (i)
-				   (vector-ref ,(strange-quotation locs)
-					       (- i ,least-uid)))))))))
-	       filename))
-
-(define strange-quotation
-  (let ((operator/quote (get-operator 'quote)))
-    (lambda (thing)
-      (make-node operator/quote `',thing))))
-
-
-; `(,make-resumer-exp ',vector) should evaluate to a procedure
-;   (lambda (locs) ... (lambda (arg i-port o-port ...) ...))
-
-(define (link-semireified-system some filename
-				 make-resumer-exp . structs)
-  (let ((loser #f))
-    (link-system (append structs (map cdr some))
-		 (lambda ()
-		   (call-with-values (lambda ()
-				       (reify-structures some))
-		     (lambda (exp locs least)
-		       (set! loser exp)
-		       `(,make-resumer-exp ,(strange-quotation locs)
-					   ,least))))
-		 filename)
-    (let ((f (namestring filename #f 'env)))
-      (call-with-output-file f
-	(lambda (port)
-	  (display "Writing environment structure to ")
-	  (display f)
-	  (newline)
-	  ;; loser evaluates to a procedure
-	  ;;  (lambda (uid->location) struct-alist)
-	  (write `(define make-the-structures
-		    (,loser location-from-id))
-		 port))))))
-
-
-; (link-system structs make-resumer filename)
-;    structs is a list of structures to be compiled,
-;    make-resumer is a thunk which should return an expression, to be
-;      evaluated in a package that opens the given structures, that
-;      evaluates to the procedure to be called after all
-;      initializations are run, and
-;    filename is the name of the file to which the image should be written.
-
-(define (link-system structs make-resumer filename)
-  (with-fresh-compiler-state
-   (if *debug-linker?* 100000 0)    ;Location uid
-   (lambda ()
-     (set! *loser* #f)
-     (let* ((location-info (make-table))
-	    (generator (make-location-generator location-info
-						(if *debug-linker?* 10000 0)))
-	    (templates (compile-structures structs
-					   generator
-					   package->environment))
-	    (package (make-simple-package structs #f #f))
-	    (startup-template (begin
-				(set-package-get-location! package generator)
-				(expand&compile-form (make-resumer) package))))
-       (let ((startup (make-closure 
-		       (make-startup-procedure templates startup-template)
-		       0)))
-	 (if *debug-linker?* (set! *loser* startup))
-	 (write-image-file startup
-			   (namestring filename #f 'image)))
-       (write-debug-info location-info
-			 (namestring filename #f 'debug))))))
-
-
-(define (expand&compile-form form package)
-  (let* ((env (package->environment package))
-	 (template (compile-forms (map (lambda (form)
-					 (expand-scanned-form form env))
-				       (scan-forms (list form) env))
-				  #f)))	;filename
-    (link! template package #t)
-    template))
-
-(define *loser* #f)
-(define *debug-linker?* #f)
-
-(define (compile-structures structs generator package->env)
-  (let ((packages (collect-packages structs (lambda (package) #t)))
-	(out (current-noise-port)))
-    (for-each (lambda (package)
-		(set-package-get-location! package generator))
-	      packages)
-    (map (lambda (package)
-	   (display #\[ out)
-	   (display (package-name package) out)
-	   (let ((template (compile-package package)))
-	     (display #\] out)
-	     (newline out)
-	     template))
-	 packages)))
-
-; Locations in new image will have their own sequence of unique id's.
-
-(define (make-location-generator location-info start)
-
-  (let ((*location-uid* start))
-
-    (define (make-new-location p name)
-      (let ((uid *location-uid*))
-	(set! *location-uid* (+ *location-uid* 1))
-	(table-set! location-info uid
-		    (cons (name->symbol name) (package-uid p))) ;?
-	(make-undefined-location uid)))
-
-    make-new-location))
-
-
-(define (write-image-file start filename)
-  (write-image filename
-	       start
-	       "This heap image was made by the Scheme 48 linker."))
-
-
-
-; Handy utility for making arguments to link-reified-system
-
-(define-syntax struct-list
-  (syntax-rules ()
-    ((struct-list name ...) (list (cons 'name name) ...))))
diff --git a/scheme/link/loadc.scm b/scheme/link/loadc.scm
deleted file mode 100644
index 5d343a3..0000000
--- a/scheme/link/loadc.scm
+++ /dev/null
@@ -1,21 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Cf. alt/config.scm
-
-(define (load-configuration filename . rest)
-  (let ((save filename))
-    (dynamic-wind (lambda () (set! *source-file-name* filename))
-		  (lambda ()
-		    (apply load filename rest))
-		  (lambda () (set! *source-file-name* save)))))
-(define (%file-name%) *source-file-name*)
-(define *source-file-name* "")
-
-
-; ?
-
-(define-syntax structure-ref
-  (syntax-rules ()
-    ((structure-ref ?struct ?name)
-     (*structure-ref ?struct '?name))))
diff --git a/scheme/link/reify.scm b/scheme/link/reify.scm
deleted file mode 100644
index fc22356..0000000
--- a/scheme/link/reify.scm
+++ /dev/null
@@ -1,283 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Structure reification.
-
-(define *least* #f)
-
-(define (reify-structures some)
-  (let* ((count 0)
-	 (least 1000000)
-	 (greatest -1000000)
-	 (locs (make-table))
-	 (loser (reify-structures-1 some
-				    (lambda (loc)
-				      (let ((id (location-id loc)))
-					(if (not (table-ref locs id))
-					    (begin 
-					      (if (< id least)
-						  (set! *least* loc))
-					      (set! least (min least id))
-					      (set! greatest (max greatest id))
-					      (set! count (+ count 1))
-					      (table-set! locs id loc)))
-					id))))
-	 (size (+ (- greatest least) 1)))
-    (write `(least ,least size ,size count ,count)) (newline)
-    (values loser
-	    (let ((v (make-vector size #f)))
-	      (table-walk (lambda (id loc)
-			    (vector-set! v (- id least) loc))
-			  locs)
-	      v)
-	    least)))
-
-
-; This is pretty gross.  We really want some kind of object dumper
-; instead.
-
-(define *objects* '())          ;List of (object . creation-form)
-(define *object-count* 0)
-(define *initializations* '())
-(define *deal-with-location* (lambda (loc) loc))
-(define *package-table* #f)     ;Entries are package-info structures
-
-
-; REIFY-STRUCTURES returns a form that evaluates to a procedure that
-; returns an alist of (name . structure).  deal-with-location is a
-; procedure that maps locations to labels for them (e.g. integers).
-; The procedure takes one argument, a procedure that will be applied
-; to the labels at startup time to re-obtain the corresponding
-; locations.
-
-(define (reify-structures-1 alist deal-with-location)
-  (flush-state)
-  (set! *deal-with-location* deal-with-location)
-
-  (display "Reifying") (force-output (current-output-port))
-
-  (let* ((result-form (reify-object alist))
-	 (shebang
-	  `(lambda (get-location)
-	     (let ((the-objects (make-vector ,*object-count* #f)))
-	       (begin ,@(map (lambda (init) (init))
-			     (reverse *initializations*)))
-	       (let ((structs ,result-form))
-		 (set! the-objects #f)	;SO IT CAN BE GC'D
-		 (set! get-location #f)
-		 structs)))))
-    (newline)
-    (if *reify-debug* (*reify-debug* shebang))
-
-    (flush-state)
-    (set! *deal-with-location* (lambda (loc) loc))
-
-    shebang))
-
-(define (flush-state)
-  (set! *objects* '())
-  (set! *object-count* 0)
-  (set! *initializations* '())
-  (set! *package-table* (make-table package-uid)))
-
-
-; Return an expression that will evaluate to thing.
-
-(define (reify-object thing)
-  (cond ((structure? thing)
-	 (let ((p-form (reify-package (structure-package thing))))
-	   (process-one-object
-	        thing
-		(lambda ()
-		  `(make-structure
-		    ,p-form
-		    ,(interface-expression thing)
-		    ',(structure-name thing)))
-		(lambda ()
-		  (process-exports thing p-form)
-		  (write-char #\. (current-output-port))
-		  (force-output (current-output-port))))))
-	((null? thing) ''())
-	((pair? thing)
-	 (if (list? thing)
-	     `(list ,@(map reify-object thing))
-	     `(cons ,(reify-object (car thing))
-		    ,(reify-object (cdr thing)))))
-	((symbol? thing)
-	 `',thing)
-	((transform? thing)
-	 (process-transform thing))
-	((operator? thing)
-	 `(operator ',(operator-name thing)
-		    ',(type->sexp (operator-type thing) #t)))
-	((primop? thing)
-	 `(primop ',(primop-name thing)))
-	;; ((interface? thing) ...)
-	(else (error "don't know how to reify this" thing))))
-
-(define (reify-package thing)
-  (process-one-object thing
-		      (lambda ()
-			(let ((bindings (package-info-bindings (package-info thing))))
-			  `(package
-			    ;; Each binding is a pair (name . loc)
-			    ',(list->vector (map car bindings)) ;names
-			    ',(list->vector (map cdr bindings)) ;location ids
-			    get-location
-			    ,(package-uid thing))))
-		      (lambda ()
-			(table-set! *package-table*
-				    thing
-				    (make-package-info)))))
-
-
-; General utility for uniquifying objects.
-
-(define (process-one-object obj make-creation-form when-new)
-  (let ((probe (assq obj *objects*)))
-    (if probe
-	(cdr probe)
-	(let* ((index *object-count*)
-	       (form `(vector-ref the-objects ,index)))
-	  (set! *object-count* (+ *object-count* 1))
-	  (set! *objects*
-		(cons (cons obj form) *objects*))
-	  (add-initialization!
-	    (lambda ()
-	      `(vector-set! the-objects ,index ,(make-creation-form))))
-	  (when-new)
-	  form))))
-
-(define (add-initialization! thunk)
-  (set! *initializations*
-	(cons thunk *initializations*)))
-
-
-; Add initializers that will create a structure's exported bindings.
-
-(define (process-exports struct p-form)
-  (let* ((package (structure-package struct))
-	 (info (package-info package)))
-    (for-each-export (lambda (name want-type binding)
-		       (if (not (process-one-binding name package info p-form))
-			   (warn "undefined export" name package)))
-		     struct)))
-
-
-; Packages...
-
-(define package-info-type
-  (make-record-type 'reify-info
-		    '(bindings  ;List of (name static-info location)
-		      table)))  ;Caches (assq? name bindings)
-
-(define (package-info package)
-  (table-ref *package-table* package))
-
-(define make-package-info
-  (let ((make (record-constructor package-info-type
-				  '(bindings table))))
-    (lambda ()
-      (make '()
-	    (make-name-table)))))
-
-(define package-info-bindings (record-accessor package-info-type 'bindings))
-(define package-info-table    (record-accessor package-info-type 'table))
-
-(define set-package-info-bindings!
-  (record-modifier package-info-type 'bindings))
-
-
-(define (process-one-binding name package info p-form)	; => #t iff bound
-  (let ((table (package-info-table info)))
-    (if (table-ref table name)
-	#t
-	(let ((binding (package-lookup package name)))
-	  (table-set! (package-info-table info) name #t)
-	  (if (binding? binding)
-	      (begin (really-process-one-binding name info binding p-form)
-		     #t)
-	      #f)))))
-
-(define (really-process-one-binding name info binding p-form)
-  (let ((static (binding-static binding))
-	(loc (*deal-with-location* (binding-place binding))))
-    (set-package-info-bindings!
-         info
-	 (cons (cons name loc)
-	       (package-info-bindings info)))
-    (if static
-	(add-package-define! p-form name (reify-object static)))))
-
-(define (add-package-define! p-form name s-form)
-  (add-initialization!
-   (lambda ()
-     `(package-define-static! ,p-form
-			      ',name
-			      ,s-form))))
-
-(define (process-transform transform)
-  (let ((name (transform-id transform))
-	(env (transform-env transform)))
-    (let ((env-form
-	   (if (package? env)
-	       (reify-package env)
-	       (reify-object env))))
-      (process-one-object
-       transform
-       (let ((source (transform-source transform)))
-	 (lambda ()
-	   `(transform ,source		;transformer
-		       ,env-form
-		       ',(type->sexp (transform-type transform) #t) ;type
-		       #f		;',source  -- omitted to save space...
-		       ',name)))
-       (if (package? env)
-	   (lambda ()
-	     (let ((info (package-info env)))
-	       (for-each (lambda (name)
-			   (process-one-binding name env info env-form))
-			 (or (transform-aux-names transform) ; () must be true
-			     (begin
-			       (warn "reified macro's auxiliary bindings are unknown"
-				     name)
-			       '())))))
-	   (lambda () #f))))))
-
-
-(define (interface-expression struct)
-  (let ((names '())
-	(types '()))
-    (for-each-export (lambda (name type binding)
-		       (set! names (cons name names))
-		       (set! types (cons (if (eq? type undeclared-type)
-					     ':undeclared
-					     (type->sexp type #t))
-					 types)))
-		     struct)
-    `(simple-interface ',(list->vector names) ',(list->vector types))))
-
-
-; The compiler doesn't like to see unusual objects quoted, but this will
-; fake it out.
-
-(define strange-quotation
-  (let ((operator/literal (get-operator 'literal)))
-    (define (normal? thing)
-      (or (number? thing)
-	  (and (vector? thing)
-	       (every normal? (vector->list thing)))))
-    (lambda (thing)
-      (if (normal? thing)
-	  `',thing
-	  (make-node operator/literal thing)))))
-
-
-(define *reify-debug*  ;#f
-  (let ((fn "build/reify-debug.tmp"))
-    (lambda (x) (call-with-output-file fn
-		  (lambda (port)
-		    (display "Writing linker debug file ")
-		    (display fn) (force-output (current-output-port))
-		    (write x port)
-		    (newline))))))
diff --git a/scheme/link/transport.scm b/scheme/link/transport.scm
deleted file mode 100644
index 7cd6aa7..0000000
--- a/scheme/link/transport.scm
+++ /dev/null
@@ -1,283 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; This is file transport.scm.
-
-; System builder for bootstrapping and debugging.
-
-; Things that have to be written out:
-;  Made by the compiler
-;   closures
-;   templates
-;   code-vectors
-;   locations
-;  Quoted data
-;   symbols
-;   pairs
-;   vectors
-;   strings
-;   booleans
-;   characters
-
-; Convert THING to the Scheme 48 virtual machine's representation and
-; return it.  Locations and symbols may have multiple references in
-; the image.  Their transported addresses are kept in a table.
-
-(define (transport thing)
-  (let transport ((thing thing))
-    (cond ((immediate? thing)
-           (transport-immediate thing))
-          ((closure? thing)
-           (transport-closure thing))
-          ((code-vector? thing)
-           (allocate-b-vector thing code-vector-length))
-          ((location? thing)
-           (let ((address (table-ref *locations* thing)))
-             (cond (address address)
-                   (else
-                    (let ((desc (transport-location thing)))
-                      (table-set! *locations* thing desc)
-                      desc)))))
-          ((symbol? thing)
-           (let ((address (table-ref *symbols* thing)))
-             (cond (address address)
-                   (else
-                    (let ((desc (transport-symbol thing)))
-                      (table-set! *symbols* thing desc)
-                      desc)))))
-          ((pair? thing)
-           (transport-pair thing))
-          ((template? thing)
-           (transport-template thing))
-          ((vector? thing)
-           (transport-vector thing))
-          ((string? thing)
-           (allocate-b-vector thing (lambda (x) (+ 1 (string-length x)))))
-          (else
-           (error "cannot transport object" thing)))))
-
-; Transport the things that are not allocated from the heap.
-
-(define (transport-immediate thing)
-  (cond ((integer? thing)
-         (make-descriptor (enum tag fixnum) thing))
-        ((char? thing)
-         (make-immediate (enum imm char) (char->ascii thing)))
-        ((eq? thing '())
-         vm-null)
-        ((eq? thing #f)
-         vm-false)
-        ((eq? thing #t)
-         vm-true)
-        ((eq? thing (unspecific))
-         vm-unspecific)
-        (else
-         (error "cannot transport literal" thing))))
-
-;==============================================================================
-; The heap is a list of transported stored objects, each of which is either a
-; string, a code-vector, or a vector of length N+1 representing a stored object
-; with N cells.  The last slot of the vector is the object's header.
-
-(define *heap* '())
-
-(define *hp* 0)       ; Current heap-pointer (in a-units)
-
-(define *symbols* #f)    ; Table of already-transported symbols
-
-(define *locations* #f)  ; Table of already-transported locations
-
-(define (initialize-memory)
-  (set! *hp*      0)
-  (set! *heap*    '())
-  (set! *symbols* (make-table))
-  (set! *locations* (make-table location-id)))
-
-; Allocate a new stored object in the heap.  DATA is whatever data is
-; associated with the object, LEN is the length of the object (not
-; including the header) in bytes.  A pointer to the new object is
-; returned.
-
-(define (allocate-stob data len)
-  (let ((addr (+ *hp* (cells->a-units 1))))   ; move past header
-    (set! *hp* (+ addr (bytes->a-units len)))
-    (set! *heap* (cons data *heap*))
-    (make-stob-descriptor addr)))
-
-; Allocate a new stored object that contains descriptors.  This
-; creates a vector to hold the header and the object's tranported
-; contents and allocates a stob in the heap.  Returns a pair
-; containing the stob-pointer and the vector.
-
-(define (allocate-d-vector type cells immutable?)
-  (let* ((vec (make-vector (+ cells 1) 0))
-         (ptr (allocate-stob vec (cells->bytes cells)))
-         (hdr (make-header type (cells->bytes cells))))
-    (vector-set! vec cells (if immutable? (make-header-immutable hdr) hdr))
-    (cons ptr vec)))
-
-; Allocate a new stored object that contains data.  VEC is either a
-; code-vector or a string.
-
-(define (allocate-b-vector vec length)
-  (let ((len (cells->bytes (bytes->cells (length vec)))))
-    (allocate-stob vec len)))
-
-;==============================================================================
-; Transport an object with two slots.  ALLOCATE-D-VECTOR allocates the
-; storage and then the two values are transported.
-
-(define (transport-two-slot type accessor1 offset1 accessor2 offset2
-                            immutable?)
-  (lambda (thing)
-    (let* ((data (allocate-d-vector type 2 immutable?))
-           (descriptor (car data))
-           (vector (cdr data)))
-      (vector-set! vector offset1 (transport (accessor1 thing)))
-      (vector-set! vector offset2 (transport (accessor2 thing)))
-      descriptor)))
-
-; Closures and pairs are transported using TRANSPORT-TWO-SLOT.
-
-(define transport-closure
-  (transport-two-slot (enum stob closure)
-                      closure-template closure-template-offset
-                      closure-env      closure-env-offset
-                      #t))  ; ***
-
-(define transport-pair
-  (transport-two-slot (enum stob pair)
-                      car car-offset
-                      cdr cdr-offset
-                      #t))  ; *** ?
-
-; Transporting a location requires some care so as to avoid calling CONTENTS
-; when the location is unbound.
-
-(define (transport-location loc)
-  (let* ((data (allocate-d-vector (enum stob location) 2 #f))
-         (descriptor (car data))
-         (vector (cdr data)))
-    (vector-set! vector
-                 location-contents-offset
-                 (if (location-defined? loc)
-                     (transport (contents loc))
-                     vm-unbound))
-    (vector-set! vector
-                 location-id-offset
-                 (transport (location-id loc)))
-    descriptor))
-
-; Symbols have two slots, the string containing the symbol's name and a slot
-; used in building the symbol table.
-; Characters in the symbol name are made to be lower case.
-
-(define (transport-symbol symbol)
-  (let* ((data (allocate-d-vector (enum stob symbol) 2 #t))
-         (descriptor (car data))
-         (vector (cdr data)))
-    (vector-set! vector
-                 0
-                 (transport (symbol-case-converter (symbol->string symbol))))
-    (vector-set! vector
-                 1
-                 (transport #f))
-    descriptor))
-
-(define (string-case-converter string)
-  (let ((new (make-string (string-length string) #\x)))
-    (do ((i 0 (+ i 1)))
-        ((>= i (string-length new))
-         new)
-      (string-set! new i (preferred-case (string-ref string i))))))
-
-;(define preferred-case                  ;Copied from rts/read.scm
-;  (if (char=? (string-ref (symbol->string 't) 0) #\T)
-;      char-upcase
-;      char-downcase))
-(define preferred-case char-downcase)
-
-(define symbol-case-converter
-  (if (char=? (string-ref (symbol->string 't) 0)
-              (preferred-case #\t))
-      (lambda (string) string)
-      string-case-converter))
-
-; Templates and vectors have an arbitrary number of slots but are otherwise
-; the same as pairs and closures.
-
-(define (transport-template template)
-  (transport-vector-like template
-                         (enum stob template)
-                         (template-length template)
-                         template-ref
-                         #f))
-
-(define (transport-vector vector)
-  (transport-vector-like vector
-                         (enum stob vector)
-                         (vector-length vector)
-                         vector-ref
-                         #t))  ;***
-
-(define (transport-vector-like vector type length ref immutable?)
-  (let* ((data (allocate-d-vector type length immutable?))
-         (descriptor (car data))
-         (new (cdr data)))
-    (do ((i 0 (+ i 1)))
-        ((>= i length))
-      (vector-set! new i (transport (ref vector i))))
-    descriptor))
-
-;==============================================================================
-; Writing the heap out to a port.
-
-(define (write-heap port)
-  (do ((heap (reverse *heap*) (cdr heap)))
-      ((null? heap))
-    (write-heap-stob (car heap) port)))
-
-; Dispatch on the type of THING and call WRITE-STOB.
-
-(define (write-heap-stob thing port)
-  (cond ((string? thing)
-         (let ((len (+ 1 (string-length thing))))
-           (write-stob (make-header-immutable ; ***
-                        (make-header (enum stob string) len))
-                       thing len nulled-string-ref write-char port)
-           (align-port len port)))
-        ((code-vector? thing)
-         (let ((len (code-vector-length thing)))
-           (write-stob (make-header-immutable  ; ***
-                        (make-header (enum stob byte-vector) len))
-                       thing len code-vector-ref write-byte port)
-           (align-port len port)))
-        ((vector? thing)
-         (let ((len (vector-length thing)))
-           (write-stob (vector-ref thing (- len 1))
-                       thing (- len 1) vector-ref write-descriptor port)))
-        (else
-         (error "do not know how to write stob" thing))))
-
-(define (nulled-string-ref string i)
-  (if (= i (string-length string))
-      (ascii->char 0)
-      (string-ref string i)))
-
-; Write out a transported STOB to PORT.  HEADER is the header, LENGTH is the
-; number of objects the STOB contains, ACCESSOR and WRITER access the contents
-; and write them to the heap.
-
-(define (write-stob header contents length accessor writer port)
-  (write-descriptor header port)
-  (do ((i 0 (+ i 1)))
-      ((>= i length))
-    (writer (accessor contents i) port)))
-
-; Write out zeros to align the port on a four-byte boundary.
-
-(define (align-port len port)
-  (let ((count (- (cells->bytes (bytes->cells len)) len)))
-    (do ((count count (- count 1)))
-        ((<= count 0))
-      (write-byte 0 port))))
-
diff --git a/scheme/link/write-image.scm b/scheme/link/write-image.scm
deleted file mode 100644
index 03d2200..0000000
--- a/scheme/link/write-image.scm
+++ /dev/null
@@ -1,66 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Writing out a Scheme 48 image
-
-(define (write-image file start-proc id-string)
-  (if (not (= 0 (remainder bits-per-cell bits-per-io-byte)))
-      (error "io-bytes to not fit evenly into cells"))
-  (initialize-memory)
-  (call-with-output-file file
-    (lambda (port)
-      (let ((start (transport start-proc))  ; transport the start-proc
-	    (false (transport #f)))
-	(display id-string port)
-	(newline port)
-	(write-page port)
-	(newline port)
-	(display architecture-version port)
-	(newline port)
-	(boot-write-number bytes-per-cell        port)
-	(boot-write-number 0                     port)   ; newspace begin
-	(boot-write-number (a-units->cells *hp*) port)
-	(boot-write-number false                 port)   ; symbol table
-	(boot-write-number false                 port)   ; imported bindings
-	(boot-write-number false                 port)   ; exported bindings
-	(boot-write-number false                 port)   ; resumer records
-	(boot-write-number start                 port)   ; start-proc
-	(write-page port)
-	(write-descriptor 1 port)	; endianness indicator
-	(write-heap port))))		; write out the heap
-  )
-
-(define bits-per-io-byte 8)    ; for writing images
-
-(define (write-page port)
-  (write-char (ascii->char 12) port))
-
-(define (write-byte byte port)
-  (write-char (ascii->char byte) port))
-  
-(define io-byte-mask
-  (low-bits -1 bits-per-io-byte))
-
-;(define bits-per-cell    -- defined in data.scm
-;  (* bits-per-byte bytes-per-cell))
-
-(define (big-endian-write-descriptor thing port)
-  (let loop ((i (- bits-per-cell bits-per-io-byte)))
-    (cond ((>= i 0)
-           (write-byte (bitwise-and io-byte-mask
-				    (arithmetic-shift thing (- 0 i))) port)
-           (loop (- i bits-per-io-byte))))))
-
-(define (little-endian-write-descriptor thing port)
-  (let loop ((i 0))
-    (cond ((< i bits-per-cell)
-           (write-byte (bitwise-and io-byte-mask
-				    (arithmetic-shift thing (- 0 i))) port)
-           (loop (+ i bits-per-io-byte))))))
-
-(define write-descriptor little-endian-write-descriptor)
-
-(define (boot-write-number n port)
-  (display n port)
-  (newline port))
-
diff --git a/scheme/misc/doodl.scm b/scheme/misc/doodl.scm
deleted file mode 100644
index 0273582..0000000
--- a/scheme/misc/doodl.scm
+++ /dev/null
@@ -1,299 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Dilapidated Object-Oriented Dynamic Language
-; Dynamic Object-Oriented Dynamic Language
-; Drug-crazed Object-Oriented Dynamic Language
-
-; Written for clarity, not for speed.
-
-; Tests are in test-doodl.scm.
-
-(define <object>     :value)
-(define <number>     :number)
-(define <complex>    :complex)
-(define <real>	     :real)
-(define <rational>   :rational)
-(define <integer>    :integer)
-(define <pair>	     :pair)
-(define <symbol>     :symbol)
-(define <char>	     :char)
-(define <null>	     :null)
-(define <vector>     :vector)
-(define <string>     :string)
-(define <eof-object> :eof-object)
-(define <function>   :procedure)
-(define <input-port> :input-port)
-(define <output-port> :output-port)
-
-
-; --------------------
-; Generic functions
-
-(define method-table? (type-predicate :method-table))
-
-(define-syntax define-generic-function
-  (syntax-rules (setter)
-    ((define-generic-function (setter ?name) ?parameter-list) ;for define-slot
-     (define-setter ?name
-       (make-generic-function
-	    '(setter ?name)
-	    (method-info ?name ("next" next-method . ?parameter-list)
-	      (next-method)))))
-    ((define-generic-function ?name ?parameter-list)
-     (define ?name
-       (make-generic-function
-	    '?name
-	    (method-info ?name ("next" next-method . ?parameter-list)
-	      (next-method)))))))
-	
-(define (make-generic-function id prototype)
-  (let ((mtable (make-method-table id prototype)))
-    (annotate-procedure (make-generic mtable) mtable)))
-
-(define (generic-function? f)
-  (and (procedure? f)
-       (method-table? (procedure-annotation f))))
-
-(define-simple-type <generic-function> (<function>) generic-function?)
-
-(define-method &add-method! ((g <generic-function>) foo)
-  (add-method! (procedure-annotation g) foo))
-
-(define-method &disclose ((g <generic-function>))
-  `(generic-function ,(method-table-id (procedure-annotation g))))
-
-(define method-table-id (record-accessor :method-table 'id))
-
-; --------------------
-; Method info (applicability / action pairs)
-
-; D***n-style METHOD syntax
-
-(define-syntax method
-  (syntax-rules ()
-    ((method ?specs ?body ...)
-     (make-method (method-info anonymous ?specs ?body ...)))))
-
-(define method-table-methods (record-accessor :method-table 'methods))
-
-(define (make-method info)
-  (letrec ((perform (methods->perform
-		      (list info
-			    (method-info method args
-			      (apply call-error "invalid arguments" m args)))
-		      ;; This oughta be a prototype
-		      #f))
-	   (m (annotate-procedure (lambda args (perform args))
-				  info)))
-    m))
-
-(define method-info? (record-predicate :method-info))
-
-(define (method? f)
-  (and (procedure? f)
-       (method-info? (procedure-annotation f))))
-
-(define-simple-type <method> (<function>) method?)
-
-(define-method &disclose ((m <method>))
-  `(method ,(procedure-annotation m)))
-
-; --------------------
-; (SETTER foo)
-
-(define-syntax setter
-  (lambda (e r c)
-    (string->symbol (string-append (symbol->string (cadr e))
-				   "-"
-				   (symbol->string 'setter)))))
-
-(define-syntax define-setter  ;for define-slot
-  (lambda (e r c)
-    `(,(r 'define)
-      ,(string->symbol (string-append (symbol->string (cadr e))
-				      "-"
-				      (symbol->string 'setter)))
-      ,(caddr e))))
-
-(define-syntax set
-  (syntax-rules ()
-    ((set (?fun ?arg ...) ?val)
-     ((setter ?fun) ?arg ... ?val))
-    ((set ?var ?val)
-     (set! ?var ?val))))
-
-(define car-setter set-car!)
-(define cdr-setter set-cdr!)
-(define vector-ref-setter vector-set!)
-
-; --------------------
-; DEFINE-CLASS
-
-(define-syntax define-class
-  (syntax-rules ()
-    ((define-class ?class-name (?super ...) ?slot ...)
-     (begin (define-slot ?slot)
-	    ...
-	    (define ?class-name
-              (make-class (list ?super ...)
-			  (list ?slot ...)
-                          '?class-name))))))
-
-(define-syntax define-slot
-  (syntax-rules ()
-    ((define-slot ?slot)
-     (begin (define-generic-function ?slot (x))
-	    (define-generic-function (setter ?slot) (x new-val))
-	    (define-method ?slot ((x <instance>))
-	      (instance-slot-ref x ?slot))
-	    (define-method (setter ?slot) ((x <instance>) new-val)
-	      (instance-slot-set! x ?slot new-val))))))
-
-; Instances
-
-(define-record-type instance <instance>
-  (make-instance classes slots)
-  instance?
-  (classes instance-classes)
-  (slots instance-slot-values))
-
-(define (instance-slot-ref instance slot)
-  (cond ((assq slot (instance-slot-values instance)) => cdr)
-	(else (call-error "no such slot"
-			  instance-slot-ref instance slot))))
-
-(define (instance-slot-set! instance slot new-value)
-  (cond ((assq slot (instance-slot-values instance))
-	 => (lambda (z) (set-cdr! z new-value)))
-	(else (call-error "no such slot"
-			  instance-slot-set! instance slot new-value))))
-
-; Classes
-
-(define-record-type class <class>
-  (really-make-class classes predicate priority slots id)
-  class?
-  (classes class-classes)
-  (predicate class-predicate)
-  (priority class-priority)
-  (slots class-slots)
-  (id class-id))
-
-(define-record-discloser <class>
-  (lambda (c) `(class ,(class-id c))))
-
-(define-method &type-predicate ((c <class>)) (class-predicate c))
-(define-method &type-priority ((c <class>)) (class-priority c))
-
-(define (make-class supers slots id)
-  (letrec ((class
-	    (really-make-class
-	         (reduce unionq '() (map get-classes supers))
-		 (lambda (x)		;Predicate
-		   (and (instance? x)
-			(memq class (instance-classes x))))
-		 (if (null? supers)	;Priority
-		     (type-priority <instance>)
-		     (+ (apply max (map type-priority supers))
-			*increment*))
-		 (unionq slots
-			 (reduce unionq '() (map get-slots supers)))
-		 id)))
-    class))
-
-(define *increment* 10)
-
-(define (get-classes type)
-  (if (class? type)
-      (cons type
-	    (class-classes type))
-      '()))
-
-(define (get-slots type)
-  (if (class? type)
-      (class-slots type)
-      '()))
-
-(define-generic-function make (class . key/value-pairs))
-
-(define-method make ((c <class>) . key/value-pairs)
-  (let ((i (make-instance (cons c (class-classes c))
-			  (map (lambda (slot)
-				 (cons slot '*uninitialized*))
-			       (class-slots c)))))
-    (apply initialize i key/value-pairs)
-    i))
-
-(define-generic-function initialize (i . key/value-pairs))
-
-(define-method initialize ((i <instance>)) (unspecific))
-
-
-(define (unionq l1 l2)
-  (cond ((null? l1) l2)
-	((null? l2) l1)
-	((memq (car l1) l2) (unionq (cdr l1) l2))
-	(else (cons (car l1) (unionq (cdr l1) l2)))))
-
-; --------------------
-; Random
-
-(define id? eq?)
-
-(define-syntax bind
-  (lambda (e r c)
-    (if (and (pair? (cdr e))
-	     (list? (cadr e)))
-	(let ((%call-with-values (r 'call-with-values))
-	      (%lambda (r 'lambda))
-	      (%method (r 'method))
-	      (%begin (r 'begin)))
-	  (let recur ((specs (cadr e)))
-	    (if (null? specs)
-		`(,%begin ,@(cddr e))
-		(let ((rspec (reverse (car specs))))
-		  `(,%call-with-values
-		    (,%lambda () ,(car rspec))
-		    (,%method ,(reverse (cdr rspec))
-			      ,(recur (cdr specs))))))))
-	e)))
-
-(define-simple-type <list> (<object>) list?)
-
-; --------------------
-; More?
-
-; (instance? obj class)
-; (as class object) => instance
-
-; <type>
-; (union type1 type2)
-; (union* type ...)
-; (subtype? type1 type2 )
-;   per design note 05
-
-; (define-method foo (x y #values (foo <integer>)) ...)
-;   per design note 21
-
-; (define-method f ((x (limited <integer> min: -1000 max: 1000)) ...) 
-;   ...)
-;   design note 06
-
-; <collection>, etc.
-
-
-; <exact> and <inexact> ?
-
-;(define <sequence>
-;  (make-generalization (list <list> <vector> <string>) '<sequence>))
-
-;(define <port>
-;  (make-generalization (list <input-port> <output-port>) '<port>))
-
-
-; Need reader syntax:
-;   #next #rest #key   etc.
-;     - implement with (define-sharp-macro #\n ...) ?
-;   keywords - foo:  
-;     - implement by customizing parse-token
diff --git a/scheme/misc/either.scm b/scheme/misc/either.scm
deleted file mode 100644
index 433cf15..0000000
--- a/scheme/misc/either.scm
+++ /dev/null
@@ -1,90 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Internal variable representing the failure stack.
-
-(define (fail) (*fail*))
-
-(define *fail* (lambda () (error "You didn't do (init).")))
-
-
-; For the alternation operator, Icon's a | b or McCarthy's (amb a b),
-; we write (either a b).
-
-(define-syntax either
-  (syntax-rules ()
-    ((either) (fail))
-    ((either x) x)
-    ((either x y ...)
-     (%either (lambda () x) (lambda () (either y ...))))))
-
-(define (%either thunk1 thunk2)		;Macro auxiliary
-  (saving-failure-state
-   (lambda (restore)
-     ((call-with-current-continuation
-	(lambda (k)
-	  (set! *fail*
-		(lambda ()
-		  (restore)
-		  (k thunk2)))
-	  thunk1))))))
-
-(define (saving-failure-state proc)
-  (let ((save *fail*))
-    (proc (lambda () (set! *fail* save)))))
-
-
-; (one-value x) is Prolog's CUT operator
-
-(define-syntax one-value
-  (syntax-rules ()
-    ((one-value x) (%one-value (lambda () x)))))
-
-(define (%one-value thunk)
-  (saving-failure-state
-   (lambda (restore)
-     (let ((value (thunk)))
-       (restore)
-       value))))
-
-
-; (all-values a) returns a list of all the possible values of the
-; expression a.  Prolog calls this "bagof"; I forget what Icon calls it.
-
-(define-syntax all-values
-  (syntax-rules ()
-    ((all-values x) (%all-values (lambda () x)))))
-
-(define (%all-values thunk)
-  (let ((results '()))
-    (either (let ((new-result (thunk)))
-	      (set! results (cons new-result results))
-	      (fail))
-	    (reverse results))))
-
-
-; Generate all the members of list l.  E.g.
-;   (all-values (+ (member-of '(10 20 30)) (member-of '(1 2 3))))
-;     => '(11 12 13 21 22 23 31 32 33)
-
-(define (member-of l)
-  (if (null? l)
-      (fail)
-      (either (car l) (member-of (cdr l)))))
-
-
-; Crufty initialization hack that allows you to type failing
-; expressions at the R-E-P loop (if there is an R-E-P loop).  E.g. try
-; evaluating the sequence
-;  (either 1 2)
-;  (fail)
-;  (+ (fail) 10)
-
-(define (init)
-  (set! *fail* #f)			;for GC purposes
-  (either 'initialized
-	  (let loop ()
-	    (either 'failed (loop)))))
-
-(display "Type (init) at the read-eval-print loop.")
-(newline)
diff --git a/scheme/misc/engine.scm b/scheme/misc/engine.scm
deleted file mode 100644
index 4a980c5..0000000
--- a/scheme/misc/engine.scm
+++ /dev/null
@@ -1,70 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Christopher P. Haynes and Daniel P. Friedman.
-; Engines build process abstractions.
-; 1984 ACM Symposium on Lisp and Functional Programming, pages 18-24.
-
-; This is incompatible with the threads package.
-
-; ,open primitives interrupts
-
-(define interrupt/alarm (enum interrupt alarm))
-
-(define (run thunk interval when-done when-timeout)
-  (let ((save (vector-ref interrupt-handlers interrupt/alarm)))
-    (let ((finish
-	   (call-with-current-continuation
-	     (lambda (k)
-	       (vector-set! interrupt-handlers
-			    interrupt/alarm
-			    (lambda (tem ei)
-			      (set-enabled-interrupts! ei)
-			      (call-with-current-continuation
-				(lambda (resume)
-				  (k (lambda ()
-				       (when-timeout (lambda ()
-						       (resume #f)))))))))
-	       (schedule-interrupt interval *exponent* #f)
-	       (call-with-values thunk
-		 (lambda vals
-		   (let ((time-remaining (schedule-interrupt 0 0 #f)))
-		     (lambda ()
-		       (apply when-done time-remaining vals)))))))))
-      (vector-set! interrupt-handlers
-		   interrupt/alarm
-		   save)
-      (finish))))
-
-(define *exponent* -3)
-
-(define-syntax engine
-  (syntax-rules ()
-    ((engine ?E) (%engine (lambda () ?E)))))
-
-(define (%engine thunk)
-  (lambda (ticks done out)
-    (run thunk
-	 ticks
-	 (lambda (ticks val)
-	   (done val ticks))
-	 (lambda (new-thunk)
-	   (out (%engine new-thunk))))))
-
-
-; Example from the LFP '84 paper (verbatim)
-
-;(define-syntax rec
-;  (syntax-rules () ((rec ?X ?E) (letrec ((?X ?E)) ?X))))
-;
-;(define complete
-;  (lambda (eng)
-;    ((rec loop
-;       (lambda (eng count)
-;         (eng 1000
-;              (lambda (val ticks-left)
-;                (cons val
-;                      (+ (- 1000 ticks-left)
-;                         count)))
-;              (lambda (eng)
-;                (loop eng (+ count 1000))))))
-;     eng 0)))
diff --git a/scheme/misc/getenv.scm b/scheme/misc/getenv.scm
deleted file mode 100644
index 8d438ba..0000000
--- a/scheme/misc/getenv.scm
+++ /dev/null
@@ -1,15 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; ,open primitives
-
-
-(define getenv
-  (let ((buffer (make-string 2000)))
-    (lambda (var-name)
-      (let ((len (vm-extension 26 (cons var-name buffer))))
-	(if len
-	    (substring buffer 0 len)
-	    #f)))))
-
-
diff --git a/scheme/misc/hilbert.scm b/scheme/misc/hilbert.scm
deleted file mode 100644
index d470a3e..0000000
--- a/scheme/misc/hilbert.scm
+++ /dev/null
@@ -1,107 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-;Date: Thu, 4 Nov 93 14:34:04 EST
-;Subject: binary search trees
-;From: kelsey@research.nj.nec.com
-;
-;If you want to add the Hilbert tables I think you should change
-;the name and add some documentation.  Neither the name nor the
-;only comment in the file are particulary informative.  They are
-;not infinite dimensional vectors, just arbitrarily large one
-;dimensional ones.
-;
-;How about make-big-vector etc.?
-
-
-; Hilbert vectors are like vectors that grow as large as they need to.
-; That is, they can be indexed by arbitrarily large nonnegative integers.
-
-; The implementation allows for arbitrarily large gaps by arranging
-; the entries in a tree.
-
-; So-called because they live in an infinite-dimensional vector
-; space...
-
-; ,open bitwise define-record-types
-
-
-(define hilbert-log 8)
-(define hilbert-node-size (arithmetic-shift 1 hilbert-log))
-(define hilbert-mask (- hilbert-node-size 1))
-(define minus-hilbert-log (- 0 hilbert-log))
-
-
-
-(define-record-type hilbert :hilbert
-  (really-make-hilbert height root)
-  (height hilbert-height set-hilbert-height!)
-  (root hilbert-root set-hilbert-root!))
-
-(define (make-hilbert)
-  (really-make-hilbert 1 (make-vector hilbert-node-size #f)))
-
-
-(define (hilbert-ref hilbert index)
-  (let recur ((height (hilbert-height hilbert))
-	      (index index))
-    (if (= height 1)
-	(let ((root (hilbert-root hilbert)))
-	  (if (< index (vector-length root))
-	      (vector-ref root index)
-	      #f))
-	(let ((node (recur (- height 1)
-			   (arithmetic-shift index minus-hilbert-log))))
-	  (if node
-	      (vector-ref node (bitwise-and index hilbert-mask))
-	      #f)))))
-	       
-(define (hilbert-set! hilbert index value)
-  (vector-set!
-   (let recur ((height (hilbert-height hilbert))
-	       (index index))
-     (if (= height 1)
-	 (make-higher-if-necessary hilbert index)
-	 (let ((index (arithmetic-shift index minus-hilbert-log)))
-	   (make-node-if-necessary
-	    (recur (- height 1) index)
-	    (bitwise-and index hilbert-mask)))))
-   (bitwise-and index hilbert-mask)
-   value))
-
-(define (make-higher-if-necessary hilbert index)
-  (if (< index hilbert-node-size)
-      (hilbert-root hilbert)
-      (let ((new-root (make-vector hilbert-node-size #f)))
-	(write `(higher ,index)) (newline)
-	(vector-set! new-root 0 (hilbert-root hilbert))
-	(set-hilbert-root! hilbert new-root)
-	(set-hilbert-height! hilbert (+ (hilbert-height hilbert) 1))
-	(let ((index (arithmetic-shift index minus-hilbert-log)))
-	  (make-node-if-necessary (make-higher-if-necessary hilbert index)
-				  (bitwise-and index hilbert-mask))))))
-
-(define (make-node-if-necessary node index)
-  (or (vector-ref node index)
-      (let ((new (make-vector hilbert-node-size #f)))
-	;; (write `(wider ,index)) (newline)
-	(vector-set! node index new)
-	new)))
-
-
-
-
-; For debugging
-;(define (hilbert->list h)
-;  (let recur ((node (hilbert-root h))
-;              (height (hilbert-height h))
-;              (more '()))
-;    (if (= height 0)
-;        (if (or node (pair? more))
-;            (cons node more)
-;            '())
-;        (do ((i (- hilbert-node-size 1) (- i 1))
-;             (more more (recur (if node
-;                                   (vector-ref node i)
-;                                   #f)
-;                               (- height 1) more)))
-;            ((< i 0) more)))))
diff --git a/scheme/misc/ilength.scm b/scheme/misc/ilength.scm
deleted file mode 100644
index 4008979..0000000
--- a/scheme/misc/ilength.scm
+++ /dev/null
@@ -1,33 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Integer-length, a la Common Lisp, written in portable Scheme.
-
-(define-syntax cons-stream
-  (syntax-rules ()
-    ((cons-stream head tail)
-     (cons head (delay tail)))))
-(define head car)
-(define (tail s) (force (cdr s)))
-
-(define integer-length
-  (let ()
-    (define useful
-      (let loop ((p 256) (n 4))
-	(cons-stream (cons p n)
-		     (loop (* p p) (* n 2)))))
-    (define (recur n)
-      (if (< n 16)
-	  (vector-ref '#(0 1 2 2 3 3 3 3 4 4 4 4 4 4 4 4) n)
-	  (let loop ((s useful) (prev 16))
-	    (let ((z (head s)))
-	      (if (< n (car z))
-		  (+ (cdr z) (recur (quotient n prev)))
-		  (loop (tail s) (car z)))))))
-    (define (integer-length n)
-      (if (exact? n)
-	  (if (< n 0)
-	      (recur (- -1 n))
-	      (recur n))
-	  (integer-length (inexact->exact n))))
-    integer-length))
diff --git a/scheme/misc/integertostring.scm b/scheme/misc/integertostring.scm
deleted file mode 100644
index 19ae940..0000000
--- a/scheme/misc/integertostring.scm
+++ /dev/null
@@ -1,66 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-;Date: Mon, 24 Jan 94 15:10:30 -0500
-;To: jar@ai.mit.edu
-;Subject: integer->string
-;From: kelsey@research.nj.nec.com
-;Sender: kelsey@research.nj.nec.com
-;
-;
-;I have gotten tired of waiting for bignums to print out.
-;Here is a somewhat more complex and faster version of integer->string.
-;
-;Converting 10**100 to a string:
-; Current:                    0.44 seconds
-; This:                       0.12 seconds
-; This using integer-divide:  0.06 seconds
-;
-;There is no overwhelming reason to use this, but here it is.
-
-
-(define integer->string
-  (let ()
-
-    (define (integer->string n radix)
-
-      (define (small-integer->magnitude n l)
-	(if (= n 0)
-	    l
-	    (small-integer->magnitude (quotient n radix)
-				      (cons (integer->digit (remainder n radix))
-					    l))))
-      
-      (define (integer->magnitude n)
-	(let ((rrrr (* (* radix radix) (* radix radix))))
-	  
-	  (let recur ((n n) (l '()))
-	       (if (< n rrrr)
-		   (small-integer->magnitude n l)
-		   (do ((i 4 (- i 1))
-			(n0 (remainder n rrrr) (quotient n0 radix))
-			(l l (cons (integer->digit (remainder n0 radix)) l)))
-		       ((= 0 i)
-			(recur (quotient n rrrr) l)))))))
-
-      (let ((magnitude (cond ((= n 0) '(#\0))
-			     ((< n 1000000)
-			      (small-integer->magnitude (abs n) '()))
-			     (else
-			      (integer->magnitude (abs n))))))
-	(list->string (if (>= n 0)
-			  magnitude
-			  (cons #\- magnitude)))))
-
-    (define (integer->digit n)
-      (ascii->char (+ n (if (< n 10)
-			    zero
-			    a-minus-10))))
-
-    (define zero (char->ascii #\0))
-    (define a-minus-10 (- (char->ascii #\a) 10))
-
-    integer->string))
-
-
-
diff --git a/scheme/misc/load-static.scm b/scheme/misc/load-static.scm
deleted file mode 100644
index d07236b..0000000
--- a/scheme/misc/load-static.scm
+++ /dev/null
@@ -1,42 +0,0 @@
-; -*- Mode: Scheme; -*-
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-;  ,exec ,load misc/load-static.scm
-;  (do-it 100000 "debug/little.image" "debug/little-heap.c")
-
-(translate "=scheme48/" "./")
-
-(config
- (lambda ()
-   (load "vm/ps-interface.scm")
-   (load "vm/interfaces.scm")
-   (load "vm/package-defs.scm" "vm/s48-package-defs.scm")))
-
-(load-package 'bigbit)
-; The following is for struct's (for-syntax ...) clause
-; (load-package 'destructuring)
-
-(load-package 'heap)
-(in 'heap
-    (lambda ()
-      (run '(define (newspace-begin) *newspace-begin*))
-      (run '(define (heap-pointer) *hp*))
-      (structure 'heap-extra
-		 '(export newspace-begin
-			  heap-pointer
-			  header-a-units
-			  d-vector?
-			  stob-type))))
-
-(config '(run (define-structure static (export do-it)
-		(open scheme heap memory data stob struct
-		      heap-extra
-		      vm-architecture
-		      formats
-		      enumerated
-		      signals)
-		(files (misc static)))))
-
-(load-package 'static)
-(user '(open static))
-
diff --git a/scheme/misc/mail.scm b/scheme/misc/mail.scm
deleted file mode 100644
index 2e121df..0000000
--- a/scheme/misc/mail.scm
+++ /dev/null
@@ -1,34 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-
-; Mailboxes (to be used with the threads package)
-
-(define (make-mailbox)
-  (vector (make-lock) (make-queue) (make-queue)))
-
-(define (mailbox-lock	  mbx) (vector-ref mbx 0))
-(define (mailbox-messages mbx) (vector-ref mbx 1))
-(define (mailbox-readers  mbx) (vector-ref mbx 2))
-
-(define (mailbox-empty? mbx)
-  (queue-empty? (mailbox-readers mbx)))
-
-(define (mailbox-write mbx message)
-  (with-lock (mailbox-lock mbx)
-    (lambda ()
-      (if (queue-empty? (mailbox-readers mbx))
-	  (enqueue! (mailbox-messages mbx) message)
-	  (condvar-set! (dequeue! (mailbox-readers mbx)) message)))))
-
-(define (mailbox-read mbx)
-  ((with-lock (mailbox-lock mbx)
-     (lambda ()
-       (if (queue-empty? (mailbox-messages mbx))
-	   (let ((cv (make-condvar)))
-	     (enqueue! (mailbox-readers mbx) cv)
-	     ;; The condvar-ref *must* happen after lock is released,
-	     ;; otherwise deadlock will result.
-	     (lambda () (condvar-ref cv)))
-	   (let ((message (dequeue! (mailbox-messages mbx))))
-	     (lambda () message)))))))
diff --git a/scheme/misc/packages.scm b/scheme/misc/packages.scm
deleted file mode 100644
index db3e4df..0000000
--- a/scheme/misc/packages.scm
+++ /dev/null
@@ -1,134 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Miscellaneous things.
-
-(define-structure reset/shift (export (reset :syntax)
-				      (shift :syntax))
-  (open scheme escapes signals)
-  (files shift-reset))
-
-(define-structure unix-system-calls
-    (export pipe waitpid fork dup close execv exit)
-  (open scheme externals signals)
-  (files syscall))
-
-(define-structure call-with-mumble-pipes
-    (export call-with-input-pipe call-with-output-pipe)
-  (open scheme
-	unix-system-calls
-	architecture channels
-	i/o-internal
-	signals)
-  (files pipe))
-
-(define-structure unix-getenv (export getenv)
-  (open scheme primitives)
-  (files getenv))
-
-(define-structure nondeterminism (export (either :syntax)
-					 (one-value :syntax)
-					 (all-values :syntax)
-					 fail
-					 init)
-  (open scheme)
-  (files either))
-
-(define-structure engines (export (engine :syntax))
-  (open scheme primitives interrupts)
-  (files engine))
-
-(define-structure remote (export remote-repl
-				 serve
-				 make-socket)
-  (open scheme
-	;; For server
-	closures
-	handle conditions
-	vm-exposure
-	;; For client
-	compiler
-	command-processor
-	interfaces
- 	environments
-	;; For both?
-	packages
-	package-commands-internal
-	;; packages-internal ?
-	syntactic
-	built-in-structures
-	dump/restore
-	sockets
-	signals features)
-  (files remote))
-
-(define-structure requirements (export (require :syntax))
-  (open scheme-level-2
-	packages
-	environments
-	ensures-loaded
-	package-commands-internal
-	signals)
-  (files require))
-
-
-; Procedure annotations
-
-(define-structure annotations
-    (export annotate-procedure procedure-annotation)
-  (open scheme-level-1 assembler)
-  (files annotate))
-
-
-; DOODL
-
-(define-structure doodl doodl-interface
-  (open scheme
-	methods
-	meta-methods
-	annotations
-	define-record-types
-	records
-	;; handle	; ignore-errors
-	;; conditions	; error?
-	util 
-	signals)
-  (files doodl))
-
-
-(define-interface doodl-interface
-  (export ((method
-	    define-class
-	    define-method
-	    define-generic-function
-	    define-class
-	    set)
-	   :syntax)
-	  <function>
-	  <generic-function>
-	  <method>
-	  <class>
-
-	  <object>
-	  <number>
-	  <complex>
-	  <real>
-	  <rational>
-	  <integer>
-	  <pair>
-	  <symbol>
-	  <char>
-	  <null>
-	  <vector>
-	  <string>
-	  <eof-object>
-	  <input-port>
-	  <output-port>
-
-	  <list>    ;foo
-	  make
-	  initialize
-	  car-setter cdr-setter vector-ref-setter
-	  id?
-	  (bind :syntax)
-	  ;; etc. etc.
-	  ))
diff --git a/scheme/misc/pipe.scm b/scheme/misc/pipe.scm
deleted file mode 100644
index 78589be..0000000
--- a/scheme/misc/pipe.scm
+++ /dev/null
@@ -1,51 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Scheme analogues of Posix popen() and pclose() library calls.
-
-(define (call-with-mumble-pipe input?)
-  (lambda (command proc)
-    (call-with-values pipe
-      (lambda (pipe-for-read pipe-for-write)
-	(let ((winner (if input? pipe-for-read pipe-for-write))
-	      (loser  (if input? pipe-for-write pipe-for-read))
-	      (pid (fork)))
-	  (if (= pid 0)
-	      (dynamic-wind
-	        (lambda () #f)
-		(lambda ()
-		  (close winner)
-		  (let ((foo (if input? 1 0)))
-		    (close foo)
-		    (if (not (= (dup loser) foo))
-			(error "dup lost" loser foo)))
-		  (execv "/bin/sh"
-			 (vector "sh" "-c" command)))
-		(lambda () (exit 1))))
-	  ;; (write `(pid = ,pid)) (newline)
-	  (close loser)
-	  (let* ((channel (open-channel winner
-					(if input?
-					    (enum open-channel-option
-						  raw-input-channel)
-					    (enum open-channel-option
-						  raw-output-channel))))
-		 (port (if input?
-			   (input-channel->port channel 1024)
-			   (output-channel->port channel 1024))))
-	    (call-with-values (lambda () (proc port))
-	      (lambda vals
-		(if input?
-		    (close-input-port port)
-		    (close-output-port port))
-		;; (display "Waiting.") (newline)
-		(call-with-values (lambda () (waitpid pid 0))
-		  (lambda (pid status)
-		    ;; (write `(status = ,status)) (newline)
-		    (apply values vals)))))))))))
-
-(define call-with-input-pipe
-  (call-with-mumble-pipe #t))
-
-(define call-with-output-pipe
-  (call-with-mumble-pipe #f))
-
diff --git a/scheme/misc/psd-s48.scm b/scheme/misc/psd-s48.scm
deleted file mode 100644
index a945b57..0000000
--- a/scheme/misc/psd-s48.scm
+++ /dev/null
@@ -1,129 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; To use PSD with Scheme 48:
-;  - Put (setq psd-using-slib nil) in your .emacs
-;  - Put this file in psd-directory
-;  - Remove (define *psd-tab-char* (integer->char 9)) from psd's read.scm
-;  - Do something horrible to primitives.scm to circumvent bug in
-;    Scheme 48's byte code compiler... those big long lists have to be
-;    split up: `((x ,x) ... (y ,y) ...) =>
-;     (let ((foo (lambda () `((x ,x) ...)))
-;	    (bar (lambda () `((y ,y) ...))))
-;	(append (foo) (bar)))
-
-; JAR's remarks:
-;   - The variable *PSD-PREVIOUS-LINE* was undefined (not consequentially so)
-;   - It doesn't support DELAY
-;   - It doesn't support the => syntax in COND
-;   - It doesn't like (write-char c port):
-;     ERROR: Wrong number of arguments to primitive procedure
-;     write-char
-;   - It would be awfully nice if there were a "quit" command
-;   - It leaves that little "=>" arrow in my buffer (except it's not
-;     really there, is it?)
-;   - It opens the source file multiple (maybe 6) times without
-;     closing it (not really a problem since the GC cleans these up, but
-;     sort of annoying)
-
-;;;;
-;;;; $Id: psd-s48.scm,v 1.1 1999/09/14 12:44:57 marting Exp $
-;;;;
-;;;; psd -- a portable Scheme debugger, version 1.1
-;;;; Copyright (C) 1992 Pertti Kellomaki, pk@cs.tut.fi
-
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 1, or (at your option)
-;;;; any later version.
-
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this program; if not, write to the Free Software
-;;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-;;;; See file COPYING in the psd distribution.
-;;;;
-;;;;  $Log: psd-s48.scm,v $
-;;;;  Revision 1.1  1999/09/14 12:44:57  marting
-;;;;  *** empty log message ***
-;;;;
-;;;; Revision 1.6  1993/10/07  08:20:14  pk
-;;;; Define force-output, redefinition hurts less than getting an error
-;;;; message about nonexistent procedure.
-;;;;
-;;;; Revision 1.5  1993/10/06  13:06:16  pk
-;;;; Removed references to slib. Commented out force-output, let the user
-;;;; uncomment it if needed.
-;;;;
-;;;; Revision 1.4  1993/09/29  08:45:11  pk
-;;;; Removed reference to long and deep lists.
-;;;;
-;;;; Revision 1.3  1993/09/24  08:01:18  pk
-;;;; Changed version number from 1.0 to 1.1.
-;;;; Added loading of version.scm and announcing of version.
-;;;;
-;;;; Revision 1.2  1993/09/23  06:50:00  pk
-;;;; Moved definition of the Scheme variable psd-directory from the psd*.scm
-;;;; files to psd.el, which sends it to the Scheme process. This way, the path
-;;;; to psd needs to be specified only once.
-;;;;
-;;;; Revision 1.1  1993/09/22  12:45:32  pk
-;;;; Initial revision
-;;;;
-;;;;  
-
-;;;; 
-;;;; Written by Pertti Kellomaki, pk@cs.tut.fi
-;;;;
-;;;; SLIB interface to load psd files.
-
-;;;; This is the file that takes care of loading psd into the Scheme
-;;;; interpreter. If you want to modify psd to work with a particular
-;;;; implementation, say "foo", this is the way to do it:
-
-;;;; 1) Make a copy of the file "psd.scm" under the name "psd-foo.scm",
-;;;;    and modify it to load "primitives-foo.scm" instead of
-;;;;    "primitives.scm". You can also do other things.
-;;;;
-;;;; 2) Make a copy of the file "primitives.scm" under the name
-;;;;    "primitives-foo.scm", and modify the definitions in it to
-;;;;    know about the additional primitives in your implementation
-;;;;
-;;;; 3) When you now set the Emacs variable scheme-program-name to
-;;;;    "foo" and give the commands ``M-x run-scheme'' ``M-x psd-mode'',
-;;;;    you have a psd system that knows about your additional
-;;;;    primitives.
-
-;;; this is not portable.
-(define psd:control-z ((access-scheme-48 'ascii->char) 26))
-
-; Neither is this.
-(define *psd-tab-char* ((access-scheme-48 'ascii->char) 9))
-
-;;; FORCE-OUTPUT flushes any pending output on optional arg output port
-;;; use this definition if your system doesn't have such a procedure.
-(define (force-output . arg)
-  ((access-scheme-48 'force-output)
-   (if (null? arg) (current-output-port) (car arg))))
-
-(load (string-append psd-directory "qp.scm"))
-(load (string-append psd-directory "version.scm"))
-(load (string-append psd-directory "instrum.scm"))
-(load (string-append psd-directory "pexpr.scm"))
-(load (string-append psd-directory "read.scm"))
-(load (string-append psd-directory "runtime.scm"))
-(load (string-append psd-directory "primitives.scm"))
-
-(define *psd-previous-line* #f)
-
-;;;
-;;; Say hello
-;;;
-
-(psd-announce-version)
-
-(define error (access-scheme-48 'error))
diff --git a/scheme/misc/remote.scm b/scheme/misc/remote.scm
deleted file mode 100644
index 63e82da..0000000
--- a/scheme/misc/remote.scm
+++ /dev/null
@@ -1,148 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; This is a small mock-up of the Cornell mobile robot system.
-; It is not intended as a remote procedure call mechanism.
-
-; ,load-config =scheme48/misc/packages.scm
-; ,open remote
-
-; To start a server, do
-;   (define sock (make-socket))
-;   (serve sock)
-; To start a client, do
-;   (remote-repl "hostname" <number>)
-; where <number> is the number displayed by the server when it starts up.
-
-
-; Server side
-
-(define (note-structure-locations! s)
-  (define (recur name env trail)
-    (let ((b (generic-lookup env name)))
-      (if (binding? b)
-	  (begin
-	    (note-location! (binding-place b))
-	    (let ((t (binding-static b)))
-	      (if (and (transform? t) (not (member t trail)))
-		  (let ((trail (cons t trail))
-			(env (transform-env t)))
-		    (for-each (lambda (name)
-				(recur name env trail))
-			      (transform-aux-names (binding-static b))))))))))
-  (for-each-declaration (lambda (name type)
-			  (recur name s '())) 
-			(structure-interface s)))
-
-(note-structure-locations! scheme-level-2)
-
-(define (make-socket)
-  (call-with-values socket-server cons))
-
-(define (serve sock)
-  (let ((port-number (car sock))
-	(accept (cdr sock)))
-    (display "Port number is ")
-    (write port-number)
-    (newline)
-    (let ((in #f)
-	  (out #f))
-      (dynamic-wind (lambda ()
-		      (call-with-values accept
-			(lambda (i-port o-port)
-			  (display "Open") (newline)
-			  (set! in i-port)
-			  (set! out o-port))))
-		    (lambda ()
-		      (start-server in out))
-		    (lambda ()
-		      (if in (close-input-port in))
-		      (if out (close-output-port out)))))))
-
-(define (start-server in out)
-  (let loop ()
-    (let ((message (restore-carefully in)))
-      (case (car message)
-	((run)
-	 (dump (run-carefully (cdr message))
-	       (lambda (c) (write-char c out))
-	       -1)
-	 (force-output out)
-	 (loop))
-	((eof) (cdr message))
-	(else (error "unrecognized message" message))))))
-
-(define (run-carefully template)
-  (call-with-current-continuation
-    (lambda (escape)
-      (with-handler
-	  (lambda (c punt)
-	    (if (error? c)
-		(escape (cons 'condition c))
-		(punt)))
-	(lambda ()
-	  (call-with-values (lambda ()
-			      (invoke-closure (make-closure template #f)))
-	    (lambda vals
-	      (cons 'values vals))))))))
-
-
-; Client side
-
-(define (make-remote-eval in out)
-  (lambda (form p)
-    (compile-and-run-forms (list form)
-			   p
-			   #f
-			   (lambda (template)
-			     (dump (cons 'run template)
-				   (lambda (c) (write-char c out))
-				   -1)
-			     (force-output out)
-			     (let ((reply (restore-carefully in)))
-			       (case (car reply)
-				 ((values)
-				  (apply values (cdr reply)))
-				 ((condition)
-				  (signal-condition (cdr reply)))
-				 ((eof)
-				  (error "eof on connection")))))
-			   #f)))
-
-
-(define (make-remote-package in out opens id)
-  (let ((p (make-simple-package opens
- 				#t
- 				(reflective-tower
- 				 (package->environment (interaction-environment)))
- 				id)))
-    (set-package-evaluator! p (make-remote-eval in out))
-    p))
-
-(define (remote-repl host-name socket-port-number)
-  (let ((in #f) (out #f))
-    (dynamic-wind
-     (lambda ()
-       (call-with-values (lambda ()
-			   (socket-client host-name socket-port-number))
-	 (lambda (i-port o-port)
-	   (set! in i-port)
-	   (set! out o-port))))
-     (lambda ()
-       (with-interaction-environment (make-remote-package in out (list scheme) 'remote)
-				     (lambda () (command-loop list #f))))
-     (lambda ()
-       (if in (close-input-port in))
-       (if out (close-output-port out))))))
-
-
-; Common auxiliary
-
-(define (restore-carefully in)
-  (call-with-current-continuation
-    (lambda (exit)
-      (restore (lambda ()
-		 (let ((c (read-char in)))
-		   (if (eof-object? c)
-		       (exit (cons 'eof c))
-		       c)))))))
diff --git a/scheme/misc/require.scm b/scheme/misc/require.scm
deleted file mode 100644
index 3737a22..0000000
--- a/scheme/misc/require.scm
+++ /dev/null
@@ -1,40 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-
-(define-syntax require
-  (syntax-rules (quote)
-    ((require '(name1 name2 ...))
-     (*require '(name1 name2 ...)))))
-
-(define (*require interface-id)
-  (let ((start-thunk
-	 (case (car interface-id)
-	   ((scheme-48)
-	    (let ((p (config-package)))
-	      (lambda () p)))
-	   ((scheme-library-1)
-	    (let* ((p (config-package))
-		   (thunk
-		    (lambda ()
-		      (environment-ref p 'scheme-library-1))))
-	      (ensure-loaded (thunk))
-	      (thunk)))
-	   (else
-	    (error "unrecognized interface identifier" interface-id)))))
-    (package-open! (interaction-environment)
-		   (let loop ((names (cdr interface-id))
-			      (thunk start-thunk))
-		     (if (null? names)
-			 thunk
-			 (let ((new-thunk 
-				(lambda ()
-				  (let ((source (thunk)))
-				    (if (package? source)
-					(environment-ref source
-							 (car names))
-					(*structure-ref source
-							(car names)))))))
-			   (ensure-loaded (new-thunk))
-			   (loop (cdr names)
-				 new-thunk)))))))
diff --git a/scheme/misc/separate.scm b/scheme/misc/separate.scm
deleted file mode 100644
index 566f6f9..0000000
--- a/scheme/misc/separate.scm
+++ /dev/null
@@ -1,140 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-;  packages packages-internal scan compiler table
-;  syntactic vm-exposure signals locations fluids template
-;  closures types inline dump/restore
-;  environments
-
-; Separate compilation
-
-; Setting the get-location method isn't sufficient because it won't
-; intercept locations in already existing structures (e.g. scheme)...
-;
-;   cf. compile-structures in link.scm
-
-; Hacking the environment lookup mechanism to modify bindings on the
-; way out won't work, because it might cause denotation comparison to
-; fail during macro expansion...
-
-; So I think the best we can do is to maintain a location -> reference map.
-; There may be many routes to any particular location, but we'll only
-; be able to remember one of them.
-; (Actually, we _could_ remember all of them and then check at load time to
-; make sure that they all agree.)
-
-; The filtered environment also ought to be passed to the scanner,
-; because it caches looked-up bindings in nodes.  The effect of not
-; doing this is to get warning at compile time, and unbound variables
-; at load time.
-
-
-(define (compile-package-to-file p filename)
-  (let* ((table (make-table location-id))
-	 (env (package->separate p table))
-	 (stuff (scan-package p env))
-	 (templates '()))
-    (for-each (lambda (filename+nodes)
-		(set! templates
-		      (cons (compile-scanned-forms
-			     (cdr filename+nodes)
-			     p
-			     (car filename+nodes)
-			     (current-output-port)
-			     env)
-			    templates)))
-	      stuff)
-    (call-with-output-file filename
-      (lambda (port)
-	(fasdump (reverse templates) p table port)))))
-
-(define (package->separate p table)
-  (let ((cenv (package->environment p)))
-    (lambda (name)
-      (let ((probe (cenv name)))
-        (if (and (pair? probe)
-		 (location? (cdr probe))
-		 (not (table-ref table (cdr probe))))
-	    (table-set! table
-			(cdr probe)
-			(cons (name->qualified name)
-			      (let ((type (binding-type probe)))
-				(if (equal? type usual-variable-type)
-				    #f
-				    type)))))
-	probe))))
-
-(define *level* 0)
-
-(define (fasdump templates p table port)
-  (let* ((write-char (lambda (c)
-		       (write-char c port)))
-	 (dump (lambda (thing)
-		 (dump thing write-char -1))))
-    (dump *level*)
-    (dump (map structure-name (package-opens p)))  ;lose
-    (dump (map car (package-accesses p)))
-    (table-walk (lambda (loc qname+type)
-		  (dump (location-id loc))
-		  (dump qname+type))
-		table)
-    (dump '-)
-    (let-fluid $dump-index (lambda (loc)
-			     (if (table-ref table loc)
-				 (location-id loc)
-				 (begin (warn "lose" loc) #f)))
-      (lambda ()
-	(dump templates)))))
-
-(define (fasload filename name->structure)
-  (call-with-input-file filename
-    (lambda (port)
-      (let* ((read-char (lambda () (read-char port)))
-	     (restore (lambda () (restore read-char)))
-	     (table (make-table))
-	     (level (restore)))
-	(if (not (equal? level *level*))
-	    (warn "format revision level disagreement - try recompiling"
-		  `(file: ,level current: ,*level*)))
-	(let* ((open-names (restore))
-	       (access-names (restore))
-	       (p (make-package (lambda () (map name->structure open-names))
-				(lambda ()
-				  (map (lambda (name)
-					 (cons name
-					       (name->structure name)))
-				       access-names))
-				#f #f filename '()
-				#f	;uid
-				#f)))	;name
-	  (let loop ()
-	    (let ((uid (restore)))
-	      (if (not (eq? uid '-))
-		  (let ((qname+type (restore)))
-		    (table-set! table uid (reference->location qname+type p))
-		    (loop)))))
-	  (let-fluid $restore-index (lambda (id define?)
-				      (table-ref table id))
-	    (lambda ()
-	      (let ((templates (restore)))
-		(for-each (lambda (template)
-			    (if (not (template? template))
-				(error "lossage" template))
-			    (invoke-closure (make-closure template
-							  (package-uid p))))
-			  templates))))
-	  p)))))
-
-
-(define (reference->location qname+type p)
-  (let* ((compile-time-type (or (cdr qname+type) usual-variable-type))
-	 (name (qualified->name (car qname+type) p))
-	 (binding (package-lookup p name)))
-    (if (pair? binding)
-	(let ((type (binding-type binding)))
-	  (if (not (equal? type compile-time-type))
-	      (warn "type inconsistency" 
-		    `(compile time: ,compile-time-type)
-		    `(load time: ,type)))
-	  (cdr binding))
-	(package-define! p name compile-time-type))))
diff --git a/scheme/misc/shift-reset.scm b/scheme/misc/shift-reset.scm
deleted file mode 100644
index 48120b2..0000000
--- a/scheme/misc/shift-reset.scm
+++ /dev/null
@@ -1,155 +0,0 @@
-; no copyright notice
-
-; ,open signals escapes
-
-; Changes by jar:
-;   Added Uses of Scheme 48's WITH-CONTINUATION primitive, so that unreachable
-;   continuations can be reclaimed by the GC.
-;
-;   Renamed reset-thunk -> *reset
-;	    call/ct -> *shift
-;
-; Note: the meta-continuation ought to be thread-specific.
-; Alternatively, the threads package could be defined in terms of
-; shift and reset.  This would have the advantage of making the threads
-; package itself re-entrant.  It would be nice to rehabilitate the
-; runnable-threads queue, currently a piece of global state, as local
-; to a particular invocation of WITH-MULTITASKING.
-
-;Date: Wed, 29 Dec 1993 13:54:52 +0100
-;From: Olivier Danvy <danvy@daimi.aau.dk>
-;To: jar@martigny.ai.mit.edu
-;Subject: little Christmas gift
-;Reply-To: danvy@daimi.aau.dk
-;
-;Hi again:
-;
-;Here is a contribution for the Scheme48 library: the shift and reset
-;operators from "Abstracting Control" (LFP90) and "Representing Control"
-;(MSCS92).  In his POPL94 paper, Andrzej Filinski observed that since the
-;meta-continuation is single-threaded, it can be globalized in a
-;register.  Andrzej has programmed this both in SML and in Scheme.  I
-;only have prettified the Scheme definition a wee bit.
-
-(define-syntax reset
-  (syntax-rules ()
-    ((_ ?e) (*reset (lambda () ?e)))))
-
-(define-syntax shift
-  (syntax-rules ()
-    ((_ ?k ?e) (*shift (lambda (?k) ?e)))))
-
-(define *meta-continuation*
-  (lambda (v)
-    (error "You forgot the top-level reset...")))
-
-(define *abort
-  (lambda (thunk)
-    (with-continuation null-continuation ;JAR hack
-      (lambda ()
-	(let ((val (thunk)))
-	  (*meta-continuation* val))))))
-
-(define null-continuation #f)
-
-(define *reset
-  (lambda (thunk)
-    (let ((mc *meta-continuation*))
-      (call-with-current-continuation
-        (lambda (k)
-	  (begin
-	    (set! *meta-continuation*
-		  (lambda (v)
-		    (set! *meta-continuation* mc)
-		    (k v)))
-	    (*abort thunk)))))))
-
-(define *shift
-  (lambda (f)
-    (call-with-current-continuation
-      (lambda (k)
-	(*abort (lambda ()
-		  (f (lambda (v)
-		       (reset (k v))))))))))
-
-;----------
-;
-;Reminder: reset specifies a control delimiter.  shift grabs the current
-;continuation up to the current control delimiter, and reifies it as a
-;composable procedure.  If the procedure is not used, shift has the
-;effect of aborting up to the current control delimiter.
-;
-;Examples:
-;
-;(+ 10 (reset (+ 2 3)))
-;-->
-;15
-;
-;(+ 10 (reset (+ 2 (shift k 3))))
-;-->
-;13
-;
-;(+ 10 (reset (+ 2 (shift k (k 3)))))
-;-->
-;15
-;
-;(+ 10 (reset (+ 2 (shift k (+ 100 (k 3))))))
-;-->
-;115
-;
-;(+ 10 (reset (+ 2 (shift k (+ 100 (k (k 3)))))))
-;-->
-;117
-;
-;
-;Other reminder: shift and reset are weaker than Matthias's control and
-;prompt, in that they can be CPS-transformed.
-;
-;Have a happy holiday,
-;
-;-- Olivier
-;
-;PS: This definition is not unlike David Espinoza's implementation of monadic
-;effects, ie, it has no interpretive or translation overhead.
-
-
-
-; JAR's notes:
-;
-;  ; CWCC defined in terms of SHIFT
-;
-;  (define cwcc
-;    (lambda (p)
-;      (shift k (k (p (lambda (x)
-;                       (shift k1 (k x))))))))
-;
-;  ; Monads from shift and reset (from Filinski, POPL '94)
-;
-;  (define (reflect meaning)
-;    (shift k (extend k meaning)))
-;
-;  (define (reify thunk)
-;    (reset (eta (thunk))))
-;
-;  Example: nondeterminism monad.
-;
-;  > (define (eta x) (list x))
-;  > (define (extend f l) (apply append (map f l)))
-;  > 
-;  > (define-syntax amb
-;      (syntax-rules () ((amb ?x ?y) (*amb (lambda () ?x) (lambda () ?y)))))
-;
-;  > (define (*amb t1 t2)
-;      (reflect (append (reify t1) (reify t2))))
-;  > 
-;  > (reify (lambda () (amb 1 2)))
-;  '(1 2)
-;  > (reify (lambda () (+ (amb 1 2) 3)))
-;  '(4 5)
-;  > 
-;  > (define cwcc call-with-current-continuation)
-;  > (reify (lambda ()
-;             (+ 1 (cwcc (lambda (k)
-;                          (* 10 (amb 3 (k 4))))))))
-;  '(31 51)
-;  > 
diff --git a/scheme/misc/sicp.scm b/scheme/misc/sicp.scm
deleted file mode 100644
index 38eb1b1..0000000
--- a/scheme/misc/sicp.scm
+++ /dev/null
@@ -1,112 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Compatibility mode for use with Abelson & Sussman's book,
-; Structure and Interpretation of Computer Programs.
-
-; Requires ERROR, MAKE-TABLE, TABLE-REF, and TABLE-SET!.
-
-
-; Incompatible change to the meanings of AND and OR
-
-(define (and . rest)
-  (let loop ((rest rest))
-    (if (null? rest)
-	#t
-	(if (car rest)
-	    (loop (cdr rest))
-	    #f))))
-
-(define (or . rest)
-  (let loop ((rest rest))
-    (if (null? rest)
-	#f
-	(let ((temp (car rest)))
-	  (if temp
-	      temp
-	      (loop (cdr rest)))))))
-
-; Misc. nonsense
-
-(define-syntax sequence
-  (syntax-rules ()
-    ((sequence form ...) (begin form ...))))
-
-(define mapcar map)
-(define mapc for-each)
-
-(define (1+ x) (+ x 1))
-(define (-1+ x) (- x 1))
-
-(define t #t)
-(define nil #f)
-(define (atom? x) (not (pair? x)))
-
-(define (print x)
-  (write x)
-  (newline))
-(define princ display)
-(define prin1 write)
-
-; Streams
-
-(define-syntax cons-stream
-  (syntax-rules ()
-    ((cons-stream head tail)
-     (cons head (delay tail)))))
-
-(define head car)
-(define (tail s) (force (cdr s)))
-(define the-empty-stream '<the-empty-stream>)
-(define (empty-stream? s) (eq? s the-empty-stream))
-
-; EXPLODE and IMPLODE
-
-(define (explode thing)
-  (map (lambda (c) (string->symbol (string c)))
-       (string->list (cond ((symbol? thing)
-			    (symbol->string thing))
-			   ((number? thing)
-			    (number->string thing))
-			   (else
-			    (error "invalid argument to explode" thing))))))
-
-(define (implode l)
-  (string->symbol (list->string (map (lambda (s)
-				       (string-ref (symbol->string s) 0))
-				     l))))
-
-; GET and PUT
-
-(define (make-property-module)
-  (define symbol-properties-table #f)
-
-  (define (put symbol indicator value)
-    (let* ((probe (table-ref symbol-properties-table symbol))
-	   (table (if probe
-		      probe
-		      (let ((table (make-table)))
-			(table-set! symbol-properties-table symbol table)
-			table))))
-      (table-set! table indicator value)))
-
-  (define (get symbol indicator)
-    (let ((probe (table-ref symbol-properties-table symbol)))
-      (if probe
-	  (table-ref probe indicator)
-	  #f)))
-
-  (set! symbol-properties-table (make-table))
-
-  (cons get put))
-
-(define property-module (make-property-module))
-(define get (car property-module))
-(define put (cdr property-module))
-
-; Need these special forms:
-;   collect make-environment access the-environment
-
-; The following are among the procedures defined in MIT's student
-; system; I don't know how many are actually needed for the book:
-;   ascii char nth nthcdr tyo vector-cons
-;   accumulate filter map-stream append-streams
diff --git a/scheme/misc/static.scm b/scheme/misc/static.scm
deleted file mode 100644
index c86c698..0000000
--- a/scheme/misc/static.scm
+++ /dev/null
@@ -1,216 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; This little utility converts a heap image into a C file.
-;
-; For example:
-;   (do-it 100000 "~/s48/debug/little.image" "little-heap.c")
-;
-; The first argument to do-it should be somewhat larger than the size,
-; in bytes, of the image file to be converted (which you can obtain with
-; "ls -l").
-;
-; If the image contains 0-length stored objects, then the .c file will
-; have to be compiled by gcc, since 0-length arrays aren't allowed in
-; ANSI C.  This wouldn't be difficult to work around.
-;
-; For loading instructions, see load-static.scm.
-
-(define *comments?* #f)
-
-; 800,000 bytes => 200,000 words => at least 100,000 objects
-;   50 chunks => 16,000 bytes per chunk => 2,000 objects per chunk
-(define *chunk-size* 10000)
-
-(define (do-it bytes infile outfile)
-  (let ((start (init bytes infile)))
-    (call-with-output-file outfile
-      (lambda (port)
-	(format port "#define D(x) (long)(&x)+7~%")
-	(format port "#define H unsigned long~%")
-	(emit-area-declarations "p" immutable? "const " port)
-	(emit-area-declarations "i" mutable? "" port)
-	(emit-area-initializers "p" immutable? "const " port)
-	(emit-area-initializers "i" mutable? "" port)
-	(display "const long entry = " port)
-	(emit-descriptor start port)
-	(write-char #\; port)
-	(newline port)))))
-
-(define (init bytes infile)
-  (create-memory (quotient bytes 2) quiescent) ;Output of ls -l
-  (initialize-heap (memory-begin) (memory-size))
-  (let ((start (read-image infile 0)))
-    (message (nchunks)
-	     " chunks")
-    start))
-
-(define (nchunks) (+ (chunk-number (heap-pointer)) 1))
-
-; emit struct declarations for areas
-
-(define (emit-area-declarations name in-area? const port)
-  (for-each-stored-object
-   (lambda (chunk)
-     (message name chunk " declaration")
-     (display "struct " port) (display name port) (display chunk port)
-     (display " {" port) (newline port))
-   (lambda (x)
-     (if (in-area? x)
-	 (emit-declaration x port)))
-   (lambda (chunk)
-     (display "};" port)
-     (newline port)
-     (display const port)
-     (display "extern struct " port) (display name port) (display chunk port)
-     (write-char #\space port) (display name port) (display chunk port)
-     (write-char #\; port) (newline port)
-     chunk)))
-
-(define (emit-declaration x port)
-  (display "  H x" port)
-  (writex x port)
-  (cond ((d-vector? x)
-	 (display "; long d" port)
-	 (writex x port)
-	 (write-char #\[ port)
-	 (write (d-vector-length x) port))
-	((vm-string? x)
-	 (display "; char d" port)
-	 (writex x port)
-	 (write-char #\[ port)
-	 ;; Ensure alignment (thanks Ian)
-	 (write (cells->bytes (bytes->cells (b-vector-length x)))
-		port))
-	(else
-	 (display "; unsigned char d" port)
-	 (writex x port)
-	 (write-char #\[ port)
-	 ;; Ensure alignment
-	 (write (cells->bytes (bytes->cells (b-vector-length x)))
-		port)))
-  (display "];" port)
-  (if *comments?*
-      (begin (display " /* " port)
-	     (display (enumerand->name (stob-type x) stob) port)
-	     (display " */" port)))
-  (newline port))
-
-; Emit initializers for areas
-
-(define (emit-area-initializers name in-area? const port)
-  (for-each-stored-object
-   (lambda (chunk)
-     (message name chunk " initializer")
-
-     (display const port)
-     (display "struct " port) (display name port) (write chunk port)
-     (write-char #\space port) (display name port) (write chunk port)
-     (display " =" port) (newline port)
-
-     (write-char #\{ port) (newline port))
-   (lambda (x)
-     (if (in-area? x)
-	 (emit-initializer x port)))
-   (lambda (chunk)
-     (display "};" port) (newline port)))
-
-  (let ((n (nchunks)))
-    (format port "const long ~a_count = ~s;~%" name n)
-    (format port "~a long * const ~a_areas[~s] = {" const name n)
-    (do ((i 0 (+ i 1)))
-	((= i n))
-      (format port "(~a long *)&~a~s, " const name i))
-    (format port "};~%const long ~a_sizes[~s] = {" name n)
-    (do ((i 0 (+ i 1)))
-	((= i n))
-      (format port "sizeof(~a~s), " name i))
-    (format port "};~%")))
-
-
-(define (message . stuff)
-  (for-each display stuff) (newline))
-
-(define (emit-initializer x port)
-  (display "  " port)
-  (write (stob-header x) port)
-  (write-char #\, port)
-  (cond ((d-vector? x)
-	 (emit-d-vector-initializer x port))
-	((vm-string? x)
-	 (write-char #\" port)
-	 (let ((len (vm-string-length x)))
-	   (do ((i 0 (+ i 1)))
-	       ((= i len) (write-char #\" port))
-	     (let ((c (vm-string-ref x i)))
-	       (cond ((or (char=? c #\") (char=? c #\\))
-		      (write-char #\\ port))
-		     ((char=? c #\newline)
-		      (display "\\n\\" port)))
-	       (write-char c port)))))
-	(else
-	 (write-char #\{ port)
-	 (let ((len (b-vector-length x)))
-	   (do ((i 0 (+ i 1)))
-	       ((= i len) (write-char #\} port))
-	     (write (b-vector-ref x i) port)
-	     (write-char #\, port)))))
-  (write-char #\, port)
-  (if *comments?*
-      (begin (display " /* " port)
-	     (writex x port)
-	     (display " */" port)))
-  (newline port))
-
-(define (emit-d-vector-initializer x port)
-  (write-char #\{ port)
-  (let ((len (d-vector-length x)))
-    (do ((i 0 (+ i 1)))
-	((= i len) (write-char #\} port))
-      (emit-descriptor (d-vector-ref x i) port)
-      (write-char #\, port))))
-
-(define (emit-descriptor x port)
-  (if (stob? x)
-      (begin (if (immutable? x)
-		 (display "D(p" port)
-		 (display "D(i" port))
-	     (display (chunk-number x) port)
-	     (display ".x" port)
-	     (writex x port)
-	     (write-char #\) port))
-      (write x port)))
-
-
-; Foo
-
-(define (writex x port)
-  (write (quotient (- (- x (memory-begin)) 7) 4) port))
-
-(define (chunk-number x)
-  (quotient (- (- x (memory-begin)) 7) *chunk-size*))
-
-
-; Image traversal utility
-
-(define (for-each-stored-object chunk-start proc chunk-end)
-  (let ((limit (heap-pointer)))
-    (let chunk-loop ((addr (newspace-begin))
-		     (i 0)
-		     (chunk (+ (newspace-begin) *chunk-size*)))
-      (if (addr< addr limit)
-	  (begin (chunk-start i)
-		 (let loop ((addr addr))
-		   (if (and (addr< addr limit)
-			    (addr< addr chunk))
-		       (let ((d (fetch addr)))
-			 (if (not (header? d))
-			     (warn "heap is in an inconsistent state" d))
-			 (proc (address->stob-descriptor (addr1+ addr)))
-			 (loop (addr1+ (addr+ addr (header-a-units d)))))
-		       (begin (chunk-end i)
-			      (chunk-loop addr
-					  (+ i 1)
-					  (+ chunk *chunk-size*))))))))))
-
-(define (mutable? x) (not (immutable? x)))
diff --git a/scheme/misc/syscall.scm b/scheme/misc/syscall.scm
deleted file mode 100644
index adf23a2..0000000
--- a/scheme/misc/syscall.scm
+++ /dev/null
@@ -1,93 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Some Unix system calls.  By no means all of them.
-; Cf. external.c
-
-(define pipe
-  (let ((s48_pipe (get-external "s48_pipe")))
-    (lambda ()
-      (let ((results (cons 0 0)))
-	(unix-system-call s48_pipe 'pipe results)
-	(values (car results) (cdr results))))))
-
-(define waitpid
-  (let ((s48_waitpid (get-external "s48_waitpid")))
-    (lambda (pid options)
-      (let ((results (cons 0 0)))
-	(unix-system-call s48_waitpid 'waitpid results pid options)
-	(values (car results) (cdr results))))))
-
-(define fork
-  (let ((s48_fork (get-external "s48_fork")))
-    (lambda ()
-      (let ((results (cons -2 #f)))
-	(unix-system-call s48_fork 'fork results)
-	(car results)))))
-
-(define dup
-  (let ((s48_dup (get-external "s48_dup")))
-    (lambda (fd)
-      (let ((result (cons 0 0)))
-	(unix-system-call s48_dup 'dup result fd)
-	(car result)))))
-
-(define close
-  (let ((s48_close (get-external "s48_close")))
-    (lambda (fd)
-      (unix-system-call s48_close 'close fd))))
-
-(define execv
-  (let ((s48_execv (get-external "s48_execv")))
-    (lambda (path argv)
-      (unix-system-call s48_execv 'execv path argv)
-      (error "execv returned?" path argv))))
-
-(define exit
-  (let ((s48_exit (get-external "s48_exit")))
-    (lambda args
-      (apply external-call s48_exit args)
-      (error "exit returned!?"))))
-
-
-; Utility
-
-(define (unix-system-call external id . args)
-  (let loop ()
-    (let ((errno (apply external-call external args)))
-      (if errno
-	  (if (= errno 4)		;EINTR
-	      (begin (warn "interrupted system call" id)
-		     (loop))
-	      (apply call-error (strerror errno) id args))
-	  #t))))
-
-; Utility for printing error messages
-
-(define strerror
-  (let ((s48_strerror (get-external "s48_strerror")))
-    (lambda (n)
-      (let* ((s (make-string 100))
-	     (l (external-call s48_strerror s n)))
-	(if (integer? l)
-	    (substring s 0 l)
-	    (call-error "miscellaneous error" strerror n))))))
-
-
-
-; To coerce a file descriptor to a channel:
-; ,open architecture channels
-;   (open-channel in-fd
-;		  (enum open-channel-option
-;			raw-input-channel))
-;   (open-channel out-fd
-;		  (enum open-channel-option
-;			raw-output-channel))
-
-; To coerce a channel to a port:
-; ,open i/o-internal
-;   (input-channel->port <channel> 1024) ; buffer size
-;   (output-channel->port <channel> 1024)
-; The inverse operation is not available.
-
-; To coerce a channel to a file descriptor:
-;   (vm-extension 30 channel) => fd
diff --git a/scheme/misc/test-doodl.scm b/scheme/misc/test-doodl.scm
deleted file mode 100644
index 97fe630..0000000
--- a/scheme/misc/test-doodl.scm
+++ /dev/null
@@ -1,52 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; ((method () 1)) => 1
-; ((method () 1) 2) => error
-
-; ((method (x) 1) 2) => 1
-; ((method ((x <symbol>)) 1) 2) => error
-
-; ((method ((x <symbol>)) 1) 'foo) => 1
-; ((method ((x <symbol>)) (next-method)) 'foo) => error
-
-
-
-(define-generic-function elt ((s <sequence>)))
-
-(define-method elt ((x <vector>) y)
-  (vector-ref x y))
-
-; (elt '#(a b c) 1) => b
-
-(define-method elt ((x <string>) y)
-  (string-ref x y))
-
-(define-method elt ((x <list>) y)
-  (list-ref x y))
-
-
-; Setters
-
-(define-generic-function (setter elt)
-  (thing index new-value))
-
-(define-method (setter elt) ((x <vector>) i z)
-  (vector-set! x i z))
-
-; (let ((v (vector 1 2 3))) (set (elt v 1) 'foo) v) => '#(1 foo 3)
-
-
-; Classes
-
-(define-class <mumble> () a b)
-
-; (a (make <mumble>)) => '*uninitialized*
-; (let ((m (make <mumble>))) (set (a m) 'foo) (a m)) => 'foo
-
-(define-method initialize ((m <mumble>) z)
-  (set (a m) z))
-
-; (a (make <mumble> 3)) => 3
-
-
diff --git a/scheme/opt/sort.scm b/scheme/opt/sort.scm
deleted file mode 100644
index 58a4489..0000000
--- a/scheme/opt/sort.scm
+++ /dev/null
@@ -1,117 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Topological sort on forms.
-
-; Puts top-level forms in the following order:
-;
-; (DEFINE X <literal>)
-; (DEFINE Z (LAMBDA ...))
-; ...everything else...
-;
-; Every (DEFINE W ...) for which W is never SET! is followed by all forms
-; (DEFINE V W).
-;
-; The procedure definitions are topologically sorted; whenever possible no
-; use of a variable occurs before its definition.
-;
-; COMPLETE? is true if STUFF contains the entire body of a module.
-;
-; This uses the FREE-VARIABLES field set by analyze.scm.
-
-(define (sort-forms nodes complete?)
-  (let ((table (make-name-table))
-	(procs '())
-	(literals '())
-	(aliases '())
-	(rest '()))
-    (for-each (lambda (node)
-		(let ((form (make-form node)))
-		  (if (define-node? node)
-		      (let ((name (node-form (cadr (node-form node))))
-			    (value (caddr (node-form node))))
-			(table-set! table name form)
-			(cond ((lambda-node? value)
-			       (set! procs (cons form procs)))
-			      ((name-node? value)
-			       (set! aliases (cons form aliases))
-			       (set! rest (cons form rest)))
-			      ((or (quote-node? value)
-				   (literal-node? value))
-			       (set! literals (cons form literals)))
-			      (else
-			       (set! rest (cons form rest)))))
-		      (set! rest (cons form rest)))))
-	      (reverse nodes))
-    (for-each (lambda (form)
-		(maybe-make-aliased form table))
-	      aliases)
-    (insert-aliases
-     (append literals
-	     (topologically-sort procs table)
-	     (filter form-unaliased? rest)))))
-
-(define (stuff-count s)
-  (apply + (map (lambda (s) (length (cdr s))) s)))
-
-; For (DEFINE A B) add the form to the list of B's aliases if B is defined
-; in the current package and never SET!.
-
-(define (maybe-make-aliased form table)
-  (let* ((value (caddr (node-form (form-node form))))
-	 (maker (table-ref table (node-form value))))
-    (if (and (node-ref value 'binding)
-	     maker
-	     (= 0 (usage-assignment-count
-		    (node-ref (cadr (node-form (form-node maker))) 'usage))))
-	(begin
-	  (set-form-aliases! maker (cons form (form-aliases maker)))
-	  (set-form-unaliased?! form #f)))))
-
-(define (topologically-sort forms table)
-  (apply append
-	 (strongly-connected-components
-	   forms
-	   (lambda (form)
-	     (filter (lambda (f)
-		       (and f
-			    (lambda-node? (caddr (node-form (form-node f))))))
-		     (map (lambda (name)
-			    (table-ref table (node-form name)))
-			  (form-free form))))
-	   form-temp
-	   set-form-temp!)))
-
-(define-record-type form :form
-  (really-make-form node free aliases unaliased?)
-  form?
-  (node form-node)
-  (aliases form-aliases set-form-aliases!)
-  (unaliased? form-unaliased? set-form-unaliased?!)
-  (free form-free set-form-free!)
-  (temp form-temp set-form-temp!))
-
-(define-record-discloser :form
-  (lambda (form)
-    (list 'form
-	  (let ((node (form-node form)))
-	    (if (define-node? node)
-		(node-form (cadr (node-form node)))
-		node)))))
-
-(define (make-form node)
-  (really-make-form node
-		    (map usage-name-node
-			 (node-ref node 'free-variables))
-		    '()		; aliases
-		    #t))	; unaliased?
-
-; (DEFINE A ...) is followed by all forms (DEFINE X A).
-
-(define (insert-aliases forms)
-  (let loop ((forms forms) (done '()))
-    (if (null? forms)
-	(reverse done)
-	(let ((form (car forms)))
-	  (loop (append (form-aliases form) (cdr forms))
-		(cons (form-node form) done))))))
diff --git a/scheme/opt/tst.scm b/scheme/opt/tst.scm
deleted file mode 100644
index 50a878f..0000000
--- a/scheme/opt/tst.scm
+++ /dev/null
@@ -1,26 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-
-(define-structure primitives (make-compiler-base))
-
-; "Level 1"
-
-(define-structures ((scheme-level-1 scheme-level-1-interface)
-		    (scheme-level-1-internal scheme-level-1-internal-interface)
-		    (bitwise bitwise-interface)
-		    (util util-interface)
-		    (signals signals-interface)
-		    (features features-interface)
-		    (ascii ascii-interface)
-		    (structure-refs (export structure-ref)))
-  (open primitives)
-  (usual-transforms)
-  (optimize auto-integrate)
-  (files (rts base)
-	 (rts util)
-	 (rts signal)
-	 (rts number)
-	 (rts lize)	  ; Rationalize
-	 ))
-
diff --git a/scheme/prescheme/interface.scm b/scheme/prescheme/interface.scm
deleted file mode 100644
index 9fdd278..0000000
--- a/scheme/prescheme/interface.scm
+++ /dev/null
@@ -1,88 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-(define-interface prescheme-interface
-  (export ((if begin lambda letrec quote set!
-	       define define-syntax let-syntax
-	       and cond case do let let* or
-	       quasiquote
-	       ;syntax-rules
-	       ) :syntax)  ; no delay
-	  ;; letrec-syntax  -- not yet implemented
-	  
-	  (goto :syntax)
-	  (external :syntax)
-
-	  ((define-enumeration define-external-enumeration enum) :syntax)
-	  ((name->enumerand enumerand->name) :syntax)  ; loadtime only
-
-	  not
-
-	  eq?
-	  + - * = <  ; /
-	  <= > >=
-	  abs
-	  expt
-	  quotient remainder
-	  ; floor numerator denominator
-	  ; real-part imag-part
-	  ; exp log sin cos tan asin acos atan sqrt
-	  ; angle magnitude make-polar make-rectangular
-	  min max
-	  char=? char<?
-
-	  ;; Data manipulation
-	  make-vector vector-length
-	  vector-ref vector-set!
-
-	  make-string string-length
-	  string-ref string-set!
-
-	  deallocate
-	  null-pointer?
-
-	  values call-with-values
-
-	  current-input-port current-output-port current-error-port
-	  open-input-file open-output-file
-	  close-output-port close-input-port
-
-	  read-char peek-char read-integer
-	  write-char newline write-string write-integer
-	  force-output
-
-	  (errors :syntax)
-	  error-string
-
-	  ascii->char char->ascii
-	  
-	  shift-left arithmetic-shift-right logical-shift-right
-	  bitwise-and bitwise-ior bitwise-xor bitwise-not
-	  unspecific
-	  error
-	  ))
-
-; memory (malloc and free)
-
-(define-interface ps-memory-interface
-  (export allocate-memory
-	  deallocate-memory
-
-	  unsigned-byte-ref unsigned-byte-set!
-	  word-ref word-set!
-
-	  address?
-	  null-address null-address?
-
-	  address+ address- address-difference
-	  address= address< address<= address> address>=
-	  address->integer integer->address
-
-	  copy-memory! memory-equal?
-
-	  char-pointer->string char-pointer->nul-terminated-string
-
-	  read-block write-block))
-
-(define-interface ps-receive-interface
-  (export receive))
-
diff --git a/scheme/prescheme/load.scm b/scheme/prescheme/load.scm
deleted file mode 100644
index 789d99c..0000000
--- a/scheme/prescheme/load.scm
+++ /dev/null
@@ -1,8 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; To load Pre-Scheme, do
-;   ,exec ,load <this file>
-
-(config)
-(load "interface.scm")
-(load "package-defs.scm")
diff --git a/scheme/prescheme/memory.scm b/scheme/prescheme/memory.scm
deleted file mode 100644
index 7c2b69b..0000000
--- a/scheme/prescheme/memory.scm
+++ /dev/null
@@ -1,255 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; An implementation of Pre-Scheme's memory interface that can detect some
-; stray reads and writes.  It has numerous limitiations:
-;    Allocations are always on page boundaries.
-;    No more than 16 megabytes can be allocated at once.
-;    More than 32 or 64 or so allocations result in addresses being
-;       bignums (dealloctions have no effect on this).
-;
-; Memory is represented as a vector of byte-vectors, with each byte-vector
-; representing a 16-megabyte page.  Allocations are always made on page
-; boundaries, so the byte-vectors only need be as large as the allocated
-; areas.  Pages are never re-used.
-;
-; (Scheme 48 still calls byte-vectors code-vectors.)
-
-
-; Addresses are distinct from integers.
-
-(define-record-type address :address
-  (make-address index)
-  address?
-  (index address-index))
-  
-(define-record-discloser :address
-  (lambda (addr) (list 'address (address-index addr))))
-
-; We add 100000000 to addresses to make them
-
-(define address-offset 100000000)
-
-(define (address->integer addr)
-  (+ (address-index addr) address-offset))
-
-(define (integer->address int)
-  (make-address (- int address-offset)))
-
-(define (address+ address integer)
-  (make-address (+ (address-index address) integer)))
-
-(define (address- address integer)
-  (make-address (- (address-index address) integer)))
-
-(define (address-binop op)
-  (lambda (address1 address2)
-    (op (address-index address1) (address-index address2))))
-
-(define address-difference (address-binop -))
-(define address= (address-binop =))
-(define address< (address-binop <))
-(define address<= (address-binop <=))
-(define address> (address-binop >))
-(define address>= (address-binop >=))
-
-(define null-address (make-address -1))
-
-(define (null-address? address)
-  (address= address null-address))
-
-; Memory
-
-(define *memory* (make-vector 16 #f))    ; vector of pages
-(define log-max-size 24)                 ; log of page size
-(define address-shift (- log-max-size))  ; turns addresses into page indices
-
-(define max-size (arithmetic-shift 1 log-max-size))  ; page size
-
-(define address-mask                     ; mask to get address within page
-  (- (arithmetic-shift 1 log-max-size) 1))
-
-(define *next-index* 0)                  ; next available page
-
-(define (reinitialize-memory)
-  (set! *memory* (make-vector 16 #f))
-  (set! *next-index* 0))
-
-; Extend the page vector if necessary, and then make a page of the
-; appropriate size.
-
-(define (allocate-memory size)
-  (cond ((> size max-size)
-	 -1)  ; error result
-	(else
-	 (if (>= *next-index* (vector-length *memory*))
-	     (let ((new (make-vector (* 2 (vector-length *memory*)))))
-	       (do ((i 0 (+ i 1)))
-		   ((>= i (vector-length *memory*)))
-		 (vector-set! new i (vector-ref *memory* i)))
-	       (set! *memory* new)))
-	 (let ((index *next-index*))
-	   (set! *next-index* (+ *next-index* 1))
-	   (vector-set! *memory* index (make-code-vector size 0))
-	   (make-address (arithmetic-shift index log-max-size))))))
-
-; Turning an address into a page or page index
-
-(define (address->vector address)
-  (vector-ref *memory* (arithmetic-shift address address-shift)))
-
-(define (address->vector-index address)
-  (bitwise-and address address-mask))
-
-; Throw away the page containing ADDRESS, which must be the first address in
-; that page, 
-
-(define (deallocate-memory address)
-  (let ((address (address-index address)))
-    (let ((vector (address->vector address))
-	  (byte-address (address->vector-index address)))
-      (if (and vector (= byte-address 0))
-	  (vector-set! *memory* (arithmetic-shift address address-shift) #f)
-	  (error "bad deallocation address" address)))))
-
-; Various ways of accessing memory
-
-(define (unsigned-byte-ref address)
-  (let ((address (address-index address)))
-    (code-vector-ref (address->vector address)
-		     (address->vector-index address))))
-
-(define (signed-code-vector-ref bvec i)
-  (let ((x (code-vector-ref bvec i)))
-    (if (< x 128)
-	x
-	(bitwise-ior x -128))))
-
-(define (word-ref address)
-  (let ((address (address-index address)))
-    (let ((vector (address->vector address))
-	  (byte-address (address->vector-index address)))
-      (if (not (= 0 (bitwise-and byte-address 3)))
-	  (error "unaligned address error" address)
-	  (+ (+ (arithmetic-shift (signed-code-vector-ref vector byte-address) 24)
-		(arithmetic-shift (code-vector-ref vector (+ byte-address 1)) 16))
-	     (+ (arithmetic-shift (code-vector-ref vector (+ byte-address 2))  8)
-		(code-vector-ref vector (+ byte-address 3))))))))
-  
-(define (unsigned-byte-set! address value)
-  (let ((address (address-index address)))
-    (code-vector-set! (address->vector address)
-		      (address->vector-index address)
-		      (bitwise-and 255 value))))
-	    
-(define (word-set! address value)
-  (let ((address (address-index address)))
-    (let ((vector (address->vector address))
-	  (byte-address (address->vector-index address)))
-      (if (not (= 0 (bitwise-and byte-address 3)))
-	  (error "unaligned address error" address))
-      (code-vector-set! vector    byte-address
-			(bitwise-and 255 (arithmetic-shift value -24)))
-      (code-vector-set! vector (+ byte-address 1)
-			(bitwise-and 255 (arithmetic-shift value -16)))
-      (code-vector-set! vector (+ byte-address 2)
-			(bitwise-and 255 (arithmetic-shift value -8)))
-      (code-vector-set! vector (+ byte-address 3)
-			(bitwise-and 255 value)))))
-
-; Block I/O procedures.
-
-(define (write-block port address count)
-  (let ((address (address-index address)))
-    (let ((vector (address->vector address))
-	  (byte-address (address->vector-index address)))
-      (do ((i 0 (+ i 1)))
-	  ((>= i count))
-	(write-char (ascii->char (code-vector-ref vector (+ i byte-address)))
-		    port))
-      (enum errors no-errors))))
-
-(define (read-block port address count)
-  (let ((address (address-index address)))
-    (cond ((not (char-ready? port))
-	   (values 0 #f (enum errors no-errors)))
-	  ((eof-object? (s-peek-char port))
-	   (values 0 #t (enum errors no-errors)))
-	  (else
-	   (let ((vector (address->vector address))
-		 (byte-address (address->vector-index address)))
-	     (let loop ((i 0))
-	       (if (or (= i count)
-		       (not (char-ready? port)))
-		   (values i #f (enum errors no-errors))
-		   (let ((c (s-read-char port)))
-		     (cond ((eof-object? c)
-			    (values i #f (enum errors no-errors)))
-			   (else
-			    (code-vector-set! vector
-					      (+ i byte-address)
-					      (char->ascii c))
-			    (loop (+ i 1))))))))))))
-
-(define (copy-memory! from to count)
-  (let ((from (address-index from))
-	(to (address-index to)))
-    (let ((from-vector (address->vector from))
-	  (from-address (address->vector-index from))
-	  (to-vector (address->vector to))
-	  (to-address (address->vector-index to)))
-      (do ((i 0 (+ i 1)))
-	  ((>= i count))
-	(code-vector-set! to-vector
-			  (+ i to-address)
-			  (code-vector-ref from-vector
-					   (+ i from-address)))))))
-
-(define (memory-equal? from to count)
-  (let ((from (address-index from))
-	(to (address-index to)))
-    (let ((from-vector (address->vector from))
-	  (from-address (address->vector-index from))
-	  (to-vector (address->vector to))
-	  (to-address (address->vector-index to)))
-      (let loop ((i 0))
-	(cond ((>= i count)
-	       #t)
-	      ((= (code-vector-ref to-vector (+ i to-address))
-		  (code-vector-ref from-vector (+ i from-address)))
-	       (loop (+ i 1)))
-	      (else
-	       #f))))))
-
-; Turn the LENGTH bytes starting from ADDRESS into a string.
-
-(define (char-pointer->string address length)
-  (let ((address (address-index address)))
-    (let ((vector (address->vector address))
-	  (byte-address (address->vector-index address))
-	  (string (make-string length)))
-      (do ((i 0 (+ i 1)))
-	  ((= i length))
-	(string-set! string
-		     i
-		     (ascii->char (code-vector-ref vector (+ byte-address i)))))
-      string)))
-
-; Turn the bytes from ADDRESS to the next nul (byte equal to 0) into a
-; string.  This is a trivial operation in C.
-
-(define (char-pointer->nul-terminated-string address)
-  (let ((index (address-index address)))
-    (let ((vector (address->vector index))
-	  (byte-address (address->vector-index index)))
-      (char-pointer->string address (index-of-first-nul vector byte-address)))))
-  
-(define (index-of-first-nul vector address)
-  (let loop ((i address))
-    (cond ((= i (code-vector-length vector))
-	   (error "CHAR-POINTER->STRING called on pointer with no nul termination"))
-	  ((= 0 (code-vector-ref vector i))
-	   (- i address))
-	  (else
-	   (loop (+ i 1))))))
-	  
diff --git a/scheme/prescheme/memory2.scm b/scheme/prescheme/memory2.scm
deleted file mode 100644
index ddd890a..0000000
--- a/scheme/prescheme/memory2.scm
+++ /dev/null
@@ -1,244 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; An implementation of Pre-Scheme's memory interface that can detect some
-; stray reads and writes.  It has numerous limitiations:
-;    Allocations are always on page boundaries.
-;    No more than 16 megabytes can be allocated at once.
-;    More than 32 or 64 or so allocations result in addresses being
-;       bignums (dealloctions have no effect on this).
-;
-; Memory is represented as a vector of byte-vectors, with each byte-vector
-; representing a 16-megabyte page.  Allocations are always made on page
-; boundaries, so the byte-vectors only need be as large as the allocated
-; areas.  Pages are never re-used.
-
-; Memory is one big vector, with markers at beginning and end of free blocks
-; and allocationg by by address ordered first fit.
-
-; Strings and things end up as bignums...
-
-(define *memory* (make-vector 0 0))
-
-(define-record-type address :address
-  (make-address index)
-  address?
-  (index address-index))
-  
-(define-record-discloser :address
-  (lambda (addr) (list 'address (address-index addr))))
-
-; We add 100000000 to addresses to make them
-
-(define address-offset 100000000)
-
-(define (address->integer addr)
-  (+ (address-index addr) address-offset))
-
-(define (integer->address int)
-  (make-address (- int address-offset)))
-
-(define (word-ref addr)
-  (if (address? addr)
-      (let ((index (address-index addr)))
-	(if (and (= 0
-  (vector-ref *memory* (address-index addr)))
-
-(define (word-ref addr)
-  (vector-ref *memory* (address-index addr)))
-
-
-
-
-
-
-
-
-
-(define *memory* (make-vector 16 #f))    ; vector of pages
-(define log-max-size 24)                 ; log of page size
-(define address-shift (- log-max-size))  ; turns addresses into page indices
-
-(define max-size (arithmetic-shift 1 log-max-size))  ; page size
-
-(define address-mask                     ; mask to get address within page
-  (- (arithmetic-shift 1 log-max-size) 1))
-
-(define *next-index* 0)                  ; next available page
-
-(define (reinitialize-memory)
-  (set! *memory* (make-vector 16 #f))
-  (set! *next-index* 0))
-
-; Extend the page vector if necessary, and then make a page of the
-; appropriate size.
-
-(define (allocate-memory size)
-  (cond ((> size max-size)
-	 #f)  ; the null pointer
-	(else
-	 (if (>= *next-index* (vector-length *memory*))
-	     (let ((new (make-vector (* 2 (vector-length *memory*)))))
-	       (do ((i 0 (+ i 1)))
-		   ((>= i (vector-length *memory*)))
-		 (vector-set! new i (vector-ref *memory* i)))
-	       (set! *memory* new)))
-	 (let ((index *next-index*))
-	   (set! *next-index* (+ *next-index* 1))
-	   (vector-set! *memory* index (make-code-vector size 0))
-	   (arithmetic-shift index log-max-size)))))
-
-; Turning an address into a page or page index
-
-(define (address->vector address)
-  (vector-ref *memory* (arithmetic-shift address address-shift)))
-
-(define (address->vector-index address)
-  (bitwise-and address address-mask))
-
-; Throw away the page containing ADDRESS, which must be the first address in
-; that page, 
-
-(define (deallocate-memory address)
-  (let ((vector (address->vector address))
-	(byte-address (address->vector-index address)))
-    (if (and vector (= byte-address 0))
-	(vector-set! *memory* (arithmetic-shift address address-shift) #f)
-	(error "bad deallocation address" address))))
-
-; Various ways of accessing memory
-
-(define (unsigned-byte-ref address)
-  (code-vector-ref (address->vector address)
-		   (address->vector-index address)))
-
-(define (signed-code-vector-ref bvec i)
-  (let ((x (code-vector-ref bvec i)))
-    (if (< x 128)
-	x
-	(bitwise-ior x -128))))
-
-(define (word-ref address)
-  (let ((vector (address->vector address))
-	(byte-address (address->vector-index address)))
-    (if (not (= 0 (bitwise-and byte-address 3)))
-	(error "unaligned address error" address)
-	(+ (+ (arithmetic-shift (signed-code-vector-ref vector byte-address) 24)
-	      (arithmetic-shift (code-vector-ref vector (+ byte-address 1)) 16))
-	   (+ (arithmetic-shift (code-vector-ref vector (+ byte-address 2))  8)
-	      (code-vector-ref vector (+ byte-address 3)))))))
-	    
-(define (unsigned-byte-set! address value)
-  (code-vector-set! (address->vector address)
-		    (address->vector-index address)
-		    (bitwise-and 255 value)))
-	    
-(define (word-set! address value)
-  (let ((vector (address->vector address))
-	(byte-address (address->vector-index address)))
-    (if (not (= 0 (bitwise-and byte-address 3)))
-	(error "unaligned address error" address))
-    (code-vector-set! vector    byte-address
-		      (bitwise-and 255 (arithmetic-shift value -24)))
-    (code-vector-set! vector (+ byte-address 1)
-		      (bitwise-and 255 (arithmetic-shift value -16)))
-    (code-vector-set! vector (+ byte-address 2)
-		      (bitwise-and 255 (arithmetic-shift value -8)))
-    (code-vector-set! vector (+ byte-address 3)
-		      (bitwise-and 255 value))))
-
-; Block I/O procedures.
-
-(define (write-block port address count)
-  (let ((vector (address->vector address))
-	(byte-address (address->vector-index address)))
-    (do ((i 0 (+ i 1)))
-	((>= i count))
-      (write-char (ascii->char (code-vector-ref vector (+ i byte-address)))
-		  port))
-    (values count (enum errors no-errors))))
-
-(define (read-block port address count)
-  (cond ((not (char-ready? port))
-	 (values 0 #f (enum errors no-errors)))
-	((eof-object? (s-peek-char port))
-	 (values 0 #t (enum errors no-errors)))
-	(else
-	 (let ((vector (address->vector address))
-	       (byte-address (address->vector-index address)))
-	   (let loop ((i 0))
-	     (if (or (= i count)
-		     (not (char-ready? port)))
-		 (values i #f (enum errors no-errors))
-		 (let ((c (s-read-char port)))
-		   (cond ((eof-object? c)
-			  (values i #f (enum errors no-errors)))
-			 (else
-			  (code-vector-set! vector
-					    (+ i byte-address)
-					    (char->ascii c))
-			  (loop (+ i 1)))))))))))
-
-(define (copy-memory! from to count)
-  (let ((from-vector (address->vector from))
-	(from-address (address->vector-index from))
-	(to-vector (address->vector to))
-	(to-address (address->vector-index to)))
-    (do ((i 0 (+ i 1)))
-	((>= i count))
-      (code-vector-set! to-vector
-			(+ i to-address)
-			(code-vector-ref from-vector
-					 (+ i from-address))))))
-
-(define (memory-equal? from to count)
-  (let ((from-vector (address->vector from))
-	(from-address (address->vector-index from))
-	(to-vector (address->vector to))
-	(to-address (address->vector-index to)))
-    (let loop ((i 0))
-      (cond ((>= i count)
-	     #t)
-	    ((= (code-vector-ref to-vector (+ i to-address))
-		(code-vector-ref from-vector (+ i from-address)))
-	     (loop (+ i 1)))
-	    (else
-	     #f)))))
-
-; Turn the LENGTH bytes starting from ADDRESS into a string.
-
-(define (char-pointer->string address length)
-  (let ((vector (address->vector address))
-	(byte-address (address->vector-index address))
-	(string (make-string length)))
-    (do ((i 0 (+ i 1)))
-	((= i length))
-      (string-set! string
-		   i
-		   (ascii->char (code-vector-ref vector (+ byte-address i)))))
-    string))
-
-; Turn the bytes from ADDRESS to the next nul (byte equal to 0) into a
-; string.  This is a trivial operation in C.
-
-(define (char-pointer->nul-terminated-string address)
-  (let ((vector (address->vector address))
-	(byte-address (address->vector-index address)))
-    (char-pointer->string address (index-of-first-nul vector byte-address))))
-
-(define (index-of-first-nul vector address)
-  (let loop ((i address))
-    (cond ((= i (code-vector-length vector))
-	   (error "CHAR-POINTER->STRING called on pointer with no nul termination"))
-	  ((= 0 (code-vector-ref vector i))
-	   (- i address))
-	  (else
-	   (loop (+ i 1))))))
-	  
-; We really need these to work.
-
-(define address+ +)
-(define address- -)
-(define address-difference -)
-(define address->integer identity)
-(define integer->address identity)
-(define ...)
diff --git a/scheme/prescheme/package-defs.scm b/scheme/prescheme/package-defs.scm
deleted file mode 100644
index 29efb0f..0000000
--- a/scheme/prescheme/package-defs.scm
+++ /dev/null
@@ -1,38 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-(define-structures ((prescheme prescheme-interface)
-		    (ps-memory ps-memory-interface)
-		    (memory-debug (export reinitialize-memory))
-		    (ps-receive ps-receive-interface)
-		    (external-constants (export make-external-constant
-						external-constant?
-						external-constant-enum-name
-						external-constant-name
-						external-constant-c-string)))
-  (open scheme code-vectors bitwise ascii primitives signals enumerated
-	structure-refs
-	define-record-types
-	bigbit)   ; make sure that bignum bitwise operations are loaded
-  (access scheme)
-  (optimize auto-integrate)
-  (begin
-    ; What we will get in C on many machines
-    (define pre-scheme-integer-size 32))
-  (files ps-defenum prescheme memory))
-
-;(define-structure byte-vectors byte-vector-interface
-;  (open scheme code-vectors)
-;  (optimize auto-integrate)
-;  (files byte-vector))
-;
-;(define-interface byte-vector-interface
-;  (export make-byte-vector
-;          byte-vector?
-;          byte-vector-ref byte-vector-set!
-;          signed-byte-vector-ref signed-byte-vector-set!
-;          byte-vector-ref32 byte-vector-set32!
-;          signed-byte-vector-ref32 signed-byte-vector-set32!))
-;
-;(define-structure xmemory ps-memory-interface
-;  (open scheme byte-vectors signals enumerated bitwise)
-;  (files simple-memory))
\ No newline at end of file
diff --git a/scheme/prescheme/prescheme.scm b/scheme/prescheme/prescheme.scm
deleted file mode 100644
index 6a0d760..0000000
--- a/scheme/prescheme/prescheme.scm
+++ /dev/null
@@ -1,138 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Stuff in Pre-Scheme that is not in Scheme.
-
-(define shift-left arithmetic-shift)
-
-(define (arithmetic-shift-right i n)
-  (arithmetic-shift i (- 0 n)))
-
-; Hack for the robots
-(define small* *) ; could do a range check
-
-(define int-mask (- (arithmetic-shift 1 pre-scheme-integer-size) 1))
-
-(define (logical-shift-right i n)
-  (if (>= i 0)
-      (arithmetic-shift i (- 0 n))
-      (arithmetic-shift (bitwise-and i int-mask) (- 0 n))))
-
-(define (deallocate x) #f)
-(define (null-pointer? x) (not x))
-
-(define-external-enumeration errors
-  (no-errors
-   (parse-error    "EDOM")
-   (file-not-found "ENOENT")
-   (out-of-memory  "ENOMEM")
-   (invalid-port   "EBADF")
-   ))
-
-(define (error-string status)
-  "an error")
-  ; (symbol->string (enumerand->name status errors)))
-
-(define (open-input-file name)
-  (let ((port ((structure-ref scheme open-input-file) name)))
-    (values port
-	    (if port
-		(enum errors no-errors)
-		(enum errors file-not-found)))))
-
-(define (open-output-file name)
-  (let ((port ((structure-ref scheme open-output-file) name)))
-    (values port
-	    (if port
-		(enum errors no-errors)
-		(enum errors file-not-found)))))
-
-(define (close-input-port port)
-  ((structure-ref scheme close-input-port) port)
-  (enum errors no-errors))
-
-(define (close-output-port port)
-  ((structure-ref scheme close-output-port) port)
-  (enum errors no-errors))
-
-(define (read-char port)
-  (let ((ch (s-read-char port)))
-    (if (eof-object? ch)
-	(values (ascii->char 0) #t (enum errors no-errors))
-	(values ch #f (enum errors no-errors)))))
-
-(define (peek-char port)
-  (let ((ch (s-peek-char port)))
-    (if (eof-object? ch)
-	(values (ascii->char 0) #t (enum errors no-errors))
-	(values ch #f (enum errors no-errors)))))
-
-(define s-read-char (structure-ref scheme read-char))
-(define s-peek-char (structure-ref scheme peek-char))
-
-(define (read-integer port)
-  (eat-whitespace! port)
-  (let ((neg? (let ((x (s-peek-char port)))
-		(if (eof-object? x)
-		    #f
-		    (case x
-		      ((#\+) (s-read-char port) #f)
-		      ((#\-) (s-read-char port) #t)
-		      (else #f))))))
-    (let loop ((n 0) (any? #f))
-      (let ((x (s-peek-char port)))
-	(cond ((and (char? x)
-		    (char-numeric? x))
-	       (s-read-char port)
-	       (loop (+ (* n 10)
-			(- (char->integer x)
-			   (char->integer #\0)))
-		     #t))
-	      (any?
-	       (values (if neg? (- n) n) #f (enum errors no-errors)))
-	      ((eof-object? x)
-	       (values 0 #t (enum errors no-errors)))
-	      (else
-	       (values 0 #f (enum errors parse-error))))))))
-
-(define (eat-whitespace! port)
-  (cond ((char-whitespace? (s-peek-char port))
-	 (s-read-char port)
-	 (eat-whitespace! port))))
-
-(define (write-x string port)
-  (display string port)
-  (enum errors no-errors))
-
-(define write-char write-x)
-(define write-string write-x)
-(define write-integer write-x)
-
-(define (force-output port)
-  (enum errors no-errors))
-
-(define (newline port)
-  (write-char #\newline port)
-  (enum errors no-errors))
-
-(define-syntax goto
-  (lambda (exp rename compare)
-    (cdr exp)))
-
-; (external <string> <type> . <maybe scheme value>)
-
-(define-syntax external
-  (lambda (exp rename compare)
-    (if (null? (cdddr exp))
-	exp
-	(cadddr exp))))
-
-(define current-error-port current-output-port)
-
-; RECEIVE (from big-scheme)
-
-(define-syntax receive
-  (syntax-rules ()
-    ((receive ?vars ?producer . ?body)
-     (call-with-values (lambda () ?producer)
-		       (lambda ?vars . ?body)))))
diff --git a/scheme/prescheme/ps-defenum.scm b/scheme/prescheme/ps-defenum.scm
deleted file mode 100644
index 8097aa2..0000000
--- a/scheme/prescheme/ps-defenum.scm
+++ /dev/null
@@ -1,98 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; DEFINE-ENUMERATION macro hacked to use external (C enumeration) names
-; instead of integers.
-
-;(define-external-enumeration bing
-;  ((foo "BAR")
-;   baz))
-;  =>
-;(define-syntax bing ...)
-;(define bing/foo (make-external-constant 'bing 'foo "BAR"))
-;(define bing/baz (make-external-constant 'bing 'baz "BAZ"))
-;
-;(enum bing foo) => bing/foo
-
-(define-record-type external-constant :external-constant
-  (make-external-constant enum-name name c-string)
-  external-constant?
-  (enum-name external-constant-enum-name)
-  (name external-constant-name)
-  (c-string external-constant-c-string))
-
-(define-record-discloser :external-constant
-  (lambda (external-const)
-    (list 'enum
-	  (external-constant-enum-name external-const)
-	  (external-constant-name external-const))))
-
-(define-syntax define-external-enumeration
-  (lambda (form rename compare)
-    (let* ((name (cadr form))
-	   (symbol->upcase-string
-	    (lambda (s)
-	      (list->string (map (lambda (c)
-				   (if (char=? c #\-)
-				       #\_
-				       (char-upcase c)))
-				 (string->list (symbol->string s))))))
-	   (constant
-	    (lambda (sym string)
-	      `(,(rename 'make-external-constant) ',name ',sym ,string)))
-	   (conc (lambda things
-		   (string->symbol (apply string-append
-					  (map (lambda (thing)
-						 (if (symbol? thing)
-						     (symbol->string thing)
-						     thing))
-					       things)))))
-	   (var-name
-	    (lambda (sym)
-	      (conc name "/" sym)))
-	   (components
-	    (list->vector
-	     (map (lambda (stuff)
-		    (if (pair? stuff)
-			(cons (car stuff)
-			      (var-name (car stuff)))
-			(cons stuff
-			      (var-name stuff))))
-		  (caddr form))))
-	   (%define (rename 'define))
-	   (%define-syntax (rename 'define-syntax))
-	   (%begin (rename 'begin))
-	   (%quote (rename 'quote))
-	   (%make-external-constant (rename 'make-external-constant))
-	   (e-name (conc name '- 'enumeration))
-	   (count (vector-length components)))
-      `(,%begin
-	(,%define-syntax ,name
-	    (let ((components ',components))
-	      (lambda (e r c)
-		(let ((key (cadr e)))
-		  (cond ((c key 'enum)
-			 (let ((which (caddr e)))
-			   (let loop ((i 0)) ;vector-posq
-			     (if (< i ,count)
-				 (if (c which (car (vector-ref components i)))
-				     (r (cdr (vector-ref components i)))
-				     (loop (+ i 1)))
-				 ;; (syntax-error "unknown enumerand name"
-				 ;;               `(,(cadr e) ,(car e) ,(caddr e)))
-				 e))))
-			(else e))))))
-	(,%define ,(conc name '- 'count) ,count)
-        . ,(map (lambda (stuff)
-		  (if (pair? stuff)
-		      `(,%define ,(var-name (car stuff))
-			   (,%make-external-constant ',name
-						     ',(car stuff)
-						     ,(cadr stuff)))
-		      `(,%define ,(var-name stuff)
-			   (,%make-external-constant ',name
-						     ',stuff
-						     ,(symbol->upcase-string stuff)))))
-		(caddr form)))))
-    (begin define define-syntax quote external make-external-constant))
-
-
diff --git a/scheme/rts/base.scm b/scheme/rts/base.scm
deleted file mode 100644
index e3cfe73..0000000
--- a/scheme/rts/base.scm
+++ /dev/null
@@ -1,424 +0,0 @@
-; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; This is file base.scm.
-
-;;;; Fundamental definitions
-
-; Order of appearance is approximately that of the Revised^4 Report.
-
-; Booleans
-
-(define (not x) (if x #f #t))
-(define (boolean? x) (or (eq? x #t) (eq? x #f)))
-
-; Equality
-
-(define (eqv? x y)
-  (or (eq? x y)
-      (and (number? x)
-           (number? y)
-           (eq? (exact? x) (exact? y))
-           (= x y))))
-
-(define (equal? obj1 obj2)
-  (cond ((eqv? obj1 obj2) #t)
-        ((pair? obj1)
-         (and (pair? obj2)
-              (equal? (car obj1) (car obj2))
-              (equal? (cdr obj1) (cdr obj2))))
-        ((string? obj1)
-         (and (string? obj2)
-              (string=? obj1 obj2)))
-        ((vector? obj1)
-         (and (vector? obj2)
-              (let ((z (vector-length obj1)))
-                (and (= z (vector-length obj2))
-                     (let loop ((i 0))
-                       (cond ((= i z) #t)
-                             ((equal? (vector-ref obj1 i) (vector-ref obj2 i))
-                              (loop (+ i 1)))
-                             (else #f)))))))
-        (else #f)))
-
-; Messy because of inexact contagion.
-
-(define (max first . rest)
-  (max-or-min first rest #t))
-
-(define (min first . rest)
-  (max-or-min first rest #f))
-
-(define (max-or-min first rest max?)
-  (let loop ((result first) (rest rest) (lose? (inexact? first)))
-    (if (null? rest)
-	(if (and lose? (exact? result))
-	    (exact->inexact result)
-	    result)
-	(let ((next (car rest)))
-	  (loop (if (if max?
-			(< result next)
-			(> result next))
-		    next
-		    result)
-		(cdr rest)
-		(or lose? (inexact? next)))))))
-
-(define (abs n) (if (< n 0) (- 0 n) n))
-
-(define (zero? x) (= x 0))
-(define (positive? x) (< 0 x))
-(define (negative? x) (< x 0))
-
-(define (even? n) (= 0 (remainder n 2)))
-(define (odd? n) (not (even? n)))
-
-; Lists
-
-(define (caar   x) (car (car x)))
-(define (cadr   x) (car (cdr x)))
-(define (cdar   x) (cdr (car x)))
-(define (cddr   x) (cdr (cdr x)))
-
-(define (caaar  x) (caar (car x)))
-(define (caadr  x) (caar (cdr x)))
-(define (cadar  x) (cadr (car x)))
-(define (caddr  x) (cadr (cdr x)))
-(define (cdaar  x) (cdar (car x)))
-(define (cdadr  x) (cdar (cdr x)))
-(define (cddar  x) (cddr (car x)))
-(define (cdddr  x) (cddr (cdr x)))
-
-(define (caaaar x) (caaar (car x)))
-(define (caaadr x) (caaar (cdr x)))
-(define (caadar x) (caadr (car x)))
-(define (caaddr x) (caadr (cdr x)))
-(define (cadaar x) (cadar (car x)))
-(define (cadadr x) (cadar (cdr x)))
-(define (caddar x) (caddr (car x)))
-(define (cadddr x) (caddr (cdr x)))
-(define (cdaaar x) (cdaar (car x)))
-(define (cdaadr x) (cdaar (cdr x)))
-(define (cdadar x) (cdadr (car x)))
-(define (cdaddr x) (cdadr (cdr x)))
-(define (cddaar x) (cddar (car x)))
-(define (cddadr x) (cddar (cdr x)))
-(define (cdddar x) (cdddr (car x)))
-(define (cddddr x) (cdddr (cdr x)))
-
-(define (null? x) (eq? x '()))
-
-(define (list . l) l)
-
-;(define (length l)
-;  (reduce (lambda (ignore n) (+ n 1)) 0 l))
-
-; Bummed version.  Pretend that you didn't see this.
-
-(define (length l)
-  (real-length l 0))
-
-(define (real-length l r)
-  (if (null? l)
-      r
-      (real-length (cdr l) (+ r 1))))
-
-(define (append . lists)
-  (if (null? lists)
-      '()
-      (let recur ((lists lists))
-	(if (null? (cdr lists))
-	    (car lists)
-	    (reduce cons (recur (cdr lists)) (car lists))))))
-
-(define (reverse list)
-  (append-reverse list '()))
-
-(define (append-reverse list seed)
-  (if (null? list)
-      seed
-      (append-reverse (cdr list) (cons (car list) seed))))
-
-(define (list-tail l i)
-  (cond ((= i 0) l)
-	(else (list-tail (cdr l) (- i 1)))))
-
-(define (list-ref l k)
-  (car (list-tail l k)))
-
-(define (mem pred)
-  (lambda (obj l)
-    (let loop ((l l))
-      (cond ((null? l) #f)
-	    ((pred obj (car l)) l)
-	    (else (loop (cdr l)))))))
-
-(define memq   (mem eq?))
-(define memv   (mem eqv?))
-(define member (mem equal?))
-
-(define (ass pred)
-  (lambda (obj l)
-    (let loop ((l l))
-      (cond ((null? l) #f)
-            ((pred obj (caar l)) (car l))
-            (else (loop (cdr l)))))))
-
-;(define assq  (ass eq?))  ; done by VM for speed
-(define assv  (ass eqv?))
-(define assoc (ass equal?))
-
-(define (list? l)			;New in R4RS
-  (let recur ((l l) (lag l))		;Cycle detection
-    (or (null? l)
-	(and (pair? l)
-	     (or (null? (cdr l))
-		 (and (pair? (cdr l))
-		      (not (eq? (cdr l) lag))
-		      (recur (cddr l) (cdr lag))))))))
-
-; Characters
-
-(define (char>? x y) (char<? y x))
-(define (char>=? x y) (not (char<? x y)))
-(define (char<=? x y) (not (char>? x y)))
-
-(define (char-whitespace? c)
-  (if (memq (char->ascii c) ascii-whitespaces) #t #f))
-
-(define (char-lower-case? c)
-  (and (char>=? c #\a)
-       (char<=? c #\z)))
-
-(define (char-upper-case? c)
-  (and (char>=? c #\A)
-       (char<=? c #\Z)))
-
-(define (char-numeric? c)
-  (and (char>=? c #\0)
-       (char<=? c #\9)))
-
-(define (char-alphabetic? c)
-  (or (char-upper-case? c)
-      (char-lower-case? c)))
-
-(define char-case-delta 
-  (- (char->ascii #\a) (char->ascii #\A)))
-
-(define (make-character-map f)
-  (let ((s (make-string ascii-limit #\0)))
-    (do ((i 0 (+ i 1)))
-	((>= i ascii-limit))
-      (string-set! s i (f (ascii->char i))))
-    s))
-
-(define upcase-map
-  (make-character-map
-   (lambda (c)
-     (if (char-lower-case? c)
-	 (ascii->char (- (char->ascii c) char-case-delta))
-	 c))))
-
-(define (char-upcase c)
-  (string-ref upcase-map (char->ascii c)))
-
-(define downcase-map
-  (make-character-map
-   (lambda (c)
-     (if (char-upper-case? c)
-	 (ascii->char (+ (char->ascii c) char-case-delta))
-	 c))))
-
-(define (char-downcase c)
-  (string-ref downcase-map (char->ascii c)))
-
-(define (char-ci-compare pred)
-  (lambda (c1 c2) (pred (char-upcase c1) (char-upcase c2))))
-(define char-ci=? (char-ci-compare char=?))
-(define char-ci<? (char-ci-compare char<?))
-(define char-ci<=? (char-ci-compare char<=?))
-(define char-ci>? (char-ci-compare char>?))
-(define char-ci>=? (char-ci-compare char>=?))
-
-
-; Strings
-
-(define (string . rest)
-  (list->string rest))
-
-(define (substring s start end)
-  (let ((new-string (make-string (- end start) #\space)))
-    (do ((i start (+ i 1))
-         (j 0 (+ j 1)))
-        ((= i end) new-string)
-      (string-set! new-string j (string-ref s i)))))
-
-(define (string-append  . strings)
-  (let ((len (reduce (lambda (s n) (+ (string-length s) n)) 0 strings)))
-    (let ((new-string (make-string len #\space)))
-      (let loop ((s strings)
-		 (i 0))
-	(if (null? s)
-	    new-string
-	    (let* ((string (car s))
-		   (l (string-length string)))
-	      (do ((j 0 (+ j 1))
-		   (i i (+ i 1)))
-		  ((= j l) (loop (cdr s) i))
-		(string-set! new-string i (string-ref string j)))))))))
-
-(define (string->list v)
-  (let ((z (string-length v)))
-    (do ((i (- z 1) (- i 1))
-         (l '() (cons (string-ref v i) l)))
-        ((< i 0) l))))
-
-(define (list->string l)
-  (let ((v (make-string (length l) #\space)))
-    (do ((i 0 (+ i 1))
-         (l l (cdr l)))
-        ((null? l) v)
-      (string-set! v i (car l)))))
-
-; comes from low-level package ...
-;(define (string-copy s)
-;  (let ((z (string-length s)))
-;    (let ((copy (make-string z #\space)))
-;      (let loop ((i 0))
-;        (cond ((= i z) copy)
-;              (else
-;               (string-set! copy i (string-ref s i))
-;               (loop (+ i 1))))))))
-
-(define (string-fill! v x)
-  (let ((z (string-length v)))
-    (do ((i 0 (+ i 1)))
-        ((= i z) (unspecific))
-      (string-set! v i x))))
-
-(define (make-string=? char=?)
-  (lambda (s1 s2)
-    (let ((z (string-length s1)))
-      (and (= z (string-length s2))
-	   (let loop ((i 0))
-	     (cond ((= i z) #t)
-		   ((char=? (string-ref s1 i) (string-ref s2 i))
-		    (loop (+ i 1)))
-		   (else #f)))))))
-
-;(define string=?    (make-string=? char=?))  -- VM implements this
-(define string-ci=? (make-string=? char-ci=?))
-
-(define (make-string<? char<? char=?)
-  (lambda (s1 s2)
-    (let ((z1 (string-length s1))
-	  (z2 (string-length s2)))
-      (let ((z (min z1 z2)))
-	(let loop ((i 0))
-	  (if (= i z)
-	      (< z1 z2)
-	      (let ((c1 (string-ref s1 i))
-		    (c2 (string-ref s2 i)))
-		(or (char<? c1 c2)
-		    (and (char=? c1 c2)
-			 (loop (+ i 1)))))))))))
-
-(define string<?    (make-string<? char<? char=?))
-(define string-ci<? (make-string<? char-ci<? char-ci=?))
-
-(define (string>? s1 s2) (string<? s2 s1))
-(define (string<=? s1 s2) (not (string>? s1 s2)))
-(define (string>=? s1 s2) (not (string<? s1 s2)))
-
-(define (string-ci>? s1 s2) (string-ci<? s2 s1))
-(define (string-ci<=? s1 s2) (not (string-ci>? s1 s2)))
-(define (string-ci>=? s1 s2) (not (string-ci<? s1 s2)))
-
-; Vectors
-
-;(define (vector . l)   ; now an opcode for efficiency
-;  (list->vector l))
-
-(define (vector->list v)
-  (do ((i (- (vector-length v) 1) (- i 1))
-       (l '() (cons (vector-ref v i) l)))
-      ((< i 0) l)))
-
-(define (list->vector l)
-  (let ((v (make-vector (length l) #f)))
-    (do ((i 0 (+ i 1))
-         (l l (cdr l)))
-        ((null? l) v)
-      (vector-set! v i (car l)))))
-
-(define (vector-fill! v x)
-  (let ((z (vector-length v)))
-    (do ((i 0 (+ i 1)))
-        ((= i z) (unspecific))
-      (vector-set! v i x))))
-
-; Control features
-
-(define (map proc first . rest)
-  (if (null? rest)
-      (map1 proc first)
-      (map2+ proc first rest)))
-
-(define (map1 proc l)
-  ;; (reduce (lambda (x l) (cons (proc x) l)) '() l)
-  (if (null? l)
-      '()
-      (cons (proc (car l)) (map1 proc (cdr l)))))
-
-(define (map2+ proc first rest)
-  (if (or (null? first)
-	  (any null? rest))
-      '()
-      (cons (apply proc (cons (car first) (map1 car rest)))
-	    (map2+ proc (cdr first) (map1 cdr rest)))))
-
-(define (for-each proc first . rest)
-  (if (null? rest)
-      (for-each1 proc first)
-      (for-each2+ proc first rest)))
-
-(define (for-each1 proc first)
-  (let loop ((first first))
-    (if (null? first)
-	(unspecific)
-	(begin (proc (car first))
-	       (loop (cdr first))))))
-
-(define (for-each2+ proc first rest)
-  (let loop ((first first) (rest rest))
-    (if (or (null? first)
-	    (any null? rest))
-	(unspecific)
-	(begin (apply proc (cons (car first) (map car rest)))
-	       (loop (cdr first) (map cdr rest))))))
-
-
-; Promises, promises.
-
-(define-syntax delay
-  (syntax-rules ()
-    ((delay ?exp) (make-promise (lambda () ?exp)))))
-
-; A slightly modified copy of the code from R4RS; the modification ensures
-; that the thunk is GC'ed after the promise is evaluted.
-; JAR writes: "It is not for us to judge the wisdom of the new definition."
-
-(define (make-promise thunk-then-result)
-  (let ((already-run? #f))
-    (lambda ()
-      (if already-run?                         ; can't be interrupted from now
-	  thunk-then-result
-	  (let ((result (thunk-then-result)))  ; until after this call
-	    (cond ((not already-run?)
-		   (set! already-run? #t)
-		   (set! thunk-then-result result)))
-	    thunk-then-result)))))
-
-(define (force promise)
-  (promise))
diff --git a/scheme/rts/bignum.scm b/scheme/rts/bignum.scm
deleted file mode 100644
index 24aa98f..0000000
--- a/scheme/rts/bignum.scm
+++ /dev/null
@@ -1,343 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; This is file bignum.scm.
-
-; Integer arithmetic
-
-(define-extended-number-type :bignum (:exact-integer)
-  (make-bignum sign magnitude)
-  bignum?
-  (sign bignum-sign)
-  (magnitude bignum-magnitude))
-
-(define (integer->bignum m)
-  (if (bignum? m)
-      m
-      (cond ((>= m 0)
-	     (make-bignum 1 (integer->magnitude m)))
-	    ((= m least-non-bignum)
-	     (make-bignum -1 least-non-bignum-magnitude))
-	    (else
-	     (make-bignum -1 (integer->magnitude (- 0 m)))))))
-
-;(define (bignum->integer n)             ;For debugging
-;  (* (bignum-sign n)
-;     (reduce (lambda (d n) (+ d (* n radix)))
-;             0
-;             (bignum-magnitude n))))
-
-(define (make-integer sign mag)
-  (if (> sign 0)
-      (if (smaller-magnitude? greatest-non-bignum-magnitude mag)
-	  (make-bignum sign mag)
-	  (magnitude->integer mag))
-      (if (smaller-magnitude? least-non-bignum-magnitude mag)
-	  (make-bignum sign mag)
-	  (if (same-magnitude? mag least-non-bignum-magnitude)
-	      least-non-bignum
-	      (- 0 (magnitude->integer mag))))))
-
-; Arithmetic
-
-(define (integer+ m n)
-  (let ((m (integer->bignum m))
-	(n (integer->bignum n)))
-    (let ((m-sign (bignum-sign m))
-	  (m-mag (bignum-magnitude m))
-	  (n-sign (bignum-sign n))
-	  (n-mag (bignum-magnitude n)))
-    (if (= m-sign n-sign)
-	(make-integer m-sign (add-magnitudes m-mag n-mag))
-	(if (smaller-magnitude? m-mag n-mag)
-	    (make-integer (- 0 m-sign) (subtract-magnitudes n-mag m-mag))
-	    (make-integer m-sign (subtract-magnitudes m-mag n-mag)))))))
-
-(define (integer- m n)
-  (integer+ m (integer-negate n)))
-
-(define (integer-negate m)
-  (cond ((bignum? m)
-	 (make-integer (- 0 (bignum-sign m))
-		       (bignum-magnitude m)))
-	((= m least-non-bignum)
-	 (make-bignum 1 least-non-bignum-magnitude))
-	(else (- 0 m))))
-
-(define (integer* m n)
-  (let ((m (integer->bignum m))
-	(n (integer->bignum n)))
-    (make-integer (* (bignum-sign m) (bignum-sign n))
-		  (multiply-magnitudes
-		   (bignum-magnitude m)
-		   (bignum-magnitude n)))))
-
-(define (integer-divide m n cont)
-  (let ((m (integer->bignum m))
-	(n (integer->bignum n)))
-    (divide-magnitudes
-       (bignum-magnitude m)
-       (bignum-magnitude n)
-       (lambda (q r)
-	 (cont (make-integer (* (bignum-sign m) (bignum-sign n)) q)
-	       (make-integer (bignum-sign m) r))))))
-
-(define (integer-quotient m n)
-  (integer-divide m n (lambda (q r) q)))
-
-(define (integer-remainder m n)
-  (integer-divide m n (lambda (q r) r)))
-
-(define integer=
-  (lambda (m n)
-    (let ((m (integer->bignum m))
-	  (n (integer->bignum n)))
-      (and (= (bignum-sign m) (bignum-sign n))
-	   (same-magnitude? (bignum-magnitude m)
-			    (bignum-magnitude n))))))
-
-(define integer<
-  (lambda (m n)
-    (let ((m (integer->bignum m))
-	  (n (integer->bignum n)))
-      (let ((m-sign (bignum-sign m))
-	    (n-sign (bignum-sign n)))
-	(or (< m-sign n-sign)
-	    (and (= m-sign n-sign)
-		 (if (< m-sign 0)
-		     (smaller-magnitude? (bignum-magnitude n)
-					 (bignum-magnitude m))
-		     (smaller-magnitude? (bignum-magnitude m)
-					 (bignum-magnitude n)))))))))
-
-
-; Magnitude (unsigned integer) arithmetic
-
-(define log-radix 14)			;Cutting it close here...
-(define radix (expt 2 log-radix))
-
-(define greatest-non-bignum (+ (expt 2 28) (- (expt 2 28) 1)))
-(define least-non-bignum (* (expt 2 28) -2))
-
-(define zero-magnitude '())
-(define zero-magnitude? null?)
-
-(define (low-digit m)
-  (if (zero-magnitude? m)
-      0
-      (car m)))
-
-(define (high-digits m)
-  (if (zero-magnitude? m)
-      m
-      (cdr m)))
-
-(define (adjoin-digit d m)
-  (if (and (= d 0) (zero-magnitude? m))
-      m
-      (cons d m)))
-
-(define (integer->magnitude n)
-  (if (= n 0)
-      zero-magnitude
-      (let ((digit (remainder n radix)))
-	(adjoin-digit digit
-		      (integer->magnitude (quotient n radix))))))
-
-(define (magnitude->integer m)
-  (if (zero-magnitude? m)
-      0
-      (+ (low-digit m)
-	 (* radix (magnitude->integer (high-digits m))))))
-
-(define greatest-non-bignum-magnitude
-  (integer->magnitude greatest-non-bignum))
-
-(define least-non-bignum-magnitude
-  (adjoin-digit (- 0 (remainder least-non-bignum radix))
-		(integer->magnitude
-		 (- 0 (quotient least-non-bignum radix)))))
-
-; Combine two numbers digitwise using op.
-
-(define (combine-magnitudes m n op)
-  (let recur ((m m) (n n) (carry 0))
-    (if (and (zero-magnitude? m) (zero-magnitude? n))
-	(integer->magnitude carry)
-	(let ((result (+ carry (op (low-digit m) (low-digit n)))))
-	  (let ((q (quotient result radix))
-		(r (remainder result radix)))
-	    (if (< r 0)
-		(adjoin-digit (+ r radix)
-			      (recur (high-digits m)
-				     (high-digits n)
-				     (- q 1)))
-		(adjoin-digit r
-			      (recur (high-digits m)
-				     (high-digits n)
-				     q))))))))
-
-(define (add-magnitudes m n)
-  (combine-magnitudes m n +))
-
-(define (subtract-magnitudes m n)
-  (combine-magnitudes m n -))
-
-; Compare
-
-(define same-magnitude? equal?)
-
-(define (smaller-magnitude? m n)
-  (let ((m-len (length m))
-	(n-len (length n)))
-    (cond ((< m-len n-len)
-	   #t)
-	  ((< n-len m-len)
-	   #f)
-	  (else
-	   (let loop ((m m) (n n) (a #f))
-	     (cond ((zero-magnitude? m)
-		    (or (not (zero-magnitude? n)) a))
-		   ((zero-magnitude? n) #f)
-		   (else
-		    (loop (high-digits m)
-			  (high-digits n)
-			  (or (< (low-digit m) (low-digit n))
-			      (and (= (low-digit m) (low-digit n)) a))))))))))
-
-; Multiply
-
-(define (multiply-magnitudes m n)
-  (let recur ((m m) (a zero-magnitude))
-    (if (zero-magnitude? m)
-	a
-	(let ((a (combine-magnitudes a n (lambda (d e)
-					   (+ d (* e (low-digit m)))))))
-	  (adjoin-digit (low-digit a)
-			(recur (high-digits m) (high-digits a)))))))
-
-; Divide m/n: find q and r such that m = q*n + r, where 0 <= r < n.
-; Oh no... time to get out Knuth...
-; The main thing we don't do that Knuth does is to normalize the
-; divisor (n) by shifting it left.
-
-(define (divide-magnitudes m n cont)
-  (if (zero-magnitude? (high-digits n))
-      (divide-by-digit m (low-digit n)
-		       (lambda (q r)
-			 (cont q (adjoin-digit r zero-magnitude))))
-      (let recur ((m m) (cont cont))
-	(if (smaller-magnitude? m n)
-	    (cont zero-magnitude m)
-	    (recur
-	     (high-digits m)
-	     (lambda (q r)
-	       ;; 0 <= r < n  and  d < b
-	       ;; so  b*r + d < b*n.
-	       (divide-step (adjoin-digit (low-digit m) r)
-			    n
-			    (lambda (q1 r)
-			      (cont (adjoin-digit q1 q) r)))))))))
-	
-; Divide m by n, where  n <= m < b*n, i.e. 1 <= quotient < b.
-; E.g.  if  n = 100  then  100 <= m <= 999
-;       if  n = 999  then  999 <= m <= 9989
-
-(define (divide-step m n cont)
-  (do ((m-high m (high-digits m-high))
-       (n-high n (high-digits n-high)))
-      ((zero-magnitude? (high-digits (high-digits n-high)))
-       ;; Occasionally q^ is one larger than the actual first digit.
-       ;; This loop will never iterate more than once.
-       (let loop ((q^ (min (guess-quotient-digit m-high n-high)
-			   (- radix 1))))
-	 (let ((r (combine-magnitudes m n (lambda (d e)
-					    (- d (* e q^))))))
-	   (if (improper-magnitude? r)
-	       ;; (begin (write `(addback ,m ,n ,q^ ,r)) (newline) ...)
-	       (loop (- q^ 1))
-	       (cont q^ r)))))))
-
-; Compute q such that [m1 m2 m3] = q*[n1 n2] + r with 0 <= r < [n1 n2]
-; Can assume b <= [0 n1 n2] <= [m1 m2 m3] <= [n1 n2 b-1]
-; Some examples:
-;  m / n :  100[1] / 10[02], 099 / 10, 099[1] / 99[0], 999[8] / 99[99]
-; Various hacks are possible to improve performance.  In particular, the
-; second division can be eliminated if the divisor is normalized.
-; See Knuth.
-;  [m1 m2] = q0*[n1] + r0
-;  [m1 m2 m3] = q0*[n1 n2] + r^
-;  r^ = b*r0 + m3 - q0*n2
-
-(define (guess-quotient-digit m n)
-  (let ((n1 (low-digit (high-digits n)))
-	(n2 (low-digit n))
-	(m1 (low-digit (high-digits (high-digits m))))
-	(m2 (low-digit (high-digits m)))
-	(m3 (low-digit m)))
-    (let ((m12 (+ (* m1 radix) m2)))
-      (let ((q0 (quotient m12 n1))
-	    (r0 (remainder m12 n1)))
-	(let ((r^ (- (+ (* radix r0) m3) (* q0 n2)))
-	      (n12 (+ (* n1 radix) n2)))
-	  (let ((q1 (quotient r^ n12))
-		(r1 (remainder r^ n12)))
-	    (if (> q1 0)
-		(begin (display "This should never happen: q1 = ")
-		       (write q1) (newline)))
-	    (let ((q (+ q0 q1)))
-	      (if (< r1 0) (- q 1) q))))))))
-
-(define (improper-magnitude? m)
-  (and (not (zero-magnitude? m))
-       (or (< (low-digit m) 0)
-	   (improper-magnitude? (high-digits m)))))
-
-; Special case of division algorithm for single-digit divisor.
-
-(define (divide-by-digit m d cont)
-  (if (= d 0)
-      (error "integer division by zero" m d)
-      (let recur ((m m) (cont cont))
-	(if (and (zero-magnitude? (high-digits m))
-		 (< (low-digit m) d))
-	    (cont zero-magnitude (low-digit m))
-	    (recur (high-digits m)
-		   (lambda (q r)
-		     (let ((m1 (+ (low-digit m) (* radix r))))
-		       (cont (adjoin-digit (quotient m1 d) q)
-			     (remainder m1 d)))))))))
-
-;(define (divide-test seed)
-;  (let ((random (make-random seed)))
-;    (let loop ()
-;      (let* ((z1 (integer+ (random) (integer* (random) 10000000)))
-;             (z2 (integer+ (random) (integer* (random) 10000000)))
-;             (n (max z1 z2))
-;             (r (min z1 z2))
-;             (q (random))
-;             (m (integer+ (integer* n q) r)))
-;        (if (not (= n r))
-;            (integer-divide m n
-;                            (lambda (q1 r1)
-;                              (if (and (= q q1) (= r r1))
-;                                  (begin (display ".")
-;                                         (force-output (current-output-port)))
-;                                  (error "division error" m n q q1 r r1)))))
-;        (loop)))))
-
-
-; Extend the generic arithmetic operators.
-
-(define-method &integer? ((n :bignum)) #t)
-(define-method &exact? ((n :bignum)) #t)
-
-(define-method &+ ((n1 :exact-integer) (n2 :exact-integer)) (integer+ n1 n2))
-(define-method &- ((n1 :exact-integer) (n2 :exact-integer)) (integer- n1 n2))
-(define-method &* ((n1 :exact-integer) (n2 :exact-integer)) (integer* n1 n2))
-(define-method &= ((n1 :exact-integer) (n2 :exact-integer)) (integer= n1 n2))
-(define-method &< ((n1 :exact-integer) (n2 :exact-integer)) (integer< n1 n2))
-
-(define-method &quotient ((n1 :exact-integer) (n2 :exact-integer))
-  (integer-quotient n1 n2))
-(define-method &remainder ((n1 :exact-integer) (n2 :exact-integer))
-  (integer-remainder n1 n2))
diff --git a/scheme/rts/condition.scm b/scheme/rts/condition.scm
deleted file mode 100644
index 30f5fc8..0000000
--- a/scheme/rts/condition.scm
+++ /dev/null
@@ -1,77 +0,0 @@
-; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; This is file condition.scm.
-
-;;;; Condition hierarchy
-
-; General design copied from gnu emacs.
-
-(define *condition-types* '())
-
-(define (condition-supertypes type)
-  (assq type *condition-types*))
-
-(define (define-condition-type type supertypes)
-  (set! *condition-types*
-	(cons (cons type (apply append
-				(map (lambda (sup)
-				       (or (condition-supertypes sup)
-					   (error "unrecognized condition type"
-						  sup)))
-				     supertypes)))
-	      *condition-types*)))
-
-(define (condition-predicate name)
-  (lambda (c)
-    (and (pair? c)
-	 (let ((probe (condition-supertypes (car c))))
-	   (if probe
-	       (if (memq name probe) #t #f)
-	       #f)))))
-
-(define (condition? x)
-  (and (pair? x)
-       (list? x)
-       (condition-supertypes (car x))))
-(define condition-type car)
-(define condition-stuff cdr)
-
-
-; Errors
-
-(define-condition-type 'error '())
-(define error? (condition-predicate 'error))
-
-(define-condition-type 'call-error '(error))
-(define call-error? (condition-predicate 'call-error))
-
-(define-condition-type 'read-error '(error))
-(define read-error? (condition-predicate 'read-error))
-
-; Exceptions
-
-(define-condition-type 'exception '(error))
-(define exception? (condition-predicate 'exception))
-(define exception-opcode cadr)
-(define exception-reason caddr)
-(define exception-arguments cdddr)
-
-(define (make-exception opcode reason args)
-  (make-condition 'exception (cons opcode (cons reason args))))
-
-
-; Warnings
-
-(define-condition-type 'warning '())
-(define warning? (condition-predicate 'warning))
-
-(define-condition-type 'syntax-error '(warning))
-(define syntax-error? (condition-predicate 'syntax-error))
-
-
-; Interrupts
-
-(define-condition-type 'interrupt '())
-(define interrupt? (condition-predicate 'interrupt))
diff --git a/scheme/rts/continuation.scm b/scheme/rts/continuation.scm
deleted file mode 100644
index 0ab5dc4..0000000
--- a/scheme/rts/continuation.scm
+++ /dev/null
@@ -1,83 +0,0 @@
-; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Continuations
-
-(define (continuation-cont                c) (continuation-ref c 0))
-(define (real-continuation-pc             c) (continuation-ref c 1))
-(define (real-continuation-template       c) (continuation-ref c 2))
-(define (continuation-env                 c) (continuation-ref c 3))
-(define (exception-continuation-pc        c) (continuation-ref c 4))
-(define (exception-continuation-template  c) (continuation-ref c 5))
-(define (exception-continuation-exception c) (continuation-ref c 6))
-
-; Exception continuations contain the state of the VM when an exception occured.
-
-(define (exception-continuation? thing)
-  (and (continuation? thing)
-       (= 0 (real-continuation-pc thing))
-       (= (enum op return-from-exception)
-	  (code-vector-ref (template-code (real-continuation-template thing))
-			   0))))
-
-(define (continuation-pc c)
-  (if (exception-continuation? c)
-      (exception-continuation-pc c)
-      (real-continuation-pc c)))
-
-(define (continuation-template c)
-  (if (exception-continuation? c)
-      (exception-continuation-template c)
-      (real-continuation-template c)))
-
-; Accessing the saved operand stack.
-
-(define normal-continuation-overhead 4)
-
-(define exception-continuation-overhead
-  (+ normal-continuation-overhead 4))
-
-(define (continuation-arg c i)
-  (continuation-ref c (+ (if (exception-continuation? c)
-			     exception-continuation-overhead
-			     normal-continuation-overhead)
-			 i)))
-
-(define (continuation-arg-count c)
-  (- (continuation-length c)
-     (if (exception-continuation? c)
-	 exception-continuation-overhead
-	 normal-continuation-overhead)))
-
-(define-simple-type :continuation (:value) continuation?)
-
-(define-method &disclose ((obj :continuation))
-  (if (exception-continuation? obj)
-      (list 'exception-continuation
-	    `(pc ,(exception-continuation-pc obj))
-	    (template-info (exception-continuation-template obj)))
-      (list 'continuation
-	    `(pc ,(continuation-pc obj))
-	    (template-info (continuation-template obj)))))
-
-; If (continuation-cont A) = B, then ignore B if the following are all true:
-;   1. (continuation-template B) = (continuation-template A)
-;   2. (continuation-pc B) > (continuation-pc A)
-;   3. (continuation-env B) = (continuation-env A)
-;                             or some parent of (continuation-env A)
-;
-; I don't think this is foolproof, but I have so far been unable to
-; contrive a situation in which it fails.  I think a double recursion of a 
-; procedure of no arguments is required, at the very least.
-
-(define (continuation-parent a)
-  (let ((b (continuation-cont a)))
-    (if (and (continuation? b)
-	     (eq? (continuation-template a) (continuation-template b))
-	     (< (continuation-pc a) (continuation-pc b))
-	     (let loop ((env (continuation-env a)))
-	       (or (eq? env (continuation-env b))
-		   (and (vector? env)
-			(loop (vector-ref env 0))))))
-	(continuation-parent b)
-	b)))
diff --git a/scheme/rts/current-port.scm b/scheme/rts/current-port.scm
deleted file mode 100644
index 3ecd9e8..0000000
--- a/scheme/rts/current-port.scm
+++ /dev/null
@@ -1,65 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Current input, output, error, and noise ports.
-
-; These two ports are needed by the VM for the READ-CHAR and WRITE-CHAR
-; opcodes.
-(define $current-input-port  (enum current-port-marker current-input-port))
-(define $current-output-port (enum current-port-marker current-output-port))
-
-(define $current-error-port  (make-fluid #f))
-(define $current-noise-port  (make-fluid #f))  ; defaults to the error port
-
-(define (current-input-port)
-  (fluid $current-input-port))
-
-(define (current-output-port)
-  (fluid $current-output-port))
-
-(define (current-error-port)
-  (fluid $current-error-port))
-
-(define (current-noise-port)
-  (fluid $current-noise-port))
-
-(define (initialize-i/o input output error thunk)
-  (with-current-ports input output error thunk))
-
-(define (with-current-ports in out error thunk)
-  (let-fluids $current-input-port in
-	      $current-output-port out
-	      $current-error-port error
-	      $current-noise-port error
-    thunk))
-
-(define (call-with-current-input-port port thunk)
-  (let-fluid $current-input-port port thunk))
-
-(define (call-with-current-output-port port thunk)
-  (let-fluid $current-output-port port thunk))
-
-(define (call-with-current-noise-port port thunk)
-  (let-fluid $current-noise-port port thunk))
-
-(define (silently thunk)
-  (call-with-current-noise-port (make-null-output-port) thunk))
-
-;----------------
-; Procedures with default port arguments.
-
-(define (newline . port-option)
-  (write-char #\newline (output-port-option port-option)))
-
-(define (char-ready? . port-option)
-  (real-char-ready? (input-port-option port-option)))
-
-(define (output-port-option port-option)
-  (cond ((null? port-option) (current-output-port))
-	((null? (cdr port-option)) (car port-option))
-	(else (error "write-mumble: too many arguments" port-option))))
-
-(define (input-port-option port-option)
-  (cond ((null? port-option) (current-input-port))
-	((null? (cdr port-option)) (car port-option))
-	(else (error "read-mumble: too many arguments" port-option))))
-
diff --git a/scheme/rts/defenum.scm b/scheme/rts/defenum.scm
deleted file mode 100644
index 7207199..0000000
--- a/scheme/rts/defenum.scm
+++ /dev/null
@@ -1,72 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; define-enumeration macro
-
-(define-syntax define-enumeration
-  (lambda (form rename compare)
-    (let ((name (cadr form))
-          (components (list->vector (caddr form)))
-          (conc (lambda things
-                  (string->symbol (apply string-append
-                                         (map (lambda (thing)
-                                                (if (symbol? thing)
-                                                    (symbol->string thing)
-                                                    thing))
-                                              things)))))
-          (%define (rename 'define))
-          (%define-syntax (rename 'define-syntax))
-          (%begin (rename 'begin))
-          (%quote (rename 'quote)))
-      (let ((e-name (conc name '- 'enumeration))
-            (count (vector-length components)))
-        `(,%begin (,%define-syntax ,name
-                    (cons (let ((components ',components))
-                            (lambda (e r c)
-                              (let ((key (cadr e)))
-                                (cond ((c key 'components)
-                                       (r ',e-name))
-                                      ((c key 'enum)
-                                       (let ((which (caddr e)))
-                                         (let loop ((i 0)) ;vector-posq
-                                           (if (< i ,count)
-                                               (if (c which (vector-ref components i))
-                                                   i
-                                                   (loop (+ i 1)))
-                                               ;; (syntax-error "unknown enumerand name"
-                                               ;;               `(,(cadr e) ,(car e) ,(caddr e)))
-                                               e))))
-                                      (else e)))))
-                          '(,e-name)))  ;Auxiliary binding
-                  (,%define ,e-name ',components)
-                  (,%define ,(conc name '- 'count) ,count)))))
-  (begin define define-syntax quote))
-
-
-(define-syntax components
-  (cons (lambda (e r c) `(,(cadr e) components))
-        '()))
-
-(define-syntax enum
-  (cons (lambda (e r c) `(,(cadr e) enum ,(caddr e)))
-        '()))
-
-
-(define-syntax enumerand->name
-  (syntax-rules ()
-    ((enumerand->name ?enumerand ?type)
-     (vector-ref (components ?type) ?enumerand))))
-
-(define-syntax name->enumerand
-  (syntax-rules ()
-    ((name->enumerand ?name ?type)
-     (lookup-enumerand (components ?type) ?name))))
-
-(define (lookup-enumerand components name)
-  (let ((len (vector-length components)))
-    (let loop ((i 0))                   ;vector-posq
-      (if (>= i len)
-          #f
-          (if (eq? name (vector-ref components i))
-              i
-              (loop (+ i 1)))))))
diff --git a/scheme/rts/env.scm b/scheme/rts/env.scm
deleted file mode 100644
index 78ca3da..0000000
--- a/scheme/rts/env.scm
+++ /dev/null
@@ -1,108 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-
-; Accessing packages
-
-(define (environment-ref package name)
-  (carefully (package-lookup package name)
-	     (lambda (loc)
-	       (if (location-assigned? loc)
-		   (contents loc)
-		   (error "uninitialized variable" name package)))
-	     package
-	     name))
-
-(define (environment-set! package name value)
-  (let ((binding (package-lookup package name)))
-    (if (and (binding? binding)
-	     (not (variable-type? (binding-type binding))))
-	(error "invalid assignment" name package value)
-	(carefully binding
-		   (lambda (loc)
-		     (set-contents! loc value))
-		   package name))))
-
-(define (environment-define! package name value)
-  (set-contents! (package-define! package name usual-variable-type #f #f)
-		 value))
-
-(define (*structure-ref struct name)
-  (let ((binding (structure-lookup struct name #f)))
-    (if binding
-	(carefully binding contents struct name)
-	(error "structure-ref: name not exported" struct name))))
-
-(define (carefully binding action env name)
-  (cond ((not binding)
-	 (error "unbound variable" name env))
-	((not (binding? binding))
-	 (error "peculiar binding" binding name env))
-	((eq? (binding-type binding) syntax-type)
-	 (error "attempt to reference syntax as variable" name env))
-	(else
-	 (let ((loc (binding-place binding)))
-	   (if (location? loc)
-	       (if (location-defined? loc)
-		   (action loc)
-		   (error "unbound variable" name env))
-	       (error "variable has no location" name env))))))
-
-; Interaction environment
-
-(define $interaction-environment (make-fluid #f))
-
-(define (interaction-environment)
-  (fluid $interaction-environment))
-
-(define (set-interaction-environment! p)
-  (if (package? p)
-      (set-fluid! $interaction-environment p)
-      (call-error "invalid package" set-interaction-environment! p)))
-
-(define (with-interaction-environment p thunk)
-  (if (package? p)
-      (let-fluid $interaction-environment p thunk)
-      (call-error "invalid package" with-interaction-environment p)))
-
-
-; Scheme report environment.  Should be read-only; fix later.
-
-(define (scheme-report-environment n)
-  (if (= n *scheme-report-number*)
-      *scheme-report-environment*
-      (error "no such Scheme report environment")))
-
-(define *scheme-report-environment* #f)
-(define *null-environment* #f)
-(define *scheme-report-number* 0)
-
-(define (set-scheme-report-environment! repnum env)
-  (set! *scheme-report-number* repnum)
-  (set! *scheme-report-environment* env)
-  (set! *null-environment* env))		; A cheat.
-
-(define (null-environment n)
-  (if (= n *scheme-report-number*)
-      *null-environment*
-      (error "no such Scheme report environment")))
-
-; Make an infinite tower of packages for syntax.
-; structs should be a non-null list of structures that should be
-; opened at EVERY level of the tower.
-
-(define (make-reflective-tower eval structs id)
-  (let recur ((level 1))
-    (delay (cons eval
-		 (make-simple-package structs
-				      eval
-				      (recur (+ level 1))
-				      `(for-syntax ,level ,id))))))
-
-; (set-reflective-tower-maker! p (lambda (clauses id) ...))
-; where clauses is a list of DEFINE-STRUCTURE clauses
-
-(define set-reflective-tower-maker!
-  (let ((name (string->symbol ".make-reflective-tower.")))
-    (lambda (p proc)
-      (environment-define! p name proc))))
diff --git a/scheme/rts/floatnum.scm b/scheme/rts/floatnum.scm
deleted file mode 100644
index 4ccc1e0..0000000
--- a/scheme/rts/floatnum.scm
+++ /dev/null
@@ -1,284 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Inexact rational arithmetic using hacked-in floating point numbers.
-
-(define floatnum? double?)
-
-(define-enumeration flop
-  (+ - * / = <
-   fixnum->float
-   string->float
-   float->string
-   exp log sin cos tan asin acos atan sqrt
-   floor
-   integer?
-   float->fixnum
-   quotient
-   remainder))
-
-(define-syntax floperate
-  (syntax-rules ()
-    ((floperate ?which ?x)
-     (vm-extension (+ ?which 100) ?x))
-    ((floperate ?which ?x ?y)
-     (vm-extension (+ ?which 100) (cons ?x ?y)))
-    ((floperate ?which ?x ?y ?z)
-     (vm-extension (+ ?which 100) (vector ?x ?y ?z)))))
-
-(define (float&float->float op)
-  (lambda (a b)
-    (let ((res (make-double)))
-      (floperate op (x->float a) (x->float b) res)
-      res)))
-
-(define (float&float->boolean op)
-  (lambda (a b)
-    (floperate op (x->float a) (x->float b))))
-
-(define (float1 op)
-  (lambda (float)
-    (floperate op float)))
-
-(define (float->float op)
-  (lambda (a)
-    (let ((res (make-double)))
-      (floperate op (x->float a) res)
-      res)))
-
-(define (string->float string)
-  (let ((res (make-double)))
-    (floperate (enum flop string->float) string res)
-    res))
-
-; Call the OS to get a string and then add a `.' if necessary (so that
-; it will be inexact).
-
-(define (float->string float)
-  (let* ((res (make-string 40 #\space))
-	 (len (floperate (enum flop float->string)
-			 float
-			 res))
-	 (str (substring res 0 len)))
-    (let loop ((i 0))
-      (cond ((>= i (string-length str))
-	     (string-append str "."))
-	    ((char=? (string-ref str i) #\.)
-	     str)
-	    ((char=? (string-ref str i) #\e)
-	     (string-append (substring str 0 i)
-			    "."
-			    (substring str i (string-length str))))
-	    (else
-	     (loop (+ i 1)))))))
-
-(define (x->float x)
-  (cond ((double? x)
-	 x)
-	((integer? x)
-	 (exact-integer->float (if (exact? x)
-				   x
-				   (inexact->exact x))))
-	((rational? x)
-	 ;; This loses when num or den overflows flonum range
-	 ;; but x doesn't.
-	 (float/ (numerator x) (denominator x)))
-	(else
-	 (error "cannot coerce to a float" x))))
-
-; Conversion to/from exact integer
-
-(define (exact-integer->float k)
-  (or (fixnum->float k)
-      (float+ (float* (fixnum->float definitely-a-fixnum)
-		      (quotient k definitely-a-fixnum))
-	      (fixnum->float (remainder k definitely-a-fixnum)))))
-
-(define (fixnum->float k)    ;Returns #f is k is a bignum
-  (let ((res (make-double)))
-    (if (floperate (enum flop fixnum->float) k res)
-	res
-	#f)))
-
-(define (float->exact-integer x)
-  (or (float->fixnum x)
-      (let ((d (fixnum->float definitely-a-fixnum)))
-	(+ (* definitely-a-fixnum
-	      (float->exact-integer (float-quotient x d)))
-	   (float->fixnum (loophole :double		; outsmarted ourselves
-				    (float-remainder x d)))))))
-
-(define definitely-a-fixnum (expt 2 23))    ;Be conservative
-
-(define integral-floatnum? (float1 (enum flop integer?)))
-(define float->fixnum      (float1 (enum flop float->fixnum)))
-
-(define float+ (float&float->float (enum flop +)))
-(define float- (float&float->float (enum flop -)))
-(define float* (float&float->float (enum flop *)))
-(define float/ (float&float->float (enum flop /)))
-(define float-quotient (float&float->float (enum flop quotient)))
-(define float-remainder (float&float->float (enum flop remainder)))
-(define float-atan (float&float->float (enum flop atan)))
-
-(define float= (float&float->boolean (enum flop =)))
-(define float< (float&float->boolean (enum flop <)))
-
-(define float-exp (float->float (enum flop exp)))
-(define float-log (float->float (enum flop log)))
-(define float-sin (float->float (enum flop sin)))
-(define float-cos (float->float (enum flop cos)))
-(define float-tan (float->float (enum flop tan)))
-(define float-asin (float->float (enum flop asin)))
-(define float-acos (float->float (enum flop acos)))
-(define float-sqrt (float->float (enum flop sqrt)))
-(define float-floor (float->float (enum flop floor)))
-
-; This lets you do ,open floatnum to get faster invocation
-(begin 
-  (define exp float-exp)
-  (define log float-log)
-  (define sin float-sin)
-  (define cos float-cos)
-  (define tan float-tan)
-  (define asin float-asin)
-  (define acos float-acos)
-  (define atan float-atan)
-  (define sqrt float-sqrt))
-
-(define (float-fraction-length x)
-  (let ((two (exact-integer->float 2)))
-    (do ((x x (float* x two))
-	 (i 0 (+ i 1)))
-	((integral-floatnum? x) i)
-      (if (> i 1000) (error "I'm bored." x)))))
-
-(define (float-denominator x)
-  (expt (exact-integer->float 2) (float-fraction-length x)))
-
-(define (float-numerator x)
-  (float* x (float-denominator x)))
-
-(define (float->exact x)
-  (if (integral-floatnum? x)
-      (float->exact-integer x)		;+++
-      (let ((lose (lambda ()
-		    (call-error "no exact representation"
-				inexact->exact x)))
-	    (q (expt 2 (float-fraction-length x))))
-	(if (exact? q)
-	    (let ((e (/ (float->exact-integer
-			     (float* x (exact-integer->float q)))
-			q)))
-	      (if (exact? e)
-		  e
-		  (lose)))
-	    (lose)))))
-
-
-; Methods on floatnums
-
-(define-method &integer? ((x :double))
-  (integral-floatnum? x))
-
-(define-method &rational? ((n :double)) #t)
-
-(define-method &exact? ((x :double)) #f)
-
-(define-method &inexact->exact ((x :double))
-  (float->exact x))
-
-(define-method &exact->inexact ((x :rational))
-  (x->float x))		;Should do this only if the number is within range.
-
-(define-method &floor ((x :double)) (float-floor x))
-
-; beware infinite regress
-(define-method &numerator ((x :double)) (float-numerator x))
-(define-method &denominator ((x :double)) (float-denominator x))
-
-(define (define-floatnum-method mtable proc)
-  (define-method mtable ((m :rational) (n :rational)) (proc m n)))
-
-(define-floatnum-method &+ float+)
-(define-floatnum-method &- float-)
-(define-floatnum-method &* float*)
-(define-floatnum-method &/ float/)
-(define-floatnum-method &quotient float-quotient)
-(define-floatnum-method &remainder float-remainder)
-(define-floatnum-method &= float=)
-(define-floatnum-method &< float<)
-
-(define-method &numerator ((x :rational)) (float-numerator x))
-(define-method &denominator ((x :rational)) (float-denominator x))
-
-(define-method &exp ((x :rational)) (float-exp x))
-(define-method &log ((x :rational)) (float-log x))
-(define-method &sqrt ((x :rational)) (float-sqrt x))
-(define-method &sin ((x :rational)) (float-sin x))
-(define-method &cos ((x :rational)) (float-cos x))
-(define-method &tan ((x :rational)) (float-tan x))
-(define-method &acos ((x :rational)) (float-acos x))
-
-(define-floatnum-method &atan float-atan)
-
-(define-method &number->string ((n :double) radix)
-  (if (= radix 10)
-      (float->string n)
-      (next-method)))
-
-; Recognizing a floating point number.  This doesn't know about `#'.
-
-(define (float-string? s)
-  (let ((len (string-length s)))
-    (define (start)
-      (and (< 1 len)
-	   (let ((first (string-ref s 0))
-		 (second (string-ref s 1)))
-	     (if (char-numeric? first)
-		 (digits 1 #f #f)
-		 (case first
-		   ((#\+ #\-)
-		    (and (char-numeric? second)
-			 (digits 2 #f #f)))
-		   ((#\.)
-		    (and (char-numeric? second)
-			 (digits 2 #t #f)))
-		   (else #f))))))
-
-    ; Read digits until the end or an `e' or a `.'.  E-OR-DOT? is true if
-    ; we have seen either, E? is true if we've seen an `e'.
-    (define (digits i e-or-dot? e?)
-      (if (= i len)
-	  e-or-dot?
-	  (let ((next (string-ref s i)))
-	    (if (char-numeric? next)
-		(digits (+ i 1) e-or-dot? e?)
-		(case next
-		  ((#\e #\E)
-		   (and (not e?)
-			(exponent (+ i 1) #f)))
-		  ((#\.)
-		   (and (not e-or-dot?)
-			(digits (+ i 1) #t #f)))
-		  (else #f))))))
-
-    ; Read in an exponent.  If SIGN? is true then we have already got the sign.
-    (define (exponent i sign?)
-      (and (< i len)
-	   (let ((next (string-ref s i)))
-	     (if (char-numeric? next)
-		 (digits (+ i 1) #t #t)
-		 (case next
-		   ((#\+ #\-)
-		    (and (not sign?)
-			 (exponent (+ i 1) #t)))
-		   (else #f))))))
-    (start)))
-
-(define-simple-type :float-string (:string) float-string?)
-
-(define-method &really-string->number ((s :float-string) radix exact?)
-  (if (and (= radix 10)
-	   (not exact?))
-      (string->float s)
-      (next-method)))
diff --git a/scheme/rts/innum.scm b/scheme/rts/innum.scm
deleted file mode 100644
index c63dd1a..0000000
--- a/scheme/rts/innum.scm
+++ /dev/null
@@ -1,108 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Inexact numbers as mere shells surrounding exact numbers.
-
-(define-extended-number-type :innum (:inexact)
-  (make-innum exact)
-  innum?
-  (exact innum-exact))
-
-(define-method &exact?  ((n :innum)) #f)
-
-(define-method &complex?  ((n :innum)) (complex?  (innum-exact n)))
-(define-method &real?     ((n :innum)) (real?	  (innum-exact n)))
-(define-method &rational? ((n :innum)) (rational? (innum-exact n)))
-(define-method &integer?  ((n :innum)) (integer?  (innum-exact n)))
-
-(define-method &exact->inexact (n)
-  (if (innum? n)
-      (next-method)
-      (make-innum n)))
-
-(define-method &inexact->exact ((n :innum)) (innum-exact n))
-
-(define (inexactify n)
-  (if (exact? n)
-      (exact->inexact n)
-      n))
-
-(define (define-innum-method mtable proc)
-  (define-method mtable ((m :innum) (n :number))
-    (inexactify (proc (innum-exact m) n)))
-  (define-method mtable ((m :number) (n :innum))
-    (inexactify (proc m (innum-exact n)))))
-
-(define-innum-method &+ +)
-(define-innum-method &- -)
-(define-innum-method &* *)
-(define-innum-method &/ /)
-(define-innum-method &quotient quotient)
-(define-innum-method &remainder remainder)
-
-(define (define-innum-comparison mtable proc)
-  (define-method mtable ((m :innum) (n :number))
-    (proc (innum-exact m) n))
-  (define-method mtable ((m :number) (n :innum))
-    (proc m (innum-exact n))))
-
-(define-innum-comparison &= =)
-(define-innum-comparison &< <)
-
-(define-method &numerator   ((n :innum))
-  (inexactify (numerator (innum-exact n))))
-
-(define-method &denominator ((n :innum))
-  (inexactify (denominator (innum-exact n))))
-
-(define-method &floor ((n :innum))
-  (inexactify (floor (innum-exact n))))
-
-(define-method &number->string ((i :innum) radix)
-  (let ((n (innum-exact i)))
-    (cond ((integer? n)
-	   (string-append (number->string n radix) "."))
-	  ((rational? n)
-	   (let ((q (denominator n)))
-	     (if (= radix 10)
-		 (let ((foo (decimable? q)))
-		   (if foo
-		       (decimal-representation (numerator n) q foo)
-		       (string-append "#i" (number->string n radix))))
-		 (string-append "#i" (number->string n radix)))))
-	  (else
-	   (string-append "#i" (number->string n radix))))))
-
-; The Scheme report obligates us to print inexact rationals using
-; decimal points whenever this can be done without losing precision.
-
-(define (decimal-representation p q foo)
-  (let ((kludge (number->string (* (car foo) (abs (remainder p q)))
-				10)))
-    (string-append (if (< p 0) "-" "")
-		   (number->string (quotient (abs p) q) 10)
-		   "."
-		   (string-append (do ((i (- (cdr foo) (string-length kludge))
-					  (- i 1))
-				       (l '() (cons #\0 l)))
-				      ((<= i 0) (list->string l)))
-				  kludge))))
-
-(define (ratio-string p q radix)
-  (string-append (number->string p radix)
-		 "/"
-		 (number->string q radix)))
-
-; (decimable? n) => non-#f iff n is a product of 2's and 5's.
-; The value returned is (k . i) such that 10^i divides n * k.
-
-(define (decimable? n)
-  (let loop ((n n) (d 1) (i 0))
-    (if (= n 1)
-	(cons d i)
-	(let ((q (quotient n 10))
-	      (r (remainder n 10)))
-	  (cond ((= r 0) (loop q d (+ i 1)))
-		((= r 5) (loop (quotient n 5) (* d 2) (+ i 1)))
-		((even? r) (loop (quotient n 2) (* d 5) (+ i 1)))
-		(else #f))))))
diff --git a/scheme/rts/lize.scm b/scheme/rts/lize.scm
deleted file mode 100644
index e9e8d8b..0000000
--- a/scheme/rts/lize.scm
+++ /dev/null
@@ -1,35 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Simplest rational within an interval.  Copied from IEEE P1178/D4 nimpl.tex.
-
-(define (rationalize x e)
-  (let ((e (abs e)))
-    (simplest-rational (- x e) (+ x e))))
-
-(define (simplest-rational x y)
-  (define (simplest-rational-internal x y)
-    ;; assumes 0 < X < Y
-    (let ((fx (floor x))
-          (fy (floor y)))
-      (cond ((not (< fx x))
-             fx)
-            ((= fx fy)
-             (+ fx
-		(/ 1 (simplest-rational-internal
-		      (/ 1 (- y fy))
-		      (/ 1 (- x fx))))))
-            (else
-             (+ 1 fx)))))
-  ;; Do some juggling to satisfy preconditions of simplest-rational-internal.
-  (cond ((not (< x y))
-         (if (rational? x) x (error "(rationalize <irrational> 0)" x)))
-        ((positive? x)
-         (simplest-rational-internal x y))
-        ((negative? y)
-         (- 0 (simplest-rational-internal (- 0 y) (- 0 x))))
-        (else
-         (if (and (exact? x) (exact? y))
-             0
-             (exact->inexact 0)))))
-
diff --git a/scheme/rts/method.scm b/scheme/rts/method.scm
deleted file mode 100644
index de4d91e..0000000
--- a/scheme/rts/method.scm
+++ /dev/null
@@ -1,515 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Generic procedure package
-
-; This is written in fairly portable Scheme.  It needs:
-;   Scheme 48 low-level macros (explicit renaming), in one small place.
-;   (CALL-ERROR message proc arg ...)  - signal an error.
-;   Record package and DEFINE-RECORD-TYPES macro.
-;   An object :RECORD-TYPE which is the record type descriptor for
-;     record type descriptors (records are assumed to be records).
-;     This wouldn't be difficult to change.
-;   A RECORD? predicate (not essential - only for defining a DISCLOSE
-;     method for records).
-
-; --------------------
-; Simple types.
-; More specific types have higher priorities.  The priorities are used
-; to establish the ordinary in which type predicates are called.
-
-(define-record-type simple-type :simple-type
-  (really-make-simple-type supers predicate priority id)
-  simple-type?
-  (supers simple-type-superiors)
-  (predicate simple-type-predicate)
-  (priority simple-type-priority)
-  (id simple-type-id)
-  (more))    ;if needed later
-
-(define-record-discloser :simple-type
-  (lambda (c) `(simple-type ,(simple-type-id c))))
-
-(define (make-simple-type supers predicate id)
-  (make-immutable!
-   (really-make-simple-type supers
-			    predicate
-			    (compute-priority supers)
-			    id)))
-
-(define (compute-priority supers)
-  (if (null? supers)
-      0
-      (+ (apply max (map %type-priority supers))
-	 *increment*)))
-
-(define *increment* 10)
-
-
-; These two procedures will become generic later, but must exist early
-; in order to be able to bootstrap the method definition mechanism.
-
-(define (%type-priority type)
-  (cond ((simple-type? type)
-	 (simple-type-priority type))
-	((record-type? type)
-	 (record-type-priority type))
-	(else (type-priority type))))	;generic
-
-(define (%type-predicate type)
-  (cond ((simple-type? type)
-	 (simple-type-predicate type))
-	((record-type? type)
-	 (record-predicate type))
-	(else (type-predicate type))))  ;generic
-
-(define (%same-type? t1 t2)
-  (or (eq? t1 t2)
-      (if (simple-type? t1)
-	  #f
-	  (if (record-type? t1)
-	      #f
-	      (same-type? t1 t2)))))
-	  
-
-(define-syntax define-simple-type
-  (syntax-rules ()
-    ((define-simple-type ?name (?super ...) ?pred)
-     (define ?name (make-simple-type (list ?super ...) ?pred '?name)))))
-
-; --------------------
-; Built-in Scheme types
-
-(define-simple-type :syntax    () #f)
-(define-simple-type :values    () #f)    ;any number of values
-
-(define (value? x) #t)
-(define-simple-type :value     (:values) value?)
-(define-simple-type :zero      (:values) (lambda (x) #f))
-
-(define-simple-type :number    (:value) number?)
-(define-simple-type :complex   (:number) complex?)
-(define-simple-type :real      (:complex) real?)
-(define-simple-type :rational  (:real) rational?)
-(define-simple-type :integer   (:rational) integer?)
-(define-simple-type :exact-integer (:integer)
-  (lambda (n) (and (integer? n) (exact? n))))
-
-(define-simple-type :boolean   (:value) boolean?)
-(define-simple-type :symbol    (:value) symbol?)
-(define-simple-type :char      (:value) char?)
-(define-simple-type :null      (:value) null?)
-(define-simple-type :pair      (:value) pair?)
-(define-simple-type :vector    (:value) vector?)
-(define-simple-type :string    (:value) string?)
-(define-simple-type :procedure (:value) procedure?)
-
-(define-simple-type :input-port  (:value) input-port?)
-(define-simple-type :output-port (:value) output-port?)
-(define-simple-type :eof-object	 (:value) eof-object?)
-
-; If there is no RECORD? predicate, do
-;   (define-simple-type :record	 (:value) value?)
-; and change the DISCLOSE method for records to
-;   (or (disclose-record obj) (next-method)).
-
-(define-simple-type :record	 (:value) record?)
-
-; If record types are not records, un-comment the following line.
-; (define-simple-type :record-type (:value) record-type?)
-
-; Given a record type, RECORD-TYPE-PRIORITY returns its priority.
-; Here we establish that every record type is a direct subtype of the
-; :RECORD type.
-
-(define record-type-priority
-  (let ((r-priority
-	 (simple-type-priority (make-simple-type (list :record) #f #f))))
-    (lambda (rt) r-priority)))
-
-; --------------------
-; Method-info records are triples <type-list, n-ary?, proc>.
-
-(define-record-type method-info :method-info
-  (really-make-method-info types n-ary? proc)
-  method-info?
-  (types method-info-types)
-  (n-ary? method-info-n-ary?)
-  (proc method-info-proc))
-
-(define (make-method-info types n-ary? proc)
-  (make-immutable! (really-make-method-info types n-ary? proc)))
-
-(define-record-discloser :method-info
-  (lambda (info)
-    `(method-info ,(method-info-types info) ,(method-info-n-ary? info))))
-
-; --------------------
-; Method lists
-
-; A method list is a list of method-info records, sorted in order from
-; most specific to least specific.
-
-(define (empty-method-list) '())
-
-; insert-method inserts an entry into a method list so that the most
-; specific methods come earliest in the list.  The last method should
-; be a default method or error signal(l)er.
-
-(define (insert-method info ms)
-  (let recur ((ms ms))
-    (if (null? ms)
-	(cons info ms)
-	(if (more-specific? (car ms) info)
-	    (cons (car ms) (recur (cdr ms)))
-	    (cons info
-		  (if (same-applicability? (car ms) info)
-		      (cdr ms)
-		      ms))))))
-
-; Replace an existing method with identical domain.
-
-(define (same-applicability? info1 info2)
-  (and (every2 %same-type?
-	       (method-info-types info1)
-	       (method-info-types info2))
-       (eq? (method-info-n-ary? info1) (method-info-n-ary? info2))))
-
-(define (every2 pred l1 l2)
-  (if (null? l1)
-      (null? l2)
-      (if (null? l2)
-	  #f
-	  (and (pred (car l1) (car l2)) (every2 pred (cdr l1) (cdr l2))))))
-
-; This interacts with methods->perform, below.
-; In this version, it's supposed to be a total order.
-
-(define (more-specific? info1 info2)
-  (let ((t1 (method-info-types info1))
-	(t2 (method-info-types info2)))
-    (let ((l1 (length t1))
-	  (l2 (length t2))
-	  (foo? (and (not (method-info-n-ary? info1))
-		     (method-info-n-ary? info2))))
-      (if (= l1 l2)
-	  (or foo?
-	      (let loop ((l1 t1)
-			 (l2 t2))
-		(if (null? l2)
-		    #f
-		    (or (more-specific-type? (car l1) (car l2))
-			(and (%same-type? (car l1) (car l2))
-			     (loop (cdr l1) (cdr l2)))))))
-	  (and (> l1 l2)
-	       foo?)))))
-  
-
-(define (more-specific-type? t1 t2)
-  (> (%type-priority t1) (%type-priority t2)))
-
-; --------------------
-; A method table is a cell that contains a method list.
-; Note that the method table is not reachable from the generic
-; procedure.  This means good things for the GC.
-
-(define-record-type method-table :method-table
-  (really-make-method-table methods prototype
-			    generic get-perform set-perform! id)
-  method-table?
-  (methods method-table-methods set-method-table-methods!)
-  (prototype method-table-prototype)
-  (generic make-generic)
-  (get-perform method-table-get-perform)
-  (set-perform! method-table-set-perform!)
-  (id method-table-id))
-
-(define-record-discloser :method-table
-  (lambda (t) `(method-table ,(method-table-id t))))
-
-(define (make-method-table id . option)
-  (let* ((prototype (if (null? option)
-			(make-method-info '() #t #f)
-			(car option)))
-	 (mtable (call-with-values make-cell-for-generic
-		   (lambda (generic get-perform set-perform!)
-		     (really-make-method-table '()
-					       prototype
-					       generic
-					       get-perform
-					       set-perform!
-					       id)))))
-    (set-final-method!
-         mtable
-	 (lambda (next-method . args)
-	   (apply call-error "invalid or unimplemented operation"
-		  id args)))
-    mtable))
-
-(define (make-cell-for-generic)
-  (let ((perform #f))
-    ;; PERFORM always caches (METHODS->PERFORM method-list prototype).
-    (values (lambda args (perform args)) ;Generic proc
-	    (lambda () perform)
-	    (lambda (new) (set! perform new)))))
-
-(define (add-to-method-table! mtable info)
-  (let ((l (insert-method info (method-table-methods mtable))))
-    (set-method-table-methods! mtable l)
-    ((method-table-set-perform! mtable)
-     (methods->perform l (method-table-prototype mtable)))))
-
-(define (set-final-method! mtable proc)
-  (add-to-method-table! mtable
-			(make-method-info '()
-					  #t
-					  proc)))
-
-(define (apply-generic mtable args)
-  ;; (apply (make-generic mtable) args)
-  (((method-table-get-perform mtable)) args)) ;+++
-
-; DEFINE-GENERIC
-
-(define-syntax define-generic
-  (syntax-rules ()
-    ((define-generic ?name ?mtable-name)
-     (begin (define ?mtable-name (make-method-table '?name))
-	    (define ?name (make-generic ?mtable-name))))
-    ((define-generic ?name ?mtable-name (?spec . ?specs))
-     (begin (define ?mtable-name
-	      (make-method-table '?name
-				 (method-info ?name ("next" next-method
-							    ?spec . ?specs)
-				   (next-method))))
-	    (define ?name (make-generic ?mtable-name))))))
-
-; --------------------
-; Method combination.
-
-; Here is the specification:
-
-;(define (apply-generic mtable args)
-;  (let loop ((ms (method-table-methods mtable)))
-;    (let ((next-method (lambda () (loop (cdr ms)))))
-;      (if (let test ((ts (method-info-types (car ms)))
-;                     (args args))
-;            (if (null? ts)
-;                (or (null? args)
-;                    (method-info-n-ary? (car ms)))
-;                (and ((%type-predicate (car ts)) (car args))
-;                     (test (cdr ts) (cdr args)))))
-;          (apply (method-info-proc (car ms))
-;                 next-method
-;                 args)
-;          (next-method)))))
-
-;   (perform arg-list)
-;   (apply proc next-method-thunk arg-list)
-
-; This version of METHODS->PERFORM simply marches through all the
-; methods, looking for one that handles the operation.
-
-; The prototype is currently ignored, but it could be put to good use.
-
-(define (methods->perform l prototype)
-  (let recur ((l l))
-    (let* ((info (car l))
-	   (proc (method-info-proc info)))
-      (if (null? (cdr l))
-	  (last-action proc)
-	  (one-action (argument-sequence-predicate info)
-		      proc
-		      (recur (cdr l)))))))
-
-(define (last-action proc)
-  (lambda (args)
-    (apply proc #f args)))
-
-(define (one-action pred proc perform-next)
-  (lambda (args)
-    (if (pred args)
-	(apply proc
-	       (lambda () (perform-next args))    ; next-method
-	       args)
-	(perform-next args))))
-
-(define (argument-sequence-predicate info)
-  (let recur ((types (method-info-types info)))
-    (if (null? types)
-	(if (method-info-n-ary? info) value? null?)
-	(let ((pred (%type-predicate (car types)))
-	      (check-rest (recur (cdr types))))
-	  (if (eq? pred value?)
-	      (check-for-next check-rest) ;+++
-	      (check-next pred check-rest))))))
-
-(define (check-for-next check-rest)
-  (lambda (args)
-    (if (null? args)
-	#f
-	(check-rest (cdr args)))))
-
-(define (check-next pred check-rest)
-  (lambda (args)
-    (if (null? args)
-	#f
-	(if (pred (car args))
-	    (check-rest (cdr args))
-	    #f))))
-
-; --------------------
-; METHOD-INFO macro.
-; Returns a method-info record.
-
-; You can specify the name of the next-method parameter by saying
-;   (method-info my-name (x y "next" n) body ...)
-; Otherwise, the next-method parameter will be named next-method.
-; Just pretend it's Dylan and that #next reads as "next".
-
-(define-syntax method-info
-  (syntax-rules ()
-    ((method-info ?id ?formals ?body ...)
-     (method-internal ?formals () () #f ?id ?body ...))))
-
-(define-syntax method-internal
-  (syntax-rules ()
-    ((method-internal ((?formal1 ?type1) . ?specs)
-		      (?formal ...) (?type ...) ?next
-		      . ?rest)
-     (method-internal ?specs
-		      (?formal ... ?formal1) (?type ... ?type1) ?next
-		      . ?rest))
-
-    ((method-internal ("next" ?next . ?specs)
-		      (?formal ...) (?type ...) ?ignore
-		      . ?rest)
-     (method-internal ?specs
-		      (?formal ...) (?type ...) ?next
-		      . ?rest))
-
-    ((method-internal (?spec . ?specs)
-		      (?formal ...) (?type ...) ?next
-		      . ?rest)
-     (method-internal ?specs
-		      (?formal ... ?spec) (?type ... :value) ?next
-		      . ?rest))
-
-    ((method-internal ?rest
-		      (?formal ...) (?type ...) ?next
-		      ?id ?body ...)
-     (make-method-info (list ?type ...)
-		       (not (null? '?rest))
-		       (let ((?id (with-next-method ?next (?formal ... . ?rest)
-				    ?body ...)))
-			 ;; The (let ...) is a hack for the Scheme 48
-			 ;; byte code compiler, which will remember
-			 ;; ?id as the procedure's name.  This should
-			 ;; aid debugging a little bit since the name
-			 ;; shows up in backtraces and the inspector.
-			 ?id)))))
-
-; Non-hygienic, a la Dylan
-
-(define-syntax with-next-method
-  (cons (lambda (e r c)
-	  (let ((next (or (cadr e) 'next-method)))
-	    `(,(r 'lambda) (,next ,@(caddr e))
-			   ,@(cdddr e))))
-	'(lambda)))
-
-; DEFINE-METHOD macro.
-
-(define-syntax define-method
-  (syntax-rules ()
-    ((define-method ?mtable ?formals ?body ...)
-     (add-method! ?mtable
-		  (method-info ?mtable ?formals ?body ...)))))
-
-(define-generic add-method! &add-method! (mtable info))
-
-(let ((info
-       (method-info add-method! ((mtable :method-table) (info :method-info))
-	 (add-to-method-table! mtable info))))
-  (add-to-method-table! &add-method! info))
-
-; --------------------
-; Generic functions on types: sort of a meta-object protocol, huh?
-
-(define-generic type-predicate &type-predicate (t))
-
-(define-method &type-predicate ((t :record-type)) (record-predicate t))
-(define-method &type-predicate ((t :simple-type)) (simple-type-predicate t))
-
-(define-generic type-priority &type-priority (t))
-
-(define-method &type-priority ((t :record-type)) (record-type-priority t))
-(define-method &type-priority ((t :simple-type)) (simple-type-priority t))
-
-(define-generic type-superiors &type-superiors (t))
-
-(define-method &type-superiors ((t :record-type)) (list :record))
-(define-method &type-superiors ((t :simple-type)) (simple-type-superiors t))
-
-
-; Type equivalence
-
-(define-generic same-type? &same-type? (t1 t2))
-
-(define-method &same-type? (t1 t2) (eq? t1 t2))
-
-(define-method &same-type? ((t1 :simple-type) (t2 :simple-type))
-  (and (eq? (simple-type-predicate t1) (simple-type-predicate t2))
-       (eq? (simple-type-id t1) (simple-type-id t2))))    ;?
-
-; --------------------
-; Singleton types.
-
-(define-record-type singleton :singleton
-  (singleton value)
-  (value singleton-value))
-  
-(define-record-discloser :singleton
-  (lambda (s) `(singleton ,(singleton-value s))))
-
-(define (compare-to val)
-  (lambda (x) (eqv? x val)))
-
-(define-method &type-predicate ((s :singleton))
-  (compare-to (singleton-value s)))
-
-(define-method &type-priority ((s :singleton)) 1000000)
-
-(define-method &same-type? ((s1 :singleton) (s2 :singleton))
-  (eqv? (singleton-value s1) (singleton-value s2)))
-
-; --------------------
-; DISCLOSE
-
-; A generic procedure for producing printed representations.
-; Should return one of
-;   - A list (symbol info ...), to be printed as #{Symbol info ...}
-;   - #f, meaning no information available on how to print.
-; This is intended to be used not only by write and display, but also by
-; the pretty printer.
-
-(define-generic disclose &disclose (x))
-
-(define-method &disclose (obj) #f)
-
-(define-method &disclose ((obj :record))
-  (or (disclose-record obj)
-      '(record)))
-
-(define-method &add-method! ((d (singleton &disclose)) info)
-  (let ((t (car (method-info-types info))))
-    (if (record-type? t)
-	(define-record-discloser t (proc->discloser (method-info-proc info)))
-	(next-method))))
-
-(define (proc->discloser proc)
-  (lambda (arg)
-    (proc (lambda () #f) arg)))
-
-;(define-method &disclose ((s :singleton))
-;  `(singleton ,(singleton-value s)))
diff --git a/scheme/rts/number.scm b/scheme/rts/number.scm
deleted file mode 100644
index 51d0ba0..0000000
--- a/scheme/rts/number.scm
+++ /dev/null
@@ -1,82 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; This is file number.scm.
-
-
-;;;; Numbers
-
-(define (inexact? n) (not (exact? n)))
-
-(define (modulo x y)
-   (let ((r (remainder x y)))
-      (if (> y 0)
-	  (if (< r 0)
-	      (+ r y)
-	      r)
-	  (if (> r 0)
-	      (+ r y)
-	      r))))
-
-(define (ceiling x)
-  (- 0 (floor (- 0 x))))		;floor is primitive
-
-(define (truncate x)
-  (if (< x 0)
-      (ceiling x)
-      (floor x)))
-
-(define (round x)
-  (let* ((x+1/2 (+ x (/ 1 2)))
-	 (r (floor x+1/2)))
-    (if (and (= r x+1/2)
-	     (odd? r))
-	(- r 1)
-	r)))
-	
-; GCD
-
-(define (gcd . integers)
-  (reduce (lambda (x y)
-	    (cond ((< x 0) (gcd (- 0 x) y))
-		  ((< y 0) (gcd x (- 0 y)))
-		  ((< x y) (euclid y x))
-		  (else (euclid x y))))
-	  0
-	  integers))
-
-(define (euclid x y)
-  (if (= y 0)
-      (if (and (inexact? y)
-	       (exact? x))
-	  (exact->inexact x)
-	  x)
-      (euclid y (remainder x y))))
-
-; LCM
-
-(define (lcm . integers)
-  (reduce (lambda (x y)
-	    (let ((g (gcd x y)))
-	      (cond ((= g 0) g)
-		    (else (* (quotient (abs x) g) (abs y))))))
-	  1
-	  integers))
-
-; Exponentiation.
-
-(define (expt x n)
-  (if (and (integer? n) (exact? n))
-      (if (>= n 0)
-	  (raise-to-integer-power x n)
-	  (/ 1 (raise-to-integer-power x (- 0 n))))
-      (exp (* n (log x)))))
-
-(define (raise-to-integer-power x n)
-  (if (= n 0)
-      1
-      (let loop ((s x) (i n) (a 1))	;invariant: a * s^i = x^n
-	(let ((a (if (odd? i) (* a s) a))
-	      (i (quotient i 2)))
-	  (if (= i 0)
-	      a
-	      (loop (* s s) i a))))))
diff --git a/scheme/rts/population.scm b/scheme/rts/population.scm
deleted file mode 100644
index df89ffe..0000000
--- a/scheme/rts/population.scm
+++ /dev/null
@@ -1,37 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-
-
-(define (make-population)
-  (list '<population>))
-
-(define (add-to-population! x pop)
-  (if (not x) (error "can't put #f in a population"))
-  (if (not (weak-memq x (cdr pop)))
-      (set-cdr! pop (cons (make-weak-pointer x) (cdr pop)))))
-
-(define (weak-memq x weaks)
-  (if (null? weaks)
-      #f
-      (if (eq? x (weak-pointer-ref (car weaks)))
-	  weaks
-	  (weak-memq x (cdr weaks)))))
-
-(define (population-reduce cons nil pop)
-  (do ((l (cdr pop) (cdr l))
-       (prev pop l)
-       (m nil (let ((w (weak-pointer-ref (car l))))
-		(if w
-		    (cons w m)
-		    (begin (set-cdr! prev (cdr l))
-			   m)))))
-      ((null? l) m)))
-
-(define (population->list pop)
-  (population-reduce cons '() pop))
-
-(define (walk-population proc pop)
-  (population-reduce (lambda (thing junk) (proc thing))
-		     #f
-		     pop))
diff --git a/scheme/rts/ratnum.scm b/scheme/rts/ratnum.scm
deleted file mode 100644
index 0f0b8cf..0000000
--- a/scheme/rts/ratnum.scm
+++ /dev/null
@@ -1,141 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; This is file ratnum.scm.
-
-; Rational arithmetic
-; Assumes that +, -, etc. perform integer arithmetic.
-
-(define-simple-type :exact-rational (:rational :exact)
-  (lambda (n) (and (rational? n) (exact? n))))
-
-(define-extended-number-type :ratnum (:exact-rational :exact) ;?
-  (make-ratnum num den)
-  ratnum?
-  (num ratnum-numerator)
-  (den ratnum-denominator))
-
-(define (integer/ m n)
-  (cond ((< n 0)
-	 (integer/ (- 0 m) (- 0 n)))
-	((= n 0)
-	  (error "rational division by zero" m))
-	((and (exact? m) (exact? n))
-	 (let ((g (gcd m n)))
-	   (let ((m (quotient m g))
-		 (n (quotient n g)))
-	     (if (= n 1)
-		 m
-		 (make-ratnum m n)))))
-	(else (/ m n))))    ;In case we get flonums
-
-(define (rational-numerator p)
-  (if (ratnum? p)
-      (ratnum-numerator p)
-      (numerator p)))
-
-(define (rational-denominator p)
-  (if (ratnum? p)
-      (ratnum-denominator p)
-      (denominator p)))
-
-; a/b * c/d = a*c / b*d
-
-(define (rational* p q)
-  (integer/ (* (rational-numerator p) (rational-numerator q))
-	    (* (rational-denominator p) (rational-denominator q))))
-
-; a/b / c/d = a*d / b*c
-
-(define (rational/ p q)
-  (integer/ (* (rational-numerator p) (rational-denominator q))
-	    (* (rational-denominator p) (rational-numerator q))))
-
-; a/b + c/d = (a*d + b*c)/(b*d)
-
-(define (rational+ p q)
-  (let ((b (rational-denominator p))
-	(d (rational-denominator q)))
-    (integer/ (+ (* (rational-numerator p) d)
-		 (* b (rational-numerator q)))
-	      (* b d))))
-
-; a/b - c/d = (a*d - b*c)/(b*d)
-
-(define (rational- p q)
-  (let ((b (rational-denominator p))
-	(d (rational-denominator q)))
-    (integer/ (- (* (rational-numerator p) d)
-		 (* b (rational-numerator q)))
-	      (* b d))))
-
-; a/b < c/d  when  a*d < b*c
-
-(define (rational< p q)
-  (< (* (rational-numerator p) (rational-denominator q))
-     (* (rational-denominator p) (rational-numerator q))))
-
-; a/b = c/d  when a = b and c = d  (always lowest terms)
-
-(define (rational= p q)
-  (and (= (rational-numerator p) (rational-numerator q))
-       (= (rational-denominator p) (rational-denominator q))))
-
-; (rational-truncate p) = integer of largest magnitude <= (abs p)
-
-(define (rational-truncate p)
-  (quotient (rational-numerator p) (rational-denominator p)))
-
-; (floor p) = greatest integer <= p
-
-(define (rational-floor p)
-  (let* ((n (numerator p))
-	 (q (quotient n (denominator p))))
-    (if (>= n 0)
-	q
-	(- q 1))))
-
-
-; Extend the generic number procedures
-
-(define-method &rational? ((n :ratnum)) #t)
-
-(define-method &numerator   ((n :ratnum)) (ratnum-numerator n))
-(define-method &denominator ((n :ratnum)) (ratnum-denominator n))
-
-(define-method &exact? ((n :ratnum)) #t)
-
-;(define-method &exact->inexact ((n :ratnum))
-;  (/ (exact->inexact (numerator n))
-;     (exact->inexact (denominator n))))
-
-;(define-method &inexact->exact ((n :rational))  ;?
-;  (/ (inexact->exact (numerator n))
-;     (inexact->exact (denominator n))))
-
-(define-method &/ ((m :exact-integer) (n :exact-integer))
-  (integer/ m n))
-
-(define (define-ratnum-method mtable proc)
-  (define-method mtable ((m :ratnum) (n :exact-rational)) (proc m n))
-  (define-method mtable ((m :exact-rational) (n :ratnum)) (proc m n)))
-
-(define-ratnum-method &+ rational+)
-(define-ratnum-method &- rational-)
-(define-ratnum-method &* rational*)
-(define-ratnum-method &/ rational/)
-(define-ratnum-method &= rational=)
-(define-ratnum-method &< rational<)
-
-(define-method &floor ((m :ratnum)) (rational-floor m))
-
-;(define-method &sqrt ((p :ratnum))
-;  (if (< p 0)
-;      (next-method)
-;      (integer/ (sqrt (numerator p))
-;                (sqrt (denominator p)))))
-
-
-(define-method &number->string ((p :ratnum) radix)
-  (string-append (number->string (ratnum-numerator p) radix)
-		 "/"
-		 (number->string (ratnum-denominator p) radix)))
diff --git a/scheme/rts/recnum.scm b/scheme/rts/recnum.scm
deleted file mode 100644
index f7ddb16..0000000
--- a/scheme/rts/recnum.scm
+++ /dev/null
@@ -1,117 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Rectangular complex arithmetic built on real arithmetic.
-
-(define-extended-number-type :recnum (:complex)
-  (make-recnum real imag)
-  recnum?
-  (real recnum-real-part)
-  (imag recnum-imag-part))
-
-(define (rectangulate x y)    ; Assumes (eq? (exact? x) (exact? y))
-  (if (= y 0)
-      x
-      (make-recnum x y)))
-
-(define (rectangular-real-part z)
-  (if (recnum? z)
-      (recnum-real-part z)
-      (real-part z)))
-
-(define (rectangular-imag-part z)
-  (if (recnum? z)
-      (recnum-imag-part z)
-      (imag-part z)))
-
-(define (rectangular+ a b)
-  (rectangulate (+ (rectangular-real-part a) (rectangular-real-part b))
-		(+ (rectangular-imag-part a) (rectangular-imag-part b))))
-
-(define (rectangular- a b)
-  (rectangulate (- (rectangular-real-part a) (rectangular-real-part b))
-		(- (rectangular-imag-part a) (rectangular-imag-part b))))
-
-(define (rectangular* a b)
-  (let ((a1 (rectangular-real-part a))
-	(a2 (rectangular-imag-part a))
-	(b1 (rectangular-real-part b))
-	(b2 (rectangular-imag-part b)))
-    (rectangulate (- (* a1 b1) (* a2 b2))
-		  (+ (* a1 b2) (* a2 b1)))))
-
-(define (rectangular/ a b)
-  (let ((a1 (rectangular-real-part a))
-	(a2 (rectangular-imag-part a))
-	(b1 (rectangular-real-part b))
-	(b2 (rectangular-imag-part b)))
-    (let ((d (+ (* b1 b1) (* b2 b2))))
-      (rectangulate (/ (+ (* a1 b1) (* a2 b2)) d)
-		    (/ (- (* a2 b1) (* a1 b2)) d)))))
-
-(define (rectangular= a b)
-  (let ((a1 (rectangular-real-part a))
-	(a2 (rectangular-imag-part a))
-	(b1 (rectangular-real-part b))
-	(b2 (rectangular-imag-part b)))
-    (and (= a1 b1) (= a2 b2))))
-
-
-; Methods
-
-(define-method &complex? ((z :recnum)) #t)
-
-(define-method &real-part ((z :recnum)) (recnum-real-part z))
-(define-method &imag-part ((z :recnum)) (recnum-imag-part z))
-
-; Methods on complexes in terms of real-part and imag-part
-
-(define-method &exact? ((z :recnum))
-  (exact? (recnum-real-part z)))
-
-(define-method &inexact->exact ((z :recnum))
-  (make-recnum (inexact->exact (recnum-real-part z))
-	       (inexact->exact (recnum-imag-part z))))
-
-(define-method &exact->inexact ((z :recnum))
-  (make-recnum (exact->inexact (recnum-real-part z))
-	       (exact->inexact (recnum-imag-part z))))
-
-(define (define-recnum-method mtable proc)
-  (define-method mtable ((m :recnum) (n :complex)) (proc m n))
-  (define-method mtable ((m :complex) (n :recnum)) (proc m n)))
-
-(define-recnum-method &+ rectangular+)
-(define-recnum-method &- rectangular-)
-(define-recnum-method &* rectangular*)
-(define-recnum-method &/ rectangular/)
-(define-recnum-method &= rectangular=)
-
-(define-method &sqrt ((n :real))
-  (if (< n 0)
-      (make-rectangular 0 (sqrt (- 0 n)))
-      (next-method)))			; not that we have to
-
-; Gleep!  Can we do quotient and remainder on Gaussian integers?
-; Can we do numerator and denominator on complex rationals?
-
-(define-method &number->string ((z :recnum) radix)
-  (let ((x (real-part z))
-	(y (imag-part z)))
-    (let ((r (number->string x radix))
-	  (i (number->string (abs y) radix))
-	  (& (if (< y 0) "-" "+")))
-      (if (and (inexact? y)		;gross
-	       (char=? (string-ref i 0) #\#))
-	  (string-append (if (char=? (string-ref r 0) #\#)
-			     ""
-			     "#i")
-			 r &
-			 (substring i 2 (string-length i))
-			 "i")
-	  (string-append r & i "i")))))
-
-(define-method &make-rectangular ((x :real) (y :real))
-  (if (eq? (exact? x) (exact? y))
-      (rectangulate x y)
-      (rectangulate (if (exact? x) (exact->inexact x) x)
-		    (if (exact? y) (exact->inexact y) y))))
diff --git a/scheme/rts/record.scm b/scheme/rts/record.scm
deleted file mode 100644
index d640a7e..0000000
--- a/scheme/rts/record.scm
+++ /dev/null
@@ -1,208 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-;;;; Records
-
-; Every record in the image is assumed to be made either by MAKE-RECORD-TYPE
-; or by a procedure returned by record-constructor.  A record-type is a
-; record that describes a type of record.  At the end of the file we create
-; a record type that describes record types.
-
-; Every record has a record type (another record) in the first slot.
-
-(define (record-type r)
-  (record-ref r 0))
-
-; We number the record types for debugging purposes.
-
-(define *record-type-uid* -1)
-
-; This is the record type that describes record types.  It is set a the end
-; of the file.  Its first slot points to itself.
-
-(define *record-type* #f)
-
-; Make a record type from a name, used for printing and debugging, and
-; a list of field names.
-;
-; The VM references both the record type and the resumer, so their offsets
-; should not be changed.
-
-(define (make-record-type name field-names)
-  (set! *record-type-uid* (+ *record-type-uid* 1))
-  (let ((r (make-record 7 (unspecific))))
-    (record-set! r 0 *record-type*)
-    (record-set! r 1 default-record-resumer)
-    (record-set! r 2 *record-type-uid*)
-    (record-set! r 3 name)
-    (record-set! r 4 field-names)
-    (record-set! r 5 (length field-names))
-    (record-set! r 6 (make-default-record-discloser name))
-    r))
-
-(define (record-type? obj)
-  (and (record? obj)
-       (eq? (record-type obj) *record-type*)))
-
-; The various fields in a record type.
-
-(define (record-type-resumer rt)          (record-ref rt 1))
-(define (set-record-type-resumer! rt r)   (record-set! rt 1 r))
-(define (record-type-uid rt)              (record-ref rt 2))
-(define (record-type-name rt)             (record-ref rt 3))
-(define (record-type-field-names rt)      (record-ref rt 4))
-(define (record-type-number-of-fields rt) (record-ref rt 5))
-(define (record-type-discloser rt)        (record-ref rt 6))
-(define (set-record-type-discloser! rt d) (record-set! rt 6 d))
-
-; This is a hack; it is read by the script that makes c/scheme48.h.
-
-(define record-type-fields
-  '(resumer uid name field-names number-of-fields discloser))
-
-;----------------
-; Given a record type and the name of a field, return the field's index.
-
-(define (record-field-index rt name)
-  (let loop ((names (record-type-field-names rt))
-	     (i 1))
-    (cond ((null? names)
-	   (error "unknown field"
-		  (record-type-name rt)
-		  name))
-	  ((eq? name (car names))
-	   i)
-	  (else
-	   (loop (cdr names) (+ i 1))))))
-
-; Return procedure for contstruction records of type RT.  NAMES is a list of
-; field names which the constructor will take as arguments.  Other fields are
-; uninitialized.
-
-(define (record-constructor rt names)
-  (let ((indexes (map (lambda (name)
-			(record-field-index rt name))
-		      names))
-	(size (+ 1 (record-type-number-of-fields rt))))
-    (lambda args
-      (let ((r (make-record size (unspecific))))
-	(record-set! r 0 rt)
-	(let loop ((is indexes) (as args))
-	  (if (null? as)
-	      (if (null? is)
-		  r
-		  (error "too few arguments to record constructor"
-			 rt names args))
-	      (if (null? is)
-		  (error "too many arguments to record constructor"
-			 rt names args)
-		  (begin (record-set! r (car is) (car as))
-			 (loop (cdr is) (cdr as))))))))))
-
-; Making accessors, modifiers, and predicates for record types.
-
-(define (record-accessor rt name)
-  (let ((index (record-field-index rt name))
-	(error-cruft `(record-accessor ,rt ',name)))
-    (lambda (r)
-      (if (eq? (record-type r) rt)
-	  (record-ref r index)
-	  (call-error "invalid record access" error-cruft r)))))
-
-(define (record-modifier rt name)
-  (let ((index (record-field-index rt name))
-	(error-cruft `(record-modifier ,rt ',name)))
-    (lambda (r x)
-      (if (eq? (record-type r) rt)
-	  (record-set! r index x)
-	  (call-error "invalid record modification" error-cruft r x)))))
-
-(define (record-predicate rt)
-  (lambda (x)
-    (and (record? x)
-	 (eq? (record-type x) rt))))
-
-;----------------
-; A discloser is a procedure that takes a record of a particular type and
-; returns a list whose head is a string or symbol and whose tail is other
-; stuff.
-;
-; Set the discloser for record type RT.
-
-(define (define-record-discloser rt proc)
-  (if (and (record-type? rt)
-	   (procedure? proc))
-      (set-record-type-discloser! rt proc)
-      (call-error "invalid argument" define-record-discloser rt proc)))
-
-; By default we just return the name of the record type.
-
-(define (make-default-record-discloser record-type-name)
-  (lambda (r)
-    (list record-type-name)))
-
-; DISCLOSE-RECORD calls the record's discloser procedure to obtain a list.
-
-(define (disclose-record r)
-  (if (record? r)
-      (let ((rt (record-type r)))
-	(if (record-type? rt)
-	    ((record-type-discloser rt) r)
-	    #f))
-      #f))
-
-;----------------
-; A resumer is a procedure that the VM calls on all records of a given
-; type on startup.
-;
-; A resumer may be:
-;  #t -> do nothing on startup.
-;  #f -> records of this type do not survive a dump/resume; in images they
-;        are replaced by their first slot (so we make sure they have one)
-;  a one-argument procedure -> pass the record to this procedure
-;
-; Resumers are primarily intended for use by external code which keeps
-; fields in records which do not survive a dump under their own power.
-; For example, a record may contain a reference to a OS-dependent value.
-;
-; Resumers are called by the VM on startup.
-
-(define (define-record-resumer rt resumer)
-  (if (and (record-type? rt)
-	   (or (eq? #t resumer)
-	       (and (eq? #f resumer)
-		    (< 0 (record-type-number-of-fields rt)))
-	       (procedure? resumer)))
-      (set-record-type-resumer! rt resumer)
-      (call-error "invalid argument" define-record-resumer rt resumer)))
-
-; By default we leave records alone.
-
-(define default-record-resumer
-  #t)
-
-(define (initialize-records! resumer-records)
-  (if (vector? resumer-records)
-      (do ((i 0 (+ i 1)))
-	  ((= i (vector-length resumer-records)))
-	(resume-record (vector-ref resumer-records i)))))
-
-(define (resume-record record)
-  ((record-type-resumer (record-type record))
-     record))
-
-;----------------
-; Initializing *RECORD-TYPE* and making a type.
-
-(set! *record-type*
-      (make-record-type 'record-type record-type-fields))
-
-(record-set! *record-type* 0 *record-type*)
-
-(define :record-type *record-type*)
-
-(define-record-discloser :record-type
-  (lambda (rt)
-    (list 'record-type
-	  (record-type-uid rt)
-	  (record-type-name rt))))
-
diff --git a/scheme/rts/session.scm b/scheme/rts/session.scm
deleted file mode 100644
index fb2d84e..0000000
--- a/scheme/rts/session.scm
+++ /dev/null
@@ -1,25 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-; Session data
-
-; The initializers are saved in images.
-
-(define *session-data-initializers* '())
-
-(define (make-session-data-slot! init)
-  (let ((slot (length *session-data-initializers*)))
-    (set! *session-data-initializers* (cons init *session-data-initializers*))
-    (if (vector? (session-data))
-	(set-session-data! (list->vector
-			    (reverse
-			     (cons init
-				   (reverse (vector->list (session-data))))))))
-    slot))
-
-(define (session-data-ref slot)
-  (vector-ref (session-data) slot))
-
-(define (session-data-set! slot value)
-  (vector-set! (session-data) slot value))
-
-(define (initialize-session-data!)
-  (set-session-data! (list->vector (reverse *session-data-initializers*))))
diff --git a/scheme/rts/signal.scm b/scheme/rts/signal.scm
deleted file mode 100644
index 8503844..0000000
--- a/scheme/rts/signal.scm
+++ /dev/null
@@ -1,35 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-;;;; Signalling conditions
-
-; I don't like the term "signal," but that's the one Gnu Emacs Lisp,
-; Common Lisp, and Dylan use, so it's probably best to stick with it.
-
-
-(define make-condition cons)
-
-(define (signal type . stuff)
-  (signal-condition (make-condition type stuff)))
-
-; Warn
-
-(define (warn message . irritants)
-  (signal-condition (make-condition 'warning (cons message irritants))))
-
-
-; Syntax errors
-
-(define (syntax-error . rest)  ; Must return a valid expression.
-  (signal-condition (make-condition 'syntax-error rest))
-  ''syntax-error)
-
-
-; "Call error" - this means that the condition's "stuff" (cdr) is of
-; the form (message procedure . args), and should be displayed appropriately.
-; Proceeding from such an error should return the value that the call
-; to the procedure on the args should have returned.
-
-(define (call-error message proc . args)
-  (signal-condition (make-condition 'call-error
-				    (cons message (cons proc args)))))
diff --git a/scheme/rts/template.scm b/scheme/rts/template.scm
deleted file mode 100644
index b644105..0000000
--- a/scheme/rts/template.scm
+++ /dev/null
@@ -1,27 +0,0 @@
-; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Somewhat redundant with vm/istruct.scm.  Fix this some day.
-
-; Templates
-;  Templates are made only by the compiler.
-
-;(define make-template make-vector)
-
-;(define (template? obj)
-;  (and (vector? obj)
-;       (>= (vector-length obj) template-overhead)
-;       (code-vector? (template-code obj))
-;       ))
-
-;(define template-length vector-length)
-;(define template-ref vector-ref)
-;(define template-set! vector-set!)
-
-(define template-overhead 2)
-
-(define (template-code tem) (template-ref tem 0))
-(define (template-info tem) (template-ref tem 1))
-(define (set-template-code! tem cv)   (template-set! tem 0 cv))
-(define (set-template-info! tem info) (template-set! tem 1 info))
-
diff --git a/scheme/rts/time.scm b/scheme/rts/time.scm
deleted file mode 100644
index d7f65a0..0000000
--- a/scheme/rts/time.scm
+++ /dev/null
@@ -1,7 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-(define (real-time)
-  (time (enum time-option real-time) #f))
-
-(define (run-time)
-  (time (enum time-option run-time) #f))
diff --git a/scheme/rts/wind.scm b/scheme/rts/wind.scm
deleted file mode 100644
index 5d2acfb..0000000
--- a/scheme/rts/wind.scm
+++ /dev/null
@@ -1,94 +0,0 @@
-; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; This is file wind.scm.  (Rhymes with "find," not "pinned.")
-
-;;;; Dynamic-wind
-
-; This is a version of dynamic-wind that tries to do "the right thing"
-; in the presence of multiple threads of control.
-; This definition of "the right thing" is due to Pavel Curtis, and is
-; the one used in Scheme Xerox.  It is very different from what you will
-; find in, say, MIT Scheme.
-;
-; When we want to go to a new target state (e.g. on invoking a
-; continuation), we ascend to the nearest common ancestor of the
-; current state and the target state, executing the "out" (or
-; "unwind") thunk for each state on the way; then we climb back down
-; to the target state executing the "in" thunk for each state.  Unlike
-; the Hanson/Lamping algorithm, the tree of states is not altered in
-; any way.
-;
-; Each thread starts out in the root state, but continuations capture
-; the state where they're created.
-
-; Dynamic-wind
-
-(define (dynamic-wind in body out)
-  (in)
-  (let ((here (get-dynamic-point)))
-    (set-dynamic-point! (make-point (if here
-					(+ (point-depth here) 1)
-					1)
-				    in
-				    out
-				    (get-dynamic-env)
-				    here))
-    (let ((results (call-with-values body list)))
-      (set-dynamic-point! here)
-      (out)
-      (apply values results))))
-
-; call-with-current-continuation
-
-(define (call-with-current-continuation proc)
-  (primitive-cwcc
-    (lambda (cont)
-      (let ((env (get-dynamic-env))
-	    (point (get-dynamic-point)))
-	;; don't close over PROC
-	(proc (continuation->procedure cont env point))))))
-
-(define (continuation->procedure cont env point)
-  (lambda results
-    (travel-to-point! (get-dynamic-point) point)
-    (set-dynamic-env! env)
-    (set-dynamic-point! point)
-    (with-continuation cont
-      (lambda () (apply values results)))))
-
-; Point in state space = <depth, in, out, dynamic-env, parent>
-; dynamic-env = dynamic environment for execution of the in and out thunks
-
-(define-record-type point :point
-  (make-point depth in out dynamic-env parent)
-  (depth point-depth)
-  (in point-in)
-  (out point-out)
-  (dynamic-env point-dynamic-env)
-  (parent point-parent))
-
-; To make the modularity simpler, and to help Kali, the root point is #F.
-
-; Go to a point in state space.  This involves running out-thunks from
-; the current point out to its common ancestor with the target, and
-; then running in-thunks from the ancestor to the target.
-
-(define (travel-to-point! here target)
-  (cond ((eq? here target) 'done)
-	((or (not here)             ; HERE has reached the root.
-	     (and target
-		  (< (point-depth here)
-		     (point-depth target))))
-	 (travel-to-point! here (point-parent target))
-	 (set-dynamic-env! (point-dynamic-env target))
-	 (set-dynamic-point! target)
-	 ((point-in target)))
-	(else
-	 (set-dynamic-env! (point-dynamic-env here))
-	 (set-dynamic-point! here)
-	 ((point-out here))
-	 (travel-to-point! (point-parent here) target))))
-
-; (put 'let-dynamic-point 'scheme-indent-hook 1)
diff --git a/scheme/rts/write.scm b/scheme/rts/write.scm
deleted file mode 100644
index 108ae6e..0000000
--- a/scheme/rts/write.scm
+++ /dev/null
@@ -1,154 +0,0 @@
-; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; This is file write.scm.
-
-;;;; WRITE
-
-; To use this with some Scheme other than Scheme 48, do the following:
-;  1. Copy the definition of output-port-option from port.scm
-;  2. Define write-string as appropriate (as a write-char loop)
-;  3. (define (disclose x) #f)
-
-(define (write obj . port-option)
-  (let ((port (output-port-option port-option)))
-    (let recur ((obj obj))
-      (recurring-write obj port recur))))
-
-(define (recurring-write obj port recur)
-  (cond ((null? obj) (write-string "()" port))
-        ((pair? obj) (write-list obj port recur))
-        ((eq? obj #t) (write-boolean 't port))
-        ((eq? obj #f) (write-boolean 'f port))
-        ((symbol? obj) (write-string (symbol->string obj) port))
-        ((number? obj) (write-number obj port))
-        ((string? obj) (write-string-literal obj port))
-        ((char? obj) (write-char-literal obj port))
-	(else (write-other obj port recur))))
-
-(define (write-boolean mumble port)
-  (write-char #\# port)
-  (write mumble port))
-
-(define (write-number n port)
-  (write-string (number->string n 10) port))
-
-(define (write-char-literal obj port)
-  (let ((probe (character-name obj)))
-    (write-string "#\\" port)
-    (if probe
-	(write probe port)
-	(write-char obj port))))
-
-(define (character-name char)
-  (cond ((char=? char #\space) 'space)
-        ((char=? char #\newline) 'newline)
-	(else #f)))
-
-(define (write-string-literal obj port)
-  (write-char #\" port)
-  (let ((len (string-length obj)))
-    (do ((i 0 (+ i 1)))
-	((= i len) (write-char #\" port))
-      (let ((c (string-ref obj i)))
-	(if (or (char=? c #\\) (char=? c #\"))
-	    (write-char #\\ port))
-	(write-char c port)))))
-
-(define (write-list obj port recur)
-  (cond ((quotation? obj)
-         (write-char #\' port)
-         (recur (cadr obj)))
-        (else
-         (write-char #\( port)
-         (recur (car obj))
-         (let loop ((l (cdr obj))
-                    (n 1))
-              (cond ((not (pair? l))
-                     (cond ((not (null? l))
-                            (write-string " . " port)
-                            (recur l))))
-                    (else
-                      (write-char #\space port)
-                      (recur (car l))
-                      (loop (cdr l) (+ n 1)))))
-         (write-char #\) port))))
-
-(define (quotation? obj)
-  (and (pair? obj)
-       (eq? (car obj) 'quote)
-       (pair? (cdr obj))
-       (null? (cddr obj))))
-
-(define (write-vector obj port recur)
-   (write-string "#(" port)
-   (let ((z (vector-length obj)))
-     (cond ((> z 0)
-            (recur (vector-ref obj 0))
-            (let loop ((i 1))
-              (cond ((>= i z))
-                    (else
-                     (write-char #\space port)
-                     (recur (vector-ref obj i))
-                     (loop (+ i 1))))))))
-   (write-char #\) port))
-
-; The vector case goes last just so that this version of WRITE can be
-; used in Scheme implementations in which records, ports, or
-; procedures are represented as vectors.  (Scheme 48 doesn't have this
-; property.)
-
-(define (write-other obj port recur)
-  (cond ((disclose obj)
-	 => (lambda (l)
-	      (write-string "#{" port)
-	      (display-type-name (car l) port)
-	      (for-each (lambda (x)
-			  (write-char #\space port)
-			  (recur x))
-			(cdr l))
-	      (write-string "}" port)))
-	((eof-object? obj) (write-string "#{End-of-file}" port))
-	((vector? obj) (write-vector obj port recur))
-	((procedure? obj) (write-string "#{Procedure}" port))
-	(((structure-ref code-vectors code-vector?) obj)
-	 (write-string "#{Byte-vector}" port))
-	(((structure-ref low-channels channel?) obj)
-	 (write-string "#{Channel " port)
-	 (display ((structure-ref low-channels channel-id) obj) port)
-	 (write-string "}" port))
-	((eq? obj (if #f #f)) (write-string "#{Unspecific}" port))
-	(else
-	 (write-string "#{Random object}" port))))
-
-; Display the symbol WHO-CARES as Who-cares.
-
-(define (display-type-name name port)
-  (if (symbol? name)
-      (let* ((s (symbol->string name))
-	     (len (string-length s)))
-	(if (and (> len 0)
-		 (char-alphabetic? (string-ref s 0)))
-	    (begin (write-char (char-upcase (string-ref s 0)) port)
-		   (do ((i 1 (+ i 1)))
-		       ((>= i len))
-		     (write-char (char-downcase (string-ref s i)) port)))
-	    (display name port)))
-      (display name port)))
-
-;(define (write-string s port)
-;  (do ((i 0 (+ i 1)))
-;      ((= i (string-length s)))
-;    (write-char (string-ref s i) port)))
-
-
-
-; DISPLAY
-
-(define (display obj . port-option)
-  (let ((port (output-port-option port-option)))
-    (let recur ((obj obj))
-      (cond ((string? obj) (write-string obj port))
-	    ((char? obj) (write-char obj port))
-	    (else
-	     (recurring-write obj port recur))))))
diff --git a/scheme/rts/xprim.scm b/scheme/rts/xprim.scm
deleted file mode 100644
index 9b67352..0000000
--- a/scheme/rts/xprim.scm
+++ /dev/null
@@ -1,34 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Hairier exceptions & interrupts.
-; Enable generic arithmetic, informative error messages, etc.
-
-; Deal with optional arguments, etc. to primitives.
-; This is not necessarily the cleanest way to do this, and certainly not
-; the most efficient, but for the time being it's the most expedient.
-
-; We don't want to depend on tables.  But if we did, we might do this:
-;(define (closure-hash closure)
-;  (let ((cv (vector-ref (closure-template closure) 0)))  ;template-ref
-;    (do ((h 0 (+ h (code-vector-ref cv i)))
-;         (i (- (code-vector-length cv) 1) (- i 1)))
-;        ((< i 0) h))))
-;(define wna-handlers (make-table closure-hash))
-
-;(define-exception-handler (enum op check-nargs=)
-;  (lambda (opcode reason proc args)
-;    (let ((probe (assq proc *wna-handlers*)))
-;      (if probe
-;          ((cdr probe) args)
-;          (signal-exception opcode reason proc args)))))
-
-(define *wna-handlers* '())
-
-(define (define-wna-handler proc handler)
-  (set! *wna-handlers* (cons (cons proc handler) *wna-handlers*)))
-
-(define op/check-nargs= (enum op protocol)) ; temporary hack
-
-(define (wna-lose proc args)
-  (signal-exception op/check-nargs= #f proc args))  ; lost our reason
-
diff --git a/scheme/vm/arith.scm b/scheme/vm/arith.scm
deleted file mode 100644
index bfcbcf1..0000000
--- a/scheme/vm/arith.scm
+++ /dev/null
@@ -1,134 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Arithmetic that checks for overflow
-
-(define (carefully op)
-  (lambda (x y succ fail)
-    (let ((z (op (extract-fixnum x) (extract-fixnum y))))
-      (if (or (too-big-for-fixnum? z)
-	      (too-small-for-fixnum? z))
-          (goto fail x y)
-          (goto succ (enter-fixnum z))))))
-
-(define add-carefully (carefully +))
-(define subtract-carefully (carefully -))
-
-(define half-word-size (quotient bits-per-cell 2))
-(define half-word-mask (- (shift-left 1 half-word-size) 1))
-(define max-middle (shift-left 1 (- (- bits-per-fixnum 1) half-word-size)))
-
-; Uses SMALL* to do half-word multiplies.  Some implementations
-; really care about this.
-
-(define (multiply-carefully x y succ fail)
-  (let* ((a (extract-fixnum x))
-         (b (extract-fixnum y))
-         (positive-result? (if (>= a 0)
-                               (>= b 0)
-                               (< b 0)))
-         (a (abs a))
-         (b (abs b))
-	 (lo-a (bitwise-and half-word-mask a))
-	 (lo-b (bitwise-and half-word-mask b))
-         (hi-a (bitwise-and half-word-mask (high-bits a half-word-size)))
-         (hi-b (bitwise-and half-word-mask (high-bits b half-word-size)))
-	 (lo-c (small* lo-a lo-b))
-	 (mid-c (+ (small* lo-a hi-b) (small* lo-b hi-a)))
-	 (c (+ lo-c (shift-left mid-c half-word-size))))
-    (cond ((or (and (> hi-a 0) (> hi-b 0))
-	       (too-big-for-fixnum? lo-c)
-               (> 0 lo-c)
-	       (> mid-c max-middle))
-	   (goto fail x y))
-	  (positive-result?
-	   (if (too-big-for-fixnum? c)
-	       (goto fail x y)
-	       (goto succ (enter-fixnum c))))
-	  (else
-	   (if (too-small-for-fixnum? (- 0 c))
-	       (goto fail x y)
-	       (goto succ (enter-fixnum (- 0 c))))))))
-
-(define small*
-  (external "SMALL_MULTIPLY" (=> (integer integer) integer) *))
-
-; Test cases for bits-per-cell = 28, bits-per-fixnum = 26
-
-;   (do ((i 2 (* i 2))
-;        (j (* -2 (expt 2 23)) (/ j 2)))
-;       ((>= j 0) 'ok)
-;     (write `((* ,i ,j) ?=? ,(* i j)))
-;     (newline))
-
-(define (divide-carefully x y succ fail)
-  (if (= y (enter-fixnum 0))
-      (fail x y)
-      (let* ((a (extract-fixnum x))
-	     (b (extract-fixnum y))
-	     (positive-result? (if (>= a 0)
-				   (>= b 0)
-				   (< b 0)))
-	     (a (abs a))
-	     (b (abs b))
-	     (c (quotient a b)))
-	(cond ((not (= 0 (remainder a b)))
-	       (goto fail x y))
-	      ((not positive-result?)
-	       (goto succ (enter-fixnum (- 0 c))))
-	      ((too-big-for-fixnum? c)  ; (divide least-fixnum -1)
-	       (goto fail x y))
-	      (else
-	       (goto succ (enter-fixnum c)))))))
-
-; Watch out for (quotient least-fixnum -1)
-(define (quotient-carefully x y succ fail)
-  (if (= y (enter-fixnum 0))
-      (fail x y)
-      (let* ((a (extract-fixnum x))
-	     (b (extract-fixnum y))
-	     (positive-result? (if (>= a 0)
-				   (>= b 0)
-				   (< b 0)))
-	     (a (abs a))
-	     (b (abs b))
-	     (c (quotient a b)))
-	(cond ((not positive-result?)
-	       (goto succ (enter-fixnum (- 0 c))))
-	      ((too-big-for-fixnum? c)  ; (quotient least-fixnum -1)
-	       (goto fail x y))
-	      (else
-	       (goto succ (enter-fixnum c)))))))
-
-; Overflow check not necessary
-(define (remainder-carefully x y succ fail)
-  (if (= y (enter-fixnum 0))
-      (goto fail x y)
-      (let* ((a (extract-fixnum x))
-	     (b (extract-fixnum y))
-	     (positive-result? (>= a 0))
-	     (a (abs a))
-	     (b (abs b))
-	     (c (remainder a b)))
-	(goto succ (enter-fixnum (if positive-result? c (- 0 c)))))))
-
-(define (shift-carefully value+tag count+tag succ fail)
-  (let ((value (extract-fixnum value+tag))
-	(count (extract-fixnum count+tag)))
-    (if (< count 0)
-	(goto succ (enter-fixnum (arithmetic-shift-right value (- 0 count))))
-	(let ((result (extract-fixnum (enter-fixnum (shift-left value count)))))
-	  (if (and (= value (arithmetic-shift-right result count))
-		   (if (>= value 0)
-		       (>= result 0)
-		       (< result 0)))
-	      (goto succ (enter-fixnum result))
-	      (goto fail value+tag count+tag))))))
-
-; beware of (abs least-fixnum)
-(define (abs-carefully n succ fail)
-  (let ((r (abs (extract-fixnum n))))
-    (if (too-big-for-fixnum? r)
-	(goto fail n)
-	(goto succ (enter-fixnum r)))))
-
diff --git a/scheme/vm/bignum-low.scm b/scheme/vm/bignum-low.scm
deleted file mode 100644
index 1295d43..0000000
--- a/scheme/vm/bignum-low.scm
+++ /dev/null
@@ -1,42 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Manipulating bignums.
-
-(define (extract-bignum desc)
-  (assert (bignum? desc))
-  (address-after-header desc))
-
-(define (enter-bignum external-bignum)
-  (let ((desc (address->stob-descriptor external-bignum)))
-    (assert (bignum? desc))
-    (make-immutable! desc)
-    desc))
-
-; The extra digit is where the MIT bignum code stores the length.
-
-(define (bignum-alloc number-of-digits key)
-  (make-bignum (cells->bytes (+ number-of-digits 1)) key))
-
-; This doesn't use ENTER-BIGNUM because we need to preserve mutability
-; until the entire bignum operation has completed.
-;
-; If the new size is smaller we change the length in the header and install a
-; new header at the beginning of the now-unused bytes at the end.
-
-(define (shorten-bignum external-bignum number-of-digits)
-  (let ((bignum (address->stob-descriptor external-bignum)))
-    (let ((new-size (cells->bytes
-		      (bignum-size (cells->bytes (+ number-of-digits 1)))))
-	  (old-size (header-lengh-in-bytes (stob-header bignum))))
-      (assert (<= new-size old-size))
-      (if (< new-size old-size)
-	  (begin
-	    (stob-header-set! bignum
-			      (make-header (enum stob bignum) new-size))
-	    (stob-header-set! (address->stob-descriptor
-			         (address+ (address-after-header bignum)
-					   (+ stob-overhead
-					      (bytes->a-units new-size))))
-			      (make-header (enum stob bignum)
-					   (- old-size new-size)))))
-      external-bignum)))
diff --git a/scheme/vm/bignum.scm b/scheme/vm/bignum.scm
deleted file mode 100644
index e86385a..0000000
--- a/scheme/vm/bignum.scm
+++ /dev/null
@@ -1,156 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; These need to operate on both bignums and fixnums.
-;bignum-add
-;bignum-subtract
-;bignum-multiply
-;bignum-quotient
-;bignum-remainder
-;bignum-abs
-;
-; These only see bignums.
-;bignum=
-;bignum<
-
-; This only sees fixnums.
-;fixnum->bignum
-
-; fixnum-as-bignum-length - the maximum bignum digits required to hold a fixnum
-; From struct.scm:
-;   bignum-length - usual length operator, gives number of descriptors
-;   bignum-size - space to hold a bignum of N descriptors
-; Defined here:
-;   bignum-digits - number of digits in a bignum
-;   bignum-digits->size - space to hold a bignum of N digits
-;   fixnum-as-bignum-digits - number of digits to hold a fixnum
-
-; The first word in a bignum is used as a header by the C code.
-
-(define (bignum-digits bignum)
-  (- (bignum-length bignum) 1))
-
-(define (bignum-digits->size n)
-  (bignum-size (+ n 1)))
-
-;----------------
-
-(define (add-space size0 size1)
-  (bignum-digits->size (+ (max size0 size1) 1)))
-
-(define bignum-add      (binary-bignum-op add-space external-bignum-add))
-(define bignum-subtract (binary-bignum-op add-space external-bignum-subtract))
-
-(define bignum-multiply
-  (binary-bignum-op (lambda (size0 size1)
-		      (bignum-digits->size (+ size0 size1)))
-		    external-bignum-multiply))
-
-; Three bignums whose total length is twice the numerator plus two.
-
-(define (divide-space numerator-size denominator-size)
-  (+ (* 2 (bignum-digits->size numerator-size))
-     (bignum-digits->size 2)))
-
-(define bignum-quotient
-  (binary-bignum-op divide-space external-bignum-quotient))
-
-(define bignum-remainder
-  (binary-bignum-op divide-space external-bignum-remainder))
-
-; These are not applied to fixnums.
-
-(define (bignum= x y)
-  (external-bignum-equal? (extract-bignum x)
-			  (extract-bignum y)))
-
-(define (bignum< x y)
-  (= -1 (external-bignum-compare (extract-bignum x)
-				 (extract-bignum y))))
-
-(define (bignum-abs x)
-  (cond ((bignum? x)
-	 (if (= (external-bignum-test (extract-bignum x))
-		-1)
-	     (external-bignum-negate (extract-bignum x))
-	     x))
-	((fx= x least-bignum)
-	 (long->external-bignum (abs (extract-fixnum x)) key))
-	(else
-	 (enter-fixnum (abs (extract-fixnum x))))))
-
-(define bignum-abs
-  (unary-bignum-op (lambda (size) size)
-		   (lambda (x)
-		     (if (= (external-bignum-test x)
-			    -1)
-			 (external-bignum-negate x)
-			 x))))
-
-;----------------
-
-; While checking for space, which may cause a GC, we have to save the two
-; arguments where they will be traced.
-
-(define (binary-bignum-op space-proc proc)
-  (let ((space-proc (binary-space-proc space-proc)))
-    (lambda (x y)
-      (let ((needed (space-proc x y)))
-	(receive (key x y)
-	    (ensure-space-saving-temps needed x y)
-	  (external-bignum->integer (proc (integer->external-bignum x)
-					  (integer->external-bignum y))))))))
-
-; Same again for unary procedures.
-
-(define (unary-bignum-op space-proc proc)
-  (let ((space-proc (unary-space-proc space-proc)))
-    (lambda (x)
-      (let ((needed (space-proc x)))
-	(receive (key x)
-	    (ensure-space-saving-temp needed x)
-	  (external-bignum->integer (proc (integer->external-bignum x))))))))
-
-; These take care of the extra space needed for fixnum arguments (they need
-; to be converted to bignums).  SPACE-PROC takes the length of the two bignums
-; and returns the space needed for the computation and results.
-
-(define (binary-space-proc space-proc)
-  (lambda (x y)
-    (receive (length0 extra0)
-	(integer-bignum-digits x)
-      (receive (length1 extra1)
-	  (integer-bignum-digits x)
-	(+ (space-proc length0 length1)
-	   extra0
-	   extra1)))))
-
-(define (unary-space-proc space-proc)
-  (lambda (x)
-    (receive (length extra)
-	(integer-bignum-digits x)
-      (+ (space-proc length)
-	 extra))))
-
-; Return the number of bignum digits in an integer.  For fixnums this is a
-; fixed amount.  The second return value is the amount of space needed to
-; convert the argument into a bignum.
-
-(define (integer-bignum-digits x)
-  (if (fixnum? x)
-      (values fixnum-as-bignum-digits
-	      (bignum-digits->size fixnum-as-bignum-digits))
-      (values (bignum-digits x)
-	      0)))
-
-; Converting back and forth between Scheme 48 integers and external bignums.
-
-(define (integer->external-bignum x)
-  (if (fixnum? x)
-      (long->external-bignum (extract-fixnum x))
-      (extract-bignum x)))
-
-(define (external-bignum->integer external-bignum)
-  (if (external-bignum-fits-in-word? external-bignum 30 #t)
-      (enter-fixnum (external-bignum->long external-bignum))
-      (enter-bignum external-bignum)))
diff --git a/scheme/vm/bug.scm b/scheme/vm/bug.scm
deleted file mode 100644
index 7bbd296..0000000
--- a/scheme/vm/bug.scm
+++ /dev/null
@@ -1,12 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-(define (church n)
-  (let loop ((application 'x) (n n))
-    (if (zero? n)
-	`(lambda (f) (lambda (x) ,application))
-	(loop `(f ,application) (- n 1)))))
-
-(define c10000 (church 10000))
-
-(define (f)
-  (eval c10000 (interaction-environment)))
diff --git a/scheme/vm/call.scm b/scheme/vm/call.scm
deleted file mode 100644
index 32b72ad..0000000
--- a/scheme/vm/call.scm
+++ /dev/null
@@ -1,628 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Code to handle the calling conventions.
-
-; *VAL* is the procedure, the arguments are on stack, and the next byte
-; is the protocol.  This checks that *VAL* is in fact a closure and checks
-; for the common case of a non-n-ary procedure that has few arguments.
-; The common case is handled directly and all others are passed off to
-; PLAIN-PROTOCOL-MATCH.
-
-(define-opcode call
-  (let ((stack-arg-count (code-byte 0)))
-    (if (closure? *val*)
-	(let* ((template (closure-template *val*))
-	       (code (template-code template)))
-	  (if (= stack-arg-count (code-vector-ref code 1))
-	      (begin
-		(set! *template* template)
-		(set-current-env! (closure-env *val*))
-		(set-code-pointer! code 2)
-		(ensure-default-procedure-space! ensure-space)
-		(if (pending-interrupt?)
-		    (goto handle-interrupt stack-arg-count)
-		    (goto interpret *code-pointer*)))
-	      (goto plain-protocol-match stack-arg-count)))
-	(goto application-exception
-	      (enum exception bad-procedure)
-	      stack-arg-count null 0))))
-
-; Two bytes of arguments.
-
-(define-opcode big-call
-  (goto perform-application (code-offset 0)))
-
-; Call a template instead of a procedure.  This is currently only used for
-; stringing together the initialization code made by the static linker.
-;
-; **limitation**: this code only works for templates that take no arguments.
-
-(define-opcode call-template
-  (let ((win (lambda ()
-	       (set-template! (get-literal 0)
-			      (enter-fixnum 2)) ; skip the protocol
-	       (if (pending-interrupt?)
-		   (goto handle-interrupt (code-byte 2))  ; pass nargs count
-		   (goto interpret *code-pointer*))))
-	(code (template-code (get-literal 0))))
-    (cond ((= 0 (code-vector-ref code 1))
-	   (ensure-default-procedure-space! ensure-space)
-	   (win))
-	  ((and (= big-stack-protocol (code-vector-ref code 1))
-		(= 0 (code-vector-ref code (- (code-vector-length code) 3))))
-	   (ensure-stack-space! (code-vector-ref16
-				   code
-				   (- (code-vector-length code) 2))
-				ensure-space)
-	   (win))
-	  (else
-	   (raise-exception wrong-type-argument 3 (get-literal 0))))))
-
-; The following two instructions are used only for experiments.  The compiler
-; does not normally use them.
-;
-; Same as op/call except that the arguments are moved to just above the
-; current continuation before the call is made.  For non-tail calls and some
-; tail-calls the arguments will already be there.
-
-(define-opcode move-args-and-call
-  (let ((nargs (code-byte 0)))
-    (move-args-above-cont! nargs)
-    (goto perform-application nargs)))
-
-(define-opcode goto-template
-  (set-template! (get-literal 0) (enter-fixnum 0))
-  (goto interpret *code-pointer*))
-
-; APPLY: *VAL* is the procedure, the rest-arg list is on top of the stack,
-; the next two bytes are the number of stack arguments below the rest-args list.
-; We check that the rest-arg list is a proper list and let
-; PERFORM-APPLICATION-WITH-REST-LIST do the work.
-    
-(define-opcode apply
-  (let ((list-args (pop)))
-    (receive (okay? length)
-	(okay-argument-list list-args)
-      (if okay?
-	  (goto perform-application-with-rest-list
-		(code-offset 0) list-args length)
-	  (begin
-	    (push list-args)
-	    (let ((args (pop-args->list* null (+ (code-offset 0) 1))))
-	      (raise-exception wrong-type-argument -1 *val* args))))))) ; no next
-
-; This is only used for the closed-compiled version of APPLY.
-;
-; Stack = arg0 arg1 ... argN rest-list N+1 total-arg-count
-; Arg0 is the procedure.
-;
-; Note that the rest-list on the stack is the rest-list passed to APPLY
-; procedure and not the rest-list to be used in the call to the procedure.
-; Consider (APPLY APPLY (LIST LIST '(1 2 3))), where the initial APPLY
-; is not done in-line.  The stack for the inner call to APPLY will be
-; [(<list-procedure> (1 2 3)), 1, 2], whereas for
-; (APPLY APPLY LIST 1 '(2 (3))) the stack will be
-; [<list-procedure>, 1, (2 (3)), 3, 4].
-;
-; We grab the counts and the procedure, and clobber the procedure's stack
-; slot for GC safety.  Then we get the true stack-arg count and list args
-; and again let PERFORM-APPLICATION-WITH-REST-LIST do the work.
-
-(define-opcode closed-apply
-  (let* ((nargs (extract-fixnum (pop)))
-	 (stack-nargs (extract-fixnum (pop)))
-	 (proc (stack-ref stack-nargs)))
-    (stack-set! stack-nargs false)
-    (receive (okay? stack-arg-count list-args list-arg-count)
-	(get-closed-apply-args nargs stack-nargs)
-      (if okay?
-	  (begin
-	    (set! *val* proc)
-	    (goto perform-application-with-rest-list
-		  stack-arg-count
-		  list-args
-		  list-arg-count))
-	  (begin
-	    (push list-args)
-	    (let ((args (pop-args->list* null (+ stack-arg-count 1))))
-	      (pop)	; remove procedure
-	      (raise-exception wrong-type-argument -1 proc args)))))))
-
-; Stack = arg0 arg1 ... argN rest-list
-; This needs to get the last argument, which is either argN or the last
-; element of the rest-list, and splice it into the rest of the arguments.
-; If the rest-list is null, then argN is the last argument and becomes the
-; new rest-list.  If the rest-list is non-null, then we go to the end, get
-; the list there, and splice the two together to make a single list.
-; This only happens if someone does (APPLY APPLY ...).
-
-(define (get-closed-apply-args nargs stack-nargs)
-  (let ((rest-list (pop)))
-    (receive (list-args stack-nargs)
-	(cond ((vm-eq? rest-list null)
-	       (values (pop)
-		       (- stack-nargs 2))) ; drop proc and final list
-	      ((vm-eq? (vm-cdr rest-list) null)
-	       (values (vm-car rest-list)
-		       (- stack-nargs 1))) ; drop proc
-	      (else
-	       (let* ((penultimate-cdr (penultimate-cdr rest-list))
-		      (list-args (vm-car (vm-cdr penultimate-cdr))))
-		 (vm-set-cdr! penultimate-cdr list-args)
-		 (values rest-list
-			 (- stack-nargs 1))))) ; drop proc
-      (receive (okay? list-arg-count)
-	  (okay-argument-list list-args)
-	(values okay?
-		stack-nargs
-		list-args
-		list-arg-count)))))
-
-; If LIST is a proper list (the final cdr is null) then we return #T and the
-; length of the list, otherwise we return #F.
-
-(define (okay-argument-list list)
-  (let loop ((fast list) (len 0) (slow list) (move-slow? #f))
-    (cond ((vm-eq? null fast)
-	   (values #t len))
-	  ((or (not (vm-pair? fast)))
-	   (values #f 0))
-	  ((not move-slow?)
-	   (loop (vm-cdr fast) (+ len 1) slow #t))
-	  ((vm-eq? fast slow)
-	   (values #f 0))
-	  (else
-	   (loop (vm-cdr fast) (+ len 1) (vm-cdr slow) #f)))))
-
-; Return the second-to-last cdr of LIST.
-
-(define (penultimate-cdr list)
-  (let loop ((list (vm-cdr (vm-cdr list))) (follower list))
-    (if (eq? null list)
-	follower
-	(loop (vm-cdr list) (vm-cdr follower)))))
-
-;----------------
-; Call the procedure in *VAL*.  STACK-ARG-COUNT is the number of arguments
-; on the stack, LIST-ARGS is a list of LIST-ARG-COUNT additional arguments.
-;
-; The CLOSURE? and protocol checks must come before the interrupt check because
-; the interrupt code assumes that the correct template is in place.  This delays
-; the handling of interrupts by a few instructions; it shouldn't matter.
-
-(define (perform-application stack-arg-count)
-  (if (closure? *val*)
-      (goto plain-protocol-match stack-arg-count)
-      (goto application-exception
-	    (enum exception bad-procedure)
-	    stack-arg-count null 0)))
-
-(define (perform-application-with-rest-list stack-arg-count
-					    list-args list-arg-count)
-  (cond ((= 0 list-arg-count)
-	 (goto perform-application stack-arg-count))
-	((closure? *val*)
-	 (goto list-protocol-match
-	       stack-arg-count list-args list-arg-count))
-	(else
-	 (goto application-exception
-	       (enum exception bad-procedure)
-	       stack-arg-count list-args list-arg-count))))
-
-(define (install-*val*-closure skip)
-  (let ((template (closure-template *val*)))
-    (set! *template* template)
-    (set-code-pointer! (template-code template) skip)
-    (set-current-env! (closure-env *val*))))
-
-(define (check-interrupts-and-go stack-slots stack-arg-count)
-  (ensure-stack-space! stack-slots ensure-space)
-  (if (pending-interrupt?)
-      (goto handle-interrupt stack-arg-count)
-      (goto interpret *code-pointer*)))
-
-(define (wrong-nargs stack-arg-count list-args list-arg-count)
-  (goto application-exception
-	(enum exception wrong-number-of-arguments)
-	stack-arg-count list-args list-arg-count))
-
-; Used by RAISE which can't raise an exception when an error occurs.
-
-(define *losing-opcode* 0)
-
-(define (call-exception-handler stack-arg-count opcode)
-  (set! *template* *val*)  ; Use *VAL* (a closure) as a marker.
-  (set! *losing-opcode* opcode)
-  (goto plain-protocol-match stack-arg-count))
-
-(define (call-interrupt-handler stack-arg-count interrupt)
-  (set! *template* *val*)  ; Use *VAL* (a closure) as a marker.
-  (set! *losing-opcode* (- interrupt))
-  (goto plain-protocol-match stack-arg-count))
-
-; Check that the arguments match those needed by *VAL*, which is a closure,
-; moving arguments to or from the stack if necessary, and ensure that there
-; is enough stack space for the procedure.  The environment needed by *VAL*
-; is created.
-
-(define (plain-protocol-match stack-arg-count)
-  (let ((code (template-code (closure-template *val*)))
-	(lose (lambda ()
-		(goto wrong-nargs stack-arg-count null 0))))
-    (assert (= (enum op protocol)
-	       (code-vector-ref code 0)))
-    (let loop ((protocol (code-vector-ref code 1))
-	       (stack-space default-stack-space))
-      (let ((win (lambda (skip stack-arg-count)
-		   (install-*val*-closure skip)
-		   (goto check-interrupts-and-go stack-space stack-arg-count))))
-	(let (;; Fixed number of arguments.
-	      (fixed-match (lambda (wants skip)
-			     (if (= wants stack-arg-count)
-				 (win skip stack-arg-count)
-				 (lose))))
-	      ;; N-ary procedure.
-	      (n-ary-match (lambda (wants-stack-args skip)
-			     (if (<= wants-stack-args stack-arg-count)
-				 (begin
-				   (rest-list-setup wants-stack-args
-						    stack-arg-count
-						    null
-						    0)
-				   (win skip (+ wants-stack-args 1)))
-				 (lose))))
-	      ;; Push the rest list, the total number of arguments, and the
-	      ;; number on the stack arguments onto the stack.
-	      (args+nargs-match (lambda (skip)
-				  (push null)
-				  (push (enter-fixnum stack-arg-count))
-				  (push (enter-fixnum stack-arg-count))
-				  (win skip (+ stack-arg-count 3)))))
-	  (cond ((= protocol nary-dispatch-protocol)
-		 (if (< stack-arg-count 3)
-		     (let ((skip (code-vector-ref code (+ 2 stack-arg-count))))
-		       (if (= 0 skip)
-			   (lose)
-			   (win skip stack-arg-count)))
-		     (let ((skip (code-vector-ref code 5)))
-		       (if (= 0 skip)
-			   (lose)
-			   (args+nargs-match skip)))))
-		((= protocol args+nargs-protocol)
-		 (if (>= stack-arg-count
-			 (code-vector-ref code 2))
-		     (args+nargs-match 3)
-		     (lose)))
-		((= protocol two-byte-nargs+list-protocol)
-		 (n-ary-match (code-vector-ref16 code 2) 4))
-		((<= protocol maximum-stack-args)
-		 (fixed-match protocol 2))
-		((= protocol two-byte-nargs-protocol)
-		 (fixed-match (code-vector-ref16 code 2) 4))
-		((= protocol big-stack-protocol)
-		 (let ((length (code-vector-length code)))
-		   (loop (code-vector-ref code (- length 3))
-			 (code-vector-ref16 code (- length 2)))))
-		(else
-		 (error "unknown protocol" protocol)
-		 (lose))))))))
-
-; Same thing, except that there is an additional list of arguments.
-
-(define (list-protocol-match stack-arg-count list-args list-arg-count)
-  (let ((code (template-code (closure-template *val*)))
-	(total-arg-count (+ stack-arg-count list-arg-count))
-	(lose (lambda ()
-		(goto wrong-nargs
-		      stack-arg-count list-args list-arg-count))))
-    (assert (= (enum op protocol)
-	       (code-vector-ref code 0)))
-    (let loop ((protocol (code-vector-ref code 1))
-	       (stack-space default-stack-space))
-      (let ((win (lambda (skip stack-arg-count)
-		   (install-*val*-closure skip)
-		   (goto check-interrupts-and-go stack-space stack-arg-count))))
-	(let (;; Fixed number of arguments.
-	      (fixed-match (lambda (wants skip)
-			     (if (= wants total-arg-count)
-				 (begin
-				   (push-list list-args list-arg-count)
-				   (win skip total-arg-count))
-				 (lose))))
-	      ;; N-ary procedure.
-	      (n-ary-match (lambda (wants-stack-args skip)
-			     (if (<= wants-stack-args total-arg-count)
-				 (begin
-				   (rest-list-setup wants-stack-args
-						    stack-arg-count
-						    list-args
-						    list-arg-count)
-				   (win skip (+ wants-stack-args 1)))
-				 (lose))))
-	      ;; If there are > 2 args the top two are pushed on the stack.
-	      ;; Then the remaining list, the total number of arguments, and
-	      ;; the number on the stack are pushed on the stack.
-	      (args+nargs-match (lambda (skip)
-				  (let ((final-stack-arg-count
-					 (if (< total-arg-count 3)
-					     total-arg-count
-					     (max 2 stack-arg-count))))
-				    (rest-list-setup (max stack-arg-count
-							  final-stack-arg-count)
-						     stack-arg-count
-						     list-args
-						     list-arg-count)
-				    (push (enter-fixnum final-stack-arg-count))
-				    (push (enter-fixnum total-arg-count))
-				    (win skip (+ final-stack-arg-count 3))))))
-	  (cond ((= protocol nary-dispatch-protocol)
-		 (if (< total-arg-count 3)
-		     (let ((skip (code-vector-ref code (+ 2 total-arg-count))))
-		       (if (= 0 skip)
-			   (lose)
-			   (begin
-			     (push-list list-args list-arg-count)
-			     (win skip total-arg-count))))
-		     (let ((skip (code-vector-ref code 5)))
-		       (if (= 0 skip)
-			   (lose)
-			   (args+nargs-match skip)))))
-		((= protocol args+nargs-protocol)
-		 (if (>= total-arg-count
-			 (code-vector-ref code 2))
-		     (args+nargs-match 3)
-		     (lose)))
-		((<= protocol maximum-stack-args)
-		 (fixed-match protocol 2))
-		((= protocol two-byte-nargs+list-protocol)
-		 (n-ary-match (code-vector-ref16 code 2) 4))
-		((= protocol two-byte-nargs-protocol)
-		 (fixed-match (code-vector-ref16 code 2) 4))
-		((= protocol big-stack-protocol)
-		 (let ((length (code-vector-length code)))
-		   (loop (code-vector-ref code (- length 3))
-			 (code-vector-ref16 code (- length 2)))))
-		(else
-		 (error "unknown protocol" protocol)
-		 (lose))))))))
-
-; Adjusts the number of stack arguments to be WANTS-STACK-ARGS by moving
-; arguments between the stack and LIST-ARGS as necessary.  Whatever is left
-; of LIST-ARGS is then copied and the copy is pushed onto the stack.
-
-(define (rest-list-setup wants-stack-args stack-arg-count list-args list-arg-count)
-  (cond ((= stack-arg-count wants-stack-args)
-	 (push (copy-list* list-args list-arg-count)))
-	((< stack-arg-count wants-stack-args)
-	 (let ((count (- wants-stack-args stack-arg-count)))
-	   (push (copy-list* (push-list list-args count)
-			     (- list-arg-count count)))))
-	(else ; (> stack-arg-count wants-stack-args)
-	 (let ((count (- stack-arg-count wants-stack-args)))
-	   (push (pop-args->list* (copy-list* list-args list-arg-count)
-				  count))))))
-
-; Raise an exception, passing to it a list of the arguments on the stack and
-; in LIST-ARGS.
-
-(define (application-exception exception
-			       stack-arg-count list-args list-arg-count)
-  (cond ((not (vm-eq? *template* *val*))
-	 (let ((args (pop-args->list* (copy-list* list-args list-arg-count)
-				      stack-arg-count)))
-	   (raise-exception* exception -1 *val* args))) ; no next opcode
-	((< 0 *losing-opcode*)
-	 (error "wrong number of arguments to exception handler"
-		*losing-opcode*))
-	(else
-	 (error "wrong number of arguments to interrupt handler"
-		(- *losing-opcode*)))))
-
-;(define (application-exception exception stack-arg-count list-args list-arg-count)
-;  (if (vm-eq? *template* *val*)
-;      (error "wrong number of arguments to exception handler"
-;             *losing-opcode*)
-;      (let ((args (pop-args->list* (copy-list* list-args list-arg-count)
-;                                   stack-arg-count)))
-;        (push (enter-fixnum (current-opcode)))
-;        (push (enter-fixnum exception))
-;        (push *val*)
-;        (push args)
-;        (goto raise 2))))
-
-; Get a two-byte number from CODE-VECTOR.
-
-(define (code-vector-ref16 code-vector index)
-  (let ((high (code-vector-ref code-vector index)))
-    (adjoin-bits high
-		 (code-vector-ref code-vector (+ index 1))
-		 bits-used-per-byte)))
-
-;----------------
-; Manipulating lists of arguments
-
-; Push COUNT elements from LIST onto the stack, returning whatever is left.
-
-(define (push-list list count)
-  (push list)
-  (ensure-stack-space! count ensure-space)
-  (let ((list (pop)))
-    (do ((i count (- i 1))
-	 (l list (vm-cdr l)))
-	((<= i 0) l)
-      (push (vm-car l)))))
-
-; Copy LIST, which has LENGTH elements.
-
-(define (copy-list* list length)
-  (if (= length 0)
-      null
-      (receive (key list)
-	  (ensure-space-saving-temp (* vm-pair-size length) list)
-	(let ((res (vm-cons (vm-car list) null key)))
-	  (do ((l (vm-cdr list) (vm-cdr l))
-	       (last res (let ((next (vm-cons (vm-car l) null key)))
-			   (vm-set-cdr! last next)
-			   next)))
-	      ((vm-eq? null l)
-	       res))))))
-
-; Pop COUNT arguments into a list with START as the cdr.
-
-(define (pop-args->list* start count)
-  (receive (key start)
-      (ensure-space-saving-temp (* vm-pair-size count) start)
-    (do ((args start (vm-cons (pop) args key))
-	 (count count (- count 1)))
-	((= count 0)
-	 args))))
-
-;----------------
-; Opcodes for the closed-compiled versions of arithmetic primitives.
-; The opcode sequences used are:
-;   binary-reduce1 binary-op binary-reduce2 return
-; and
-;   compare-reduce1 binary-comparison-op compare-reduce2 return
-; The compare version quits if the comparison operator returns false.
-;
-; For ...-reduce1 the stack looks like:
-;   arg0 arg1 ... argN rest-list N+1
-; If there are two or more arguments then at least two arguments are on the
-; stack.
-
-; Turn
-;   *stack* = arg0 (arg1 . more) <3
-; into
-;   *val* = arg1, *stack* = arg0 (arg1 .more) 1 arg0
-; or turn
-;   *stack* = arg0 arg1 ... argN rest-list N+1
-; into
-;   *val* = arg1, *stack* = false arg1 ... argN rest-list N arg0
-
-(define-opcode binary-reduce1
-  (let ((stack-nargs (extract-fixnum (stack-ref 0))))
-    (if (= stack-nargs 0)
-	(let ((rest-list (stack-ref 1))
-	      (arg0 (stack-ref 2)))
-	  (push arg0)
-	  (set! *val* (vm-car rest-list)))
-	(let ((arg0 (stack-ref (+ stack-nargs 1)))
-	      (arg1 (stack-ref stack-nargs)))
-	  (stack-set! (+ stack-nargs 1) false)
-	  (stack-set! 0 (enter-fixnum (- stack-nargs 1)))
-	  (push arg0)
-	  (set! *val* arg1)))
-    (goto continue 0)))
-
-; Turn
-;   *val* = result, *stack* = arg0 (arg1 . more) 2
-; into
-;   *stack* = result more 2
-; or turn
-;   *val* = result, *stack* = arg1 ... argN rest-list N
-; into
-;   *stack* = result ... argN rest-list N
-
-(define-opcode binary-reduce2
-  (let* ((stack-nargs (extract-fixnum (stack-ref 0)))
-	 (delta (case stack-nargs
-		  ((0)
-		   (let ((rest-list (stack-ref 1)))
-		     (if (vm-eq? (vm-cdr rest-list) null)
-			 1
-			 (begin
-			   (stack-set! 1 (vm-cdr rest-list))
-			   (stack-set! 2 *val*)
-			   -2))))
-		  ((1)
-		   (let ((rest-list (stack-ref 1)))
-		     (if (vm-eq? rest-list null)
-			 1
-			 (begin
-			   (stack-set! 0 (enter-fixnum 0))
-			   (stack-set! 2 *val*)
-			   -2))))
-		  (else
-		   (stack-set! (+ stack-nargs 1) *val*)
-		   -2))))
-    (set! *code-pointer* (address+ *code-pointer* delta))
-    (goto interpret *code-pointer*)))
-
-(define-opcode binary-comparison-reduce2
-  (if (false? *val*)
-      (goto continue 0)
-      (let* ((stack-nargs (extract-fixnum (stack-ref 0)))
-	     (delta (case stack-nargs
-		      ((0)
-		       (let ((rest-list (stack-ref 1)))
-			 (if (vm-eq? (vm-cdr rest-list) null)
-			     1
-			     (begin
-			       (stack-set! 1 (vm-cdr rest-list))
-			       (stack-set! 2 (vm-car rest-list))
-			       -2))))
-		      ((1)
-		       (let ((rest-list (stack-ref 1)))
-			 (if (vm-eq? rest-list null)
-			     1
-			     (begin
-			       (stack-set! 0 (enter-fixnum 0))
-			       -2))))
-		      (else
-		       -2))))
-	(set! *code-pointer* (address+ *code-pointer* delta))
-	(goto interpret *code-pointer*))))
-
-;----------------
-; Statistics stuff
-;
-;(define call-stats (make-vector 16 0))
-;
-;		(let ((i (min stack-arg-count 15)))
-;		  (vector-set! call-stats i (+ 1 (vector-ref call-stats i))))
-;
-;(define plain-calls (make-vector 7 0))
-;
-;(define (add-plain-call i)
-;  (vector-set! plain-calls i (+ (vector-ref plain-calls i) 1)))
-;
-;(define apply-calls (make-vector 7 0))
-;
-;(define (add-apply-call i)
-;  (vector-set! apply-calls i (+ (vector-ref apply-calls i) 1)))
-;
-;(define (dump-call-stats)
-;  (let ((out (current-output-port)))
-;    (write-string "Calls:" out)
-;    (do ((i 0 (+ i 1)))
-;        ((= i 16))
-;      (write-char #\space out)
-;      (write-integer (vector-ref call-stats i) out))
-;    (write-char #\newline out)
-;    (write-string "Plain calls" out)
-;    (write-char #\newline out)
-;    (do ((i 0 (+ i 1)))
-;        ((= i 7))
-;      (write-char #\space out)
-;      (write-string (vector-ref call-strings i) out)
-;      (write-integer (vector-ref plain-calls i) out)
-;      (write-char #\newline out))
-;    (write-string "Apply calls" out)
-;    (write-char #\newline out)
-;    (do ((i 0 (+ i 1)))
-;        ((= i 7))
-;      (write-char #\space out)
-;      (write-string (vector-ref call-strings i) out)
-;      (write-integer (vector-ref apply-calls i) out)
-;      (write-char #\newline out))))
-;
-;(define call-strings
-;  '#("nary-dispatch: "
-;     "args&nargs: "
-;     "no-env: "
-;     "two-bytes-nargs+list: "
-;     "plain: "
-;     "two-byte-nargs: "
-;     "big-stack: "))
-     
-
diff --git a/scheme/vm/data.scm b/scheme/vm/data.scm
deleted file mode 100644
index 0eef61b..0000000
--- a/scheme/vm/data.scm
+++ /dev/null
@@ -1,267 +0,0 @@
-; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; This is file data.scm.
-; Requires DEFINE-ENUMERATION macro.
-
-;;;; Data representations
-
-; This implementation of the data representations is particularly
-; tuned for byte-addressable machines with 4 bytes per word.
-; Good representations for other kinds of machines would necessarily
-; look quite different; e.g. on a word-addressed machine you might
-; want to put tag bits in the high end of a word, or even go to some
-; kind of BIBOP system.
-
-; Descriptors
-;  A descriptor describes a Scheme object.
-;  A descriptor is represented as an integer whose low two bits are
-;  tag bits.  The high bits contain information whose format and
-;  meaning are dependent on the tag.
-
-(define tag-field-width 2)
-(define data-field-width (- bits-per-cell tag-field-width))
-
-(define (make-descriptor tag data)
-  (adjoin-bits data tag tag-field-width))
-
-(define (descriptor-tag descriptor)
-  (low-bits descriptor tag-field-width))
-
-(define (descriptor-data descriptor)
-  (high-bits descriptor tag-field-width))
-
-(define (unsigned-descriptor-data descriptor)
-  (unsigned-high-bits descriptor tag-field-width))
-
-(define (set-descriptor-tag proto-descriptor tag)
-  (assert (= 0 (descriptor-tag proto-descriptor)))
-  (+ proto-descriptor tag))
-
-(define vm-eq? =)
-
-; The four tags are: fixnum, immediate (character, boolean, etc.),
-; header (gives the type and size of a stored object), and stored
-; (pointer into memory).
-; The header and immediate tags could be multiplexed, thus freeing up
-; one of the 4 type codes for some other purpose, but the
-; implementation is simpler if they're not.
-
-(define-enumeration tag
-  (fixnum
-   immediate
-   header
-   stob))
-
-;; (assert (>= (shift-left 1 tag-field-width)
-;;             (vector-length tag)))
-
-(define (fixnum? descriptor)
-  (= (descriptor-tag descriptor) (enum tag fixnum)))
-
-(define (immediate? descriptor)
-  (= (descriptor-tag descriptor) (enum tag immediate)))
-
-(define (header? descriptor)
-  (= (descriptor-tag descriptor) (enum tag header)))
-
-(define (stob? descriptor)
-  (= (descriptor-tag descriptor) (enum tag stob)))
-
-; Fixnums
-
-(define bits-per-fixnum
-  (- (if (< bits-per-cell useful-bits-per-word)
-          bits-per-cell
-          useful-bits-per-word)
-      tag-field-width))
-
-(define    least-fixnum-value (- 0 (shift-left 1 (- bits-per-fixnum 1))))
-(define greatest-fixnum-value (-   (shift-left 1 (- bits-per-fixnum 1)) 1))
-
-(define (too-big-for-fixnum? n)
-  (> n greatest-fixnum-value))
-
-(define (too-small-for-fixnum? n)
-  (< n least-fixnum-value))
-
-(define (enter-fixnum n)
-  (assert (not (or (too-big-for-fixnum? n)
-		   (too-small-for-fixnum? n))))
-  (make-descriptor (enum tag fixnum) n))
-
-(define (extract-fixnum p)
-  (assert (fixnum? p))
-  (descriptor-data p))
-
-(define (descriptor->fixnum p)
-  (enter-fixnum (descriptor-data p)))
-
-; These happen to work out, given our representation for fixnums.
-(define fixnum= =)
-(define fixnum< <)
-(define fixnum> >)
-(define fixnum<= <=)
-(define fixnum>= >=)
-
-(define (fixnum-bitwise-not x)
-  (bitwise-not (bitwise-ior x 3)))
-(define fixnum-bitwise-and bitwise-and)
-(define fixnum-bitwise-ior bitwise-ior)
-(define fixnum-bitwise-xor bitwise-xor)
-
-;----------------
-; Immediates
-;  The number 8 is chosen to streamline 8-bit-byte-oriented implementations.
-
-(define immediate-type-field-width
-  (- 8 tag-field-width))
-
-(define (make-immediate type info)
-  (make-descriptor (enum tag immediate)
-                   (adjoin-bits info type immediate-type-field-width)))
-
-(define (immediate-type imm)
-  (assert (immediate? imm))
-  (low-bits (descriptor-data imm)
-             immediate-type-field-width))
-
-(define (immediate-info imm)
-  (assert (immediate? imm))
-  (high-bits (descriptor-data imm)
-              immediate-type-field-width))
-
-(define (tag&immediate-type descriptor)
-  (low-bits descriptor (+ tag-field-width immediate-type-field-width)))
-
-(define (make-tag&immediate-type type)
-  (adjoin-bits type (enum tag immediate) tag-field-width))
-
-(define-enumeration imm
-  (false      ; #f
-   true       ; #t
-   char
-   unspecific
-   undefined
-   eof
-   null))
-
-;; (assert (>= (shift-left 1 immediate-type-field-width)
-;;             (vector-length imm)))
-
-(define (immediate-predicate type)
-  (lambda (descriptor)
-    ;; Check low 8 bits...
-    (= (tag&immediate-type descriptor)
-	(make-tag&immediate-type type))))
-
-(define vm-char?   (immediate-predicate (enum imm char)))
-(define undefined? (immediate-predicate (enum imm undefined)))
-
-(define true          (make-immediate (enum imm true) 0))
-(define false         (make-immediate (enum imm false) 0))
-(define eof-object    (make-immediate (enum imm eof)  0))
-(define null          (make-immediate (enum imm null) 0))
-(define unspecific-value  (make-immediate (enum imm unspecific) 0))
-(define quiescent         (make-immediate (enum imm undefined) 0))
-(define unbound-marker    (make-immediate (enum imm undefined) 1))
-(define unassigned-marker (make-immediate (enum imm undefined) 2))
-
-(define (false? x)
-  (vm-eq? x false))
-
-(define (enter-boolean b)
-  (if b true false))
-
-(define (extract-boolean b)
-  (assert (vm-boolean? b))
-  (if (false? b) #f #t))
-
-(define (vm-boolean? x)
-  (or (vm-eq? x false)
-      (vm-eq? x true)))
-
-; Characters
-
-(define (enter-char c)
-  (make-immediate (enum imm char) (char->ascii c)))
-
-(define (extract-char d)
-  (assert (vm-char? d))
-  (ascii->char (immediate-info d)))
-
-; these work given the representations
-(define vm-char=? =)
-(define vm-char<? <)
-
-; Headers
-
-(define header-type-field-width (- immediate-type-field-width 1))
-
-(define header-size-field-width (- data-field-width immediate-type-field-width))
-
-; Assumes headers sizes are extracted as unsigned.
-
-(define max-stob-contents-size-in-cells
-  (bytes->cells (- (shift-left 1 header-size-field-width) 1)))
-
-(define (make-header type length-in-bytes)
-  (make-descriptor (enum tag header)
-		   (adjoin-bits length-in-bytes
-				type
-				(+ 1 header-type-field-width))))
-
-(define header-immutable-bit-mask
-  (adjoin-bits 1 0 (+ header-type-field-width tag-field-width)))
-
-(define (make-header-immutable header)
-  (bitwise-ior header header-immutable-bit-mask))
-
-(define (header-type h)
-  (assert (header? h))
-  (low-bits (descriptor-data h)
-             header-type-field-width))
-
-(define (immutable-header? h)
-  (assert (header? h))
-  (not (= 0 (bitwise-and h header-immutable-bit-mask))))
-
-(define (header-length-in-bytes h)
-  (assert (header? h))
-  (unsigned-high-bits (unsigned-descriptor-data h)
-		      (+ 1 header-type-field-width)))
-
-(define (header-length-in-cells header)
-  (bytes->cells (header-length-in-bytes header)))
-
-(define (header-length-in-a-units h)
-  (cells->a-units (header-length-in-cells h)))
-
-(define (d-vector-header? h)
-  (< (header-type h) least-b-vector-type))
-
-(define (b-vector-header? h)
-  (and (header? h)
-       (>= (header-type h) least-b-vector-type)))
-
-; Stored objects
-;  The data field of a descriptor for a stored object contains the
-;  cell number of the first cell after the object's header cell.
-
-(define (address->stob-descriptor addr)
-  (set-descriptor-tag (address->integer addr) (enum tag stob)))
-
-(define stob-overhead 1)  ; header uses up one descriptor
-
-(define (address-after-header stob)
-  (assert (stob? stob))
-  (integer->address (- stob (enum tag stob))))
-
-(define (address-at-header stob)
-  (address- (address-after-header stob) (cells->a-units 1)))
-
-(define (stob-header stob)
-  (fetch (address-at-header stob)))
-
-(define (stob-header-set! stob header)
-  (store! (address-at-header stob) header))
diff --git a/scheme/vm/debug-package.scm b/scheme/vm/debug-package.scm
deleted file mode 100644
index 81b104f..0000000
--- a/scheme/vm/debug-package.scm
+++ /dev/null
@@ -1,78 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; For debugging
-
-(define-structure vm-disassembler (export disassemble write-instruction)
-  (open scheme
-	struct
-        enumerated              ; enumerand->name
-        vm-architecture
-	bitwise                 ; arithmetic-shift
-	signals)                ; error
-  (files disasm))
-
-; Independent byte-code compiler for testing (from Michael Sperber).
-
-(define-structure scan-test scan-interface
-  (open scheme-level-2
-	packages syntactic
-	usual-macros		; for dealing with (usual-transforms ...)
-	meta-types
-	packages-internal
-	signals fluids tables util
-	features		;force-output current-noise-port
-	filenames)		;translate
-  (files (bcomp scan)
-	 (bcomp undefined)))
-
-(define-structure expander-test expander-interface
-  (open scheme-level-2
-	syntactic packages scan-test meta-types reconstruction
-	define-record-types
-	util signals tables fluids strong
-	features)  ; string-hash
-  (files (opt expand)
-         (opt sort)
-	 (opt flatten)))
-
-(define-structure compiler-test compiler-interface
-  (open scheme-level-2 syntactic scan-test meta-types
-	segments
-	reconstruction
-	packages
-	packages-internal       ;only for structure-package ?
-	interfaces		;interface-ref
-	locations		;make-undefined-location
-	architecture
-	enumerated		;enumerand->name
-	signals tables util fluids 
-	features)		;force-output
-  (files (bcomp comp)
-	 (bcomp cprim)
-	 (bcomp ctop)))
-
-(define-interface evaluation-test-interface
-  (export test-eval
-	  test-load
-	  test-load-into
-	  test-eval-from-file
-	  test-eval-scanned-forms))
-
-(define-structure evaluation-test evaluation-test-interface
-  (open scheme-level-2
-	compiler-test
-	packages			;package-uid
-	environments			;package-for-load
-	closures			;make-closure
-	vm-exposure			;invoke-closure
-	scan				;noting-undefined-variables
-	i/o				;current-noise-port
-	signals fluids)
-  (files (rts eval))
-  (begin
-    (define test-eval eval)
-    (define test-load load)
-    (define test-load-into load-into)
-    (define test-eval-from-file eval-from-file)
-    (define test-eval-scanned-forms eval-scanned-forms)))
-
diff --git a/scheme/vm/defdata.scm b/scheme/vm/defdata.scm
deleted file mode 100644
index b0fe83f..0000000
--- a/scheme/vm/defdata.scm
+++ /dev/null
@@ -1,146 +0,0 @@
-; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Macros for defining data types.
-
-; An ugly and unsafe macro for defining VM data structures.
-;
-; (DEFINE-PRIMITIVE-DATA-TYPE <name> <type> <immutable?> <constructor-name>
-;                             <slot>*)
-; <slot> ::= (<accessor-name>) | (<accessor-name> <modifier-name>)
-;
-; (define-primitive-data-type pair N #f cons (car set-car!) (cdr))
-; =>
-; (begin
-;  (define (cons a b) (d-vector N ...))
-;  (define pair? (stob-predicate ...))
-;  (define pair-size 3)
-;  (define (car x) (d-vector-ref x 0))
-;  (define (set-car! x val) (d-vector-set! x 0 val))
-;  (define (cdr x) (d-vector-ref x 1))
-
-(define-syntax define-primitive-data-type
-  (lambda (exp rename compare)
-    (destructure (((d-p-d-t name type immutable? make . body) exp))
-      (define (concatenate-symbol . syms)
-	(string->symbol (apply string-append (map symbol->string syms))))
-      (let* ((pred (concatenate-symbol name '?))
-	     (size (concatenate-symbol name '- 'size))
-	     (shorten (lambda (l1 l2) (map (lambda (x1 x2) x2 x1) l1 l2)))
-	     (vars (shorten `(a b c d e f g h i j) body)))
-	`(begin ,@(if make
-		      `((define ,make
-			  (let ((type (enum stob ,type)))
-			    (lambda (,@vars key)
-			      ,(if immutable?
-				   `(immutable-d-vector type key ,@vars)
-				   `(d-vector type key ,@vars))))))
-		      '())
-		(define ,pred (stob-predicate (enum stob ,type)))
-		(define ,size (+ ,(length body) stob-overhead))
-		,@(do ((s body (cdr s))
-		       (i 0 (+ i 1))
-		       (d '() (let* ((slot (car s))
-				     (d (cons `(define (,(car slot) x)
-						 (d-vector-ref x ,i))
-					      d)))
-				(if (null? (cdr slot))
-				    d
-				    (cons `(define (,(cadr slot) x val)
-					     (d-vector-set! x ,i val))
-					  d)))))
-		      ((null? s) (reverse d))))))))
-
-; This is a front for DEFINE-PRIMITIVE-DATA-TYPE that gets the names from
-; STOB-DATA (which is defined in arch.scm).  This ensures that the run-time
-; code, the VM, and the linker agree on what these structures look like.
-;
-; SCHEME? is #T if the data structure is a Scheme structure, in which case
-; the names defined by the form all have VM- prepended.
-
-(define-syntax define-shared-primitive-data-type
-  (lambda (exp rename compare)
-    (let* ((name (cadr exp))
-	   (scheme? (if (null? (cddr exp)) #f (car (cddr exp))))
-	   (immutable? (if (or (null? (cddr exp))
-			       (null? (cdddr exp)))
-			   #f
-			   (cadr (cddr exp))))
-	   (rest (if (or (null? (cddr exp))
-			 (null? (cdddr exp)))
-		     '()
-		     (cddddr exp)))
-	   (extra-maker (if (null? rest) #f (car rest)))
-	   (extra-setters (if (or (null? rest)
-				  (null? (cdr rest)))
-			      '()
-			      (cadr rest)))
-	   (extra-fields (if (or (null? rest)
-				 (null? (cdr rest)))
-			     '()
-			     (cddr rest))))
-      (define (concatenate-symbol . syms)
-	(string->symbol (apply string-append (map symbol->string syms))))
-      (let ((data (cddr (assq name stob-data)))
-	    (fixup (lambda (n)
-		     (if scheme? (concatenate-symbol 'vm- n) n))))
-	`(define-primitive-data-type
-	   ,(fixup name)
-	   ,name
-	   ,immutable?
-	   ,(fixup (if (car data) (car data) extra-maker))
-	   . ,(map (lambda (p)
-		     (cons (fixup (car p))
-			   (cond ((and (not (null? (cdr p)))
-				       (cadr p))
-				  (list (fixup (cadr p))))
-				 ((assq (car p) extra-setters)
-				  => cdr)
-				 (else '()))))
-		   (append (cdr data) extra-fields)))))))
-
-; A d-vector macro version of the VECTOR procedure.
-; This is only used in the expansion of DEFINE-PRIMITIVE-DATA-TYPE.
-
-(define-syntax d-vector
-  (lambda (exp rename compare)
-    (destructure (((d-v type key . args) exp))
-      `(let ((v (make-d-vector ,type ,(length args) key)))
-	 ,@(do ((a args (cdr a))
-		(i 0 (+ i 1))
-		(z '() (cons `(d-vector-init! v ,i ,(car a)) z)))
-	       ((null? a) (reverse z)))
-	 v))))
-
-(define-syntax immutable-d-vector
-  (syntax-rules ()
-   ((immutable-d-vector stuff ...)
-    (let ((vec (d-vector stuff ...)))
-      (make-immutable! vec)
-      vec))))
-
-; A simpler macro for defining types of vectors.  Again SCHEME? being #T
-; causes VM- to be prepended to the defined names.
-
-(define-syntax define-vector-data-type
-  (lambda (exp rename compare)
-    (let ((name (cadr exp))
-	  (scheme? (cddr exp)))
-      (define (concatenate-symbol . syms)
-	(string->symbol (apply string-append (map symbol->string syms))))
-      (let* ((type `(enum stob ,name))
-	     (fix (if (not (null? scheme?))
-		      'vm-
-		      (string->symbol "")))
-	     (pred (concatenate-symbol fix name '?))
-	     (make (concatenate-symbol fix 'make- name))
-	     (size (concatenate-symbol fix name '- 'size))
-	     (length (concatenate-symbol fix name '- 'length))
-	     (ref (concatenate-symbol fix name '- 'ref))
-	     (set (concatenate-symbol fix name '- 'set!)))
-	`(begin (define ,make (stob-maker ,type make-d-vector))
-		(define ,pred (stob-predicate ,type))
-		(define (,size len) (+ len stob-overhead))
-		(define ,length d-vector-length)
-		(define ,ref d-vector-ref)
-		(define ,set d-vector-set!))))))
diff --git a/scheme/vm/define-primitive.scm b/scheme/vm/define-primitive.scm
deleted file mode 100644
index fa56d7f..0000000
--- a/scheme/vm/define-primitive.scm
+++ /dev/null
@@ -1,138 +0,0 @@
-; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; These are hacked to ensure that all calls to INPUT-TYPE-PREDICATE and
-; INPUT-TYPE-COERCION are evaluated at load time (because they don't
-; have readily reconstructed types).
-
-(define-syntax define-primitive
-  (syntax-rules ()
-    ((define-primitive opcode input-types action)
-     (define-consing-primitive opcode input-types #f action))
-    ((define-primitive opcode input-types action returner)
-     (define-consing-primitive opcode input-types #f action returner))))
-
-(define-syntax define-consing-primitive
-  (syntax-rules ()
-    ((define-consing-primitive opcode input-types space-proc action)
-     (let ((proc (primitive-procedure-action input-types space-proc action)))
-       (define-opcode opcode (proc))))
-    ((define-consing-primitive opcode input-types space-proc action returner)
-     (let ((proc (primitive-procedure-action input-types space-proc action returner)))
-       (define-opcode opcode (proc))))))
-  
-(define-syntax primitive-procedure-action
-  (lambda (exp rename compare)
-    (destructure (((p-p-b input-types space-proc action . returner-option) exp))
-      (let* ((nargs (length input-types))
-	     (%action       (rename 'action))
-	     (%key          (rename 'key))
-	     (%ensure-space (rename 'ensure-space))
-	     (%*val*        (rename '*val*))
-	     (%arg2         (rename 'arg2))
-	     (%arg3         (rename 'arg3))
-	     (%arg4         (rename 'arg4))
-	     (%arg5         (rename 'arg5))
-	     (%pop          (rename 'pop))
-	     (%let          (rename 'let))
-	     (%let*         (rename 'let*))
-	     (%lambda       (rename 'lambda))
-	     (%if           (rename 'if))
-	     (%and          (rename 'and))
-	     (%goto         (rename 'goto))
-	     (%input-type-predicate (rename 'input-type-predicate))
-	     (%input-type-coercion  (rename 'input-type-coercion))
-	     (%raise-exception      (rename 'raise-exception))
-	     (%wrong-type-argument  (rename 'wrong-type-argument))
-	     (shorten (lambda (l1 l2)
-			(map (lambda (x1 x2) x2 x1) l1 l2)))
-	     (places (reverse (shorten (list %*val* %arg2 %arg3 %arg4 %arg5)
-				       input-types)))
-	     (preds (reverse (shorten (map rename
-					   '(pred1 pred2 pred3 pred4 pred5))
-				      input-types)))
-	     (x->ys (reverse (shorten (map rename
-					   '(x->y1 x->y2 x->y3 x->y4 x->y5))
-				      input-types))))
-	(if (> nargs 5)
-	    (error "time to add more arguments to DEFINE-PRIMITIVE"))
-	`(,%let (,@(map (lambda (type pred)
-			  `(,pred (,%input-type-predicate ,type)))
-			input-types
-			preds)
-		 ,@(map (lambda (type x->y)
-			  `(,x->y (,%input-type-coercion ,type)))
-			input-types
-			x->ys)
-		 (,%action ,action))
-	   (,%lambda ()
-	     (,%let* (,@(if space-proc
-			  `((,%key (,%ensure-space (,space-proc ,%*val*))))
-			  '())
-		    ,@(if (>= nargs 2) `((,%arg2 (,%pop))) `())
-		    ,@(if (>= nargs 3) `((,%arg3 (,%pop))) `())
-		    ,@(if (>= nargs 4) `((,%arg4 (,%pop))) `())
-		    ,@(if (>= nargs 5) `((,%arg5 (,%pop))) `())
-		    )
-	       (,%if (,%and ,@(map (lambda (pred place)
-				     `(,pred ,place))
-				   preds
-				   places))
-		     ,(let ((yow `(,%action
-				   ,@(map (lambda (x->y place)
-					    `(,x->y ,place))
-					  x->ys
-					  places)
-				   ,@(if space-proc `(,%key) '()))))
-			(if (null? returner-option)
-			    yow
-			    `(,%goto ,(car returner-option) ,yow)))
-		     (,%raise-exception ,%wrong-type-argument
-					0
-					. ,places)))))))))
-
-;----------------
-; Checking inputs and coercing results
-
-(define (input-type pred coercer)  ;Alonzo wins
-  (lambda (f) (f pred coercer)))
-
-(define (input-type-predicate type) (type (lambda (x y) y x)))
-(define (input-type-coercion type)  (type (lambda (x y) x y)))
-
-(define (no-coercion x) x)
-
-(define any->         (input-type (lambda (x) x #t) no-coercion))
-(define fixnum->      (input-type fixnum?      extract-fixnum))
-(define char->        (input-type vm-char?     extract-char))
-(define vm-char->     (input-type vm-char?     no-coercion))
-(define boolean->     (input-type vm-boolean?  extract-boolean))
-(define location->    (input-type location?    no-coercion))
-(define string->      (input-type vm-string?   no-coercion))
-(define vector->      (input-type vm-vector?   no-coercion))
-(define code-vector-> (input-type code-vector? no-coercion))
-
-; Output coercion
-
-(define (return val)
-  (set! *val* val)
-  (goto continue 0))
-
-(define return-any return)
-
-(define (return-boolean x)
-  (goto return (enter-boolean x)))
-
-(define (return-fixnum x)
-  (goto return (enter-fixnum x)))
-
-(define (return-char x)
-  (goto return (enter-char x)))
-
-(define (return-unspecific x)
-  x ;ignored
-  (goto return unspecific-value))
-
-(define (no-result)
-  (goto return unspecific-value))
-
diff --git a/scheme/vm/disasm.scm b/scheme/vm/disasm.scm
deleted file mode 100644
index 88adc90..0000000
--- a/scheme/vm/disasm.scm
+++ /dev/null
@@ -1,164 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Disassembler that uses the VM's data structures.
-
-(define (disassemble stuff . no-subtemplates)
-  (let ((template (cond ((template? stuff) stuff)
-			((closure? stuff) (closure-template stuff))
-			((and (location? stuff)
-			      (closure? (contents stuff)))
-			 (closure-template (contents stuff)))
-			(else
-			 (error "cannot coerce to template" stuff)))))
-    (really-disassemble template
-			0
-			(if (null? no-subtemplates)
-			    #f
-			    (car no-subtemplates)))
-    (newline)))
-
-(define (really-disassemble tem level write-templates?)
-  (let loop ((pc 0))
-    (if (< pc (code-vector-length (template-code tem)))
-        (loop (write-instruction tem pc level write-templates?)))))
-
-(define (newline-indent n)
-  (newline)
-  (do ((i n (- i 1)))
-      ((= i 0))
-    (display #\space)))
-
-(define (write-pc pc)
-  (if (< pc 100) (display " "))
-  (if (< pc 10) (display " "))
-  (write pc))
-
-(define (write-instruction template pc level write-sub-templates?)
-  (let* ((code (template-code template))
-         (opcode (code-vector-ref code pc)))
-    (newline-indent (* level 3))
-    (write-pc pc)
-    (display " (")
-    (write (enumerand->name opcode op))
-    (let ((pc (cond ((= opcode (enum op computed-goto))
- 		     (display-computed-goto pc code))
- 		    ((= opcode (enum op make-flat-env))
- 		     (display-flat-env (+ pc 1) code))
-		    ((= opcode (enum op protocol))
-		     (display-protocol pc code))
- 		    (else
- 		     (print-opcode-args opcode (+ pc 1) code template
- 					level write-sub-templates?)))))
-      (display #\))
-      pc)))
-
-(define (display-computed-goto start-pc code)
-  (display #\space)
-  (let ((count (code-vector-ref code (+ start-pc 1))))
-    (write count)
-    (do ((pc (+ start-pc 2) (+ pc 2))
-	 (count count (- count 1)))
-	((= count 0) pc)
-      (display #\space)
-      (write `(=> ,(+ start-pc (get-offset pc code)))))))
-
-(define (display-flat-env pc code)
-  (let ((total-count (code-vector-ref code (+ pc 1))))
-    (display #\space) (write total-count)
-    (let loop ((pc (+ pc 2)) (count 0) (old-back 0))
-      (if (= count total-count)
-	  pc
-	  (let ((back (+ (code-vector-ref code pc)
-			 old-back))
-		(limit (+ pc 2 (code-vector-ref code (+ pc 1)))))
-	    (do ((pc (+ pc 2) (+ pc 1))
-		 (count count (+ count 1))
-		 (offsets '() (cons (code-vector-ref code pc) offsets)))
-		((= pc limit)
-		 (display #\space)
-		 (write `(,back ,(reverse offsets)))
-		 (loop pc count back))))))))
-
-(define (display-protocol pc code)
-  (let ((protocol (code-vector-ref code (+ pc 1))))
-    (display #\space)
-    (+ pc (cond ((<= protocol maximum-stack-args)
-		 (display protocol)
-		 2)
-		((= protocol two-byte-nargs-protocol)
-		 (display (get-offset (+ pc 2) code))
-		 4)
-		((= protocol two-byte-nargs+list-protocol)
-		 (display (get-offset (+ pc 2) code))
-		 (display "+")
-		 4)
-		((= protocol args+nargs-protocol)
-		 (display "args+nargs")
-		 3)
-		((= protocol nary-dispatch-protocol)
-		 (display "nary-dispatch")
-		 (do ((i 0 (+ i 1)))
-		     ((= i 4))
-		   (let ((offset (code-vector-ref code (+ pc 2 i))))
-		     (if (not (= offset 0))
-			 (begin
-			   (display #\space)
-			   (display (list (if (= i 3) "3+" i)
-					  '=>
-					  (+ pc offset)))))))
-		 6)
-		(else
-		 (error "unknown protocol" protocol))))))
-
-(define (print-opcode-args op pc code template level write-templates?)
-  (let ((specs (vector-ref opcode-arg-specs op)))
-    (let loop ((specs specs) (pc pc))
-      (cond ((or (null? specs)
-		 (= 0 (arg-spec-size (car specs))))
-	     pc)
-	    (else
-	     (display #\space)
-	     (print-opcode-arg specs pc code template level write-templates?)
-	     (loop (cdr specs) (+ pc (arg-spec-size (car specs)))))))))
-
-(define (arg-spec-size spec)
-  (case spec
-    ((nargs byte stob junk) 1)
-    ((offset small-index index two-bytes) 2)
-    (else 0)))
-
-(define (print-opcode-arg specs pc code template level write-templates?)
-  (case (car specs)
-    ((nargs byte)
-     (write (code-vector-ref code pc)))
-    ((two-bytes)
-     (write (get-offset pc code)))
-    ((index)
-     (let ((thing (template-ref template (get-offset pc code))))
-       (write-literal-thing thing level write-templates?)))
-    ((small-index)
-     (let ((thing (template-ref template (code-vector-ref code pc))))
-       (write-literal-thing thing level write-templates?)))
-    ((offset)
-     (write `(=> ,(+ pc -1 (get-offset pc code)))))  ; -1 to back up over opcode
-    ((stob)
-     (write (enumerand->name (code-vector-ref code pc) stob)))))
-
-(define (get-offset pc code)
-  (+ (* (code-vector-ref code pc)
-	byte-limit)
-     (code-vector-ref code (+ pc 1))))
-
-(define (write-literal-thing thing level write-templates?)
-  (cond ((location? thing)
-	 (write `(location ,thing ,(location-id thing))))
-	((not (template? thing))
-	 (display #\')
-	 (write thing))
-	(write-templates?
-	 (really-disassemble thing (+ level 1) #t))
-	(else
-	 (display "..."))))
-
-
diff --git a/scheme/vm/env.scm b/scheme/vm/env.scm
deleted file mode 100644
index e8ffce4..0000000
--- a/scheme/vm/env.scm
+++ /dev/null
@@ -1,98 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-(define *env*)
-
-(define (current-env) *env*)
-(define (set-current-env! env) (set! *env* env))
-
-; Access to environment slots
-
-(define env-ref  vm-vector-ref)
-(define env-set! vm-vector-set!)
-(define (env-parent env) (env-ref env 0))
-(define (set-env-parent! env x) (env-set! env 0 x))
-
-(define (env-back env back)  ;Resembles NTHCDR
-  (do ((env env (env-parent env))
-       (i back (- i 1)))
-      ((= i 0) env)))
-
-; Making new environments
-
-(define (pop-args-into-env count)
-  (push *env*)
-  (push (make-header (enum stob vector) (cells->bytes (+ count 1))))
-  (add-env-stats count)
-  (set! *env* (address->stob-descriptor (address2+ *stack*))))
-
-; Alternative method for making environments - put the values into the heap.
-
-(define (heap-env-space count)
-  (+ stob-overhead (+ count 1)))  ; includes superior environment
-
-(define (pop-args-into-heap-env count key)
-  (let ((stob (make-d-vector (enum stob vector) (+ count 1) key)))
-    (copy-memory! (address1+ *stack*)
-		  (address+ (address-after-header stob)
-			    (cells->a-units 1))
-		  (cells->bytes count))
-    (add-cells-to-stack! (- 0 count))
-    (vm-vector-set! stob 0 *env*)
-    (set! *env* stob)))
-
-; Migrate the current environment to the heap.  Used when creating a closure.
-; CURRENT-ENV-SIZE size is conservative.
-
-(define (current-env-size)
-  (if (within-stack? *env*)
-      (stack-size)
-      0))
-
-; This is what the interpreter calls when it needs to put the current
-; environment in a closure.
-
-(define (preserve-current-env key)
-  (preserve-current-env-with-reason key (enum copy closure)))
-
-(define (preserve-current-env-with-reason key reason)
-  (if (within-stack? *env*)
-      (set! *env* (save-env-in-heap *env* *cont* key reason)))
-  *env*)
-
-; 1) Copy ENV and its ancestors into heap, adding forwarding pointers
-; 2) Go down the continuation chain updating the env pointers
-;
-; This code depends on continuation-cont pointers not crossing environment
-; parent pointers on the stack.
-
-(define (save-env-in-heap env cont key reason)
-  (let ((top (copy-env env key reason)))
-    (let loop ((env top))
-      (cond ((within-stack? (env-parent env))
-             (let ((new (copy-env (env-parent env) key reason)))
-               (set-env-parent! env new)
-               (loop new)))))
-    (let loop ((cont cont))
-      (let ((env (continuation-env cont)))
-        (cond ((and (stob? env)
-                    (stob? (stob-header env)))
-               (set-continuation-env! cont (stob-header env))
-               (loop (continuation-cont cont))))))
-    top))
-
-; ARGUMENTS-ON-STACK needs to walk down the stack and find the end of the
-; current arguments.  It looks for headers, which we clobber with forwarding
-; pointers, so we put a marker in the first slot of the environment and
-; ARGUMENTS-ON-STACK knows to back up one if it finds the marker.
-; (Putting the forwarding pointer in the first slot doesn't work, because
-;  we can't distinguish between it and a normal first slot.)
-
-(define (copy-env env key reason)
-  (let ((new (header+contents->stob (stob-header env)
-				    (address-after-header env)
-				    key)))
-    (add-copy-env-stats env reason)
-    (vm-vector-set! env 0 argument-limit-marker)
-    (stob-header-set! env new)
-    new))
diff --git a/scheme/vm/error-util.scm b/scheme/vm/error-util.scm
deleted file mode 100644
index 61aa2e8..0000000
--- a/scheme/vm/error-util.scm
+++ /dev/null
@@ -1,13 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-(define (error? status)
-  (not (eq? status (enum errors no-errors))))
-
-(define (write-error-string string)
-  (write-string string (current-error-port)))
-
-(define (write-error-integer integer)
-  (write-integer integer (current-error-port)))
-
-(define (error-newline)
-  (write-char #\newline (current-error-port)))
diff --git a/scheme/vm/external.scm b/scheme/vm/external.scm
deleted file mode 100644
index 9fa2e64..0000000
--- a/scheme/vm/external.scm
+++ /dev/null
@@ -1,18 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-(define (fake-it name)
-  (lambda args
-    (display "Call to ")
-    (display (cons name args))
-    (newline)
-    0))
-
-(define extended-vm        (fake-it 'extended-vm))
-(define external-call      (fake-it 'call-external-value))
-(define schedule-interrupt (fake-it 'schedule-interrupt))
-
-(define (real-time) 0)
-(define (run-time) 0)
-(define (cheap-time) 0)
-
diff --git a/scheme/vm/fixnum-op.scm b/scheme/vm/fixnum-op.scm
deleted file mode 100644
index c68444b..0000000
--- a/scheme/vm/fixnum-op.scm
+++ /dev/null
@@ -1,140 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Fixnum-only primitive operations
-
-; These predicates are used to characterize the numeric representations that
-; are implemented in the VM.
-
-(define (unary-lose x)
-  (raise-exception wrong-type-argument 0 x))
-
-(define (binary-lose x y)
-  (raise-exception wrong-type-argument 0 x y))
-
-(define-primitive number? (any->)
-  (lambda (x)
-    (or (fixnum? x)
-	(bignum? x)
-	(ratnum? x)
-	(double? x)
-	(extended-number? x)))
-  return-boolean)
-  
-(define (vm-number-predicate rationals? doubles?)
-  (lambda (n)
-    (cond ((or (fixnum? n)
-	       (bignum? n)
-	       (and rationals? (ratnum? n))
-	       (and doubles? (double? n)))
-	   (goto return-boolean #t))
-	  ((extended-number? n)
-	   (unary-lose n))
-	  (else
-	   (goto return-boolean #f)))))
-
-(define-primitive integer?  (any->) (vm-number-predicate #f #f))
-(define-primitive rational? (any->) (vm-number-predicate #t #t))
-(define-primitive real?     (any->) (vm-number-predicate #t #t))
-(define-primitive complex?  (any->) (vm-number-predicate #t #t))
-
-;----------------
-; A macro for defining primitives that only operate on fixnums.
-
-(define-syntax define-fixnum-only
-  (syntax-rules ()
-    ((define-fixnum-only (opcode arg) value)
-     (define-primitive opcode (any->)
-       (lambda (arg)
-	 (if (fixnum? arg)
-	     (goto return value)
-	     (unary-lose arg)))))
-    ((define-fixnum-only (opcode arg0 arg1) value)
-     (define-primitive opcode (any-> any->)
-       (lambda (arg0 arg1)
-	 (if (and (fixnum? arg0)
-		  (fixnum? arg1))
-	     (goto return value)
-	     (binary-lose arg0 arg1)))))))
-
-; These primitives have a simple answer in the case of fixnums; for all others
-; they punt to the run-time system.
-
-(define-fixnum-only (exact?      n) true)
-(define-fixnum-only (real-part   n) n)
-(define-fixnum-only (imag-part   n) (enter-fixnum 0))
-(define-fixnum-only (floor       n) n)
-(define-fixnum-only (numerator   n) n)
-(define-fixnum-only (denominator n) (enter-fixnum 1))
-
-(define-primitive angle (any->)
-  (lambda (n)
-    (if (and (fixnum? n)
-	     (>= n 0))
-	(goto return (enter-fixnum 0))
-	(unary-lose n))))
-
-(define-primitive magnitude (any->)
-  (lambda (n)
-    (if (fixnum? n)
-	(abs-carefully n
-		       (lambda (r)
-			 (goto return r))
-		       unary-lose)
-	(unary-lose n))))
-
-; These all just raise an exception and let the run-time system do the work.
-
-(define-syntax define-punter
-  (syntax-rules ()
-    ((define-punter opcode)
-     (define-primitive opcode (any->) unary-lose))))
-
-(define-punter exact->inexact)
-(define-punter inexact->exact)
-(define-punter exp)
-(define-punter log)
-(define-punter sin)
-(define-punter cos)
-(define-punter tan)
-(define-punter asin)
-(define-punter acos)
-(define-punter sqrt)
-
-(define-syntax define-punter2
-  (syntax-rules ()
-    ((define-punter2 opcode)
-     (define-primitive opcode (any-> any->) binary-lose))))
-
-(define-punter2 atan)
-(define-punter2 make-polar)
-(define-punter2 make-rectangular)
-
-(define-syntax define-binop
-  (syntax-rules ()
-    ((define-binop opcode careful-op)
-     (define-primitive opcode (any-> any->)
-       (lambda (x y)
-	 (if (and (fixnum? x)
-		  (fixnum? y))
-	     (goto careful-op x y return binary-lose)
-	     (binary-lose x y)))))))
-
-(define-binop + add-carefully)
-(define-binop - subtract-carefully)
-(define-binop * multiply-carefully)
-(define-binop / divide-carefully)
-(define-binop quotient         quotient-carefully)
-(define-binop remainder        remainder-carefully)
-(define-binop arithmetic-shift shift-carefully)
-
-(define-fixnum-only (=  x y) (enter-boolean (fixnum=  x y)))
-(define-fixnum-only (<  x y) (enter-boolean (fixnum<  x y)))
-(define-fixnum-only (>  x y) (enter-boolean (fixnum>  x y)))
-(define-fixnum-only (<= x y) (enter-boolean (fixnum<= x y)))
-(define-fixnum-only (>= x y) (enter-boolean (fixnum>= x y)))
-
-(define-fixnum-only (bitwise-not x)   (fixnum-bitwise-not x))
-(define-fixnum-only (bitwise-and x y) (fixnum-bitwise-and x y))
-(define-fixnum-only (bitwise-ior x y) (fixnum-bitwise-ior x y))
-(define-fixnum-only (bitwise-xor x y) (fixnum-bitwise-xor x y))
diff --git a/scheme/vm/gc-package-defs.scm b/scheme/vm/gc-package-defs.scm
deleted file mode 100644
index 0d2f661..0000000
--- a/scheme/vm/gc-package-defs.scm
+++ /dev/null
@@ -1,30 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; These are used to compile the GC separately from the VM.  It has new
-; definitions of the VM structures that the GC uses, with all of the values
-; defined as externals.  We only need to define those values that the GC
-; actually uses.
-
-; These are all called when writing images.
-
-(define-structure symbols (export s48-copy-symbol-table)
-  (open prescheme)
-  (begin
-    (define s48-copy-symbol-table
-      (external "s48_copy_symbol_table" (=> () integer)))))
-
-(define-structure vmio (export s48-mark-traced-channels-closed!)
-  (open prescheme)
-  (begin
-    (define s48-mark-traced-channels-closed!
-      (external "s48_mark_traced_channels_closedB" (=> () null)))))
-
-(define-structure external-opcodes (export s48-cleaned-imported-bindings
-					   s48-exported-bindings)
-  (open prescheme)
-  (begin
-    (define s48-cleaned-imported-bindings
-      (external "s48_cleaned_imported_bindings" (=> () integer)))
-    (define s48-exported-bindings
-      (external "s48_exported_bindings" (=> () integer)))))
diff --git a/scheme/vm/generic-arith.scm b/scheme/vm/generic-arith.scm
deleted file mode 100644
index 9d3dce1..0000000
--- a/scheme/vm/generic-arith.scm
+++ /dev/null
@@ -1,366 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Generic arithmetic.
-
-; The different kinds of numbers.
-
-(define-enumeration numbers
-  (fixnum
-   bignum
-   rational
-   float
-   complex
-   not-a-number))
-
-; Mapping numbers to their representation.
-
-(define stob-numbers
-  (make-vector stob-count (enum numbers not-a-number)))
-
-; For now all we have are bignums (and fixnums, of course).
-(vector-set! stob-numbers (enum stob bignum) (enum numbers bignum))
-
-(define (number->representation x)
-  (cond ((fixnum? x)
-	 (enum numbers fixnum))
-	((stob? x)
-	 (vector-ref stob-numbers (header-type (stob-header x))))
-	(else
-	 (enum numbers not-a-number))))
-
-;----------------
-; Tables for unary and binary operations.  All entries initially return DEFAULT.
-
-(define (make-unary-table default)
-  (make-vector numbers-count
-	       (lambda (x)
-		 default)))
-	
-; (unary-table-set! <table> <type> <value>)
-; (unary-table-set! <table> (<type> ...) <value>)
-
-(define-syntax unary-table-set!
-  (syntax-rules ()
-    ((unary-table-set! ?table (?kind ...) ?value)
-     (real-unary-table-set! ?table (list (enum numbers ?kind) ...) ?value))
-    ((unary-table-set! ?table ?kind ?value)
-     (real-unary-table-set! ?table (list (enum numbers ?kind)) ?value))))
-
-(define (real-unary-table-set! table kinds value)
-  (for-each (lambda (kind)
-	      (vector-set! table kind value))
-	    kinds))
-
-(define (unary-dispatch table x)
-  ((vector-ref table
-	       (number->representation x))
-     x))
-
-(define (make-binary-table default)
-  (make-vector (* numbers-count numbers-count)
-	       (lambda (x y)
-		 default)))
-
-; Same as for unary tables, except that we have two indexes or lists of indexes.
-
-(define-syntax binary-table-set!
-  (syntax-rules ()
-    ((binary-table-set! ?table (?kind0 ...) (?kind1 ...) ?value)
-     (real-binary-table-set! ?table
-			     (list (enum numbers ?kind0) ...)
-			     (list (enum numbers ?kind1) ...)
-			     ?value))
-    ((binary-table-set! ?table (?kind0 ...) ?kind1 ?value)
-     (real-binary-table-set! ?table
-			     (list (enum numbers ?kind0) ...)
-			     (list (enum numbers ?kind1))
-			     ?value))
-    ((binary-table-set! ?table ?kind0 (?kind1 ...) ?value)
-     (real-binary-table-set! ?table
-			     (list (enum numbers ?kind0))
-			     (list (enum numbers ?kind1) ...)
-			     ?value))
-    ((binary-table-set! ?table ?kind0 ?kind1 ?value)
-     (real-binary-table-set! ?table
-			     (list (enum numbers ?kind0))
-			     (list (enum numbers ?kind1))
-			     ?value))))
-
-(define (real-binary-table-set! table kinds0 kinds1 value)
-  (for-each (lambda (kind0)
-	      (for-each (lambda (kind1)
-			  (vector-set! table
-				       (+ (* kind0 numbers-count)
-					  kind1)
-				       value))
-			kinds1))
-	    kinds0))
-
-; Does this need to be changed to get a computed goto?
-
-(define (binary-dispatch table x y)
-  ((vector-ref table
-	       (+ (* (number->representation x)
-		     numbers-count)
-		  (number->representation y)))
-     x
-     y))
-
-(define (binary-lose x y)
-  unspecific-value)
-
-;----------------
-; The actual opcodes
-
-; Predicates
-
-(define-primitive number? (any->)
-  (lambda (x)
-    (not (= (number->representation x)
-	    (enum numbers not-a-number))))
-  return-boolean)
-
-(define-primitive integer? (any->)
-  (lambda (x)
-    (let ((type (number->representation x)))
-      (or (= type (enum numbers fixnum))
-	  (= type (enum numbers bignum)))))
-  return-boolean)
-
-(define-primitive rational? (any->)
-  (lambda (x)
-    (let ((type (number->representation x)))
-      (or (= type (enum numbers fixnum))
-	  (= type (enum numbers bignum))
-	  (= type (enum numbers rational)))))
-  return-boolean)
-
-(define-primitive real? (any->)
-  (lambda (x)
-    (let ((type (number->representation x)))
-      (not (or (= type (enum numbers complex))
-	       (= type (enum numbers not-a-number))))))
-  return-boolean)
-
-(define-primitive complex? (any->)
-  (lambda (x)
-    (not (= (number->representation x)
-	    (enum numbers not-a-number))))
-  return-boolean)
-
-(define-primitive exact? (any->)
-  (lambda (x)
-    (enum-case number (number->representation x)
-	       ((float)
-		(goto return-boolean #f))
-	       ((complex)
-		(goto return-boolean (not (float? (complex-real-part x)))))
-	       ((not-a-number)
-		(raise-exception wrong-type-argument 0 x))
-	       (else
-		(goto return-boolean #t)))))
-
-;----------------
-; Arithmetic
-
-(define-syntax define-binary-primitive
-  (syntax-rules ()
-    ((define-binary-primitive id table careful integer)
-     (define table (make-binary-table binary-lose))
-     (define-primitive id (any-> any->)
-       (lambda (x y)
-	 (if (and (fixnum? x)
-		  (fixnum? y))
-	     (goto careful
-		   x
-		   y
-		   return
-		   (lambda (x y)
-		     (goto return (integer x y))))
-	     (let ((r (binary-dispatch table x y)))
-	       (if (vm-eq? r unspecific-value)
-		   (raise-exception wrong-type-argument 0 x y)
-		   (goto return r))))))
-     (binary-table-set! table (fixnum bignum) (fixnum bignum) integer))))
-
-(define-binary-primitive + add-table add-carefully integer-add)
-(define-binary-primitive - subtract-table subtract-carefully integer-subtract)
-(define-binary-primitive * multiply-table multiply-carefully integer-multiply)
-(define-binary-primitive quotient quotient-table quotient-carefully integer-quotient)
-(define-binary-primitive remainder remainder-table remainder-carefully integer-remainder)
-(define-binary-primitive arithmetic-shift shift-table shift-carefully integer-shift)
-
-; Hm.  There is no integer-divide (obviously)
-
-(define-binary-primitive / divide-table divide-carefully integer-)
-
-
-
-
-
-
-
-
-
-
-
-
-****************************************************************
-
-How to structure all this?  It would be nice if the interpreter could be
-broken into several modules.  The registers and define-primitive would
-need to be separated out.
-
-;----------------
-; Tower predicates.
-; These need to be changed.
-
-(define-unary-opcode-extension integer?       &integer?  #f)
-(define-unary-opcode-extension rational?      &rational? #f)
-(define-unary-opcode-extension real?          &real?     #f)
-(define-unary-opcode-extension complex?       &complex?  #f)
-(define-unary-opcode-extension number?        &number?   #f)
-(define-unary-opcode-extension exact?         &exact?    #f)
-
-(let ((true (lambda (x) #t)))
-  (unary-table-set! &integer?  (fixnum bignum)                        true)
-  (unary-table-set! &rational? (fixnum bignum rational)               true)
-  (unary-table-set! &real?     (fixnum bignum rational float)         true)
-  (unary-table-set! &complex?  (fixnum bignum rational float complex) true)
-  (unary-table-set! &number?   (fixnum bignum rational float complex) true)
-  (unary-table-set! &exact?    (fixnum bignum rational)               true))
-
-; The two parts of a complex number must have the same exactness.
-
-(unary-table-set! &exact? (complex)
-		  (lambda (z)
-		    (real-part z)))
-
-;----------------
-; Imaginary operations.
-
-(define-unary-opcode-extension real-part      &real-part (lambda (x) x))
-(define-unary-opcode-extension imag-part      &imag-part (lambda (x) 0))
-
-(unary-table-set! &real-part (complex not-a-number)
-		  (lambda (x) unimplemented))
-
-(unary-table-set! &imag-part (complex not-a-number)
-		  (lambda (x) unimplemented))
-
-;----------------
-; Fractions
-
-(define-unary-opcode-extension floor          &floor)
-(define-unary-opcode-extension numerator      &numerator)
-(define-unary-opcode-extension denominator    &denominator)
-
-(define (identity x) x)
-
-(unary-table-set! &floor       (fixnum bignum) identity)
-(unary-table-set! &numerator   (fixnum bignum) identity)
-(unary-table-set! &denominator (fixnum bignum) (lambda (x) 1))
-
-;----------------
-; Square root.
-
-(define-unary-opcode-extension sqrt &sqrt)
-
-; The bignum code could whack this.
-; The VM doesn't do sqrt for positive fixnums.  I wonder why?
-
-; For negative N, we lose if MAKE-RECTANGULAR loses.
-
-(unary-table-set! &sqrt (fixnum bignum)
-  (lambda (n)
-    (if (>= n 0)
-	(non-negative-integer-sqrt n)	;Dubious (JAR)
-	(let ((s (non-negative-integer-sqrt (- n))))
-	  (if (eq? s unimplemented)
-	      s
-	      (binary-dispatch &make-rectangular
-			       0
-			       s))))))
-
-; Courtesy of Mr. Newton.
-
-(define (non-negative-integer-sqrt n)
-  (if (<= n 1)    ; for both 0 and 1
-      n
-      (let loop ((m (quotient n 2)))
-	(let ((m1 (quotient n m)))
-	  (cond ((< m1 m)
-		 (loop (quotient (+ m m1) 2)))
-		((= n (* m m))
-		 m)
-		(else
-		 unimplemented))))))
-
-;----------------
-; Make sure this has very low priority, so that it's only tried as a
-; last resort.
-;
-; In fact, I'll comment it out completely. -RK
-
-;(define-method &/ (m n)
-;  (if (and (integer? m) (integer? n))
-;      (if (= 0 (remainder m n))
-;          (quotient m n)
-;          (let ((z (abs (quotient n 2))))
-;            (set-exactness (quotient (if (< m 0)
-;                                         (- m z)
-;                                         (+ m z))
-;                                     n)
-;                           #f)))
-;      (next-method)))
-
-;----------------
-; The rest have no useful defaults.
-
-(define-unary-opcode-extension exact->inexact &exact->inexact)
-(define-unary-opcode-extension inexact->exact &inexact->exact)
-
-(define-binary-opcode-extension +              &+)
-(define-binary-opcode-extension -              &-)
-(define-binary-opcode-extension *              &*)
-(define-binary-opcode-extension /              &/)
-(define-binary-opcode-extension =              &=)
-(define-binary-opcode-extension <              &<)
-(define-binary-opcode-extension quotient       &quotient)
-(define-binary-opcode-extension remainder      &remainder)
-  
-(define-binary-opcode-extension make-rectangular &make-rectangular)
-
-(define-unary-opcode-extension exp  &exp)
-(define-unary-opcode-extension log  &log)
-(define-unary-opcode-extension sin  &sin)
-(define-unary-opcode-extension cos  &cos)
-(define-unary-opcode-extension tan  &tan)
-(define-unary-opcode-extension asin &asin)
-(define-unary-opcode-extension acos &acos)
-(define-unary-opcode-extension atan &atan)
-
-; >, <=, and >= are all extended using the table for <.
-
-(extend-opcode! (enum op >)
-		(lambda (lose)
-		  (lambda (reason arg0 arg1)
-		    (let ((res (binary-dispatch &< arg1 arg0)))
-		      (if (eq? res unimplemented)
-			  (lose reason arg0 arg1)
-			  res)))))
-(extend-opcode! (enum op <=)
-		(lambda (lose)
-		  (lambda (reason arg0 arg1)
-		    (let ((res (binary-dispatch &< arg1 arg0)))
-		      (if (eq? res unimplemented)
-			  (lose reason arg0 arg1)
-			  (not res))))))
-(extend-opcode! (enum op >=)
-		(lambda (lose)
-		  (lambda (reason arg0 arg1)
-		    (let ((res (binary-dispatch &< arg0 arg1)))
-		      (if (eq? res unimplemented)
-			  (lose reason arg0 arg1)
-			  (not res))))))
-
diff --git a/scheme/vm/image.scm b/scheme/vm/image.scm
deleted file mode 100644
index bc374e1..0000000
--- a/scheme/vm/image.scm
+++ /dev/null
@@ -1,328 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Write-image and read-image
-
-(define (s48-image-writing-okay?)
-  (not (have-static-areas?)))
-
-(define *status* (enum errors no-errors))
-
-(define-syntax write-check
-  (syntax-rules ()
-    ((write-check exp)
-     (if (eq? *status* (enum errors no-errors))
-	 (set! *status* exp)))))
-
-(define (write-heap-integer n port)
-  (write-check (write-integer n port))
-  (write-check (write-char #\newline port)))
-
-(define (s48-write-image resume-proc port)
-  (begin-writing-image)
-  (let ((resume-proc (s48-trace-value resume-proc))
-	(exported-bindings (s48-trace-value (s48-exported-bindings))))
-    (s48-do-gc)
-    (s48-mark-traced-channels-closed!)
-    (let ((symbols (s48-copy-symbol-table))
-	  (imported-bindings (s48-cleaned-imported-bindings))
-	  (resumer-records (find-resumer-records)))
-      (if (vm-eq? false resumer-records)
-	  (begin
-	    (abort-collection)
-	    (enum errors out-of-memory))
-	  (let ((status (really-write-image port resume-proc
-					    symbols
-					    imported-bindings
-					    exported-bindings
-					    resumer-records)))
-	    (abort-collection)
-	    status)))))
-
-(define (really-write-image port restart-proc
-			    symbols imported-bindings exported-bindings
-			    resumer-records)
-  (set! *status* (enum errors no-errors))
-  (write-check (write-char #\newline port))
-  (write-check (write-page port))
-  (write-check (write-char #\newline port))
-  (write-check (write-string architecture-version port))
-  (write-check (write-char #\newline port))
-  (write-heap-integer bytes-per-cell port)
-  (write-heap-integer (a-units->cells (address->integer (heap-start))) port)
-  (write-heap-integer (a-units->cells (address->integer (heap-pointer))) port)
-  (write-heap-integer symbols port)
-  (write-heap-integer imported-bindings port)
-  (write-heap-integer exported-bindings port)
-  (write-heap-integer resumer-records port)
-  (write-heap-integer restart-proc port)
-  (write-check (write-page port))
-  (store! (heap-pointer) 1)  ; used to detect endianess of image
-  (write-check (write-block port
-			    (heap-pointer)
-			    (address-difference (address1+ (heap-pointer)) (heap-pointer))))
-  (write-check (write-block port
-			    (heap-start)
-			    (address-difference (heap-pointer) (heap-start))))
-  *status*)
-
-; Make sure the image file is okay and return the size of the heap it
-; contains.
-
-(define *eof?* #f)
-
-(define-syntax read-check
-  (syntax-rules ()
-    ((read-check exp)
-     (read-check exp -1))
-    ((read-check exp losing-value)
-     (let ((lose losing-value))
-       (if *eof?*
-	   lose
-	   (receive (thing eof? status)
-	       exp
-	     (cond (eof?
-		    (set! *eof?* #t)
-		    lose)
-		   ((eq? *status* (enum errors no-errors))
-		    thing)
-		   (else
-		    (set! *eof?* #t)
-		    (set! *status* status)
-		    lose))))))))
-
-; Read in the ASCII portion of the image and make sure that it is compatible
-; with this version of the VM.
-
-(define (s48-check-image-header filename)
-  (receive (port status)
-      (open-input-file filename)
-    (cond ((error? status)
-	   (error-message  "Can't open heap image file")
-	   (error-message (error-string status))
-	   -1)
-	  (else
-	   (set! *status* (enum errors no-errors))
-	   (set! *eof?* #f)
-	   (read-check (read-page port))
-	   (read-check (read-newline port)) ; version starts on next line
-	   (let* ((same-version? (read-check (check-image-version port) #f))
-		  (old-bytes-per-cell (read-check (read-integer port))))
-	     (set! *old-begin*
-		   (integer->address
-		     (cells->a-units (read-check (read-integer port)))))
-	     (set! *old-hp*
-		   (integer->address
-		     (cells->a-units (read-check (read-integer port)))))
-	     (set! *symbols*           (read-check (read-integer port)))
-	     (set! *imported-bindings* (read-check (read-integer port)))
-	     (set! *exported-bindings* (read-check (read-integer port)))
-	     (set! *resumer-records*   (read-check (read-integer port)))
-	     (set! *startup-procedure* (read-check (read-integer port)))
-	     (set! *image-port* port)
-	     (read-check (read-page port)) ; read to beginning of heap
-	     (cond ((error? *status*)
-		    (read-lost "Error reading from image file" port))
-		   (*eof?*   ; has to come after *status* check
-		    (set! *status* (enum errors parse-error))
-		    (read-lost "Premature EOF when reading image file" port))
-		   ((not same-version?)
-		    (read-lost "Format of image is incompatible with this version of system" port))
-		   ((not (= old-bytes-per-cell bytes-per-cell))
-		    (read-lost "Incompatible bytes-per-cell in image" port))
-		   (else
-		    (address-difference *old-hp* *old-begin*))))))))
-
-(define (read-page port)
-  (read-this-character page-character port))
-
-(define (read-newline port)
-  (read-this-character #\newline port))
-
-(define (read-this-character char port)
-  (let loop ()
-    (receive (ch eof? status)
-	(read-char port)
-      (cond ((or eof? (error? status))
-	     (values -1 eof? status))
-	    ((char=? char ch)
-	     (values -1 #f status))
-	    (else
-	     (loop))))))
-
-(define (check-image-version port)
-  (let ((len (string-length architecture-version)))
-    (let loop ((i 0))
-      (receive (ch eof? status)
-	  (read-char port)
-	(cond ((or eof? (error? status))
-	       (values #f eof? status))
-	      ((= i len)
-	       (values (char=? #\newline ch) #f status))
-	      ((char=? ch (string-ref architecture-version i))
-	       (loop (+ i 1)))
-	      (else
-	       (values #f #f status)))))))
-
-(define *image-port*)
-(define *old-begin*)
-(define *old-hp*)
-
-;----------------
-; Values provided by the image file.
-
-(define *startup-procedure*)
-(define *symbols*)
-(define *imported-bindings*)
-(define *exported-bindings*)
-(define *resumer-records*)
-
-(define *initializing?* #t)
-
-; Save initial values across any GC's.
-
-(define (s48-initializing-gc-root)
-  (if *initializing?*
-      (begin
-	(set! *startup-procedure* (s48-trace-value *startup-procedure*))
-	(set! *symbols*           (s48-trace-value *symbols*))
-	(set! *imported-bindings* (s48-trace-value *imported-bindings*))
-	(set! *exported-bindings* (s48-trace-value *exported-bindings*))
-	(set! *resumer-records*   (s48-trace-value *resumer-records*)))))
-  
-; For the outside world.
-
-(define (s48-startup-procedure)         *startup-procedure*)
-(define (s48-initial-symbols)           *symbols*)
-(define (s48-initial-imported-bindings) *imported-bindings*)
-(define (s48-initial-exported-bindings) *exported-bindings*)
-(define (s48-resumer-records)           *resumer-records*)
-
-(define (s48-initialization-complete!)
-  (set! *initializing?* #f))
-
-; For resuming static images.
-
-(define (s48-set-image-values! startup-proc symbols imports exports records)
-  (set! *startup-procedure* startup-proc)
-  (set! *symbols*           symbols)
-  (set! *imported-bindings* imports)
-  (set! *exported-bindings* exports)
-  (set! *resumer-records*   records))
-
-;----------------
-
-(define (s48-read-image)
-  (let ((port *image-port*))
-    (receive (okay? string)
-	(image-read-block port (cells->a-units 1))
-      (cond ((not okay?)
-	     (read-lost string port))
-	    ((= (fetch (heap-pointer)) 1)
-	     (really-read-image port #f))
-	    (else
-	     (reverse-descriptor-byte-order! (heap-pointer))
-	     (if (= (fetch (heap-pointer)) 1)
-		 (really-read-image port #t)
-		 (read-lost "Unable to correct byte order" port)))))))
-
-(define (really-read-image port reverse?)
-  (let* ((delta (address-difference (heap-pointer) *old-begin*))
-	 (new-hp (address+ *old-hp* delta))
-	 (new-limit (heap-limit))
-	 (start (heap-pointer)))
-    (if (address>= new-hp new-limit)
-	(read-lost "Heap not big enough to restore this image" port)
-	(receive (okay? string)
-	    (image-read-block port (address-difference *old-hp* *old-begin*))
-	  (receive (ch eof? status)
-	      (read-char port)
-	    (cond ((not okay?)
-		   (read-lost string port))
-		  ((error? status)
-		   (read-lost "Error reading from image file" port))
-		  ((not eof?)
-		   (read-lost "Image file has extraneous data after image" port))
-		  ((error? (close-input-port port))
-		   (read-lost "Error closing image file" port))
-		  (else
-		   (if reverse?
-		       (reverse-byte-order! start new-hp))
-		   (if (not (= delta 0))
-		       (relocate-image delta start new-hp))
-		   (set-heap-pointer! new-hp)
-		   (set! *startup-procedure* (adjust *startup-procedure* delta))
-		   (set! *symbols*           (adjust *symbols* delta))
-		   (set! *imported-bindings* (adjust *imported-bindings* delta))
-		   (set! *exported-bindings* (adjust *exported-bindings* delta))
-		   (set! *resumer-records*   (adjust *resumer-records* delta))
-		   0)))))))
-
-(define (image-read-block port need)
-  (receive (got eof? status)
-      (read-block port (heap-pointer) need)
-    (cond ((error? status)
-	   (set! *status* status)
-	   (values #f "Error reading from image file"))
-	  (eof?
-	   (values #f "Premature EOF when reading image file"))
-	  ((< got need)
-	   (values #f "Read returned too few bytes"))
-	  (else
-	   (values #t "")))))
-
-(define (read-lost message port)
-  (error-message message)
-  (if (error? *status*)
-      (error-message (error-string *status*)))
-  (if (error? (close-input-port port))
-      (error-message "Error closing image file"))
-  -1)
-
-; ABCD => DCBA
-
-; memory intensive, but independent of Scheme's integer size
-
-(define (reverse-descriptor-byte-order! addr)
-  (let ((x (fetch-byte addr)))
-    (store-byte! addr (fetch-byte (address+ addr 3)))
-    (store-byte! (address+ addr 3) x))
-  (let ((x (fetch-byte (address+ addr 1))))
-    (store-byte! (address+ addr 1) (fetch-byte (address+ addr 2)))
-    (store-byte! (address+ addr 2) x)))
-
-(define (reverse-byte-order! start end)
-  (error-message "Correcting byte order of resumed image.")
-  (let loop ((ptr start))
-    (if (address< ptr end)
-	(begin
-	  (reverse-descriptor-byte-order! ptr)
-	  (loop (let ((value (fetch ptr))
-		      (next (address1+ ptr)))
-		  (if (b-vector-header? value)
-		      (address+ next (header-length-in-a-units value))
-		      next)))))))
-
-(define (adjust descriptor delta)
-  (if (stob? descriptor)
-      (address->stob-descriptor
-        (address+ (address-after-header descriptor) delta))
-      descriptor))
-
-(define (relocate-image delta start end)
-  (let loop ((ptr start))
-    (if (address< ptr end)
-	(let ((d (adjust (fetch ptr) delta)))
-	  (store! ptr d)
-	  (loop (if (b-vector-header? d)
-		    (address+ (address1+ ptr) (header-length-in-a-units d))
-		    (address1+ ptr)))))))
-
-; The page character is used to mark the ends of the user and prelude sections
-; of image files.
-
-(define page-character (ascii->char 12))
-
-(define (write-page port)
-  (write-char page-character port))
-
diff --git a/scheme/vm/integer-op.scm b/scheme/vm/integer-op.scm
deleted file mode 100644
index 5a68829..0000000
--- a/scheme/vm/integer-op.scm
+++ /dev/null
@@ -1,193 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Integer-only primitive operations
-
-; These predicates are used to characterize the numeric representations that
-; are implemented in the VM.
-
-(define (unary-lose x)
-  (raise-exception wrong-type-argument 0 x))
-
-(define (binary-lose x y)
-  (raise-exception wrong-type-argument 0 x y))
-
-; They're all numbers, even if we can't handle them.
-
-(define-primitive number? (any->)
-  (lambda (x)
-    (or (fixnum? x)
-	(bignum? x)
-	(ratnum? x)
-	(double? x)
-	(extended-number? x)))
-  return-boolean)
-  
-(define (vm-integer? n)
-  (cond ((or (fixnum? n)
-	     (bignum? n))
-	 (goto return-boolean #t))
-	((extended-number? n)
-	 (unary-lose n))
-	(else
-	 (goto return-boolean #f))))
-
-; These assume that ratnums and doubles aren't being used.
-
-(define-primitive integer?  (any->) vm-integer?)
-(define-primitive rational? (any->) vm-integer?)
-(define-primitive real?     (any->) vm-integer?)
-(define-primitive complex?  (any->) vm-integer?)
-
-;----------------
-; A macro for defining primitives that only operate on fixnums.
-
-(define-syntax define-integer-only
-  (syntax-rules ()
-    ((define-integer-only (opcode arg) value)
-     (define-primitive opcode (vm-integer->)
-       (lambda (arg)
-	 (goto return value))))
-    ((define-integer-only (opcode arg0 arg1) value)
-     (define-primitive opcode (vm-integer-> vm-integer->)
-       (lambda (arg0 arg1)
-	 (goto return value))))))
-
-; These primitives have a simple answer in the case of fixnums; for all others
-; they punt to the run-time system.
-
-(define-integer-only (exact?      n) true)
-(define-integer-only (real-part   n) n)
-(define-integer-only (imag-part   n) (enter-fixnum 0))
-(define-integer-only (floor       n) n)
-(define-integer-only (numerator   n) n)
-(define-integer-only (denominator n) (enter-fixnum 1))
-
-(define-primitive angle (vm-integer->)
-  (lambda (n)
-    (if (if (fixnum? n)
-	    (fx>= n (enter-fixnum 0))
-	    (bignum-nonnegative? n))
-	(goto return (enter-fixnum 0))
-	(unary-lose n))))
-
-(define-primitive magnitude (vm-integer->) integer-abs)
-
-; These all just raise an exception and let the run-time system do the work.
-
-(define-syntax define-punter
-  (syntax-rules ()
-    ((define-punter opcode)
-     (define-primitive opcode (any->) unary-lose))))
-
-(define-punter exact->inexact)
-(define-punter inexact->exact)
-(define-punter exp)
-(define-punter log)
-(define-punter sin)
-(define-punter cos)
-(define-punter tan)
-(define-punter asin)
-(define-punter acos)
-(define-punter sqrt)
-
-(define-syntax define-punter2
-  (syntax-rules ()
-    ((define-punter2 opcode)
-     (define-primitive opcode (any-> any->) binary-lose))))
-
-(define-punter2 atan)
-(define-punter2 make-polar)
-(define-punter2 make-rectangular)
-
-(define-syntax define-binop
-  (syntax-rules ()
-    ((define-binop opcode careful-op integer-op)
-     (define-primitive opcode (any-> any->)
-       (lambda (x y)
-	 (cond ((and (fixnum? x)
-		     (fixnum? y))
-		(goto careful-op
-		      x
-		      y
-		      return
-		      (lambda (x y)
-			(goto return (integer-op x y)))))
-	       ((and (vm-integer? x)
-		     (vm-integer? y))
-		(goto return (integer-op x y)))
-	       (else
-		(binary-lose x y))))))))
-
-(define-binop + add-carefully integer-add)
-(define-binop - subtract-carefully integer-subtract)
-(define-binop * multiply-carefully integer-multiply)
-(define-binop / divide-carefully integer-divide)
-(define-binop quotient         quotient-carefully integer-quotient)
-(define-binop remainder        remainder-carefully integer-remainder)
-;(define-binop arithmetic-shift shift-carefully)
-
-(define-syntax define-comparison
-  (syntax-rules ()
-    ((define-comparison opcode fixnum-op integer-op)
-     (define-primitive opcode (any-> any->)
-       (lambda (x y)
-	 (cond ((and (fixnum? x)
-		     (fixnum? y))
-		(goto careful-op
-		      x
-		      y
-		      return
-		      (lambda (x y)
-			(goto return (integer-op x y)))))
-	       ((and (vm-integer? x)
-		     (vm-integer? y))
-		(goto return (integer-op x y)))
-	       (else
-		(binary-lose x y))))))))
-
-(define-primitive = (any-> any->)
-  (lambda (x y)
-    (cond ((fixnum? x)
-	   (if (fixnum? y)
-	       (goto return-boolean (fixnum= x y))
-	       (if (bignum? y)
-		   (goto return-boolean #f)
-		   (binary-lose x y))))
-	  ((fixnum? y)
-	   (if (bignum? x)
-	       (goto return-boolean #f)
-	       (binary-lose x y)))
-	  ((and (bignum? x)
-		(bignum? y))
-	   (goto return-boolean (bignum= x y)))
-	  (else
-	   (binary-lose x y)))))
-
-(define-primitive < (any-> any->)
-  (lambda (x y)
-    (cond ((fixnum? x)
-	   (if (fixnum? y)
-	       (goto return-boolean (fixnum< x y))
-	       (if (bignum? y)
-		   (goto return-boolean (bignum-positive? y))
-		   (binary-lose x y))))
-	  ((fixnum? y)
-	   (if (bignum? x)
-	       (goto return-boolean (bignum-negative? x))
-	       (binary-lose x y)))
-	  ((and (bignum? x)
-		(bignum? y))
-	   (goto return-boolean (bignum< x y)))
-	  (else
-	   (binary-lose x y)))))
-
-(define-integer-only (<  x y) (enter-boolean (fixnum<  x y)))
-(define-integer-only (>  x y) (enter-boolean (fixnum>  x y)))
-(define-integer-only (<= x y) (enter-boolean (fixnum<= x y)))
-(define-integer-only (>= x y) (enter-boolean (fixnum>= x y)))
-
-(define-integer-only (bitwise-not x)   (fixnum-bitwise-not x))
-(define-integer-only (bitwise-and x y) (fixnum-bitwise-and x y))
-(define-integer-only (bitwise-ior x y) (fixnum-bitwise-ior x y))
-(define-integer-only (bitwise-xor x y) (fixnum-bitwise-xor x y))
diff --git a/scheme/vm/integer.scm b/scheme/vm/integer.scm
deleted file mode 100644
index 49d0d4d..0000000
--- a/scheme/vm/integer.scm
+++ /dev/null
@@ -1,63 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Operations on integers.
-
-; This expects its arguments to be integers.
-
-(define (integer-op fixnum-op bignum-op)
-  (if (and (fixnum? x)
-	   (fixnum? y))
-      (fixnum-op x y (lambda (r) r) bignum-op)
-      (bignum-op x y)))
-  
-(define integer-add       (integer-op add-carefully       bignum-add))
-(define integer-subtract  (integer-op subtract-carefully  bignum-subtract))
-(define integer-multiply  (integer-op multiply-carefully  bignum-multiply))
-(define integer-quotient  (integer-op quotient-carefully  bignum-quotient))
-(define integer-remainder (integer-op remainder-carefully bignum-remainder))
-
-(define (integer-abs x)
-  (if (fixnum? x)
-      (abs-carefully x (lambda (r) r) bignum-abs)
-      (bignum-abs x)))
-
-; What about shifts and bitwise operations?
-
-; Fixnums and bignums are disjoint.
-
-(define (integer= x y)
-  (cond ((and (fixnum? x)
-	      (fixnum? y))
-	 (fixnum= x y))
-	((and (bignum? x)
-	      (bignum? y))
-	 (bignum= x y))
-	(else
-	 #f)))
-
-; Positive bignums are greater than all fixnums, negative bignums are less
-; than all fixnums.
-
-(define (integer< x y)
-  (cond ((fixnum? x)
-	 (if (fixnum? y)
-	     (fixnum< x y)
-	     (bignum-positive? y)))
-	((fixnum? y)
-	 (not (bignum-positive? y)))
-	(else
-	 (bignum< x y))))
-
-(define (integer<= x y)
-  (not (integer< y x)))
-
-(define (integer> x y)
-  (integer< y x))
-
-(define (integer>= x y)
-  (not (integer< x y)))
-
-
-	 
-		
diff --git a/scheme/vm/interp-gc.scm b/scheme/vm/interp-gc.scm
deleted file mode 100644
index 47191a6..0000000
--- a/scheme/vm/interp-gc.scm
+++ /dev/null
@@ -1,107 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; Different ways to call the GC, depending on how many temporaries need to
-; be traced.
-
-; ENSURE-SPACE and friends make sure that there is at least SPACE remaining
-; in the heap, triggering a GC if necessary.  A key to the pre-allocated space
-; is returned (keys and pre-allocation are described in heap.scm).  If SPACE
-; is not available, even after a GC, we kill the process.
-
-(define (ensure-space space)
-  (receive (key temp)
-      (ensure-space-saving-temp space false)
-    key))
-
-(define (ensure-space-saving-temp space temp)
-  (receive (okay? key temp ignore)
-      (maybe-ensure-space-saving-temps space temp false)
-    (if (not okay?)
-	(error "Scheme48 heap overflow"))
-    (values key temp)))
-
-(define (ensure-space-saving-temps space temp0 temp1)
-  (receive (okay? key temp0 temp1)
-      (maybe-ensure-space-saving-temps space temp0 temp1)
-    (if (not okay?)
-	(error "Scheme48 heap overflow"))
-    (values key temp0 temp1)))
-
-; Same thing, except that we return a flag instead of dying if the space is
-; not available.
-
-(define (maybe-ensure-space space)
-  (receive (okay? key ignore0 ignore1)
-      (maybe-ensure-space-saving-temps space false false)
-    (values okay? key)))
-
-(define (maybe-ensure-space-saving-temp space temp)
-  (receive (okay? key temp ignore0)
-      (maybe-ensure-space-saving-temps space temp false)
-    (values okay? key temp)))
-
-(define (maybe-ensure-space-saving-temps space temp0 temp1)
-  (if (s48-available? space)
-      (values #t (s48-preallocate-space space) temp0 temp1)
-      (receive (temp0 temp1)
-	  (collect-saving-temps temp0 temp1)
-	(if (s48-available? space)
-	    (values #t (s48-preallocate-space space) temp0 temp1)
-	    (values #f 0 temp0 temp1)))))
-
-;----------------
-; The GC itself, with versions that handle one or two temporaries.
-
-(define (collect)
-  (receive (ignore0 ignore1)
-      (collect-saving-temps (enter-fixnum 0) (enter-fixnum 0))
-    0))  ; type checker rejected (values) here; why?
-
-(define (collect-saving-temp value)
-  (receive (value ignore1)
-      (collect-saving-temps value (enter-fixnum 0))
-    value))
-
-; This is a front for the real GC, which is a separate program.  All that the
-; interpreter contributes is the root set and some post-gc cleanup code.
-
-(define (collect-saving-temps value0 value1)
-  (s48-begin-collection)
-  (gc-root)
-  (let ((value0 (s48-trace-value value0))
-	(value1 (s48-trace-value value1)))
-    (s48-do-gc)
-    (post-gc-cleanup)
-    (s48-end-collection)
-    (values value0 value1)))
-
-;----------------
-; GC-ROOT and POST-GC-CLEANUP are defined incrementally.
-;
-; (ADD-GC-ROOT! <thunk>)           ; call <thunk> when tracing the GC roots
-; (ADD-POST-GC-CLEANUP! <thunk>)   ; call <thunk> when a GC has finished
-;
-; (GC-ROOT)                        ; call all the root thunks
-; (POST-GC-CLEANUP)                ; call all the cleanup thunks
-
-(define-syntax define-extensible-proc
-  (syntax-rules ()
-    ((define-extensible-proc proc extender temp)
-     (begin
-       (define temp unspecific)
-       (define (proc) (temp))
-       (define (extender more)
-	 (let ((old temp))
-	   (set! temp (lambda ()
-			(more)
-			(old)))))))))
-
-(define-extensible-proc gc-root
-  add-gc-root!
-  *gc-root-proc*)
-
-(define-extensible-proc post-gc-cleanup
-  add-post-gc-cleanup!
-  *post-gc-cleanup*)
-
diff --git a/scheme/vm/macro-package-defs.scm b/scheme/vm/macro-package-defs.scm
deleted file mode 100644
index 7c6a333..0000000
--- a/scheme/vm/macro-package-defs.scm
+++ /dev/null
@@ -1,8 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; VM-ARCHITECTURE is used in a FOR-SYNTAX clause in the VM package definitions.
-
-(define-structures ((vm-architecture (export stob-data)))
-  (open scheme enumerated)
-  (files arch))
diff --git a/scheme/vm/memory.scm b/scheme/vm/memory.scm
deleted file mode 100644
index 066aeb9..0000000
--- a/scheme/vm/memory.scm
+++ /dev/null
@@ -1,87 +0,0 @@
-; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; This is file memory.scm.
-
-; Fundamental parameters
-
-(define bits-per-byte 8)
-(define bytes-per-cell 4)
-(define bits-per-cell (* bits-per-byte bytes-per-cell))
-
-(define (bytes->cells bytes)
-  ; using shift instead of quotient for speed
-  ; (quotient (+ bytes (- bytes-per-cell 1)) bytes-per-cell)
-  (arithmetic-shift-right (+ bytes (- bytes-per-cell 1))
-			  2))  ; log(bytes-per-cell)
-
-(define (cells->bytes cells)
-  (* cells bytes-per-cell))
-
-; Addresses
-;
-;  An "addressing unit" is the smallest quantum of storage addressed by
-;  an address on a particular machine.  On a DEC-20, 3600, or other
-;  word-addressed architecture there is one addressing unit per cell.  On
-;  the VAX or 68000, though, the addressing unit is the byte, of which there
-;  are 4 to a cell.
-;
-;  Note: by a "byte" is meant enough bits to store either a character or
-;  a bytecode.  That probably means either 7, 8, or 9 bits.
-;
-;  If the addressing unit is smaller than a cell each address will have some
-;  number of "unused bits" at its low end.  On a byte-addressable machine with
-;  32 bit addresses, there are two.
-
-(define unused-field-width 2)
-
-(define addressing-units-per-cell 4)
-
-(define (cells->a-units cells)
-  (adjoin-bits cells 0 unused-field-width))
-
-(define (a-units->cells cells)
-  (high-bits cells unused-field-width))
-
-(define (bytes->a-units byte-count)
-  (cells->a-units (bytes->cells byte-count)))
-
-(define (address1+ x)
-  (address+ x addressing-units-per-cell))
-
-(define (address2+ x)
-  (address1+ (address1+ x)))
-
-; Memory access
-
-(define *memory*)
-(define *memory-begin* 0)
-(define *memory-end* 0)
-
-(define (memory-begin)
-  *memory-begin*)
-
-; Size of memory in cells.
-(define (memory-size)
-  (a-units->cells (address-difference *memory-end* *memory-begin*)))
-
-(define (create-memory size initial-value)   ;size in cells
-  (let ((size (cells->a-units size)))
-    (cond ((not (= size (address-difference *memory-end* *memory-begin*)))
-	   (if (not (= *memory-end* 0))
-	       (deallocate-memory *memory*))
-           (set! *memory* (allocate-memory size))
-	   (if (= -1 *memory*)
-	       (error "out of memory, unable to continue"))
-	   (set! *memory-begin* *memory*)
-           (set! *memory-end* (+ *memory* size))))))
-
-(define fetch word-ref)
-(define fetch-byte unsigned-byte-ref)
-(define store! word-set!)
-(define store-byte! unsigned-byte-set!)
-
-(define fetch-string char-pointer->string)
-(define fetch-nul-terminated-string char-pointer->nul-terminated-string)
-
diff --git a/scheme/vm/prim-arith.scm b/scheme/vm/prim-arith.scm
deleted file mode 100644
index 85dff3d..0000000
--- a/scheme/vm/prim-arith.scm
+++ /dev/null
@@ -1,2 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
diff --git a/scheme/vm/prim.scm b/scheme/vm/prim.scm
deleted file mode 100644
index eafaab0..0000000
--- a/scheme/vm/prim.scm
+++ /dev/null
@@ -1,528 +0,0 @@
-; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; Scalar primitives
-
-(define-primitive eq? (any-> any->) vm-eq? return-boolean)
-
-(define-primitive char?       (any->) vm-char? return-boolean)
-(define-primitive char=?      (vm-char-> vm-char->) vm-char=? return-boolean)
-(define-primitive char<?      (vm-char-> vm-char->) vm-char<? return-boolean)
-(define-primitive char->ascii (char->) char->ascii return-fixnum)
-
-(define-primitive ascii->char
-  (fixnum->)
-  (lambda (x)
-    (if (or (> x 255) (< x 0))
-        (raise-exception wrong-type-argument 0 (enter-fixnum x))
-	(goto return (enter-char (ascii->char x))))))
-
-(define-primitive eof-object?
-  (any->)
-  (lambda (x) (vm-eq? x eof-object))
-  return-boolean)
-
-;----------------
-
-(define-primitive stored-object-has-type?
-  (any->)
-  (lambda (x)
-    (goto continue-with-value
-	  (enter-boolean (stob-of-type? x (code-byte 0)))
-	  1)))
-
-(define-primitive stored-object-length
-  (any->)
-  (lambda (stob)
-    (let ((type (code-byte 0)))
-      (if (stob-of-type? stob type)
-	  (goto continue-with-value
-		(enter-fixnum (d-vector-length stob))
-		1)
-	  (raise-exception wrong-type-argument 1 stob (enter-fixnum type))))))
-  
-; Fixed sized objects
-
-(define-primitive stored-object-ref
-  (any->)
-  (lambda (stob)
-    (let ((type (code-byte 0))
-	  (offset (code-byte 1)))
-      (if (stob-of-type? stob type)
-	  (goto continue-with-value
-		(d-vector-ref stob offset)
-		2)
-	  (raise-exception wrong-type-argument 2
-			   stob
-			   (enter-fixnum type)
-			   (enter-fixnum offset))))))
-
-(define-primitive stored-object-set!
-  (any-> any->)
-  (lambda (stob value)
-    (let ((type (code-byte 0))
-	  (offset (code-byte 1)))
-      (cond ((and (stob-of-type? stob type)
-		  (not (immutable? stob)))
-	     (d-vector-set! stob offset value)
-	     (goto continue-with-value
-		   unspecific-value
-		   2))
-	    (else
-	     (raise-exception wrong-type-argument 2
-			      stob
-			      (enter-fixnum type)
-			      (enter-fixnum offset)
-			      value))))))
-
-; Indexed objects
-
-(define-primitive stored-object-indexed-ref (any-> any->)
-  (lambda (stob index)
-    (let ((type (code-byte 0)))
-      (cond ((or (not (fixnum? index))
-	         (not (stob-of-type? stob type)))
-	     (raise-exception wrong-type-argument 1
-			      stob (enter-fixnum type) index))
-	    ((valid-index? (extract-fixnum index) (d-vector-length stob))
-	     (goto continue-with-value
-		   (d-vector-ref stob (extract-fixnum index))
-		   1))
-	    (else
-	     (raise-exception index-out-of-range 1
-			      stob (enter-fixnum type) index))))))
-
-(define-primitive stored-object-indexed-set! (any-> any-> any->)
-  (lambda (stob index value)
-    (let ((type (code-byte 0)))
-      (cond ((or (not (fixnum? index))
-		 (not (stob-of-type? stob type))
-		 (immutable? stob))
-	     (raise-exception wrong-type-argument 1
-			      stob (enter-fixnum type) index value))
-	    ((valid-index? (extract-fixnum index) (d-vector-length stob))
-	     (d-vector-set! stob (extract-fixnum index) value)
-	     (goto continue-with-value unspecific-value 1))
-	    (else
-	     (raise-exception index-out-of-range 1
-			      stob (enter-fixnum type) index value))))))
-
-; Hacko record handlers done for speed.
-
-(define-primitive checked-record-ref
-  (any-> any-> fixnum->)
-  (lambda (record type index)
-    (cond ((not (and (stob-of-type? record (enum stob record))
-		     (vm-eq? type (record-ref record 0))))
-	   (raise-exception wrong-type-argument 0
-			    record type (enter-fixnum index)))
-	  ((valid-index? index (record-length record))
-	   (goto return (record-ref record index)))
-	  (else
-	   (raise-exception index-out-of-range 0
-			    record type (enter-fixnum index))))))
-
-(define-primitive checked-record-set! (any-> any-> fixnum-> any->)
-  (lambda (record type index value)
-    (cond ((not (and (stob-of-type? record (enum stob record))
-		     (vm-eq? type (record-ref record 0))
-		     (not (immutable? record))))
-	   (raise-exception wrong-type-argument 0
-			    record type (enter-fixnum index) value))
-	  ((valid-index? index (record-length record))
-	   (record-set! record index value)
-	   (goto no-result))
-	  (else
-	   (raise-exception index-out-of-range 0
-			    record type (enter-fixnum index) value)))))
-
-; Constructors
-
-(define-primitive make-stored-object ()
-  (lambda ()
-    (let* ((len (code-byte 0))
-	   (key (ensure-space (cells->bytes (+ stob-overhead len))))
-	   (new (make-d-vector (code-byte 1) len key)))
-      (cond ((>= len 1)
-	     (d-vector-init! new (- len 1) *val*)
-	     (do ((i (- len 2) (- i 1)))
-		 ((> 0 i)
-		  (unspecific))  ; for the type checker!
-	       (d-vector-init! new i (pop)))))
-      (goto continue-with-value new 2))))
-
-; This is for the closed compiled versions of VECTOR and RECORD.
-; *stack* = arg0 arg1 ... argN rest-list N+1 total-nargs
-
-(define-primitive closed-make-stored-object ()
-  (lambda ()
-    (let* ((len (extract-fixnum (pop)))
-	   (key (ensure-space (cells->bytes (+ stob-overhead len))))
-	   (new (make-d-vector (code-byte 0) len key))
-	   (stack-nargs (extract-fixnum (pop)))
-	   (rest-list (pop)))
-      (do ((i (- stack-nargs 1) (- i 1)))
-	  ((> 0 i)
-	   (unspecific))  ; for the type checker!
-	(d-vector-init! new i (pop)))
-      (do ((i stack-nargs (+ i 1))
-	   (rest-list rest-list (vm-cdr rest-list)))
-	  ((vm-eq? rest-list null)
-	   (unspecific))  ; for the type checker!
-	(d-vector-init! new i (vm-car rest-list)))
-      (goto continue-with-value new 1))))
-
-(define-primitive make-vector-object (any-> any->)
-  (lambda (len init)
-    (let ((type (code-byte 0)))
-      (if (fixnum? len)
-	  (let* ((len (extract-fixnum len))
-		 (size (vm-vector-size len)))
-	    (if (or (< len 0)
-		    (> size max-stob-size-in-cells))
-		(raise-exception wrong-type-argument 1
-				 (enter-fixnum type) (enter-fixnum len) init)
-		(receive (okay? key init)
-		    (maybe-ensure-space-saving-temp size init)
-		  (if (not okay?)
-		      (raise-exception heap-overflow 1
-				       (enter-fixnum type) (enter-fixnum len)
-				       init)
-		      (let ((v (make-d-vector type len key)))
-			(do ((i (- len 1) (- i 1)))
-			    ((< i 0))
-			  (d-vector-set! v i init))
-			(goto continue-with-value v 1))))))
-	  (raise-exception wrong-type-argument 1
-			   (enter-fixnum type) len init)))))
-
-; Strings and byte vectors
-
-(define-primitive string-length
-  (string->)
-  (lambda (string)
-    (goto return-fixnum (vm-string-length string))))
-
-(define-primitive byte-vector-length
-  (code-vector->)
-  (lambda (byte-vector)
-    (goto return-fixnum (code-vector-length byte-vector))))
-
-(define (make-byte-ref ref length returner)
-  (lambda (vector index)
-    (if (valid-index? index (length vector))
-	(goto returner (ref vector index))
-	(raise-exception index-out-of-range 0 vector (enter-fixnum index)))))
-
-(let ((proc (make-byte-ref vm-string-ref vm-string-length return-char)))
-  (define-primitive string-ref (string-> fixnum->) proc))
-
-(let ((proc (make-byte-ref code-vector-ref code-vector-length return-fixnum)))
-  (define-primitive byte-vector-ref (code-vector-> fixnum->) proc))
-
-(define (make-byte-setter setter length enter-elt)
-  (lambda (vector index char)
-    (cond ((immutable? vector)
-	   (raise-exception wrong-type-argument 0
-			    vector (enter-fixnum index) (enter-elt char)))
-	  ((valid-index? index (length vector))
-	   (setter vector index char)
-	   (goto no-result))
-	  (else
-	   (raise-exception index-out-of-range 0
-			    vector (enter-fixnum index) (enter-elt char))))))
-
-(let ((proc (make-byte-setter vm-string-set! vm-string-length enter-char)))
-  (define-primitive string-set! (string-> fixnum-> char->) proc))
-
-(let ((proc (make-byte-setter code-vector-set! code-vector-length enter-fixnum)))
-  (define-primitive byte-vector-set! (code-vector-> fixnum-> fixnum->) proc))
-
-(define (byte-vector-maker size maker setter enter-elt)
-  (lambda (len init)
-    (let ((size (size len)))
-      (if (or (< len 0)
-	      (> size max-stob-size-in-cells))
-	  (raise-exception wrong-type-argument 0
-			   (enter-fixnum len) (enter-elt init))
-	  (receive (okay? key)
-	      (maybe-ensure-space size)
-	    (if (not okay?)
-		(raise-exception heap-overflow 0
-				 (enter-fixnum len) (enter-elt init))
-		(let ((vector (maker len key)))
-		  (do ((i (- len 1) (- i 1)))
-		      ((< i 0))
-		    (setter vector i init))
-		  (goto return vector))))))))
-
-(let ((proc (byte-vector-maker vm-string-size
-			       vm-make-string
-			       vm-string-set!
-			       enter-char)))
-  (define-primitive make-string (fixnum-> char->) proc))
-  
-(let ((proc (byte-vector-maker code-vector-size
-			       make-code-vector
-			       code-vector-set!
-			       enter-fixnum)))
-  (define-primitive make-byte-vector (fixnum-> fixnum->) proc))
-
-; Locations & mutability
-
-(define-primitive location-defined? (location->)
-  (lambda (loc)
-    (return-boolean (or (not (undefined? (contents loc)))
-			(= (contents loc) unassigned-marker)))))
-
-(define-primitive set-location-defined?! (location-> boolean->)
-  (lambda (loc value)
-    (cond ((not value)
-	   (set-contents! loc unbound-marker))
-	  ((undefined? (contents loc))
-	   (set-contents! loc unassigned-marker))))
-  return-unspecific)
-
-(define-primitive immutable? (any->) immutable? return-boolean)
-
-(define-primitive make-immutable! (any->)
-  (lambda (thing)
-    (make-immutable! thing)
-    (goto return thing)))
-
-;----------------
-; Misc
-
-(define-primitive false ()
-  (lambda ()
-    (goto return false)))
-
-(define-primitive eof-object ()
-  (lambda ()
-    (goto return eof-object)))
-
-(define-primitive trap (any->)
-  (lambda (arg)
-    (raise-exception trap 0 arg)))
-
-(define-primitive find-all (fixnum->)
-  (lambda (type)
-    (let loop ((first? #t))
-      (let ((vector (s48-find-all type)))
-	(cond ((not (false? vector))
-	       (goto return vector))
-	      (first?
-	       (collect)
-	       (loop #f))
-	      (else
-	       (raise-exception heap-overflow 0 (enter-fixnum type))))))))
-
-(define-primitive find-all-records (any->)
-  (lambda (type)
-    (let loop ((first? #t) (type type))
-      (let ((vector (s48-find-all-records type)))   ; only one call site
-	(cond ((not (false? vector))
-	       (goto return vector))
-	      (first?
-	       (loop #f (collect-saving-temp type)))
-	      (else
-	       (raise-exception heap-overflow 0 type)))))))
-
-(define-primitive collect ()
-  (lambda ()
-    (set! *val* unspecific-value)
-    (collect)
-    (goto continue 0)))
-
-(define-consing-primitive add-finalizer! (any-> any->)
-  (lambda (n) (* 2 vm-pair-size))
-  (lambda (stob proc key)
-    (cond ((not (and (stob? stob)
-		     (closure? proc)))
-	   (raise-exception wrong-type-argument 0 stob proc))
-; This would be useful but could get quite expensive
-;	  ((vm-assq stob *finalizer-alist*)
-;	   (raise-exception has-finalizer 0 stob proc))
-	  (else
-	   (set! *finalizer-alist*
-		 (vm-cons (vm-cons stob proc key)
-			  *finalizer-alist*
-			  key))
-	   (goto no-result)))))
-
-(define-primitive memory-status (fixnum-> any->)
-  (lambda (key other)
-    (enum-case memory-status-option key
-      ((pointer-hash)
-       (goto return (descriptor->fixnum other)))
-      ((available)
-       (goto return-fixnum (s48-available)))
-      ((heap-size)
-       (goto return-fixnum (bytes->cells (s48-heap-size))))
-      ((stack-size)
-       (goto return-fixnum (stack-size)))
-      ((gc-count)
-       (goto return-fixnum (s48-gc-count)))
-      ((expand-heap!)
-       (raise-exception unimplemented-instruction 0 (enter-fixnum key) other))
-      (else
-       (raise-exception bad-option 0 (enter-fixnum key) other)))))
-
-(define-primitive time (fixnum-> any->)
-  (lambda (option other)
-    (enum-case time-option option
-      ((cheap-time)
-       (goto return-fixnum (cheap-time)))
-      ((run-time)
-       (receive (seconds mseconds)
-	   (run-time)
-	 (goto return-time-value option seconds mseconds)))
-      ((real-time)
-       (receive (seconds mseconds)
-	   (real-time)
-	 (goto return-time-value option seconds mseconds)))
-      (else
-       (raise-exception bad-option 0 (enter-fixnum option) other)))))
-      
-; The largest number of seconds that can be converted into a fixnum number
-; of milliseconds.
-
-(define maximum-seconds (quotient (- greatest-fixnum-value 1000) 1000))
-
-(define (return-time-value option seconds mseconds)
-  (if (> seconds maximum-seconds)
-      (raise-exception arithmetic-overflow 0
-		       (enter-fixnum option)
-		       (enter-fixnum seconds)
-		       (enter-fixnum mseconds))
-      (goto return-fixnum (+ (* seconds 1000) mseconds))))
-
-(define-primitive schedule-interrupt (fixnum->)
-  (lambda (delta)
-    (clear-interrupt! (enum interrupt alarm))
-    (goto return-fixnum (schedule-interrupt delta))))
-
-; Convert from the user's exponent to the system's.
-
-;(define (adjust-time mantissa exponent)
-;  (let ((system (clock-exponent)))
-;    (cond ((= exponent system)
-;           mantissa)
-;          ((> system exponent)
-;           (quotient mantissa (expt 10 (- system exponent))))
-;          (else
-;           (* mantissa (expt 10 (- exponent system)))))))
-
-(define-enumeration vm-extension-status
-  (okay
-   exception
-   ))
-
-(define s48-*extension-value*)
-
-(define-primitive vm-extension (fixnum-> any->)
-  (lambda (key value)
-    (let ((status (extended-vm key value)))
-      (cond ((vm-eq? status (enum vm-extension-status okay))
-	     (goto return s48-*extension-value*))
-	    ((vm-eq? status (enum vm-extension-status exception))
-	     (raise-exception extension-exception 0 (enter-fixnum key) value))
-	    (else
-	     (raise-exception extension-return-error 0 (enter-fixnum key) value))))))
-
-; This is exported to keep s48-*EXTENSION-VALUE* from being eliminated by the
-; compiler.
-
-(define (s48-set-extension-value! value)
-  (set! s48-*extension-value* value))
-
-; Used to indicate which stack block we are returning to.  Set to FALSE if we are
-; returning from the VM as a whole.
-(define s48-*callback-return-stack-block* false)
-
-(define-primitive return-from-callback (any-> any->)
-  (lambda (stack-block value)
-    (enable-interrupts!)	; Disabled to ensure that we return to the right
-				; stack block.
-    (set! s48-*callback-return-stack-block* stack-block)
-    value))                     ; the interpreter returns this value
-
-(define-primitive current-thread ()
-  (lambda () *current-thread*)
-  return-any)
-
-(define-primitive set-current-thread! (any->)
-  (lambda (state)
-    (set! *current-thread* state))
-  return-unspecific)
-
-(define-primitive session-data ()
-  (lambda () *session-data*)
-  return-any)
-
-(define-primitive set-session-data! (any->)
-  (lambda (state)
-    (set! *session-data* state))
-  return-unspecific)
-
-; Unnecessary primitives
-
-(define-primitive string=? (string-> string->) vm-string=? return-boolean)
-
-; Special primitive called by the reader.
-; Primitive for the sake of speed.  Probably should be flushed.
-
-(define-consing-primitive reverse-list->string (any-> fixnum->) 
-  (lambda (n) (vm-string-size (extract-fixnum n)))
-  (lambda (l n k)
-    (if (not (or (vm-pair? l) (vm-eq? l null)))
-        (raise-exception wrong-type-argument 0 l (enter-fixnum n))
-        (let ((obj (vm-make-string n k)))
-          (do ((l l (vm-cdr l))
-               (i (- n 1) (- i 1)))
-              ((< i 0)
-	       (goto return obj))
-            (vm-string-set! obj i (extract-char (vm-car l))))))))
-
-(define-primitive string-hash (string->) vm-string-hash return-fixnum)
-
-; Messy because we have to detect circular lists (alternatively we
-; could check for interrupts and then pclsr).  ***
-
-(define-primitive assq (any-> any->)
-  (lambda (thing list)
-    (let ((lose (lambda ()
-		  (raise-exception wrong-type-argument 0 thing list))))
-      (let loop ((list list) (slow list) (move-slow? #t))
-	(cond ((vm-eq? list null)
-	       (goto return-boolean #f))
-	      ((not (vm-pair? list))
-	       (lose))
-	      (else
-	       (let ((head (vm-car list)))
-		 (cond ((not (vm-pair? head))
-			(lose))
-		       ((vm-eq? (vm-car head) thing)
-			(goto return head))
-		       (else
-			(let ((list (vm-cdr list)))
-			  (cond ((eq? list slow)
-				 (lose))
-				(move-slow?
-				 (loop list (vm-cdr slow) #f))
-				(else
-				 (loop list slow #t)))))))))))))
-
-; Eventually add make-table, table-ref, table-set! as primitives?
-; No -- write a compiler instead.
-
-; *** Our entry for the obscure comment of the year contest.
-;
-; Pclsring is the term in ITS for the mechanism that makes the operating system
-; appear to be a virtual machine.  The paradigm is that of the BLT instruction
-; on the PDP-10: its arguments are in a set of registers, and if the instruction
-; gets interrupted in the middle, the registers reflect the intermediate state;
-; the PC is set to the BLT instruction itself, and the process can be resumed
-; in the usual way.
-; For more on pclsring see `Pclsring: Keeping Process State Modular' by Alan
-; Bawden (ftp.ai.mit.edu:pub/alan/pclsr.memo).
diff --git a/scheme/vm/ps-package-defs.scm b/scheme/vm/ps-package-defs.scm
deleted file mode 100644
index 1994d2f..0000000
--- a/scheme/vm/ps-package-defs.scm
+++ /dev/null
@@ -1,42 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-(define-structures ((vm-utilities vm-utilities-interface))
-  (open prescheme)
-  (files vm-utilities)
-  (begin
-    (define-syntax assert
-      (lambda (exp rename compare)
-    	0))
-    ))
-
-(define-structures ((external external-interface))
-  (open prescheme)
-  (begin
-    (define extended-vm
-      (external "s48_extended_vm" (=> (integer integer) integer)))
-    (define external-call
-      (external "s48_external_call" (=> (integer integer integer address)
-					integer)))
-    (define schedule-interrupt 
-      (external "s48_schedule_alarm_interrupt" (=> (integer) integer)))
-    (define cheap-time
-      (external "CHEAP_TIME" (=> () integer)))
-    (define real-time 
-      (external "s48_real_time" (=> () integer integer)))
-    (define run-time 
-      (external "s48_run_time" (=> () integer integer)))))
-   
-(define-structures ((channel-io channel-interface)
-		    (events event-interface))
-  (open prescheme)
-  (files ps-channel))
-
-; The number of usable bits in a small integer.
-
-(define-structures ((system-spec (export useful-bits-per-word)))
-  (open prescheme)
-  (begin
-    (define useful-bits-per-word 32)   ; when compiled
-    ))
-
diff --git a/scheme/vm/resume.scm b/scheme/vm/resume.scm
deleted file mode 100644
index 283f7c1..0000000
--- a/scheme/vm/resume.scm
+++ /dev/null
@@ -1,60 +0,0 @@
-; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; This is file resume.scm.
-
-(define (s48-initialize-vm stack-begin stack-size)
-  (install-symbols!+gc (s48-initial-symbols))
-  (install-shared-bindings!+gc (s48-initial-imported-bindings)
-			       (s48-initial-exported-bindings))
-  (initialize-stack+gc stack-begin stack-size)
-  (initialize-interpreter+gc))
-
-;----------------
-; Push the arguments to the initial procedure (a vector of strings passed
-; in from the outside and the three standard channels) and call it.
-
-(define (s48-call-startup-procedure startup-vector startup-vector-length)
-  (clear-registers)
-  (push (enter-startup-argument+gc startup-vector startup-vector-length))
-  (receive (input output error)
-      (initialize-i/o-system+gc)
-    (push input)
-    (push output)
-    (push error)
-    (push (s48-resumer-records))
-    (s48-initialization-complete!)
-    (s48-restart (s48-startup-procedure) 5)))
-  
-(define (enter-startup-argument+gc startup-vector startup-vector-length)
-  (let* ((size (+ (do ((i 0 (+ i 1))
-		       (size 0 (+ size (vm-string-size
-					(string-length
-					 (vector-ref startup-vector i))))))
-		      ((= i startup-vector-length)
-		       size))
-		  (vm-vector-size startup-vector-length)))
-	 (key (ensure-space size))
-	 (vector (vm-make-vector startup-vector-length key)))
-    (natural-for-each (lambda (i)
-			(vm-vector-set! vector
-					i
-					(enter-string
-					 (vector-ref startup-vector i)
-					 key)))
-		      startup-vector-length)
-    vector))
-
-;----------------
-; Restart the interpreter, calling PROC with NARGS arguments already on the
-; stack.
-
-(define (s48-restart proc nargs)
-  (receive (key proc)
-      (ensure-space-saving-temp (code-vector-size 2) proc)
-    (let ((code (make-code-vector 2 key)))
-      (code-vector-set! code 0 (enum op call))
-      (code-vector-set! code 1 nargs)
-      (set-code-pointer! code 0)
-      (set-val! proc)
-      (interpret (code-pointer)))))
diff --git a/scheme/vm/s48-package-defs.scm b/scheme/vm/s48-package-defs.scm
deleted file mode 100644
index 5834728..0000000
--- a/scheme/vm/s48-package-defs.scm
+++ /dev/null
@@ -1,35 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-(define-structures ((vm-utilities vm-utilities-interface))
-  (open prescheme)
-  (files vm-utilities)
-  (begin
-;    (define-syntax assert
-;      (lambda (exp rename compare)
-;    	0))
-    (define (assert x)
-      (if (not x)
-    	  (error "assertion failed")))
-    ))
-
-(define-structures ((external external-interface))
-  (open scheme)
-  (for-syntax (open scheme signals)) ; for error
-  (files external))
-
-(define-structures ((channel-io channel-interface)
-		    (events event-interface))
-  (open scheme big-scheme ps-memory structure-refs ports)
-  (access prescheme
-	  i/o)         ; current-error-port
-  (files s48-channel))
-
-; The number of usable bits in a small integer.
-
-(define-structures ((system-spec (export useful-bits-per-word)))
-  (open prescheme)
-  (begin
-    (define useful-bits-per-word 30)   ; in Scheme 48
-    ))
-
diff --git a/scheme/vm/stack.scm b/scheme/vm/stack.scm
deleted file mode 100644
index 6a735c1..0000000
--- a/scheme/vm/stack.scm
+++ /dev/null
@@ -1,509 +0,0 @@
-; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; The stack grows from higher addresses to lower ones.
-; *STACK-BEGIN* and *STACK-END* delimit the stack portion of memory.
-; *STACK* points to the next unused cell on top of the stack.
-; *STACK-LIMIT* is value against which stack requests are checked.  There is a
-;   buffer area between the limit and the actual end of the stack.  The buffer
-;   is large enough to contain the default procedure stack requirement plus the
-;   space needed to make a call to an exception plus an interrupts plus some
-;   slack for safety's sake.
-
-; These slots are filled with a funny value so that we can detect overruns.
-
-(define stack-warning-limit 30)
-
-; The supposedly unused space at the end of the stack is marked with this
-; value so that we can detect incursions.
-
-(define stack-marker #xf0f0f0f)
-
-; We need at least this amount of space for the stack.
-
-(define stack-slack
-  (+ default-stack-space
-     continuation-stack-size	    ; *bottom-of-stack*
-     (+ continuation-stack-size 13) ; exceptions need at most 14 values
-                                    ; (long pole is external exceptions with
-                                    ; exception + procedure-name + 10 irritants +
-                                    ; saved-exception + stack-block)
-     (+ continuation-stack-size 7)  ; interrupts need at most 7 values
-                                    ; (also from examining the code)
-     (+ stack-warning-limit 2)))    ; safety
-
-; *BOTTOM-OF-STACK* is a continuation that lies a the base of the stack.
-
-(define *stack-begin*)
-(define *stack-end*)
-(define *stack*)
-(define *stack-limit*)
-
-; Current continuation
-(define *cont*)
-
-; For tracking the reason for copying closures and environments (used for
-; debugging and gathering statistics).
-
-(define-enumeration copy
-  (closure
-   overflow
-   preserve))
-
-; At the bottom of the stack is a special continuation that is never removed.
-; When it is invoked it copies the next continuation out of the heap (if there
-; is any such) and invokes that instead.
-
-(define *bottom-of-stack*)
-
-; Initialize the stack and related registers.  All sizes are in descriptors.
-
-(define (initialize-stack+gc start have-size)
-  (let ((required-size (+ available-stack-space stack-slack)))
-    (receive (start size)
-	(if (>= have-size required-size)
-	    (values start have-size)
-	    (let ((stack (allocate-memory (cells->a-units required-size))))
-	      (if (null-address? stack)
-		  (error "out of memory, unable to continue"))
-	      (values stack required-size)))
-      (set! *stack-begin* start)
-      (set! *stack-end* (address+ start (cells->a-units size)))
-      (set! *stack-limit* (address+ *stack-begin* (cells->a-units stack-slack)))
-      (set! *stack* (the-pointer-before *stack-end*))
-      (set! *cont* false)
-      (set! *env* quiescent)
-      (do ((a start (address1+ a)))
-	  ((address= a *stack-end*))
-	(store! a stack-marker))
-      (let ((key (ensure-space (op-template-size 2))))
-	(push-continuation-on-stack
-	  (make-template-containing-ops (enum op get-cont-from-heap)
-					(enum op return)
-					key)
-	  (enter-fixnum 0)
-	  0))
-      (set! *bottom-of-stack* *cont*))))
-
-(define (reset-stack-pointer base-continuation)
-  (set! *stack* (the-pointer-before
-		 (the-pointer-before (address-after-header *bottom-of-stack*))))
-  (set-continuation-cont! *bottom-of-stack* base-continuation)
-  (set! *cont* *bottom-of-stack*))
-
-;----------------
-; Utilities
-
-(define (within-stack? p)
-  (and (stob? p)
-       (>= p (address->integer *stack-begin*))
-       (<= p (address->integer *stack-end*))))
-
-(define (stack-size)
-  (address-difference *stack-end* *stack-begin*))
-
-; The stob-overhead is to get room for one vector that is made.
-(define (current-stack-size)
-  (+ stob-overhead (a-units->cells (address-difference *stack-end* *stack*))))
-
-; Add CELLS cells onto the stack.
-; The stack grows towards negative memory.
-
-(define (add-cells-to-stack! cells)
-  (set! *stack* (address- *stack* (cells->a-units cells))))
-
-(define (the-pointer-before x)
-  (address- x (cells->a-units 1)))
-
-(define (push x)     ; check for overflow is done when continuations are pushed
-  (store! *stack* x)
-  (add-cells-to-stack! 1))
-
-(define (pop)
-  (add-cells-to-stack! -1)
-  (fetch *stack*))
-
-; Use the stack as a vector, with (STACK-REF 0) => current top of stack
-
-(define (stack-ref index)
-  (fetch (address+ *stack* (cells->a-units (+ 1 index)))))
-
-(define (stack-set! index value)
-  (store! (address+ *stack* (cells->a-units (+ 1 index))) value))
-
-(define (pointer-to-stack-arguments)
-  (address+ *stack* (cells->a-units 1)))
-
-(define (remove-stack-arguments count)
-  (add-cells-to-stack! (- 0 count)))
-
-(define (address-at-header stob)
-  (address- (address-after-header stob) (cells->a-units 1)))
-
-;----------------
-; *STACK-LIMIT* is offset by DEFAULT-STACK-SPACE to make this test faster.
-
-(define (ensure-default-procedure-space! ensure-space)
-  (if (address< *stack* *stack-limit*)
-      (begin
-	(copy-stack-into-heap (ensure-space (current-stack-size)))
-	(if (address< *stack* *stack-limit*)
-	    (error "Couldn't get default procedure space (how can this happen?)"))))
-  0)
-
-; Compiler is not allowed to use more than one stack's worth of space for
-; any given procedure.
-
-(define (ensure-stack-space! space ensure-space)
-  (if (not (available-on-stack? space))
-      (begin
-	(copy-stack-into-heap (ensure-space (current-stack-size)))
-	(if (not (available-on-stack? space))
-	    (error "VM's stack is too small (how can this happen?)")))))
-
-(define (available-on-stack? space)
-  (> (+ (a-units->cells			; space on the stack
-	   (address-difference *stack* *stack-limit*))
-	default-stack-space)            ; allow for *stack-limit*'s offset
-     space))
-
-;----------------
-; Setting the current continuation.
-
-; Called when replacing the current continuation with a new one.
-
-(define (set-current-continuation! cont)
-  (if (continuation? cont)
-      (copy-continuation-from-heap! cont)
-      (reset-stack-pointer cont)))
-
-; Called when returning off of the end of the stack.
-
-(define (get-continuation-from-heap)
-  (continuation-cont *bottom-of-stack*))
-
-; Copy CONT from heap onto stack just above *BOTTOM-OF-STACK*, linking it
-; to *BOTTOM-OF-STACK* and *BOTTOM-OF-STACK* to CONT's continuation.
-
-(define (copy-continuation-from-heap! cont)
-  (assert (continuation? cont))
-  (let* ((top (address- (address-at-header *bottom-of-stack*)
-			(cells->a-units (+ 1 (continuation-length cont)))))
-         (new-cont (address->stob-descriptor (address1+ top))))
-    (add-copy-cont-from-heap-stats cont)
-    (set! *stack* (the-pointer-before top))
-    (set! *cont* new-cont)
-    (copy-memory! (address-at-header cont)
-		  top
-		  (cells->bytes (+ 1 (continuation-length cont))))
-    (set-continuation-cont! *bottom-of-stack* (continuation-cont new-cont))
-    (set-continuation-cont! new-cont *bottom-of-stack*)
-    new-cont))
-
-(define (push-continuation-on-stack template pc arg-count)
-  (add-continuation-stats arg-count)
-  (add-cells-to-stack! (+ 1 continuation-cells))
-  (store! (address1+ *stack*) (make-continuation-header arg-count))
-  (let ((cont (address->stob-descriptor (address2+ *stack*))))
-    (set-continuation-pc!       cont pc)
-    (set-continuation-template! cont template)
-    (set-continuation-env!      cont *env*)
-    (set-continuation-cont!     cont *cont*)
-    (set! *cont* cont)))
-
-(define make-continuation-header
-  (let ((type (enum stob continuation)))
-    (lambda (arg-count)
-      (make-header-immutable
-       (make-header type (cells->bytes (+ arg-count continuation-cells)))))))
-
-(define (pop-continuation-from-stack set-template!)
-  (let ((cont *cont*))
-    (set-template! (continuation-template cont)
-		   (continuation-pc       cont))
-    (set! *env*    (continuation-env      cont))
-    (set! *cont*   (continuation-cont     cont))
-    (set! *stack* (address+ (address-at-header cont)
-			    (cells->a-units continuation-cells)))))
-
-;----------------
-; Support for multiple-value returns.
-
-(define (peek-at-current-continuation)
-  (if (= *cont* *bottom-of-stack*)
-      (continuation-cont *bottom-of-stack*)
-      *cont*))
-
-(define (skip-current-continuation!)
-  (let ((next (continuation-cont *cont*)))
-    (if (= *cont* *bottom-of-stack*)
-	(set-continuation-cont! *cont* (continuation-cont next))
-	(set! *cont* next))))
-
-;----------------
-; Copying the stack into the heap because there is no more room on the
-; stack.  This preserves the continuation and then moves any arguments
-; down on top of the current continuation.
-
-(define (copy-stack-into-heap key)
-  (let ((arg-count (arguments-on-stack))
-	(top *stack*))
-    (preserve-continuation key (enum copy overflow))
-    (really-move-args-above-cont! arg-count top)))
-
-(define (arguments-on-stack)
-  (do ((p (address1+ *stack*) (address1+ p))
-       (i 0 (+ i 1)))
-      ((header? (fetch p))
-       (if (= (fetch p) argument-limit-marker)
-	   (- i 1)  ; marker is one past the original header location
-	   i))))
-
-; This is used by the environment code to mark environments that have been
-; migrated to the heap (their header gets clobbered during the of migration).
-; Any header type that is not normally found on the heap will work.
-
-(define argument-limit-marker (make-header (enum stob channel) 0))
-
-(define (really-move-args-above-cont! nargs top-of-args)
-  (let ((start-loc (the-pointer-before (address-at-header *cont*)))
-	(start-arg (address+ top-of-args (cells->a-units nargs))))
-    (do ((loc start-loc (the-pointer-before loc))
-	 (arg start-arg (the-pointer-before arg)))
-	((address<= arg top-of-args)
-	 (set! *stack* loc))
-      (store! loc (fetch arg)))))
-
-; Copy NARGS arguments from the top of the stack to just above CONT.
-; Used by OP/MOVE-ARGS-AND-CALL to implement tail-recursive calls.
-
-(define (move-args-above-cont! nargs)
-  (really-move-args-above-cont! nargs *stack*))
-
-; Migrating the current continuation into the heap, saving the environment
-; first.  The heap space needed is no more than the current stack size.
-
-(define current-continuation-size current-stack-size)
-
-(define (current-continuation key)
-  (preserve-continuation key (enum copy preserve)))
-
-(define (preserve-continuation key reason)
-  (if (false? *cont*)
-      false
-      (really-preserve-continuation key reason)))
-
-; 1. Preserve the current lexical environment
-; 2. Loop down the continuations copying them into the heap, including their
-;    lexical environments
-; 3. Copy the current continuation back onto the stack
-
-(define (really-preserve-continuation key reason)
-  (preserve-current-env-with-reason key reason)
-  (let ((end (continuation-cont *bottom-of-stack*)))
-    (let loop ((cont *cont*) (previous *bottom-of-stack*))
-      (cond ((vm-eq? cont *bottom-of-stack*)
-	     (set-continuation-cont! previous end))
-            (else
-             (if (within-stack? (continuation-env cont))
-                 (save-env-in-heap (continuation-env cont) cont key reason)
-		 0) ; for type inferencer (which could use some improvement)
-             (let ((new (header+contents->stob
-			 (stob-header cont)
-			 (address-after-header cont)
-			 key)))
-	       (add-preserve-cont-stats new reason)
-               (set-continuation-cont! previous new)
-               (loop (continuation-cont new) new))))))
-  (set! *cont* *bottom-of-stack*)  
-  (continuation-cont *bottom-of-stack*))
-
-;----------------
-; Tracing the stack for garbage collection - first trace any arguments pushed
-; above the current continuation, then loop down the continuations, tracing
-; each one along with its environment (if the environment has not yet been
-; done).
-
-(define *stack-warning?* #t)
-
-(define (trace-stack trace-locations! trace-stob-contents! trace-value)
-  (if *stack-warning?*
-      (do ((a *stack-begin* (address1+ a)))
-	  ((not (= stack-marker (fetch a)))
-	   (let ((unused (a-units->cells (address-difference a *stack-begin*))))
-	     (if (< unused stack-warning-limit)
-		 (begin
-		   (newline (current-error-port))
-		   (write-string "[Alert: stack overconsumption ("
-				 (current-error-port))
-		   (write-integer unused (current-error-port))
-		   (write-string "); please inform the Scheme 48 implementors]"
-				 (current-error-port))
-		   (newline (current-error-port))
-		   (set! *stack-warning?* #f)))))))
-  (let ((arg-count (arguments-on-stack)))
-    (trace-locations! (address1+ *stack*)
-		      (address+ *stack* (cells->a-units (+ arg-count 1)))))
-  (if (within-stack? *env*)
-      (trace-env *env* trace-stob-contents!)
-      (set! *env* (trace-value *env*)))
-  (let loop ((cont *cont*) (last-env 0))
-    (let ((env (continuation-env cont)))
-      (trace-stob-contents! cont)
-      (if (not (vm-eq? env last-env))
-	  (trace-env env trace-stob-contents!))
-      (if (not (vm-eq? cont *bottom-of-stack*))
-	  (loop (continuation-cont cont) env)))))
-
-(define (trace-env env trace-stob-contents!)
-  (let loop ((env env))
-    (if (within-stack? env)
-	(begin
-	  (trace-stob-contents! env)
-	  (loop (vm-vector-ref env 0))))))
-
-;----------------
-; Error reporting
-
-(define (report-continuation-uids current-template out)
-  (let ((not-first? (maybe-write-template current-template #f out)))
-    (let loop ((cont *cont*) (not-first? not-first?))
-      (if (continuation? cont)
-	  (loop (continuation-cont cont)
-		(maybe-write-template (continuation-template cont)
-				      not-first?
-				      out))))))
-
-(define (maybe-write-template template not-first? out)
-  (if (and (fixnum? (template-name template))
-	   (not (vm-eq? template (continuation-template *bottom-of-stack*))))
-      (begin
-	(if not-first?
-	    (write-string " <- " out))
-	(write-integer (extract-fixnum (template-name template)) out)
-	#t)
-      not-first?))
-
-;----------------
-; Collecting and printing statistics on stack usage
-
-(define collect-statistics? #f)
-
-(define *conts* 0)
-(define *conts-slots* 0)
-(define *conts-overflow* 0)
-(define *conts-overflow-slots* 0)
-(define *conts-preserved* 0)
-(define *conts-preserved-slots* 0)
-(define *conts-from-heap* 0)
-(define *conts-from-heap-slots* 0)
-
-(define *envs* 0)
-(define *envs-slots* 0)
-(define *envs-closed* 0)
-(define *envs-closed-slots* 0)
-(define *envs-overflow* 0)
-(define *envs-overflow-slots* 0)
-(define *envs-preserved* 0)
-(define *envs-preserved-slots* 0)
-
-(define (reset-stack-stats)
-  (cond (collect-statistics?
-	 (set! *conts* 0)
-	 (set! *conts-slots* 0)
-	 (set! *conts-overflow* 0)
-	 (set! *conts-overflow-slots* 0)
-	 (set! *conts-preserved* 0)
-	 (set! *conts-preserved-slots* 0)
-	 (set! *conts-from-heap* 0)
-	 (set! *conts-from-heap-slots* 0)
-
-	 (set! *envs* 0)
-	 (set! *envs-slots* 0)
-	 (set! *envs-closed* 0)
-	 (set! *envs-closed-slots* 0)
-	 (set! *envs-overflow* 0)
-	 (set! *envs-overflow-slots* 0)
-	 (set! *envs-preserved* 0)
-	 (set! *envs-preserved-slots* 0)
-	 )
-	(else 0)))
-
-(define (print-stack-stats port)
-  (if collect-statistics?
-      (really-print-stack-stats port)))
-
-(define (really-print-stack-stats port)
-  (let ((one-record (lambda (name count slots port)
-		      (newline port)
-		      (write-string "(" port)
-		      (write-string name port)
-		      (write-string " " port)
-		      ;(write-number count port)   ; don't have write-number!
-		      ;(write-number slots port)
-		      (write-string ")" port))))
-    (newline port)
-    (write-string "(continuations" port)
-    (one-record "made" *conts* *conts-slots* port)
-    (one-record "overflow" *conts-overflow* *conts-overflow-slots* port)
-    (one-record "preserved" *conts-preserved* *conts-preserved-slots* port)
-    (one-record "from-heap" *conts-from-heap* *conts-from-heap-slots* port)
-    (write-string ")" port)
-
-    (newline port)
-    (write-string "(environments" port)
-    (one-record "made" *envs* *envs-slots* port)
-    (one-record "closed" *envs-closed* *envs-closed-slots* port)
-    (one-record "overflow" *envs-overflow* *envs-overflow-slots* port)
-    (one-record "preserved" *envs-preserved* *envs-preserved-slots* port)
-    (write-string ")" port)
-    (newline port)
-    ))
-
-(define (add-continuation-stats arg-count)
-  (cond (collect-statistics?
-	 (set! *conts* (+ *conts* 1))
-	 (set! *conts-slots*
-	       (+ *conts-slots* (+ arg-count continuation-cells))))))
-
-
-(define (add-env-stats count)
-  (cond (collect-statistics?
-	 (set! *envs* (+ *envs* 1))
-	 (set! *envs-slots* (+ *envs-slots* (+ count 1))))))
-
-(define (add-copy-env-stats env reason)
-    (cond ((not collect-statistics?)
-	   (unspecific))
-	  ((= reason (enum copy closure))
-	   (set! *envs-closed* (+ *envs-closed* 1))
-	   (set! *envs-closed-slots*
-		 (+ *envs-closed-slots* (vm-vector-length env))))
-	  ((= reason (enum copy overflow))
-	   (set! *envs-overflow* (+ *envs-overflow* 1))
-	   (set! *envs-overflow-slots*
-		 (+ *envs-overflow-slots* (vm-vector-length env))))
-	  ((= reason (enum copy preserve))
-	   (set! *envs-preserved* (+ *envs-preserved* 1))
-	   (set! *envs-preserved-slots*
-		 (+ *envs-preserved-slots* (vm-vector-length env))))))
-
-(define (add-preserve-cont-stats new reason)
-  (cond ((not collect-statistics?)
-	 (unspecific))
-	((= reason (enum copy overflow))
-	 (set! *conts-overflow* (+ *conts-overflow* 1))
-	 (set! *conts-overflow-slots*
-	       (+ *conts-overflow-slots*
-		  (continuation-length new))))
-	((= reason (enum copy preserve))
-	 (set! *conts-preserved* (+ *conts-preserved* 1))
-	 (set! *conts-preserved-slots*
-	       (+ *conts-preserved-slots*
-		  (continuation-length new))))))
-
-(define (add-copy-cont-from-heap-stats cont)
-  (cond (collect-statistics?
-	 (set! *conts-from-heap* (+ *conts-from-heap* 1))
-	 (set! *conts-from-heap-slots* (+ *conts-from-heap-slots*
-					  (continuation-length cont))))))
diff --git a/scheme/vm/stob.scm b/scheme/vm/stob.scm
deleted file mode 100644
index 8ab8d81..0000000
--- a/scheme/vm/stob.scm
+++ /dev/null
@@ -1,98 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-(define max-stob-size-in-cells
-  (+ max-stob-contents-size-in-cells
-     stob-overhead))
-
-(define (make-stob type len key)
-  (let ((addr (s48-allocate-space type (+ len (cells->bytes stob-overhead)) key)))
-    (store! addr (make-header type len))
-    (address->stob-descriptor (address+ addr (cells->bytes stob-overhead)))))
-
-(define (make-d-vector type len key)
-  (make-stob type (cells->bytes len) key))
-
-(define make-b-vector make-stob)
-
-; Used to copy stuff from the stack to the heap.
-
-(define (header+contents->stob header contents key)
-  (let* ((addr (s48-allocate-space (header-type header)
-				   (+ (header-length-in-bytes header)
-				      (cells->bytes stob-overhead))
-				   key))
-	 (data-addr (address+ addr (cells->bytes stob-overhead))))
-    (store! addr header)
-    (copy-memory! contents data-addr (header-length-in-bytes header))
-    (address->stob-descriptor data-addr)))
-
-(define (stob-type obj)
-  (header-type (stob-header obj)))
-
-(define (stob-of-type? obj type)
-  (and (stob? obj)
-       (= (stob-type obj) type)))
-
-; Immutability
-
-(define (immutable? thing)
-  (or (not (stob? thing))
-      (immutable-header? (stob-header thing))))
-
-(define (make-immutable! thing)
-  (if (not (immutable? thing))
-      (stob-header-set! thing (make-header-immutable (stob-header thing)))))
-
-; D-vectors (vectors of descriptors)
-
-(define (d-vector? obj)
-  (and (stob? obj)
-       (< (header-type (stob-header obj)) least-b-vector-type)))
-
-; The type in these routines is used only for internal error checking.
-
-(define (d-vector-length x)
-  (assert (d-vector? x))
-  (header-length-in-cells (stob-header x)))
-
-(define (d-vector-ref x index)
-  (assert (valid-index? index (d-vector-length x)))
-  (fetch (address+ (address-after-header x) (cells->a-units index))))
-
-(define (d-vector-set! x index value)
-  (assert (valid-index? index (d-vector-length x)))
-  (let ((addr (address+ (address-after-header x) (cells->a-units index))))
-    (s48-write-barrier x addr value)
-    (store! addr value)))
-
-(define (d-vector-init! x index value)
-  (assert (valid-index? index (d-vector-length x)))
-  (store! (address+ (address-after-header x) (cells->a-units index))
-          value))
-
-; B-vector = vector of bytes.
-
-(define (b-vector? obj)
-  (and (stob? obj)
-       (>= (header-type (stob-header obj))
-	   least-b-vector-type)))
-
-(define (b-vector-length x)
-  (assert (b-vector? x))
-  (header-length-in-bytes (stob-header x)))
-
-(define (b-vector-ref b-vector index)
-  (assert (valid-index? index (b-vector-length b-vector)))
-  (fetch-byte (address+ (address-after-header b-vector) index)))
-
-(define (b-vector-set! b-vector index value)
-  (assert (valid-index? index (b-vector-length b-vector)))
-  (store-byte! (address+ (address-after-header b-vector) index) value))
-
-; Various utilities
-
-(define (valid-index? index len)
-  (and (>= index 0) (< index len)))
-
-
diff --git a/scheme/vm/symbol.scm b/scheme/vm/symbol.scm
deleted file mode 100644
index 509f73c..0000000
--- a/scheme/vm/symbol.scm
+++ /dev/null
@@ -1,63 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-; The symbol table, which is just a string table full of symbols.
-
-(define *the-symbol-table*)
-
-(define-consing-primitive intern (string->)
-  (lambda (ignore)
-    (+ vm-symbol-size
-       hash-table-entry-size))
-  (let ((searcher (table-searcher vm-symbol->string
-				  vm-symbol-next
-				  vm-make-symbol)))
-    (lambda (string key)
-      (searcher *the-symbol-table* string key)))
-  return)
-
-; Using the regular set-...-next! procedures in the cleanup procedure is
-; unfortunate, because they go through the write barrier.  Of course, we
-; could disable that for these setters, since the symbol table has to be
-; checked every GC anyway.
-
-; Copy the table and remove any unreachable symbols.  This is exported for
-; use when writing an image.
-
-(define s48-copy-symbol-table
-  (let ((cleaner! (table-cleaner vm-symbol-next vm-set-symbol-next!)))
-    (lambda ()
-      (let ((new (s48-trace-value *the-symbol-table*)))
-	(cleaner! new)
-	new))))
-
-(add-post-gc-cleanup!
-  (lambda ()
-    (set! *the-symbol-table* (s48-copy-symbol-table))))
-
-; There is no symbol table in images created by the static linker.
-
-(define (install-symbols!+gc symbol-table)
-  (if (eq? symbol-table false)
-      (build-symbol-table+gc)
-      (set! *the-symbol-table* symbol-table)))
-
-; Create the symbol table and then add to it all currently-extant symbols.
-
-(define (build-symbol-table+gc)
-  (set! *the-symbol-table* (make-hash-table (ensure-space hash-table-size)))
-  (let ((symbols (let ((maybe (s48-find-all (enum stob symbol))))
-		   (if (eq? maybe false)
-		       (begin
-			 (collect)
-			 (let ((maybe (s48-find-all (enum stob symbol))))
-			   (if (eq? maybe false)
-			       (error "insufficient heap space to build symbol table"))
-			   maybe))
-		       maybe))))
-    (natural-for-each (lambda (i)
-			(symbol-table-add! *the-symbol-table*
-					   (vm-vector-ref symbols i)))
-		      (vm-vector-length symbols))))
-
-(define symbol-table-add! (table-adder vm-symbol->string vm-set-symbol-next!))
diff --git a/scheme/vm/vm-tables.scm b/scheme/vm/vm-tables.scm
deleted file mode 100644
index 25b0f34..0000000
--- a/scheme/vm/vm-tables.scm
+++ /dev/null
@@ -1,109 +0,0 @@
-; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-; String hash tables for managing three tables:
-;  the symbol table : string -> symbol
-;  exported-bindings : string -> shared-binding
-;  imported-bindings : string -> shared-binding
-
-; Size of the hash vectors (is this a reasonable size?).
-
-(define hash-table-slots 1024)
-
-(define hash-table-size (vm-vector-size hash-table-slots))
-
-; All hash table values are required to have their own link fields.
-
-(define hash-table-entry-size 0)
-
-(define (hash-table-index string)
-  (bitwise-and (vm-string-hash string)
-	       (- hash-table-slots 1)))
-
-; All buckets are initially false.
-
-(define (make-hash-table key)
-  (let ((table (vm-make-vector hash-table-slots key)))
-    (natural-for-each (lambda (index)
-			(vm-vector-set! table index false))
-		      hash-table-slots)
-    table))
-
-; Return a procedure for adding FOO's to tables.
-
-(define (table-adder foo-string set-foo-next!)
-  (lambda (table foo)
-    (let ((index (hash-table-index (foo-string foo))))
-      (set-foo-next! foo (vm-vector-ref table index))
-      (vm-vector-set! table index foo))))
-
-; Return a function for looking up strings in a Foo table.  A new Foo is
-; made if none is found.
-
-(define (table-searcher foo-string foo-next make-foo)
-  (lambda (table string key)
-    (let* ((index (hash-table-index string))
-           (bucket (vm-vector-ref table index)))
-      (let loop ((foo bucket))
-        (cond ((vm-eq? foo false)
-               (let ((new (make-foo string bucket key)))
-                 (vm-vector-set! table index new)
-                 new))
-              ((vm-string=? string (foo-string foo))
-	       foo)
-              (else
-	       (loop (foo-next foo))))))))
-
-; Same thing, except we remove the entry if it is found.
-
-(define (table-remover foo-string foo-next set-foo-next!)
-  (lambda (table string)
-    (let* ((index (hash-table-index string))
-           (bucket (vm-vector-ref table index)))
-      (let loop ((previous-foo false) (foo bucket))
-	(cond ((vm-eq? foo false)
-	       (unspecific))
-	      ((not (vm-string=? string (foo-string foo)))
-	       (loop foo (foo-next foo)))
-	      ((vm-eq? previous-foo false)
-	       (vm-vector-set! table index (foo-next foo)))
-	      (else
-	       (set-foo-next! previous-foo (foo-next foo))))))))
-
-; Return a procedure that will apply PROC to every element of TABLE.
-
-(define (table-walker foo-next)
-  (lambda (proc table)
-    (natural-for-each (lambda (index)
-			(let loop ((entry (vm-vector-ref table index)))
-			  (if (not (vm-eq? entry false))
-			      (begin
-				(proc entry)
-				(loop (foo-next entry))))))
-		      hash-table-slots)))
-
-; Copy a table, treating the entries weakly.
-
-(define (table-cleaner foo-next set-foo-next!)
-  (let ((entry-cleaner (entry-cleaner foo-next set-foo-next!)))
-    (lambda (table)
-      (let ((table (s48-trace-value table)))
-	(natural-for-each
-	  (lambda (index)
-	    (vm-vector-set! table
-			    index
-			    (entry-cleaner (vm-vector-ref table index))))
-	  hash-table-slots)))))
-  
-(define (entry-cleaner foo-next set-foo-next!)
-  (lambda (foo)
-    (let loop ((foo foo) (okay false))
-      (if (vm-eq? foo false)
-	  okay
-	  (loop (foo-next foo)
-		(if (s48-extant? foo)
-		    (let ((new-foo (s48-trace-value foo)))
-		      (set-foo-next! new-foo okay)
-		      new-foo)
-		    okay))))))
-
diff --git a/scheme/vm/vm-utilities.scm b/scheme/vm/vm-utilities.scm
deleted file mode 100644
index c1a4000..0000000
--- a/scheme/vm/vm-utilities.scm
+++ /dev/null
@@ -1,47 +0,0 @@
-; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-
-(define (adjoin-bits high low k)
-  (+ (shift-left high k) low))
-
-(define (low-bits n k)
-  (bitwise-and n (- (shift-left 1 k) 1)))
-
-(define high-bits arithmetic-shift-right)
-
-(define unsigned-high-bits logical-shift-right)
-
-(define (digit? ch)
-  (let ((ch (char->ascii ch)))
-    (and (>= ch (char->ascii #\0))
-	 (<= ch (char->ascii #\9)))))
-
-(define (vector+length-fill! v length x)
-  (do ((i 0 (+ i 1)))
-      ((>= i length))
-    (vector-set! v i x)))
-
-; Apply PROC to 0 ... N-1.
-
-(define (natural-for-each proc n)
-  (do ((i 0 (+ i 1)))
-      ((= i n))
-    (proc i)))
-
-;----------------
-
-(define (error? status)
-  (not (eq? status (enum errors no-errors))))
-
-(define (write-error-string string)
-  (write-string string (current-error-port)))
-
-(define (write-error-integer integer)
-  (write-integer integer (current-error-port)))
-
-(define (write-error-newline)
-  (write-char #\newline (current-error-port)))
-
-(define (error-message string)
-  (write-error-string string)
-  (write-error-newline))