;;; -*- Mode: Lisp; Package: (CLSCH LISP); Syntax: Common-lisp -*-

;;; An implementation of Scheme, less continuations, in Common Lisp.

;;; ***** Initial version - not fully debugged
;;; ***** Please do not redistribute without permission (yet).
;;; ***** This version has significant performance and other problems.
;;; ***** A rewrite is in progress.

;;; ***** This isn't recommended for educational use, since the only 
;;; ***** debugging tool is TRACE.  There's no backtrace, stack debugger,
;;; ***** or break package.

;;; The dialect here is a union of the features needed for
;;;  (a) the code in Abelson & Sussman's book "Structure and Interpretation
;;;	 of Computer Programs"
;;;  (b) the problem sets for the 6.001 course
;;;  (c) the "essential" subset of the Revised Revised Report on Scheme
;;;      Scheme

;;; The only thing from (c) that's missing is CALL-WITH-CURRENT-CONTINUATION.
;;; Some things from (b) might be missing; I haven't checked thoroughly.

;;; A small number of important nonstandard features are present also:
;;; RANDOM, tables, "named LET", FLUID-LET, and DEFINE-MACRO.

;;; Implementing full CALL-WITH-CURRENT-CONTINUATION would be a major
;;; headache.  Fortunately, Scheme is still moderately useful without
;;; upwards continuations.

;;; Thanks to John Ramsdell of Mitre Corp. and Eric Benson of Lucid Inc. for
;;; various contributions.

;;; Hacked intermittently from August 1985 to April 86
;;; by Jonathan Rees, MIT

;;; *** CHANGE LOG ***
;;; Version 184 (4/23/86)
;;;  - CASE, 3600 backquote compatibility
;;; Version 181 (4/16/86)
;;;  - Curried define, BOOLEAN?, #T and #F, #S (short), #L (long), #D (decimal)
;;; Version 180 (4/7/86)
;;;  - 2 tiny fixes (ignore and iterate)
;;; Version 179 (3/10/86)
;;;  - Fixed various problems found by Eric Benson and John Ramsdell
;;; Version 174 (2/27/86)
;;;  - Tested with query system, CLISP, etc. and fixed a few bugs.
;;;  - Microfeatures (%ge env), (lisp), #I and #E, #L = use Lisp syntax.
;;;  - Implemented Eric Benson's incredible read table hack, which
;;;    unfortunately doesn't work at all on the 3600.  Parameterized by
;;;    *use-roadblock-method?*.
;;; Version 160 (12/7/85)
;;;  - Revamped top level dispatch of TRANSLATE.
;;;  - Generic operation system for use internal to the implementation.
;;;  - Hacko implementation of MAKE-ENVIRONMENT.
;;;  - Extend EXPLODE to work on numbers.
;;; Version 156 (11/22/85)
;;;  - JDR's latest set of fixes
;;; Version 154 (11/21/85)
;;;  - Flushed idea of exporting things in Scheme package.
;;;  - Translator passes an ENV argument around (doesn't use it yet).
;;; Version 149 (11/16/85)
;;;  - Winning quasiquote macro.
;;;  - Scheme's very own printer.
;;; Version 146 (11/12/85)
;;;  - Eric Benson's colon read macro.
;;;  - Fixed a bug in WRITE.
;;;  - John Ramsdell's meta-. hacks.
;;; Version 134 (11/10/85)
;;;  - Entry function S renamed to be SCHEME.
;;;  - Object file extension is now SBIN istead of SFASL.
;;;  - Improvements in package structure; SCHEME now inherits from CLSCH.
;;;     E.g., Scheme's QUOTE is now the same as Lisp's.
;;;  - Definition of a DEFINE macro in the SCHEME package, so that it
;;;     will now sort of work to use Common Lisp LOAD and EVAL and editor
;;;	commands to cause Scheme values to get defined.
;;;  - No more call to MACROEXPAND (avoid Symbolics DEFSUBST screw).
;;;  - Elimination of REC in DEFINE expansion (for speed and debugging).
;;;  - Some nonstandard features: tables, FLUID-LET, and DEFINE-MACRO.
;;;  - Scheme DEFINE also sets the function cell.
;;;  - Trivial definition of NUMBER->STRING.

;;; A minor flaw:
;;;  (define (foo x) y) is the same as
;;;  (define foo (lambda (x) y)), NOT
;;;  (define foo (rec foo (lambda (x) y))), as the RRRS would dictate.
;;; Fortunately, this delinquency leads to faster execution, and makes
;;; TRACE work besides.  Also the new report is going to fix this.

;;; Another minor flaw (which e.g. makes the explicit control evaluator
;;; from S&ICP fail to run):
;;;  Forward references don't work properly with MAKE-ENVIRONMENT, i.e.
;;;  if an EVAL in a non-top-level environment refers to something
;;;  which isn't defined until a later EVAL, you'll lose.  In particular,
;;;  the 6.001 register machine simulator can do backwards jumps but not
;;;  forward jumps (!).

;;; To do:
;;;  - It would be nice if there was an evaluator.  Code runs too
;;;    slowly if it's not compiled; and debugging is a pain.
;;;  - CAR and CDR of () should be error.
;;;  - () and #F should be distinct.
;;;  - Error reporting is bad; e.g., no procedure names.
;;;  - Need equivalent of GRINDEF.
;;;  - Want optimization of LETREC.
;;;  - Variants of the compiler: (1) real continuations, (2) CL's which
;;;    already have tail recursion, (3) CL's which can kludge tail 
;;;    recursion (e.g. 3600's)

;;; **********************************************************************

;;; Package setup, etc.

(in-package 'clsch)				;Common Lisp SCHeme

;;; Scheme lives within its own package, but happens to inherit the
;;; symbols that CLSCH exports.  It does NOT inherit from LISP!

(eval-when (eval load compile)
  (defvar clsch-package (find-package "CLSCH"))
  (defvar scheme-package
	  (make-package 'scheme :use (list clsch-package))))

(shadow '(help lambda) clsch-package)

(export '(help lambda
	       else scheme quote set! begin if
	       delay define-macro fluid-let the-environment)
	clsch-package)

(import '(scheme) (package #-3600 "USER" #+3600 "CL-USER"))

(shadow '(define nil t)
	scheme-package)

(proclaim '(special *current-environment*))

(defvar help

"How to use Scheme:
 - To start a scheme read-eval-print loop, evaluate (CLSCH:SCHEME).
 - To exit scheme once in it, do (EXIT).
 - To get back into the scheme read-eval-print loop, e.g. when an
   error occurs, do (RESET).
 - Use MIT AI memo 848, the Revised Revised Report on Scheme, as a
   reference manual.  All features marked 'essential' are here,
   along with many of the non-essential features.
 - CALL-WITH-CURRENT-CONTINUATION exists, but continuations will have
   indefinite extent only if the host Common Lisp's BLOCK tags do.
 - Additional features used in S&ICP are also defined, with the
   exception of macros like COLLECT and DEFINE-MACHINE.
 - The expression ## evaluates to the value of the read-eval-print
   loop's last evaluation.
 - To compile a scheme file, use scheme's COMPILE-FILE procedure.")

;;; Utilities for avoiding compiler warnings

(defmacro ignorable (&rest vars)
  `(progn ,@vars))

;;; The following may need to be adjusted for particular implementations,
;;; since there isn't really any reliable way to do this.
;;; (Macros can't expand into declarations.)

(defmacro ignore (&rest vars)
  `(progn ,@vars))

(defmacro with-package-and-readtable (pkg rt &body body)
  #-Symbolics
  `(let ((*package* ,pkg)
	 (*readtable* ,rt))
     ,@body)
  #+Symbolics
  `(zl:standard-value-let ((zl:package ,pkg)
			   (zl:readtable ,rt))
     ,@body))

;;;----- Scheme-like macros for Common Lisp code

;;; The main reason the following things exist is so that the translator
;;; itself can be written in Scheme instead of in Common Lisp.  This is
;;; mostly just an exercise.

(eval-when (eval load compile)

(defun ampersandify (bvl)
  (do ((l bvl (cdr l))
       (z '() (cons (car l) z)))
      ((atom l)
       (cond ((null l)
	      (nreverse z))
	     (t
	      (nreconc z `(&rest ,l)))))))

(defun concatenate-symbol (&rest things)	;   T
  (values (intern (apply #'concatenate 'string (mapcar #'string things)))))
)

;;; Same as SETQ but inhibits "not declared special" warning.

(defmacro setq-global-value (var val)
  (let ((g (gensym)))
    `(let ((,g ,val))
       (declare (special ,var))
       (setq ,var ,g)
       ',var)))

(defmacro define (pat &body body)
  (cond ((consp pat)
	 `(defun ,(car pat) ,(ampersandify (cdr pat)) ,@body))
	(t
	 `(setq-global-value ,pat ,@body))))

;;; LAMBDA is shadowed in the CLSCH package, to avoid a conflict here with
;;; any possible LAMBDA macro defined in the host Common Lisp.

(defmacro lambda (vars &body body)
  `#'(lisp:lambda ,(ampersandify vars) ,@body))

;#-Lucid
(defmacro iterate (tag specs &body body)
  (let ((vars (mapcar #'car specs))
	(id (gensym)))
    `(block ,id
       (let ,specs
	 (tagbody
	   ,id (macrolet ((,tag ,vars
			   `(progn (psetq ,@(list ,@(mapcan #'(lisp:lambda (var)
								`(',var ,var))
							    vars)))
				   (go ,',id))))
		 (return-from ,id (progn ,@body))))))))

;;; The following version is better, but isn't efficiently compiled by most CL's.
;#+Lucid
;(defmacro iterate (tag specs &body body)
;  `(labels ((,tag ,(mapcar #'car specs)
;	     ,@body))
;     (,tag ,@(mapcar #'cadr specs))))

(defun symbol? (x)
  (and x (symbolp x)))

(eval-when (eval compile)
(defmacro defsynonym (dst src)
  `(defmacro ,dst (&rest x) `(,',src ,@x)))

(defsynonym eq?      eq)
(defsynonym equal?   equal)
(defsynonym null?    null)
(defsynonym pair?    consp)
(defsynonym atom?    atom)
(defsynonym number?  numberp)
(defsynonym append!  nconc)
(defsynonym reverse! nreverse)
)

(defconstant else t)

;;; Pretty useless, but the existence of these definitions may help
;;; indentation work on the 3600.

(defmacro letrec (specs &body body)
  `(labels ,(mapcar #'(lisp:lambda (spec)
			(let ((var (car spec)) (val (cadr spec)))
			  (cond ((and (pair? val)
				      (eq? (car val) 'lambda))
				 `(,var ,(ampersandify (cadr val))
					,@(cddr val)))
				(t
				 (error "losing LETREC spec - ~s" spec)))))
		    specs)
     ,@body))

(defmacro fluid-let (specs &body body)
  `(let ,specs
     (declare (special ,@(mapcar #'car specs)))
     ,@body))

(defmacro define-macro ((name . bvl) &body body)
  `(progn 'compile
	  (defmacro ,name ,(ampersandify bvl) ,@body)
	  (*define-scheme-macro ',name ',name)))

(defmacro set! (var val)
  `(setq ,var ,val))


;;;----- Basic things which need to be defined before everything else

(eval-when (eval load compile)
  
  (defun clsch-symbol (symbol)
    (cond ((eq (symbol-package symbol) clsch-package)
	   symbol)
	  (t
	   (let ((symbol (intern (symbol-name symbol) scheme-package)))
	     symbol))))
  (defun clsch-export (symbol)
    (cond ((eq (symbol-package symbol) clsch-package)
	   (export symbol clsch-package))
	  ((not (eq (symbol-package symbol) scheme-package))
	   (error "bogus symbol: (CLSCH-EXPORT '~s)" symbol)))
    symbol))


;;; Registers for passing arguments

(defvar *argument-registers*
  (list '**a1** '**a2** '**a3** '**a4** '**a5**))

(defvar *proc+arg-regs*
  (cons '**p** *argument-registers*))

(defvar *number-of-arg-regs*
  (length *argument-registers*))

(defvar **p**)
(defvar **a1**)
(defvar **a2**)
(defvar **a3**)
(defvar **a4**)
(defvar **a5**)

(define (ensure-enough-arg-regs n)
  (cond ((> n *number-of-arg-regs*)
	 (iterate loop ((i (1+ *number-of-arg-regs*))
			(l '()))
	   (cond ((> i n)
		  (setf (cdr (last *argument-registers*))
			(reverse! l))
		  (setq *number-of-arg-regs* n))
		 (else
		  (loop (1+ i)
			(cons (intern (format nil "**A~D**" i)
				      (find-package "CLSCH"))
			      l))))))))

;;; The Scheme readtable isn't needed until run time, but this seems
;;; like a good place to put it.

(defvar cl-readtable *readtable*)
(defvar scheme-readtable (copy-readtable nil))

(defconstant quasiquote-marker 'quasiquote-marker)
(defconstant unquote-marker    'unquote-marker)
(defconstant splice-marker     'splice-marker)

(defun sharp-excl-read-macro (stream subchar arg)
  (ignore subchar arg)
  (let ((name (read stream t nil t)))
    (ccase name
      ((scheme::true) t)
      ((scheme::false) nil)
      ((scheme::null) '())
      ((scheme::quasiquote) quasiquote-marker)
      ((scheme::unquote) unquote-marker)
      ((scheme::splice) splice-marker)
      )))

(defun sharp-E/I/S/D-read-macro (stream subchar arg)
  (ignore subchar arg)
  (read stream t nil t))

(defun sharp-L-read-macro (stream subchar arg)  ;long
  (ignore subchar arg)
  (coerce (read stream t nil t) 'double-float))

(defun sharp-T/F-read-macro (stream subchar arg)
  (ignore arg stream)
  (let (#+3600(subchar (character subchar)))
    (ccase subchar ((#\t #\T) t) ((#\f #\F) nil))))

(defun sharp-Q-read-macro (stream subchar arg)  ; #Q: lisp syntax
  (ignore subchar arg)
  (with-package-and-readtable clsch-package cl-readtable
    (read stream t nil t)))

(defun sharp-sharp-read-macro (stream subchar arg)
  (cond (arg (funcall (get-dispatch-macro-character #\# #\# cl-readtable)
		      stream subchar arg))
	(t '(%out))))

;;; Thanks to Eric Benson for the following hack.
;;; Small bug: a symbol beginning ":#" can't be read.

(defun read-alphabetic (stream char)
  (let ((following-char (peek-char nil stream nil stream t)))
    ;; EOF is OK, STREAM is EOF-VALUE.
    (if (or (eq following-char stream)
	    (not (constituentp following-char)))
        (values (intern (string char)))
	(let ((subsymbol (read stream t nil t)))
	  (check-type subsymbol symbol)
	  (values (intern (concatenate 'string
				       (string char)
				       (symbol-name subsymbol))))))))

(defun constituentp (char)
  (multiple-value-bind (fun n-t-p)
      (get-macro-character char)
    (cond (fun (not n-t-p))
	  (t (and (graphic-char-p char)
		  (not (find char " ',;`()[]{}")))))))

(defun quasiquote-read-macro (stream c)
  (ignore c)
  (list quasiquote-marker (read stream t nil t)))

(defun unquote-read-macro (stream c)
  (ignore c)
  (list (let ((following-char
		(peek-char nil stream nil stream t)))
	  (cond ((char= following-char #\@)
		 (read-char stream)
		 splice-marker)
		(t unquote-marker)))
	(read stream t nil t)))

(defun illegal-read-macro (stream char)
  (ignore stream)
  (cerror "treat the character as whitespace"
	  "illegal character read - ~s"
	  char)
  (values))

(let ((*readtable* scheme-readtable))
  (set-macro-character #\` #'quasiquote-read-macro)
  (set-macro-character #\, #'unquote-read-macro)
  #-Symbolics
  (set-macro-character #\: #'read-alphabetic t)
  #+Symbolics   ;Symbolics Common Lisp has many bugs.
  (set-syntax-from-char #\: #\!)
  (set-macro-character #\| #'illegal-read-macro)
  ;(set-macro-character #\\ #'illegal-read-macro)  screws up string reading
  (set-macro-character #\[ #'illegal-read-macro)
  (set-macro-character #\] #'illegal-read-macro)
  (set-macro-character #\{ #'illegal-read-macro)
  (set-macro-character #\} #'illegal-read-macro)
  (set-dispatch-macro-character #\# #\! #'sharp-excl-read-macro)
  (set-dispatch-macro-character #\# #\# #'sharp-sharp-read-macro)
  (set-dispatch-macro-character #\# #\E #'sharp-E/I/S/D-read-macro) ;exact
  (set-dispatch-macro-character #\# #\I #'sharp-E/I/S/D-read-macro) ;inexact
  (set-dispatch-macro-character #\# #\D #'sharp-E/I/S/D-read-macro) ;decimal
  (set-dispatch-macro-character #\# #\S #'sharp-E/I/S/D-read-macro) ;short
  (set-dispatch-macro-character #\# #\L #'sharp-L-read-macro)     ;long
  (set-dispatch-macro-character #\# #\T #'sharp-T/F-read-macro)   ;true
  (set-dispatch-macro-character #\# #\F #'sharp-T/F-read-macro)   ;false
  (set-dispatch-macro-character #\# #\Q #'sharp-Q-read-macro))    ;lisp


;;; Weird primitive object system.  For internal use only.

;;; Generics and instances

(defstruct (instance (:predicate instance?)
		     (:print-function print-instance)))

(defun instance-type (instance) (type-of instance))

(defmacro define-type (foo &body slots)
  (multiple-value-bind (name options)
      (if (atom foo) (values foo '()) (values (car foo) (cdr foo)))
    (multiple-value-bind (parent options)
	(let ((probe (assoc ':include options)))
	  (if probe
	      (values probe
		      (remove-if (lambda (x) (eq? (car x) ':include)) options))
	      '(:include instance)))
      `(defstruct (,name
		   ,parent
		   (:print-function print-instance)
		   (:predicate ,(concatenate-symbol name '?))
		   ,@options)
	 ,@slots))))

;;; Operations & discriminators

(defmacro define-operation ((name instance-arg . other-args) &body body)
  `(*define-operation ',name
		      ,(if (null body)
			   nil
			   `(lambda (,instance-arg ,@other-args) ,@body))))

(define-type discriminator
  name
  (default-method nil)
  (methods '()))

(defun *define-operation (name default-method)
  (cond ((or (not (get name 'discriminator))
	     (not (fboundp name)))
	 (let ((d (make-discriminator :name name)))
	   (if default-method
	       (setf (discriminator-default-method d) default-method))
	   (setf (symbol-function name)
		 (lambda (instance . args)
		   (apply (let ((probe (assoc (instance-type instance)
					      (discriminator-methods d))))
			    (if probe (cdr probe) (default-method d)))
			  instance
			  args)))
	   (setf (get name 'discriminator) d)))))

(defun default-method (d)
  (or (discriminator-default-method d)
      (lambda (&rest args)
	(error "operation ~s not handled; arguments = ~s"
	       (discriminator-name d) args))))

(define-operation (identification obj) (ignore obj) nil)

(define-operation (set-identification obj id) (ignore obj id) nil)

(define-operation (object-hash obj) (ignore obj) nil)

(define-operation (print-instance obj stream guk)
  (ignore guk)
  (print-with-braces obj stream (string-capitalize (symbol-name (type-of obj)))))

(defun print-with-braces (obj stream type-string &rest stuff)
  (format stream "#{~A" type-string)
  (let ((probe (identification obj)))
    (cond (probe (write-char #\space stream) (scheme::write probe stream))
	  (else (let ((probe (object-hash obj)))
		  (cond (probe (write-char #\space stream) (scheme::write probe stream)))))))
  (mapc (lambda (x)
	  (write-char #\space stream)
	  (scheme::write x stream))
	stuff)
  (format stream "}"))

;;; Methods

(defmacro define-method ((name instance-arg . other-args) &body body)
  (cond ((consp instance-arg)
	 (let ((instance-arg (car instance-arg))
	       (instance-type (cadr instance-arg)))
	   `(progn 'compile
		   (define-operation (,name ,instance-arg ,@other-args))
		   (*define-method ',name
				   ',instance-type
				   (lambda (,instance-arg ,@other-args) ,@body)))))
	(t
	 `(define-operation (,name ,instance-arg ,@other-args) ,@body))))

(defun *define-method (operation instance-type method)
  (let ((d (get operation 'discriminator)))
    (let ((probe (assoc instance-type (discriminator-methods d))))
      (if probe
	  (setf (cdr probe) method)
	  (push (cons instance-type method) (discriminator-methods d)))))
  operation)

(define-method (identification (d discriminator))
  (discriminator-name d))


;;;----- The Scheme-to-Common-Lisp Compiler

;;; Each definition of a Scheme special form or procedure is annotated
;;; with one or more letters indicating why that feature is included in
;;; this Scheme implementation.
;;;   E = essential feature of RRRSS
;;;   R = inessential feature of RRRSS
;;;   S = something used in the book S&ICP
;;;   M = MIT Scheme feature needed to run 6.001 course software
;;;   T = random T feature which JAR likes to use

;;; Brief description of compilation strategy:
;;; Scheme code is translated into Common Lisp code, which can then be
;;; either interpreted or compiled.  Scheme parasitizes Common Lisp's
;;; data types.  Also, the compiler doesn't need to keep track of
;;; lexical variable references, since Common Lisp's lexical scoping can
;;; be used.  The main thing the compiler worries about is tail recursion.
;;; If a Scheme procedure returns a non-null second value, that means that
;;; it wants to do a tail-recursive call.  A driver loop is expected to
;;; call the procedure in the **P** register.  Procedures always expect
;;; to receive their arguments in registers **A1**, **A2**, etc.

;;; The top-level form translator returns a Common Lisp LAMBDA
;;; expression.  To evaluate the original expression in an environment
;;; E, just FUNCALL this LAMBDA-expression passing it E.

(define (translate-top-level exp env)
  (multiple-value-bind (type x exp)
      (determine-syntactic-type exp)
    (ignore x)
    `(lisp:lambda (%%the-environment%%)
       %%the-environment%%			;OK if it's ignored
       ,(cond ((eq? type 'definition)
	       (translate-top-level-sequence (list exp) env))
	      ((eq? type 'begin)
	       (translate-top-level-sequence (cdr exp) env))
	      (else
	       (translate exp env nil))))))

(define (translate-top-level-sequence body env)
  (multiple-value-bind (new-body new-vars)
      (scan-defines body env)
    (multiple-value-bind (code trivial?)
	(translate-sequence new-body env nil)
      (ignore trivial?)
      (if new-vars
	  `(progn (prepare-to-define! %%the-environment%% ',new-vars)
		  ,code)
	  code))))

;;; TRANSLATE returns two values: the output expression, and a flag
;;; saying whether or not the expression was trivial (i.e. made
;;; assignments to the argument registers).

(define (translate exp env ret?)
  (multiple-value-bind (type translator exp)
      (determine-syntactic-type exp)
    (ignore type)
    (funcall translator exp env ret?)))

(defvar syntax-table)
(setq syntax-table (make-hash-table :test #'eq))

;;; Returns 3 values:  the type (symbol), translator (function), and
;;; a possibly updated version of the expression.

(define (determine-syntactic-type exp)
  (cond ((pair? exp)
	 (cond ((not (symbol? (car exp)))
		(values 'combination #'translate-combination exp))
	       (else
		(let ((probe (gethash (car exp) syntax-table)))
		  (cond ((not probe)
			 (values 'combination #'translate-combination exp))
			((eq? (car probe) 'macro)
			 (determine-syntactic-type
			   (expand-macro-form (cdr probe) exp)))
			(else
			 (let ((type (car probe)))
			   (cond ((eq? type 'set!)
				  (warn-if-redefining (cadr exp) "assigning"))
				 ((eq? type 'definition)
				  (warn-if-redefining (cadr exp) "redefining")))
			   (values type (cdr probe) exp))))))))
	((symbol? exp)
	 (values 'variable #'translate-variable exp))
	(else
	 (values 'quote #'translate-quote `(quote ,exp)))))

(defmacro define-scheme-syntax (name args &body body)
  ;; Symbolics CL sucks.  Anonymous functions don't get compiled!
  (let ((aux-name (concatenate-symbol 'translate- name)))
    `(progn 'compile
	    (defun ,aux-name ,args ,@args ,@body)
	    (*define-scheme-syntax ',name ',name #',aux-name))))

(define (*define-scheme-syntax name type info)
  (setf (gethash name syntax-table) (cons type info))
  name)

;;; QUOTE

(define-scheme-syntax quote (exp env ret?)	;E S
  (translate-return `(quote ,(cadr exp)) t ret?))

;;; VARIABLE

(define-scheme-syntax variable (exp env ret?)
  (translate-return (translate-reference env exp) t ret?))

;;; SET!

(define-scheme-syntax set! (exp env ret?)	;E S
  (let ((var (cadr exp)))
    (multiple-value-bind (type translator val-exp)
	(determine-syntactic-type (caddr exp))
      (multiple-value-bind (code trivial?)
	  (cond ((eq? type 'lambda)
		 (really-translate-lambda val-exp env nil var))
		(t
		 (funcall translator val-exp env nil)))
	(translate-return (translate-assignment env var code)
			  trivial?
			  ret?)))))

;;; BEGIN

(define-scheme-syntax begin (exp env ret?)	;E
  (translate-sequence (cdr exp) env ret?))

(define (translate-sequence exp-list env ret?)
  (cond ((null? (cdr exp-list))
	 (translate (car exp-list) env ret?))
	(else
	 (iterate loop ((l exp-list)
			(z '())
			(trivial? t))
	   (multiple-value-bind (code arg-trivial?)
	       (translate (car l) env (and (null? (cdr l)) ret?))
	     (let ((trivial? (and trivial? arg-trivial?)))
	       (cond ((null? (cdr l))
		      (values `(progn ,@(reverse! (cons code z))) trivial?))
		     (else
		      (loop (cdr l)
			    (cons code z)
			    trivial?)))))))))

;;; DEFINITION

(define-scheme-syntax definition (exp env ret?)
  (cerror "compile a SET! in place of the DEFINE"
	  "DEFINE in illegal context - ~s"
	  (cons 'define (cdr exp)))
  (translate `(set! ,@(cdr exp)) env ret?))

;;; IF

(define-scheme-syntax if (exp env ret?)	;E
  (multiple-value-bind (test-code test-trivial?)
      (translate (cadr exp) env nil)
    (multiple-value-bind (con-code con-trivial?)
	(translate (caddr exp) env ret?)
      (multiple-value-bind (alt-code alt-trivial?)
	  (translate (cadddr exp) env ret?)
	(values `(if ,test-code
		     ,con-code
		     ,alt-code)
		(and test-trivial? con-trivial? alt-trivial?))))))

;;; LAMBDA

(define-scheme-syntax lambda (exp env ret?)	;E S
  (really-translate-lambda exp env ret? nil))

(defun really-translate-lambda (exp env ret? name)
  (multiple-value-bind (code trivial?)
      (translate-lambda-body (cadr exp)
			     (cddr exp)
			     env
			     t)
    (ignore trivial?)
    (translate-return `(create-procedure
			 (lambda (nargs)
			   ;; Eventually, check number of args.
			   (ignore nargs)
			   (let ,(bind-arguments (cadr exp))
			     ,code))
			 ',name)
		      t				;yes, closures are trivial
		      ret?)))

(define (bind-arguments bvl)
  (ensure-enough-arg-regs (improper-length bvl))
  (do ((l bvl (cdr l))
       (a *argument-registers* (cdr a))
       (n 0 (+ n 1))
       (z '() (cons `(,(car l) ,(car a)) z)))
      ((not (pair? l))
       (reverse! (cond ((null? l) z)
		       (else (cons `(,l (get-n-ary-arg nargs ,n)) z)))))
    (assert (not (null? a)))
    (warn-if-redefining (car l) "binding")))

(define (improper-length l)
  (do ((l l (cdr l))
       (n 0 (1+ n)))
      ((atom? l) n)))

(define (translate-lambda-body arg-vars body env ret?)
  (let ((env (extend-environment arg-vars env)))
    (multiple-value-bind (new-body new-vars)
	(scan-defines body env)
      (multiple-value-bind (code trivial?)
	  (translate-sequence new-body env ret?)
	(values (if (null? new-vars)
		    code
		    `(let ,(mapcar (lambda (var) `(,var '*undefined*))
				   new-vars)
		       ,code))
		trivial?)))))

(define (scan-defines body env)  ;Side-affects env
  (iterate loop ((b body)
		 (vars '())
		 (z '()))
    (cond ((null? b)
	   (values (reverse! z) (reverse! vars)))
	  (else
	   (multiple-value-bind (type x exp)
	       (determine-syntactic-type (car b))
	     (ignore x)
	     (cond ((eq? type 'definition)
		    (let ((name (cadr exp)) (val (caddr exp)))
		      (process-definition! env name)
		      (loop (cdr b)
			    (cons name vars)
			    (cons `(set! ,name ,val)
				  z))))
		   (else
		    (loop (cdr b)
			  vars
			  (cons exp z)))))))))

;;; COMBINATION

(define-scheme-syntax combination (exp env ret?)
  (let ((proc-exp (car exp))
	(arg-exps (cdr exp)))
    (multiple-value-bind (type x proc-exp)
	(determine-syntactic-type proc-exp)
      (ignore x)
      (cond ((eq? type 'variable)
	     (let ((probe (get proc-exp 'trivial)))
	       (cond (probe
		      (translate-trivial-call probe arg-exps env t ret?))
		     (t
		      (translate-nontrivial-call proc-exp arg-exps env ret?)))))
	    ((eq? type 'lambda)
	     ;; LAMBDA-combinations are trivial.
	     (multiple-value-bind (code trivial?)
		 (translate-lambda-body (cadr proc-exp) (cddr proc-exp) env ret?)
	       (let ((new-bvl (ampersandify (cadr proc-exp))))
		 (mapc (lambda (b) (warn-if-redefining b "binding")) new-bvl)
		 (translate-trivial-call `(lisp:lambda ,new-bvl
					    ,code)
					 arg-exps
					 env
					 trivial?
					 ret?))))
	    (else
	     (translate-nontrivial-call proc-exp arg-exps env ret?))))))

(define (translate-trivial-call proc-code arg-exps env trivial? ret?)
  (iterate loop ((a arg-exps)
		 (z '())
		 (trivial? trivial?))
    (cond ((null? a)
	   (translate-return `(,proc-code ,@(reverse! z))
			     trivial?
			     ret?))
	  (else
	   (multiple-value-bind (code arg-trivial?)
	       (translate (car a) env nil)
	     (loop (cdr a) (cons code z) (and trivial? arg-trivial?)))))))

(define (translate-nontrivial-call proc-exp arg-exps env ret?)
  (let ((nargs (length arg-exps)))
    (ensure-enough-arg-regs nargs)
    (let ((setup-code (psetqify-args proc-exp arg-exps env)))
      (cond (ret? (values `(progn ,@setup-code
				  (values nil ,nargs))
			  nil))
	    (else (values `(progn ,@setup-code
				  (driver-loop ,nargs))
			  nil))))))

;;; Tries to do SETQ's in preference to PSETQ's, where possible.

(define (psetqify-args proc-exp arg-exps env)
  (iterate loop ((a (cons proc-exp arg-exps))
		 (r *proc+arg-regs*)
		 (setqs '())
		 (psetqs '()))
    (cond ((null? a)
	   (append (if (null? psetqs) '() `((psetq ,@(reverse! psetqs))))
		   (if (null?  setqs) '() `(( setq ,@(reverse!  setqs))))))
	  (else
	   (multiple-value-bind (code trivial?)
	       (translate (car a) env nil)
	     (let ((reg (car r)))
	       (cond (trivial?
		      (loop (cdr a) (cdr r) (list* code reg setqs) psetqs))
		     (else
		      (loop (cdr a) (cdr r) setqs (list* code reg psetqs))
		      ))))))))

;;; Generates adequate, but potentially inferior, code.

(define (psetqify-args-ez proc-exp arg-exps env)
  `((psetq ,@(mapcan (lambda (reg exp)
		       (list reg (translate exp env nil)))
		     *proc+arg-regs*
		     (cons proc-exp arg-exps)))))

;;; Utilities

(define (warn-if-redefining name what)
  (cond ((get name 'trivial)
	 (with-package-and-readtable scheme-package scheme-readtable
	   (format *error-output*
		   "~&Warning: ~A ~S, which is a built-in procedure.~&"
		   what
		   name))
	 (remprop name 'trivial))))

;;; This is how to actually deliver the object code for some expression.

(define (translate-return exp trivial? ret?)
  (ignore ret?)
  (values exp trivial?))

;;;; Nonstandard special forms

;;; DELAY
;;; Could be a macro, but this is a speed hack.

(define-scheme-syntax delay (exp env ret?)	;  S
  (translate-return `(make-delay :thunk-or-value
				 #'(lisp:lambda () ,(translate (cadr exp) env nil)))
		    t ret?))

;;; DEFINE-MACRO - sort of compatible with MIT Scheme

(define-scheme-syntax define-macro (exp env ret?)	;   M
  (let ((name (caadr exp))
	(bvl  (cdadr exp))
	(body (cddr exp)))
    (let ((internal-name (concatenate-symbol name '/scheme-macro)))
      (multiple-value-bind (code trivial?)
	  (translate-sequence body env nil)
	(ignore trivial?)
	(translate-return `(progn 'compile
				  (defmacro ,internal-name ,(ampersandify bvl)
				    ,code)
				  (*define-scheme-macro ',name
							',internal-name))
			  t
			  ret?)))))

;;; FLUID-LET - like MIT Scheme, but only works on top level
;;; variables, at least for now.

(define-scheme-syntax fluid-let (exp env ret?)
  (let ((specs (cadr exp))
	(body (cddr exp)))
    (multiple-value-bind (code trivial?)
	(translate-sequence body env ret?)
      (ignore trivial?)
      (translate-return `(let ,(mapcar (lambda (spec)
					 `(,(car spec)
					   ,(translate (cadr spec) env nil)))
				       specs)
			   (declare (special ,@(mapcar #'car specs)))
			   ,code)
			nil
			ret?))))

;;; THE-ENVIRONMENT

(define-scheme-syntax the-environment (exp env ret?)   ; feature
  (translate-return (translate-environment env)
		    t ret?))

;;; EXPRESSION-QUOTE

(define-scheme-syntax expression-quote (exp env ret?)  ; feature
  (ignore env)
  (translate-return `'(begin ,@(cdr exp)) t ret?))

;;; Compile-time environments
;;; Same data structure is used for run-time environments.  Beware!

(define-type package-environment
  name
  package)

(define-method (identification (env package-environment))
  (package-environment-name env))

(define-method (translate-reference (env package-environment) sym)
  (let ((sp (symbol-package sym))
	(ep (package-environment-package env)))
    (cond ((or (eq? sp ep)
	       (eq? sp clsch-package))		;kludge
	   sym)
	  (else (values (intern (symbol-name sym) ep))))))

(define-method (translate-assignment (env package-environment) sym code)
  (let ((sym (translate-reference env sym)))
    `(setq-global-value ,sym ,code)))

(define-method (process-definition! (env package-environment) sym)
  (ignore env sym)
  nil)

(define-method (translate-environment (env package-environment))
  (ignore env)
  '%%the-environment%%)

;;; Contour (exists only during compilation)

(define-type contour
  variables
  parent)

(define (extend-environment vars env)
  (make-contour :parent env :variables vars))

(define (belongs-to-contour? var env)
  (iterate loop ((vars (contour-variables env)))
    (cond ((atom? vars)
	   (eq? var vars))
	  ((eq? var (car vars)) t)
	  (else (loop (cdr vars))))))

(define-method (translate-reference (env contour) var)
  (if (belongs-to-contour? var env)
      var
      (translate-reference (contour-parent env) var)))

(define-method (translate-assignment (env contour) var code)
  (if (belongs-to-contour? var env)
      `(setq ,var ,code)
      (translate-assignment (contour-parent env) var code)))

(define-method (process-definition! (env contour) var)
  (push var (contour-variables env)))

(define-method (translate-environment (env contour))
  (do ((env env (contour-parent env))
       (vars (contour-variables env)
	     (append (contour-variables env) vars)))
      ((not (contour? env))
       `(*the-environment %%the-environment%% ',vars (list ,@vars)))))

;;; Test routines for translator

#|(define (tst exp)
  (pp (translate-top-level exp *current-environment*))
  '*)

(define (show obj)
    (check-type obj procedure)
    (pp (si::undigest (sys::%p-contents-offset (procedure-function obj) 1)))
    '*)|#

;;;----- Scheme macros

(defmacro define-scheme-macro ((name . args) &body body)
  (let ((aux-name (concatenate-symbol name '/scheme-macro)))
    `(progn 'compile
	    (export ',name clsch-package)
	    (defmacro ,aux-name ,(ampersandify args) ,@body)
	    (*define-scheme-macro ',name ',aux-name))))

(define (expand-macro-form aux-name exp)
  (macroexpand-1 (cons aux-name (cdr exp))))

(defun *define-scheme-macro (sym mac)
  (*define-scheme-syntax sym 'macro mac))

;;; (Definitions of macros appear in alphabetical order.)

(define-scheme-macro (and . forms)		; RS
  (labels ((expand-and (forms)
            (cond ((atom? forms) 't)
                  ((atom? (cdr forms)) (car forms))
                  (else `(if ,(car forms)
			     ,(expand-and (cdr forms))
			     nil)))))
    (expand-and forms)))

;;; case					; R

(define-scheme-macro (case key . clauses)
  (let ((var '%%key%%))
    `(let ((,var ,key))
       (cond ,@(mapcar (lambda (clause)
			 `(,(cond ((eq (car clause) 'else) 'else)
				  ((null (car clause)) `nil)
				  ((null (cdr (car clause))) `(eqv? ,var ',(caar clause)))
				  (t `(memv ,var ',(car clause))))
			   ,@(cdr clause)))
		       clauses)))))

;;; collect					;  S (!)

(define-scheme-macro (cond . clauses)		;E S
  (labels ((expand-cond (clauses)
            (cond ((atom? clauses) ''**no-more-cond-clauses**)
                  ((atom? (car clauses))
                   (cerror "ignore it" "atomic COND clause: ~s" (car clauses))
		   (expand-cond (cdr clauses)))
                  ((atom? (cdar clauses))
                   `(or ,(caar clauses)
			,(expand-cond (cdr clauses))))
		  ((eq? (caar clauses) 'else)
		   (if (not (atom? (cdr clauses)))
		       (cerror "ignore clauses following ELSE clause"
			       "ELSE clause not last in COND: ~s"
			       `(cond ,@clauses)))
		   `(begin ,@(cdar clauses)))
                  (else `(if ,(caar clauses)
			     (begin ,@(cdar clauses))
			     ,(expand-cond (cdr clauses)))))))
    (expand-cond clauses)))

(define-scheme-macro (cons-stream head tail)	;  S
  `(scheme::cons ,head (delay ,tail)))

(defmacro define/scheme-macro (pat &body body)	; E
  (labels ((z (pat body)
	     (cond ((pair? pat)
		    (z (car pat) `((lambda ,(cdr pat) ,@body))))
		   (else
		    `(definition ,pat ,@body)))))
    (z pat body)))
(*define-scheme-macro 'scheme::define 'define/scheme-macro)

(define-scheme-macro (do specs end &body body)	; R
  (let ((loop (gensym "DO")))
    `(letrec ((,loop (lambda ,(mapcar #'car specs)
                       (cond ,end
                             (else ,@body
				   (,loop
				    ,@(mapcar (lambda (y)
						(if (and (cdr y) (cddr y))
						    (caddr y)
						    (car y)))
					      specs)))))))
       (,loop ,@(mapcar (lambda (y) (if (cdr y) (cadr y) 'nil))
			specs)))))

(define-scheme-macro (let specs &body body)	;E S
  (cond ((and (not (pair? specs))   ;Weird MIT extension
	      (not (null? specs)))
	 (let ((tag specs)
	       (specs (car body))
	       (body (cdr body)))
	   `(letrec ((,tag (lambda ,(mapcar #'car specs) ,@body)))
	      (,tag ,@(mapcar #'cadr specs)))))
	(else
	 `((lambda ,(mapcar #'car specs) ,@body)
	   ,@(mapcar (lambda (x)
		       (cond ((atom? (cdr x)) ''**let-missing-initializer**)
			     (else (cadr x))))
		     specs)))))

;;; let*					; R

(define-scheme-macro (letrec specs &body body)	;E
  (iterate loop ((s specs)
		 (vars '())
		 (inits '()))
    (cond ((null? s)
           `((lambda ,vars
	       ,@(reverse! inits)
	       . ,body)
             ,@(mapcar (lambda (var) (ignore var) ''**unbound-label**)
		       vars)))
          (else
           (let ((spec (car s)))
             (cond ((atom? spec)
                    (cerror "ignore it"
			    "bad spec - (LETREC (... ~S ...) ...)"
			    spec)
		    (loop (cdr s) vars inits))
                   ((atom? (car spec))
                    (loop (cdr s)
                          (cons (car spec) vars)
                          (cons `(set! ,@spec)
                                inits)))
                   (else
                    (loop (cdr s)
                          (cons (caar spec) vars)
                          (cons `(set! ,(caar spec)
				       (lambda ,(cdar spec)
					 ,@(cdr spec)))
                                inits)))))))))

(define-scheme-macro (make-environment . body)
  `(*make-environment (the-environment) (expression-quote ,@body)))

(define-scheme-macro (or . args)		; RS
  (labels ((expand-or (args)
	     (cond ((atom? args) ''nil)
		   ((atom? (cdr args)) (car args))
		   (else `((lambda (p)
			     (if p p ,(expand-or (cdr args))))
			   ,(car args))))))
    (expand-or args)))

(define-scheme-macro (rec var exp)		;E S
  `(letrec ((,var ,exp)) ,var))

(define-scheme-macro (sequence . body)		; RS
  `(begin ,@body))

(define-scheme-macro (trace var)
  `(set! ,var (*trace ,var ',var)))

(define-scheme-macro (untrace var)
  `(set! ,var (*untrace ,var)))

;;; Quasiquote

(*define-scheme-macro quasiquote-marker quasiquote-marker)
(defmacro quasiquote-marker (x)
  (expand-quasiquote x 0))

(*define-scheme-macro unquote-marker unquote-marker)
(defmacro unquote-marker (x)
  (cerror "act as if the comma wasn't there at all"
	  "comma not inside backquote form - ,~S" x)
  x)

(*define-scheme-macro splice-marker splice-marker)
(defmacro splice-marker (x)
  (cerror "act as if the ,@ wasn't there at all"
	  "\",@\" not inside backquote form - ,@~S" x)
  x)

(define (expand-quasiquote x level)
  (multiple-value-bind (mode arg)
      (descend-quasiquote x level)
    (finalize-quasiquote mode arg)))

(define (finalize-quasiquote mode arg)
  (cond ((eq? mode 'quote) `',arg)
	((eq? mode 'unquote) arg)
	((eq? mode 'splice)
	 (cerror "act as if () had been seen instead of ,@<form>"
		 ",@ in illegal context - ,@~s"
		 arg))
	(else `(,mode ,@arg))))

;;; The two return values, mode and arg, are interpreted as follows:
;;;    mode    arg          meaning
;;;    QUOTE   x            'x
;;;    UNQUOTE x            x
;;;    LIST    (x1 x2 ...)  (LIST x1 x2 ...)
;;;    CONS*   (x1 x2 ...)  (CONS* x1 x2 ...)
;;;    APPEND  (x1 x2 ...)  (APPEND x1 x2 ...)

(define (descend-quasiquote x level)
  (cond ((vector? x)
	 (descend-quasiquote-vector x level))
	((atom? x)
	 (values 'quote x))
	((interesting-to-quasiquote? x quasiquote-marker)
	 (descend-quasiquote-pair x (1+ level)))
	((interesting-to-quasiquote? x unquote-marker)
	 (cond ((= level 0)
		(values 'unquote (cadr x)))
	       (else
		;; BUG: ,,@ doesn't work.  I think this is the spot
		;; where it would have to be hacked in.
		(descend-quasiquote-pair x (- level 1)))))
	((interesting-to-quasiquote? x splice-marker)
	 (cond ((= level 0)
		(values 'splice (cadr x)))
	       (else
		(descend-quasiquote-pair x (- level 1)))))
        (else
	 (descend-quasiquote-pair x level))))

(define (descend-quasiquote-pair x level)
  (multiple-value-bind (car-mode car-arg)
      (descend-quasiquote (car x) level)
    (multiple-value-bind (cdr-mode cdr-arg)
	(descend-quasiquote (cdr x) level)
      (cond ((and (eq? car-mode 'quote) (eq? cdr-mode 'quote))
	     (values 'quote x))
	    ((eq? car-mode 'splice)
	     ;; (,@mumble ...)
	     (cond ((and (eq? cdr-mode 'quote) (null? cdr-arg))
		    (values 'unquote
			    car-arg))
		   ((eq? cdr-mode 'scheme::append)
		    (values 'scheme::append
			    (cons car-arg cdr-arg)))
		   (else
		    (values 'scheme::append
			    (list car-arg (finalize-quasiquote cdr-mode cdr-arg))))))
	    ((and (eq? cdr-mode 'quote) (null? cdr-arg))
	     (values 'scheme::list
		     (list (finalize-quasiquote car-mode car-arg))))
	    ((or (eq? cdr-mode 'scheme::list) (eq? cdr-mode 'cons*))
	     (values cdr-mode
		     (cons (finalize-quasiquote car-mode car-arg)
			   cdr-arg)))
	    (else
	     (values 'cons*
		     (list (finalize-quasiquote car-mode car-arg)
			   (finalize-quasiquote cdr-mode cdr-arg))))))))

;;;   #(a b c)     ==>  '#(a b c)
;;;   #(a ,b c)    ==>  (vector 'a b 'c)
;;;   #(a ,@b ,c)  ==>  (list->vector (append '(a) b (list c)))
;;; Isn't there some elegant way to do this?

(define (descend-quasiquote-vector x level)
  (iterate loop ((i (- (vector-length x) 1))
		 (modes '())
		 (args '())
		 (flag nil))
    (cond ((>= i 0)
	   (multiple-value-bind (mode arg)
	       (descend-quasiquote (vector-ref x i) level)
	     ;; mode = quote, unquote, splice, list, cons*
	     (loop (- i 1)
		   (cons mode modes)
		   (cons arg args)
		   (or flag (not (eq? mode 'quote))))))
	  ((not flag)
	   (values x 'quote))
	  ((memq 'splice modes)
	   (values 'list->vector
		   (list (cons 'append
			       (mapcar (lambda (mode arg)
					 (cond ((eq? mode 'splice) arg)
					       ;; Not good.
					       ((eq? mode 'quote)
						(list 'quote (list arg)))
					       (else
						(list 'list
						      (finalize-quasiquote mode arg)))))
				       modes
				       args)))))
	  (else
	   (values 'vector
		   (mapcar #'finalize-quasiquote modes args))))))

(define (interesting-to-quasiquote? x marker)
  (and (pair? x)
       (eq? (car x) marker)
       (pair? (cdr x))
       (null? (cddr x))))

;;;----- Runtime system

(define-type procedure
  function
  name)

(defun create-procedure (fun name)
  (make-procedure :function fun :name name))

(define-method (identification (p procedure))
  (let ((n (procedure-name p)))
    (if (not (number? n)) n nil)))

(defvar *procedure-uid-counter* 0)

(define-method (object-hash (p procedure))
  (let ((n (procedure-name p)))
    (cond ((number? n) n)
	  ((null? n)
	   (setf (procedure-name p) (incf *procedure-uid-counter*))))))

(define-method (set-identification (obj procedure) name)
  (if (not (symbol? (procedure-name obj)))
      (setf (procedure-name obj) name)))

(defun driver-loop (nargs)
  (prog (val)
   loop
    (multiple-value-setq (val nargs)
      (funcall (procedure-function **p**) nargs))
    (if (not nargs) (return val))
    (go loop)))

(defun get-n-ary-arg (nargs n)
  (do ((i n (1+ i))
       (l (nthcdr n *argument-registers*) (cdr l))
       (z '() (cons (symbol-value (car l)) z)))
      ((= i nargs) (nreverse z))
    (declare (fixnum i))))

(defun function->procedure (fun name)
  (create-procedure (lambda (nargs)
			(apply fun (get-n-ary-arg nargs 0)))	;Suboptimal
		    name))

(defun procedure->function (proc)
  (lambda args
    (driver-loop (set-registers-from-list proc args))))

;;; Returns number of args.

(defun set-registers-from-list (proc args)
  (let ((nargs (length args)))
    (ensure-enough-arg-regs nargs)
    (mapc (lambda (arg-reg arg)
	      (setf (symbol-value arg-reg) arg))
	  *argument-registers*
	  args)
    (setf **p** proc)
    nargs))

(defun scheme-call (proc &rest args)
  (driver-loop (set-registers-from-list proc args)))

;;; Macros for defining scheme procedures

;;; A nontrivial procedure is one which potentially modifies the
;;; registers.

(defmacro define-scheme-nontrivial ((name . bvl) &body body)
  (let ((scheme-name (clsch-symbol name)))
    `(progn 'compile
	    (clsch-export ',scheme-name) 
	    (defun ,scheme-name ,(ampersandify bvl) ,@body)
	    (setq-global-value ,scheme-name
			       (function->procedure #',scheme-name
						    ',scheme-name)))))

(defmacro define-scheme (pat &body body)
  (cond ((consp pat)
	 (let ((scheme-name (clsch-symbol (car pat))))
	   `(progn 'compile
		   (define-scheme-nontrivial ,pat ,@body)
		   (setf (get ',scheme-name 'trivial) ',scheme-name))))
	(t
	 (let ((scheme-name (clsch-symbol pat)))
	   `(progn 'compile
		   (clsch-export ',scheme-name)
		   (setq-global-value ,scheme-name ,(car body)))))))

(define-scheme-nontrivial (eval exp env)
  (funcall (translate-top-level exp env) env))

;;; Environment manipulation

(define-method (*access (env package-environment) name)
  (symbol-value (translate-reference env name)))

(define-method (*assign! (env package-environment) name value)
  (set-symbol-value-etc (translate-reference env name) value)
  name)

(defun set-symbol-value-etc (name value)
  (setf (symbol-value name) value)
  (set-identification value name)
  ;; Set function cell, but avoid clobbering things like WRITE and LAMBDA.
  (if (and (procedure? value)
	   (eq (symbol-package name) scheme-package)
	   (not (get name 'trivial)))
      (setf (symbol-function name) (procedure->function value)))
  #+Symbolics
  (si:record-source-file-name name 'scheme::define))	; JDR Hack.

(define-method (prepare-to-define! (env package-environment) names)
  (ignore names env)
  nil)

;;; First-class (but somewhat broken) environments

(define-type environment parent variables values mutable?)

(defun really-make-environment (parent names vals mutable?)
  (make-environment
    :parent parent
    :variables names
    :values vals
    :mutable? mutable?))

(define-scheme-nontrivial (*make-environment parent code)
  (let ((env (really-make-environment parent '() '() t)))
    (scheme::eval code env)
    env))

(defun *the-environment (parent names vals)
  (really-make-environment parent names vals nil))

(define-method (*access (env environment) name)
  (iterate loop ((vars (environment-variables env))
		 (vals (environment-values env)))
    (cond ((atom? vars)
	   (if (eq? name vars) vals (*access (environment-parent env) name)))
	  ((eq? name (car vars)) (car vals))
	  (else (loop (cdr vars) (cdr vals))))))

(define-method (*assign! (env environment) name val)
  (iterate loop ((vars (environment-variables env))
		 (vals (environment-values env)))
    (cond ((endp vars)
	   (*assign! (environment-parent env) name val))
	  ((eq? name (car vars))
	   (setf (car vals) val)
	   name)
	  (else (loop (cdr vars) (cdr vals))))))

(define-method (prepare-to-define! (env environment) names)
  (mapc (lambda (name)
	  (process-definition! env name))
	names))

;;; Shadowing loses, but you don't need it

(define-method (translate-reference (env environment) var)
  (cond ((member var (environment-variables env))
	 `(*access %%the-environment%% ',var))
	(else
	 (translate-reference (environment-parent env) var))))

(define-method (translate-assignment (env environment) var code)
  (cond ((member var (environment-variables env))
	 `(*assign! %%the-environment%% ',var ,code))
	(else
	 (translate-assignment (environment-parent env) var code))))

(define-method (process-definition! (env environment) var)
  (cond ((not (environment-mutable? env))
	 (cerror "will treat the DEFINE as a SET!"
		 "ouch!  This environment isn't mutable! - (DEFINE ~s ...)"
		 var))
	((not (member var (environment-variables env)))
	 (push var (environment-variables env))
	 (push '*undefined* (environment-values env)))))

(define-method (translate-environment (env environment))
  (ignore env)
  '%%the-environment%%)

;;;----- LOAD/COMPILE subsystem

(defvar *scheme-object-file-type* "SBIN")
(defvar *scheme-source-file-type* "SCM")

;;; READ-SCHEME-FILE returns two values:
;;;    1. A list of source expressions
;;;    2. The truename of the file it openend

(defun read-scheme-file (name)
  (with-open-file (s (scheme-source-pathname name)
		     :direction :input)
    (let ((true (truename s)))
      (format t "~&Reading ~S~%" (namestring true))
      (values (read-scheme-forms s) true))))

(defun read-scheme-forms (s)
  (with-package-and-readtable scheme-package scheme-readtable
    (iterate loop ((z '()))
      (let ((form (read s nil '*eof-object*)))
	(cond ((eq form '*eof-object*)
	       (nreverse z))
	      (t
	       (loop (cons form z))))))))

;;; Like READ-SCHEME-FILE, but translates as well.

(defun translate-scheme-file (name)
  (multiple-value-bind (code true-name)
      (read-scheme-file name)
    (format t "~&Translating ~S~%" (namestring true-name))
    (values (translate-scheme-forms code)
	    true-name)))

;;; Turn a list of scheme forms (the contents of a file) into an expression
;;; suitable for a top level expression in a common lisp file (something
;;; that LOAD or COMPILE-FILE might like to see).

(defun translate-scheme-forms (forms)
  `(progn 'compile
	  (defun run-top-level-forms (%%the-environment%%)
	    %%the-environment%%
	    ;; Avoid function redefinition message.
	    (fmakunbound 'run-top-level-forms)
	    ;; Flush any information compiler or LOAD might have stored.
	    (setf (symbol-plist 'run-top-level-forms) '())
	    ,(translate-top-level-sequence forms *current-environment*))
	  (run-top-level-forms *current-environment*)))

;;; Eric Benson's clever kludge.
;;; It won't work on the 3600, but might be worth trying elsewhere.

(defvar *use-roadblock-method?* nil)

(defvar roadblock-readtable (copy-readtable nil))

(defun roadblock-read-macro (stream ch)
  (unread-char ch stream)
  (translate-scheme-forms (read-scheme-forms stream)))

(let ((*readtable* roadblock-readtable))
  (do ((i 0 (1+ i))
       (stop (min 256. char-code-limit)))
      ((>= i stop) 'done)
    (let ((c (code-char i)))
      (if (or (graphic-char-p c)
	      (member c '(#\page #\tab #\newline #\linefeed #\return)))
	  (set-macro-character c #'roadblock-read-macro nil roadblock-readtable)))))

;;; Smart LOAD routine.

(define-scheme-nontrivial (load name &optional (compile? nil))  ;E
  (let ((name (pathname name)))
    (cond ((scheme-object-file? name)
	   (load-scheme-object-file name))
	  ((member (pathname-type name) '(nil :unspecific))
	   (let* ((src-name (scheme-source-pathname name))
		  (obj-name (scheme-object-pathname name))
		  (src (probe-file src-name))
		  (obj (probe-file obj-name)))
	     (cond ((not obj)
		    (load-scheme-source-file (or src src-name) compile?))
		   ((not src)
		    (load-scheme-object-file obj))
		   (t
		    (let ((src-version (pathname-version src))
			  (obj-version (pathname-version obj)))
		      (cond ((or (not (numberp obj-version))
				 (not (numberp src-version))
				 (>= obj-version src-version))
			     (load-scheme-object-file obj))
			    (t
			     (format t "~&Source file is newer, loading source file~%")
			     (load-scheme-source-file src compile?))))))))
	  (t
	   (load-scheme-source-file name compile?)))))

(defun scheme-object-file? (name)
  (let ((type (pathname-type name)))
    (and (or (stringp type) #+Symbolics (zl:stringp type))
	 (string-equal type *scheme-object-file-type*))))

(defun unspecify (name)
  (make-pathname :defaults name
		 :type *scheme-source-file-type*  ; - ?? loses on ITS
		 :version nil))

(defun load-scheme-object-file (name)
  (with-package-and-readtable scheme-package scheme-readtable
    (load name))
  name)

(defun load-scheme-source-file (name compile?)
  (cond (*use-roadblock-method?*
	 (with-package-and-readtable scheme-package roadblock-readtable
	   (load name)))
	(t
	 (let (#+Symbolics (si:fdefine-file-pathname (unspecify name)))	;JDR hack.
	   (multiple-value-bind (code name)
	       (translate-scheme-file name)
	     (format t "~&Loading ~S~%" (namestring name))
	     (let ((fun `(lisp:lambda (%%the-environment%%) %%the-environment%% ,code)))
	       (funcall (cond (compile?
			       (let (#+Symbolics (compiler:suppress-compiler-warnings t))
				 (compile nil fun)))
			      (t fun))		;LAMBDA-expressions are funcallable
			*current-environment*)
	       name))))))

;;; File compiler.

(define-scheme-nontrivial (compile-file scheme-pathname
					&optional keep-lisp-file?)
  (cond (*use-roadblock-method?*
	 (let ((name (probe-file (scheme-source-pathname scheme-pathname))))
	   (cond (name
		  #-Symbolics
		  (let ((*readtable* roadblock-readtable))
		    (compile-file-aux name))
		  #+Symbolics
		  (zl:standard-value-let ((zl:readtable roadblock-readtable))
		    (compile-file-aux name)))
		 (t
		  (cerror "skip compiling this file"
			  "file not found - (COMPILE-FILE ~s)"
			  scheme-pathname)))))
	(t
	 (multiple-value-bind (form name)
	     (translate-scheme-file scheme-pathname)
	   (format t "~&Compiling ~S~%" (namestring name))
	   (let (#+Symbolics
		 (form `(progn 'compile
			       (setq si:fdefine-file-pathname
				     ;; parse-pathname ??
				     (parse-namestring ',(namestring (unspecify name))))
			       ,form))
		 (lisp-pathname (make-pathname :type "TEMP" :defaults name)))
	     (unwind-protect (with-package-and-readtable scheme-package cl-readtable
			       (with-open-file (out lisp-pathname :direction :out)
				 (format out ";-*-Package:SCHEME-*-~%")
				 (print '(in-package "SCHEME") out)
				 (if keep-lisp-file?
				     (pp form out)
				   (print form out)))
			       (compile-file-aux lisp-pathname))
	       (if (not keep-lisp-file?) (delete-file lisp-pathname))))))))

(defun compile-file-aux (name)
  (let (#+Symbolics
	(compiler:suppress-compiler-warnings t)
	(fasl-pathname (scheme-object-pathname name)))
    (compile-file name :output-file fasl-pathname)
    fasl-pathname))


;;; Pathname hacking auxiliaries.

(defun scheme-source-pathname (name)
  (let* ((pathname (pathname name))
	 (type (pathname-type pathname))
	 (type (cond ((member (pathname-type pathname)
			      '(nil :unspecific))
		      *scheme-source-file-type*)
		     (t type)))
	 (version (or (pathname-version pathname) :newest)))
    (merge-pathnames					;JDR hack
      (make-pathname :defaults pathname
		     :type type
		     :version version))))

(defun scheme-object-pathname (name)
  (merge-pathnames					;JDR hack
    (make-pathname :type *scheme-object-file-type* :defaults name)))

#+Symbolics
(let ((type (zl:string *scheme-source-file-type*)))
  (cond ((not (member type fs:*its-uninteresting-types* :test #'equal))
	 (push type fs:*its-uninteresting-types*))))

#+Symbolics
(fs:define-canonical-type :scheme *scheme-source-file-type*) ;Scheme source

#+Symbolics
(fs:define-canonical-type :scheme-bin *scheme-object-file-type*) ;Scheme binary

;;; Default mode for scheme source is lisp.
#+Symbolics
(unless (assoc :scheme fs:*file-type-mode-alist*)
  (push (cons :scheme :lisp) fs:*file-type-mode-alist*))

#+Symbolics
(push scheme-package si:*reasonable-packages*)		;pushnew ?
#+Symbolics
(push scheme-readtable si:*valid-readtables*)
#+Symbolics
(push roadblock-readtable si:*valid-readtables*)

;;; Hack to allow loading scheme code as lisp code.
;;; Also makes indenting work right in ZMACS.

(defmacro scheme::define (pat &body body)
  `(,(translate-top-level `(scheme::define ,pat ,@body) *current-environment*)
    *current-environment*))


;;;----- Definitions for various Scheme procedures

;;; In alphabetical order

(define-scheme-nontrivial (apply proc . rest)	;E S
  (values nil (set-registers-from-list proc (apply #'list* rest))))

(define-scheme (assq obj list)			;E S
  (assoc obj list :test #'eq))

(define-scheme (assoc obj list)			;E
  (assoc obj list :test #'equal))

(define-scheme (boolean? obj)			;new
  (or (eq obj t) (eq obj nil)))

;;; Note that in a true Scheme, the escape procedure would have
;;; indefinite extent.

(define-scheme-nontrivial (call-with-current-continuation proc)	;E (!!)
  (block cwcc
    (scheme-call proc
		 (function->procedure (lambda (val)
					  (return-from cwcc val))
				      'scheme::continuation))))

(define-scheme-nontrivial (call-with-input-file string proc)	;E
  (with-open-file (port string :direction :input)
    (scheme-call proc port)))

(define-scheme-nontrivial (call-with-output-file string proc)	;E
  (with-open-file (port string :direction :output)
    (scheme-call proc port)))

(define-scheme (ceiling num)			; R
  (values (ceiling num 1)))

(define-scheme (char-whitespace? char)		; R
  (or (char= char #\space)
      (not (graphic-char-p char))))

(define-scheme (current-input-port)		;E
  *standard-input*)

(define-scheme (current-output-port)		;E
  *standard-output*)

(define-scheme (display obj &optional (port *standard-output*))
  (fluid-let ((*print-escape* nil))
    (scheme::write obj port)))			;E

(define-scheme (eof-object? obj)		;E
  (eq obj '*eof-object*))

(define-scheme-nontrivial (error . items)	;  S
  (apply #'error
	 (apply #'concatenate
		'string
		"~a"
		(mapcar (lambda (item) (ignore item) "~%~10t~s")
			(cdr items)))
	 items))

(define-scheme (exact? num)			;E
  (ignore num) nil)

(define-scheme (exit . vals)			;   T
  (throw 'exit-scheme (values-list vals)))

(define-scheme (explode atom)			;  S
  (map 'list
       (lambda (ch)
	 (intern (string ch) scheme-package))
       (if (symbol? atom)
	   (symbol-name atom)
	   (write-to-string atom :escape nil))))

(define-scheme (floor num)				; R
  (values (floor num 1)))

(define-scheme-nontrivial (for-each proc . lists)	;E
  (apply #'mapc (procedure->function proc) lists))

(define-scheme mapc					;  S
  (locally (declare (special for-each))
	   for-each))

(define-type delay
  (forced-yet? nil)
  thunk-or-value)

(define-method (print-instance (obj delay) stream guk)
  (ignore guk)
  (if (delay-forced-yet? obj)
      (print-with-braces obj stream "Forced" (delay-thunk-or-value obj))
      (print-with-braces obj stream "Delayed")))

(define-scheme-nontrivial (force obj)		;  S
  (cond ((delay? obj)
	 (let ((tv (delay-thunk-or-value obj)))
	   (cond ((delay-forced-yet? obj) tv)
		 (t (let ((val (funcall tv)))
		      (setf (delay-thunk-or-value obj) val)
		      (setf (delay-forced-yet? obj) t)
		      val)))))
	(t obj)))

(define-scheme (implode list)			;  S
  (values (intern (map 'string #'character list) scheme-package)))

(define-scheme (inexact? num)			;E
  (ignore num)
  t)

(define-scheme (input-port? obj)		;E
  (and (streamp obj) (input-stream-p obj)))

(define-scheme (lisp)
  (with-package-and-readtable clsch-package cl-readtable
    (break "Lisp")))

(define-scheme (list->string list)		;E
  (coerce list 'string))

(define-scheme (list->vector list)		;E
  (coerce list 'vector))

(define-scheme (list-ref list n)		; R
  (nth n list))

(define-scheme (list-tail list n)		; R
  (nthcdr n list))

(define-scheme (make-table &optional (name nil)) ;   T
  (ignore name)
  (values (make-hash-table)))

(define-scheme (make-vector size		;E S
			    &optional
			    (fill '*uninitialized-vector-element*))
  (make-sequence 'vector size :initial-element fill))

(define-scheme-nontrivial (map proc . lists)		;E
  (apply #'mapcar (procedure->function proc) lists))

(define-scheme mapcar					;  S
  (locally (declare (special scheme::map))
	   scheme::map))

(define-scheme (memq obj list)			;E S
  (member obj list :test #'eq))

(define-scheme (member obj list)		;E
  (member obj list :test #'equal))

(define-scheme nil nil)				; RS

(define-scheme (number->string num format)
  (if (not (equal? format '(scheme::heur)))
      (cerror "act as if the format was (HEUR)"
	      "unimplemented format: (NUMBER->STRING '~s '~s)"
	      num format))
  (write-to-string num))

(define-scheme (output-port? obj)		;E
  (and (streamp obj) (output-stream-p obj)))

(define-scheme (quotient n1 n2)			;E S
  (values (truncate n1 n2)))

(define-scheme (read &optional (port *standard-input*))		;E
  (read port nil '*eof-object*))

(define-scheme (read-char &optional (port *standard-input*))	;E
  (read-char port nil '*eof-object*))

(define-scheme (real? obj)			;E
  (and (numberp obj) (not (complexp obj))))

(define-scheme (reset)				; feature
  (throw 'reset-scheme nil))

(define-scheme (round num)			; R
  (values (round num 1)))

(define-scheme (set-car! pair obj)		;E
  (setf (car pair) obj))

(define-scheme (set-cdr! pair obj)		;E
  (setf (cdr pair) obj))

(define-scheme (string->list string)		;E
  (coerce string 'list))

(define-scheme (string->symbol string)		;E
  (values (intern string scheme-package)))

(define-scheme (string-null? string)		;E
  (= (length string) 0))

;;; Query system uses this
(define-scheme (pp obj &optional (port *standard-output*))	;   M
  (fluid-let ((*print-pretty* t))
    (print obj port)
    t))

(define-scheme (put sym ind val)		;  S  !
  (setf (get sym ind) val))

(define-scheme (set-table-entry! table key val)	;   T (sort of)
  (setf (gethash key table) val))

(define-scheme (string-append . strings)	;E
  (apply #'concatenate 'string strings))

(define-scheme t t)				; RS

(define-scheme (table-entry table key)		;   T
  (gethash key table nil))

(define-scheme-nontrivial (tail stream)		;  S
  (let ((d (force (cdr stream))))
    (setf (cdr stream) d)
    d))

(define-scheme the-empty-stream '())		;  S

(define-scheme (truncate num)			; R
  (values (truncate num 1)))

(define-scheme (vector? obj)			;E
  (and (simple-vector-p obj)
       ;; Strings are simple vectors in CLISP (this is a bug)
       #+tops-20
       (not (stringp obj))
       ;; Structures are vectors in CLISP and bolixlisp
       #+(or tops-20 symbolics)
       (not (typep obj 'structure))))

(define-scheme (vector->list vec)		;E
  (coerce vec 'list))

(define-scheme (vector-set! vec k obj)		;E S
  (setf (svref vec k) obj))

(define-scheme-nontrivial (with-input-from-file string thunk)	; R
  (with-open-file (*standard-input* string :direction :input)
    (scheme-call thunk)))

(define-scheme-nontrivial (with-output-to-file string thunk)	; R
  (with-open-file (*standard-output* string :direction :output)
    (scheme-call thunk)))

(define-scheme user-initial-environment		;  S
  (make-package-environment :package scheme-package
			    :name 'user-initial-environment))

(define-scheme clsch-environment		; feature
  (make-package-environment :package clsch-package
			    :name 'clsch-environment))

(define-scheme (write obj &optional (port *standard-output*))  ;E
  (fluid-let ((*standard-output* port))
    (really-write obj)))

(define (really-write obj)
  (cond ((null? obj)
	 (format *standard-output* "()"))
	((pair? obj) (write-list obj))
	((eq? obj t)
	 (format *standard-output* "#!TRUE"))
	((eq? obj quasiquote-marker)
	 (format *standard-output* "#!QUASIQUOTE"))
	((eq? obj unquote-marker)
	 (format *standard-output* "#!UNQUOTE"))
	((eq? obj splice-marker)
	 (format *standard-output* "#!SPLICE"))
	((vector? obj) (write-vector obj))
	(else (write obj))))

(define (write-list obj)
  (cond ((and *print-level* (<= *print-level* 0))
         (write-string "#"))
        ((and (symbol? (car obj))
	      (get (car obj) 'printer))
	 (funcall (get (car obj) 'printer) obj))
	(else
	 (write-list-normally obj))))

(define (write-list-normally obj)
  (write-char #\()
  (fluid-let ((*print-level* (and *print-level* (1- *print-level*))))
    (really-write (car obj))
    (iterate loop ((l (cdr obj))
		   (n 1))
      (cond ((atom? l)
	     (cond ((not (null? l))
		    (write-char #\space)
		    (write-char #\.)
		    (write-char #\space)
		    (really-write l))))
	    (else
	     (write-char #\space)
	     (cond ((and *print-length* (>= n *print-length*))
		    (write-string "..."))
		   (else
		    (really-write (car l))
		    (loop (cdr l) (1+ n))))))))
  (write-char #\))
  t)

(define (write-vector obj)
   (write-char #\#)
   (write-char #\()
   (let ((z (length obj)))
     (cond ((> z 0)
	    (really-write (svref obj 0))
	    (iterate loop ((i 1))
	      (cond ((>= i z))
		    (else
		     (write-char #\space)
		     (cond ((and *print-length* (>= i *print-length*))
			    (write-string "..."))
			   (else
			    (really-write (svref obj i))
			    (loop (1+ i))))))))))
   (write-char #\))
   t)

;;; Stuff for making printers understand Scheme backquote

(define (make-macro-char-printer prefix)
  (lambda (obj)
    (cond ((or (not (pair? (cdr obj)))
	       (not (null? (cddr obj))))
	   (write-list-normally obj))
	  (else
	   (write-string prefix)
	   (really-write (cadr obj))))))

(setf (get 'quote            'printer) (make-macro-char-printer "'"))
(setf (get quasiquote-marker 'printer) (make-macro-char-printer "`"))
(setf (get unquote-marker    'printer) (make-macro-char-printer ","))
(setf (get splice-marker     'printer) (make-macro-char-printer ",@"))

#+Symbolics
(progn 'compile   ;Until a pretty-printer exists
       (setf (get quasiquote-marker 'gprint::formatter)
	     (lambda (x) (gprint::format-quote "`" x)))
       (setf (get unquote-marker 'gprint::formatter)
	     (lambda (x) (gprint::format-quote "," x)))
       (setf (get splice-marker 'gprint::formatter)
	     (lambda (x) (gprint::format-quote ",@" x))))

(defvar *trace-level* 0)

(define-scheme (*trace proc name)
  (function->procedure
   (lambda args
     (fluid-let ((*trace-level* (1+ *trace-level*)))
       (format t "~&~vt~d Enter ~s" *trace-level* *trace-level* name)
       (mapc (lambda (arg) (princ #\space) (scheme::write arg)) args)
       (let ((val (apply #'scheme-call proc args)))
	 (format t "~&~vt~d Exit ~s "
		 *trace-level* *trace-level* name)
	 (scheme::write val)
	 val)))
   `(trace ,proc)))

(define-scheme (*untrace proc)
  (let ((name (procedure-name proc)))
    (cond ((and (consp name) (eq (car name) 'trace))
	   (cadr name))
	  (t
	   (format t "~&Wasn't traced in the first place.~%")
	   proc))))

(define-scheme (%out) (declare (special *)) *)

(define-scheme (%ge env)
  (check-type env (or environment package-environment) "an environment")
  (setq *current-environment* env))

;;; Entries are in alphabetical order.  (Any other order would seem
;;; arbitrary.  This way it's easy to tell whether something exists.)

(mapc (lambda (z)
	(multiple-value-bind (from to)
	    (cond ((consp z) (values (cadr z) (car z)))
		  (t	     (values z        z)))
	  (assert (not (eq (symbol-package from) clsch-package)) (from))
	  (let ((to (clsch-symbol to)))
	    (clsch-export to)
	    (setf (symbol-value to)
		  (function->procedure (symbol-function from) to))
	    (setf (get to 'trivial) from)
	    (setf (symbol-function to) (symbol-function from)))))
      '(
	1+					; RS
	(-1+ 1-)				; RS
	+ - * /					;E S
	= < >					;E S
        <= >=					;E S ?
	(=? =) (<? <) (>? >) (<=? <=) (>=? >=)	;E
	abs					;E S
	acos					; R
	append					;E
	(append! nconc)				; R
	asin					; R
	atan					; R
	(assv assoc)				;E
	(atom? atom)				;  S
	car cdr caar cadr cdar cddr		;E S
	caaar caadr cadar caddr			;E S
	cdaar cdadr cddar cdddr			;E S
	caaaar caaadr caadar caaddr		;E S
	cadaar cadadr caddar cadddr		;E S
	cdaaar cdaadr cdadar cdaddr		;E S
	cddaar cddadr cdddar cddddr		;E S
	(char->integer char-code)		;E
	(char-alphabetic? alpha-char-p)		; R
	(char-ci<=? char-not-greaterp)		; R
	(char-ci<?  char-lessp)			; R
	(char-ci=?  char-equal)			; R
	(char-ci>=? char-not-lessp)		; R
	(char-ci>?  char-greaterp)		; R
	(char-numeric? digit-char-p)		; R  (almost)
	char-downcase				; R
	(char-lower-case? lower-case-p)		; R
	char-upcase				; R
	(char-upper-case? upper-case-p)		; R
	(char<=? char<=)			;E
	(char<?  char<)				;E
	(char=?  char=)				;E
	(char>=? char>=)			;E
	(char>?  char>)				;E
	(char? characterp)			;E
	(cons* list*)				;   T
	cos					; RS
	(complex? numberp)			;E
	cons					;E S
	(empty-stream? null)			;  S
	(eq? eq)				;E S
	(equal? equal)				;E
	(eqv? eql)				;E
	(even? evenp)				;E
	exp					; RS
	expt					; RS
	gcd					; RS
	get					;  S  ?
	(head car)				;  S
	(integer->char code-char)		;E
	(integer? integerp)			;E
	(last-pair last)			; R
	(length list-length)			;E S
	lcm					; R
	list					;E S
	log					; R
	max					;E S
	(memv member)				;E
	min					;E S
	(modulo mod)				; R
	(negative? minusp)			;E
	(newline terpri)			;E
	not					;E S
	nth					;   M
	(null? null)				;E S
	(number? numberp)			;E S
	(odd? oddp)				;E
	(pair? consp)				;E
	(positive? plusp)			;E
	princ					;  S
	print					;  S
	random					;   M
	(rational? rationalp)			;E
	(remainder rem)				;E S
	reverse					; R
	(reverse! nreverse)			;   MT
	sin					; RS
	sqrt					; RS
	(string-length length)			;E
	(string-ref char)			;E
	(string-ci<=? string-not-greaterp)	; R
	(string-ci<?  string-lessp)		; R
	(string-ci=?  string-equal)		; R
	(string-ci>=? string-not-lessp)		; R
	(string-ci>?  string-greaterp)		; R
	(string<=? string<=)			;E
	(string<?  string<)			;E
	(string=?  string=)			;E
	(string>=? string>=)			;E
	(string>?  string>)			;E
	(string? stringp)			;E
	(substring subseq)			;E
	(symbol->string symbol-name)		;E
	(symbol? symbolp)			;E S
	tan					; R
	vector					;E
	(vector-length length)			;E
	(vector-ref svref)			;E S
	write-char				;E
	(zero? zerop)				;E
	))

;;; Another hack for editor interface
#+Symbolics
(progn 'compile
       (put 'si:xr-bq-list 'trivial 'si:xr-bq-list)
       (put 'si:xr-bq-list* 'trivial 'si:xr-bq-list*)
       (put 'si:xr-bq-cons 'trivial 'si:xr-bq-cons)
       (put 'si:xr-bq-append 'trivial 'si:xr-bq-append))

;;; Missing inessential RRRS features:
;;;   exact and complex numbers
;;;   make-rectangular make-polar real-part imag-part magnitude angle
;;;   exact->inexact inexact->exact
;;;   string->number
;;;   make-string string-set! string-fill! string-copy substring-fill!
;;;   substring-move-right! substring-move-left!
;;;   vector-fill!
;;;   object-hash object-unhash
;;;   open-input-file open-output-file
;;;   close-input-port close-output-port
;;;   char-ready?
;;;   transcript-on transcript-off

;;;   T, MacScheme, and CL all have peek-char; should add this?

;;; For more efficient execution on a Lisp Machine, see this file:
;;;   z:>multilisp>emulator>emulator.lisp

;;;----- Top level  (need a definition for running in a real CL!)

;;; Read-eval-print loop.

(defvar *current-environment*
  (locally (declare (special user-initial-environment))
	   user-initial-environment))

(defun scheme-eval (exp)
  (scheme::eval exp *current-environment*))

#-Symbolics
(defun scheme ()
  (catch 'exit-scheme
    (with-package-and-readtable scheme-package scheme-readtable
      (progv *proc+arg-regs*
	     '()			;Make them all be unbound.  CLtL p. 112
	     (iterate loop ()
	       (catch 'reset-scheme
		 (format *terminal-io* "~&==> ")
		 (let ((form (read *terminal-io* nil '*eof-object*)))
		   (cond ((eq form '*eof-object*)
			  (return-from scheme t))
			 (t
			  (setq * (scheme-eval form))
			  (format *terminal-io* "~&")
			  (scheme::write * *terminal-io*)))))
	       (loop))))))

#+Symbolics
(defun scheme ()
  (catch 'exit-scheme
    (fluid-let ((si:*command-loop-eval-function* #'scheme-eval)
		(si:*command-loop-print-function*
		  (lambda (values)
		    (zl:send zl:standard-output :fresh-line)
		    (cond ((or (null values) (not (null (cdr values))))
			   (format t
			      "~&[Strange, there should have been exactly one value.]~&")
			   (scheme::write values))
			  (t
			   (scheme::write (car values))))))
		(si:*read-form-edit-trivial-errors-p* nil)
		(si:*cp-prompt* "Scheme: "))
      (with-package-and-readtable scheme-package scheme-readtable
	(progv *proc+arg-regs*
	       '()
	       (block done
		 (iterate loop ()
		   (catch 'reset-scheme
		     (si:lisp-command-loop *terminal-io*
					   :name "Scheme Command Loop")
		     (return-from done (values)))
		   (loop))))))))


;;; Local Modes:
;;; Lisp block Indent:1
;;; Lisp with-open-file Indent:1
;;; Lisp with-package-and-readtable Indent:2
;;; Lisp zl:standard-value-let Indent:1
;;; Lisp lisp:lambda Indent:1
;;; Lisp catch Indent:1
;;; Lisp iterate Indent:2
;;; End: